Skip to content

haskell-gargantext
haskell-gargantext
Commit f760d187 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge remote-tracking branch 'origin/adinapoli/more-db-test-coverage' into dev

parents d7571b77 ae336002
Show whitespace changes
Inline Side-by-side
Showing with 347 additions and 91 deletions
.gitlab-ci.yml
View file @ f760d187
......@@ -12,6 +12,7 @@ variables:
stages:
- stack
- cabal
- bench
- test
stack:
......@@ -34,7 +35,19 @@ cabal:
- .cabal/
policy: pull-push
script:
- nix-shell --run "./bin/update-cabal-project $CABAL_STORE_DIR && cabal --store-dir=$CABAL_STORE_DIR v2-build --ghc-options='-O0 -fclear-plugins'"
- nix-shell --run "./bin/update-cabal-project $CABAL_STORE_DIR && cabal --store-dir=$CABAL_STORE_DIR v2-build --ghc-options='-O2 -fclear-plugins'"
allow_failure: false
bench:
stage: bench
cache:
key: cabal.project
paths:
- dist-newstyle/
- .cabal/
policy: pull-push
script:
- nix-shell --run "./bin/update-cabal-project $CABAL_STORE_DIR && cabal --store-dir=$CABAL_STORE_DIR v2-bench --ghc-options='-O2 -fclear-plugins'"
allow_failure: false
test:
......@@ -63,11 +76,13 @@ test:
nix-shell --run "./bin/update-cabal-project $CABAL_STORE_DIR"
mkdir -p /root/.cache/cabal/logs
chown -R test:test /root/.cache/cabal/logs/
nix-shell --run "chown -R test:test /root/.config/ && su -m test -c \"export PATH=$PATH:$TEST_NIX_PATH && cd /builds/gargantext/haskell-gargantext && $CABAL --store-dir=$CABAL_STORE_DIR v2-test --test-show-details=streaming --ghc-options='-O0 -fclear-plugins'\""
chown -R test:test /root/.cache/cabal/packages/hackage.haskell.org/
nix-shell --run "chown -R test:test /root/.config/ && su -m test -c \"export PATH=$PATH:$TEST_NIX_PATH && cd /builds/gargantext/haskell-gargantext && $CABAL --store-dir=$CABAL_STORE_DIR v2-test --test-show-details=streaming --flags test-crypto --ghc-options='-O0 -fclear-plugins'\""
chown -R root:root dist-newstyle/
chown -R root:root /root/
chown -R root:root $CABAL_STORE_DIR
chown -R root:root /root/.cache/cabal/logs/
chown -R root:root /root/.cache/cabal/packages/hackage.haskell.org/
#docs:
# stage: docs
......
bench/Main.hs 0 → 100644
View file @ f760d187
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import Gargantext.Core.Types.Individu
import Gargantext.Prelude.Crypto.Auth (createPasswordHash)
import Test.Tasty.Bench
main :: IO ()
main = defaultMain
[ bgroup "Benchmarks"
[ bgroup "User creation" [
bench "createPasswordHash" $ whnfIO (createPasswordHash "rabbit")
, bench "toUserHash" $
whnfIO (toUserHash $ NewUser "alfredo" "alfredo@well-typed.com" (GargPassword "rabbit"))
]
]
]
bin/gargantext-admin/Main.hs
View file @ f760d187
......@@ -18,6 +18,7 @@ module Main where
import Gargantext.API.Dev (withDevEnv, runCmdDev)
import Gargantext.API.Prelude (GargError)
import Gargantext.Database.Action.User.New (newUsers)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd'')
import Gargantext.Prelude
import System.Environment (getArgs)
......@@ -28,6 +29,6 @@ main = do
(iniPath:mails) <- getArgs
withDevEnv iniPath $ \env -> do
x <- runCmdDev env ((newUsers $ map cs mails) :: Cmd'' DevEnv GargError Int64)
x <- runCmdDev env ((newUsers $ map cs mails) :: Cmd'' DevEnv GargError [UserId])
putStrLn $ show x
pure ()
bin/update-cabal-project
View file @ f760d187
......@@ -7,11 +7,12 @@ STORE_DIR="${1:-$DEFAULT_STORE}"
# README!
# Every time you modify the `stack.yaml` and as result the relevant `cabal.project`
# changes, you have to make sure to update the `expected_cabal_projet_hash` with the
# `sha256sum` result calculated on the `cabal.project`. This ensures the `cabal.project`
# stays deterministic so that CI cache can kick in.
#expected_cabal_project_hash="2754bf61cc7a2aa7b29345ffe34dc1e90a06426f00fc39da9f793cd828be4e15"
expected_cabal_project_hash="5e989e199765ba2dd476208a66e96495ade69eb7cb14c0a448dfebd5748c9b39"
# changes, you have to make sure to update the `expected_cabal_project_hash` and
# `expected_cabal_project_freeze_hash` with the
# `sha256sum` result calculated on the `cabal.project` and `cabal.project.freeze`.
# This ensures the files stay deterministic so that CI cache can kick in.
expected_cabal_project_hash="eb12c232115b3fffa1f81add7c83d921e5899c7712eddee6100ff8df7305088e"
expected_cabal_project_freeze_hash="b7acfd12c970323ffe2c6684a13130db09d8ec9fa5676a976afed329f1ef3436"
cabal --store-dir=$STORE_DIR v2-update 'hackage.haskell.org,2023-06-24T21:28:46Z'
......@@ -24,9 +25,16 @@ fi
stack2cabal --no-run-hpack -p '2023-06-24 21:28:46'
actual_cabal_project_hash=$(sha256sum cabal.project | awk '{printf "%s",$1}')
actual_cabal_project_freeze_hash=$(sha256sum cabal.project.freeze | awk '{printf "%s",$1}')
if [[ $actual_cabal_project_hash != $expected_cabal_project_hash ]]; then
echo "ERROR! hash mismatch between expected cabal.project and the one computed by stack2cabal."
exit 1
else
echo "cabal.project updated successfully."
fi
if [[ $actual_cabal_project_freeze_hash != $expected_cabal_project_freeze_hash ]]; then
echo "ERROR! hash mismatch between expected cabal.project.freeze and the one computed by stack2cabal."
exit 1
else
echo "cabal.project.freeze updated successfully."
fi
cabal.project
View file @ f760d187
......@@ -66,11 +66,6 @@ source-repository-package
location: https://gitlab.iscpif.fr/amestanogullari/accelerate-utility.git
tag: a3875fe652d3bb5acb522674c22c6c814c1b4ad0
source-repository-package
type: git
location: https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude
tag: 8f97fef4dfd941d773914ad058d8e02ce2bb1a3e
source-repository-package
type: git
location: https://gitlab.iscpif.fr/cgenie/patches-class.git
......@@ -111,6 +106,11 @@ source-repository-package
location: https://gitlab.iscpif.fr/gargantext/gargantext-graph.git
tag: 588e104fe7593210956610cab0041fd16584a4ce
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude
tag: 8f97fef4dfd941d773914ad058d8e02ce2bb1a3e
source-repository-package
type: git
location: https://gitlab.iscpif.fr/gargantext/haskell-igraph.git
......
cabal.project.freeze
View file @ f760d187
......@@ -1205,12 +1205,12 @@ constraints: any.AC-Angle ==1.0,
any.hslua-module-text ==0.3.0.1,
any.hsp ==0.10.0,
any.hsparql ==0.3.8,
any.hspec ==2.7.10,
any.hspec ==2.11.1,
any.hspec-attoparsec ==0.1.0.2,
any.hspec-checkers ==0.1.0.2,
any.hspec-contrib ==0.5.1,
any.hspec-core ==2.7.10,
any.hspec-discover ==2.7.10,
any.hspec-core ==2.11.1,
any.hspec-discover ==2.11.1,
any.hspec-expectations ==0.8.3,
any.hspec-expectations-json ==1.0.0.4,
any.hspec-expectations-lifted ==0.10.0,
......@@ -2385,7 +2385,7 @@ constraints: any.AC-Angle ==1.0,
any.tasty-focus ==1.0.1,
any.tasty-golden ==2.3.5,
any.tasty-hedgehog ==1.1.0.0,
any.tasty-hspec ==1.1.6,
any.tasty-hspec ==1.2.0.3,
any.tasty-hunit ==0.10.0.3,
any.tasty-hunit-compat ==0.2.0.1,
any.tasty-inspection-testing ==0.1,
......
gargantext.cabal
View file @ f760d187
......@@ -33,6 +33,13 @@ data-files:
test-data/test_config.ini
.clippy.dhall
-- When enabled, it swaps the hashing algorithm
-- with a quicker (and less secure) version, which
-- runs faster in tests.
flag test-crypto
default: False
manual: True
library
exposed-modules:
Gargantext
......@@ -105,6 +112,7 @@ library
Gargantext.Core.Viz.Types
Gargantext.Database.Action.Flow
Gargantext.Database.Action.Flow.Types
Gargantext.Database.Action.User
Gargantext.Database.Action.User.New
Gargantext.Database.Admin.Config
Gargantext.Database.Admin.Trigger.Init
......@@ -115,10 +123,12 @@ library
Gargantext.Database.Query.Table.Node
Gargantext.Database.Query.Table.Node.Error
Gargantext.Database.Query.Table.Node.UpdateOpaleye
Gargantext.Database.Query.Tree.Root
Gargantext.Database.Query.Table.User
Gargantext.Database.Schema.Ngrams
Gargantext.System.Logging
Gargantext.Database.Schema.User
Gargantext.Defaults
Gargantext.System.Logging
Gargantext.Utils.Jobs
Gargantext.Utils.Jobs.Internal
Gargantext.Utils.Jobs.Map
......@@ -281,7 +291,6 @@ library
Gargantext.Database.Action.Search
Gargantext.Database.Action.Share
Gargantext.Database.Action.TSQuery
Gargantext.Database.Action.User
Gargantext.Database.Admin.Access
Gargantext.Database.Admin.Bashql
Gargantext.Database.Admin.Trigger.ContextNodeNgrams
......@@ -331,7 +340,6 @@ library
Gargantext.Database.Query.Table.NodesNgramsRepo
Gargantext.Database.Query.Tree
Gargantext.Database.Query.Tree.Error
Gargantext.Database.Query.Tree.Root
Gargantext.Database.Schema.Context
Gargantext.Database.Schema.ContextNodeNgrams
Gargantext.Database.Schema.ContextNodeNgrams2
......@@ -346,7 +354,6 @@ library
Gargantext.Database.Schema.NodeNodeNgrams2
Gargantext.Database.Schema.NodesNgramsRepo
Gargantext.Database.Schema.Prelude
Gargantext.Database.Schema.User
Gargantext.Database.Types
Gargantext.Utils.Aeson
Gargantext.Utils.JohnSnowNLP
......@@ -371,6 +378,8 @@ library
RecordWildCards
StrictData
ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-signatures -Wunused-binds -Wunused-imports -Werror -freduction-depth=300 -fplugin=Clippy
if flag(test-crypto)
cpp-options: -DTEST_CRYPTO
build-depends:
HSvm ^>= 0.1.1.3.22
, KMP ^>= 0.2.0.0
......@@ -865,9 +874,9 @@ executable gargantext-upgrade
, text ^>= 1.2.4.1
default-language: Haskell2010
test-suite garg-test
test-suite garg-test-tasty
type: exitcode-stdio-1.0
main-is: Main.hs
main-is: tasty/Main.hs
other-modules:
Core.Text
Core.Text.Corpus.Query
......@@ -936,6 +945,87 @@ test-suite garg-test
, gargantext
, gargantext-prelude
, hspec ^>= 2.7.10
, hspec-core
, hspec-expectations >= 0.8 && < 0.9
, http-client ^>= 0.6.4.1
, http-client-tls ^>= 0.3.5.3
, lens >= 5.2.2 && < 5.3
, monad-control >= 1.0.3 && < 1.1
, mtl ^>= 2.2.2
, parsec ^>= 3.1.14.0
, patches-class ^>= 0.1.0.1
, patches-map ^>= 0.1.0.1
, postgres-options >= 0.2 && < 0.3
, postgresql-simple >= 0.6.4 && < 0.7
, quickcheck-instances ^>= 0.3.25.2
, raw-strings-qq
, recover-rtti >= 0.4 && < 0.5
, resource-pool >= 0.2.3.2 && < 0.2.4
, servant-job
, shelly >= 1.9 && < 2
, stm ^>= 2.5.0.1
, tasty ^>= 1.4.2.1
, tasty-hspec
, tasty-hunit
, tasty-quickcheck
, tasty-smallcheck
, text ^>= 1.2.4.1
, time ^>= 1.9.3
, tmp-postgres >= 1.34.1 && < 1.35
, unordered-containers ^>= 0.2.16.0
, validity ^>= 0.11.0.1
default-language: Haskell2010
test-suite garg-test-hspec
type: exitcode-stdio-1.0
main-is: hspec/Main.hs
other-modules:
Database.Operations
Paths_gargantext
hs-source-dirs:
test
default-extensions:
DataKinds
DeriveGeneric
FlexibleContexts
FlexibleInstances
GADTs
GeneralizedNewtypeDeriving
ImportQualifiedPost
MultiParamTypeClasses
NamedFieldPuns
NoImplicitPrelude
OverloadedStrings
RankNTypes
RecordWildCards
StrictData
DataKinds
DeriveGeneric
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
ImportQualifiedPost
MultiParamTypeClasses
NoImplicitPrelude
OverloadedStrings
RankNTypes
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends:
QuickCheck ^>= 2.14.2
, aeson ^>= 1.5.6.0
, async ^>= 2.2.4
, base ^>= 4.14.3.0
, boolexpr ^>= 0.2
, bytestring ^>= 0.10.12.0
, conduit ^>= 1.3.4.2
, containers ^>= 0.6.5.1
, crawlerArxiv
, duckling ^>= 0.2.0.0
, extra ^>= 1.7.9
, gargantext
, gargantext-prelude
, hspec ^>= 2.7.10
, hspec-core
, hspec-expectations >= 0.8 && < 0.9
, http-client ^>= 0.6.4.1
, http-client-tls ^>= 0.3.5.3
......@@ -958,6 +1048,7 @@ test-suite garg-test
, tasty-hspec
, tasty-hunit
, tasty-quickcheck
, tasty-smallcheck
, text ^>= 1.2.4.1
, time ^>= 1.9.3
, tmp-postgres >= 1.34.1 && < 1.35
......@@ -965,3 +1056,15 @@ test-suite garg-test
, validity ^>= 0.11.0.1
default-language: Haskell2010
benchmark garg-bench
main-is: Main.hs
hs-source-dirs: bench
type: exitcode-stdio-1.0
build-depends: base
, bytestring
, gargantext
, gargantext-prelude
, tasty-bench
ghc-options: "-with-rtsopts=-A32m"
if impl(ghc >= 8.6)
ghc-options: "-with-rtsopts=--nonmoving-gc"
src/Gargantext/Core/Types/Individu.hs
View file @ f760d187
{-# LANGUAGE CPP #-}
{-|
Module : Gargantext.Core.Types.Individu
Description : Short description
......@@ -15,11 +17,11 @@ Individu defintions
module Gargantext.Core.Types.Individu
where
import Data.Aeson
import Control.Monad.IO.Class (MonadIO)
import GHC.Generics (Generic)
import Data.Aeson
import Data.Swagger
import Data.Text (Text, pack, reverse)
import GHC.Generics (Generic)
import Gargantext.Database.Admin.Types.Node (NodeId, UserId)
import Gargantext.Prelude hiding (reverse)
import qualified Gargantext.Prelude.Crypto.Auth as Auth
......@@ -68,8 +70,15 @@ toUserHash :: MonadIO m
=> NewUser GargPassword
-> m (NewUser HashPassword)
toUserHash (NewUser u m (GargPassword p)) = do
h <- Auth.createPasswordHash p
salt <- Auth.newSalt
let h = Auth.hashPasswordWithSalt params salt (Auth.mkPassword p)
pure $ NewUser u m h
where
#if TEST_CRYPTO
params = Auth.defaultParams { Auth.argon2MemoryCost = 4096 }
#else
params = Auth.defaultParams
#endif
-- TODO remove
arbitraryUsersHash :: MonadIO m
......
src/Gargantext/Database/Action/User.hs
View file @ f760d187
......@@ -16,7 +16,7 @@ module Gargantext.Database.Action.User
import Data.Text (Text)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, DBCmd)
import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.User
import Gargantext.Database.Query.Table.Node.Error
......@@ -24,14 +24,14 @@ import Gargantext.Database.Schema.Node
import Gargantext.Prelude
------------------------------------------------------------------------
getUserLightWithId :: HasNodeError err => Int -> Cmd err UserLight
getUserLightWithId :: HasNodeError err => UserId -> DBCmd err UserLight
getUserLightWithId i = do
candidates <- head <$> getUsersWithId (UserDBId i)
case candidates of
Nothing -> nodeError NoUserFound
Just u -> pure u
getUserLightDB :: HasNodeError err => User -> Cmd err UserLight
getUserLightDB :: HasNodeError err => User -> DBCmd err UserLight
getUserLightDB u = do
userId <- getUserId u
userLight <- getUserLightWithId userId
......
src/Gargantext/Database/Action/User/New.hs
View file @ f760d187
......@@ -28,6 +28,7 @@ import Gargantext.Core.Mail
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow (getOrMkRoot)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
import Gargantext.Database.Query.Table.User
......@@ -41,13 +42,13 @@ import qualified Data.Text as Text
-- be valid (i.e. a valid username needs to be inferred via 'guessUsername').
newUser :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
=> EmailAddress
-> m Int64
-> m UserId
newUser emailAddress = do
cfg <- view mailSettings
pwd <- gargPass
let nur = mkNewUser emailAddress (GargPassword pwd)
affectedRows <- new_user nur
withNotification (SendEmail True) cfg Invitation $ pure (affectedRows, nur)
new_user_id <- new_user nur
withNotification (SendEmail True) cfg Invitation $ pure (new_user_id, nur)
------------------------------------------------------------------------
-- | A DB-specific action to create a single user.
......@@ -56,8 +57,12 @@ newUser emailAddress = do
-- use 'newUser' instead for standard Gargantext code.
new_user :: HasNodeError err
=> NewUser GargPassword
-> DBCmd err Int64
new_user = new_users . (:[])
-> DBCmd err UserId
new_user rq = do
ur <- new_users [rq]
case head ur of
Nothing -> nodeError MkNode
Just uid -> pure uid
------------------------------------------------------------------------
-- | A DB-specific action to bulk-create users.
......@@ -67,17 +72,16 @@ new_user = new_users . (:[])
new_users :: HasNodeError err
=> [NewUser GargPassword]
-- ^ A list of users to create.
-> DBCmd err Int64
-> DBCmd err [UserId]
new_users us = do
us' <- liftBase $ mapM toUserHash us
r <- insertUsers $ map toUserWrite us'
_ <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us
pure r
void $ insertUsers $ map toUserWrite us'
mapM (fmap fst . getOrMkRoot) $ map (\u -> UserName (_nu_username u)) us
------------------------------------------------------------------------
newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
=> [EmailAddress]
-> m Int64
-> m [UserId]
newUsers us = do
config <- view $ mailSettings
us' <- mapM (\ea -> mkNewUser ea . GargPassword <$> gargPass) us
......@@ -102,14 +106,14 @@ guessUserName n = case splitOn "@" n of
------------------------------------------------------------------------
newUsers' :: HasNodeError err
=> MailConfig -> [NewUser GargPassword] -> Cmd err Int64
=> MailConfig -> [NewUser GargPassword] -> Cmd err [UserId]
newUsers' cfg us = do
us' <- liftBase $ mapM toUserHash us
r <- insertUsers $ map toUserWrite us'
_ <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us
void $ insertUsers $ map toUserWrite us'
urs <- mapM (fmap fst . getOrMkRoot) $ map (\u -> UserName (_nu_username u)) us
_ <- mapM (\u -> mail cfg (Invitation u)) us
-- printDebug "newUsers'" us
pure r
pure urs
------------------------------------------------------------------------
-- | Updates a user's password, notifying the user via email, if necessary.
......
src/Gargantext/Database/Query/Table/Node.hs
View file @ f760d187
......@@ -195,7 +195,7 @@ getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument
getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataCorpus]
getCorporaWithParentId :: HasDBid NodeType => NodeId -> DBCmd err [Node HyperdataCorpus]
getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
------------------------------------------------------------------------
......@@ -271,7 +271,7 @@ getNodeWith nId _ = do
------------------------------------------------------------------------
-- | Sugar to insert Node with NodeType in Database
insertDefaultNode :: HasDBid NodeType
=> NodeType -> ParentId -> UserId -> Cmd err [NodeId]
=> NodeType -> ParentId -> UserId -> DBCmd err [NodeId]
insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
insertDefaultNodeIfNotExists :: HasDBid NodeType
......@@ -382,7 +382,7 @@ data CorpusType = CorpusDocument | CorpusContact
class MkCorpus a
where
mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> DBCmd err [NodeId]
instance MkCorpus HyperdataCorpus
where
......
src/Gargantext/Database/Query/Table/User.hs
View file @ f760d187
......@@ -72,7 +72,7 @@ import Gargantext.Database.Admin.Config (nodeTypeId)
------------------------------------------------------------------------
-- TODO: on conflict, nice message
insertUsers :: [UserWrite] -> DBCmd err Int64
insertUsers us = mkCmd $ \c -> runInsert_ c insert
insertUsers us = mkCmd $ \c -> runInsert c insert
where
insert = Insert userTable us rCount Nothing
......
src/Gargantext/Database/Query/Tree/Root.hs
View file @ f760d187
......@@ -23,7 +23,7 @@ import Gargantext.Database.Action.User (getUserId, getUsername)
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, runOpaQuery, DBCmd)
import Gargantext.Database.Prelude (runOpaQuery, DBCmd)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
......@@ -34,7 +34,7 @@ import Opaleye (restrict, (.==), Select)
import Opaleye.SqlTypes (sqlStrictText, sqlInt4)
getRootId :: (HasNodeError err) => User -> Cmd err NodeId
getRootId :: (HasNodeError err) => User -> DBCmd err NodeId
getRootId u = do
maybeRoot <- head <$> getRoot u
case maybeRoot of
......@@ -66,7 +66,7 @@ getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
=> User
-> Either CorpusName [CorpusId]
-> Maybe a
-> Cmd err (UserId, RootId, CorpusId)
-> DBCmd err (UserId, RootId, CorpusId)
getOrMk_RootWithCorpus user cName c = do
(userId, rootId) <- getOrMkRoot user
corpusId'' <- if user == UserName userMaster
......
stack.yaml
View file @ f760d187
......@@ -21,7 +21,7 @@ nix:
allow-newer: true
extra-deps:
- git: https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude
- git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude
commit: 8f97fef4dfd941d773914ad058d8e02ce2bb1a3e
- git: https://gitlab.iscpif.fr/gargantext/gargantext-graph.git
commit: 588e104fe7593210956610cab0041fd16584a4ce
......@@ -58,7 +58,7 @@ extra-deps:
- git: https://gitlab.iscpif.fr/gargantext/crawlers/isidore.git
commit: 3db385e767d2100d8abe900833c6e7de3ac55e1b
- git: https://gitlab.iscpif.fr/gargantext/crawlers/arxiv-api.git
commit: 2d7e5753cbbce248b860b571a0e9885415c846f7
commit: eb130c71fa17adaceed6ff66beefbccb13df51ba
- git: https://gitlab.iscpif.fr/gargantext/crawlers/openalex.git
commit: 1cf872fb3bd0e3e44af31247833c4b6bb7d0dca5
# NP libs
......@@ -116,6 +116,9 @@ extra-deps:
- hgal-2.0.0.2@sha256:13d58afd0668b9cb881c612eff8488a0e289edd4bbffa893df4beee60cfeb73b,653
- hsparql-0.3.8
- hstatistics-0.3.1
- hspec-2.11.1
- hspec-core-2.11.1
- hspec-discover-2.11.1
- hspec-expectations-0.8.3
- json-stream-0.4.2.4@sha256:8b7f17d54a6e1e6311756270f8bcf51e91bab4300945400de66118470dcf51b9,4716
- located-base-0.1.1.1@sha256:7c6395f2b6fbf2d5f76c3514f774423838c0ea94e1c6a5530dd3c94b30c9d1c8,1904
......@@ -133,6 +136,7 @@ extra-deps:
- stemmer-0.5.2@sha256:823aec56249ec2619f60a2c0d1384b732894dbbbe642856d337ebfe9629a0efd,4082
- taggy-0.2.1@sha256:7bc55ddba178971dc6052163597f0445a0a2b5b0ca0e84ce651d53d722e3c265,4662
- taggy-lens-0.1.2@sha256:091ca81d02bd3d7fb493dce0148e1a38f25eb178a1ebd751043a23239e5e3265,3009
- tasty-hspec-1.2.0.3
- tmp-postgres-1.34.1.0
- vector-0.12.3.0@sha256:0ae2c1ba86f0077910be242ec6802cc3d7725fe7b2bea6987201aa3737b239b5,7953
- xmlbf-0.6.1@sha256:57867fcb39e0514d17b3328ff5de8d241a18482fc89bb742d9ed820a6a2a5187,1540
......
test/Database/Operations.hs
View file @ f760d187
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Database.Operations where
module Database.Operations (
tests
) where
import Control.Exception
import Control.Lens
import Control.Exception hiding (assert)
import Control.Lens hiding (elements)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.IORef
import Data.Pool hiding (withResource)
import Data.String
import Database.PostgreSQL.Simple
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.User
import Gargantext.Database.Action.User.New
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Prelude
import Gargantext.Prelude.Config
import Prelude
import Shelly hiding (FilePath)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.Hspec
import Shelly hiding (FilePath, run)
import Test.QuickCheck.Monadic
import Test.Hspec
import Test.Tasty.HUnit hiding (assert)
import Test.Tasty.QuickCheck
import qualified Data.Pool as Pool
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.Options as Client
import qualified Database.Postgres.Temp as Tmp
import qualified Shelly as SH
import Paths_gargantext
-- | Keeps a log of usernames we have already generated, so that our
-- roundtrip tests won't fail.
uniqueArbitraryNewUser :: Int -> Gen (NewUser GargPassword)
uniqueArbitraryNewUser currentIx = do
ur <- (`mappend` (T.pack (show currentIx) <> "-")) <$> ascii_txt
let email = ur <> "@foo.com"
NewUser <$> pure ur <*> pure email <*> elements arbitraryPassword
where
ascii_txt :: Gen T.Text
ascii_txt = fmap (T.pack . getPrintableString) arbitrary
-- | Test DB settings.
dbUser, dbPassword, dbName :: String
dbUser = "gargantua"
dbPassword = "gargantua_test"
dbName = "gargandbV5"
dbName = "gargandb_test"
newtype Counter = Counter { _Counter :: IORef Int }
deriving Eq
instance Show Counter where
show (Counter _) = "Counter"
emptyCounter :: IO Counter
emptyCounter = Counter <$> newIORef 0
nextCounter :: Counter -> IO Int
nextCounter (Counter ref) = atomicModifyIORef' ref (\old -> (succ old, old))
data TestEnv = TestEnv {
test_db :: !DBHandle
, test_config :: !GargConfig
, test_usernameGen :: !Counter
}
newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
......@@ -72,9 +102,6 @@ fakeIniPath = getDataFileName "test-data/test_config.ini"
gargDBSchema :: IO FilePath
gargDBSchema = getDataFileName "devops/postgres/schema.sql"
gargDBExtensionsSchema :: IO FilePath
gargDBExtensionsSchema = getDataFileName "devops/postgres/extensions.sql"
teardown :: TestEnv -> IO ()
teardown TestEnv{..} = do
destroyAllResources $ _DBHandle test_db
......@@ -87,7 +114,7 @@ bootstrapDB tmpDB pool _cfg = Pool.withResource pool $ \conn -> do
schemaPath <- gargDBSchema
let connString = Tmp.toConnectionString tmpDB
(res,ec) <- shelly $ silently $ escaping False $ do
result <- run "psql" ["-d", "\"" <> TE.decodeUtf8 connString <> "\"", "<", fromString schemaPath]
result <- SH.run "psql" ["-d", "\"" <> TE.decodeUtf8 connString <> "\"", "<", fromString schemaPath]
(result,) <$> lastExitCode
unless (ec == 0) $ throwIO (userError $ show ec <> ": " <> T.unpack res)
......@@ -107,26 +134,75 @@ setup = do
Right db -> do
gargConfig <- fakeIniPath >>= readConfig
pool <- createPool (PG.connectPostgreSQL (Tmp.toConnectionString db))
(PG.close)
2
60
2
(PG.close) 2 60 2
bootstrapDB db pool gargConfig
pure $ TestEnv (DBHandle pool db) gargConfig
ugen <- emptyCounter
pure $ TestEnv (DBHandle pool db) gargConfig ugen
withTestDB :: (TestEnv -> IO ()) -> IO ()
withTestDB = bracket setup teardown
tests :: Spec
tests = sequential $ aroundAll withTestDB $ describe "Database" $ do
describe "Read/Writes" $
describe "User creation" $ do
it "Simple write/read" writeRead01
it "Simple duplicate" mkUserDup
it "Read/Write roundtrip" prop_userCreationRoundtrip
tests :: TestTree
tests = withResource setup teardown $
\getEnv -> testGroup "Database" [unitTests getEnv]
data ExpectedActual a =
Expected a
| Actual a
deriving Show
unitTests :: IO TestEnv -> TestTree
unitTests getEnv = testGroup "Read/Writes"
[ testCase "Simple write" (write01 getEnv)
]
instance Eq a => Eq (ExpectedActual a) where
(Expected a) == (Actual b) = a == b
(Actual a) == (Expected b) = a == b
_ == _ = False
write01 :: IO TestEnv -> Assertion
write01 getEnv = do
env <- getEnv
writeRead01 :: TestEnv -> Assertion
writeRead01 env = do
flip runReaderT env $ runTestMonad $ do
let nur1 = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
let nur2 = mkNewUser "paul@acme.com" (GargPassword "my_secret")
uid1 <- new_user nur1
uid2 <- new_user nur2
liftBase $ uid1 `shouldBe` 1
liftBase $ uid2 `shouldBe` 2
-- Getting the users by username returns the expected IDs
uid1' <- getUserId (UserName "alfredo")
uid2' <- getUserId (UserName "paul")
liftBase $ uid1' `shouldBe` 1
liftBase $ uid2' `shouldBe` 2
mkUserDup :: TestEnv -> Assertion
mkUserDup env = do
let x = flip runReaderT env $ runTestMonad $ do
-- This should fail, because user 'alfredo' exists already.
let nur = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
x <- new_user nur
liftBase $ x `shouldBe` 1
\ No newline at end of file
new_user nur
--
-- SqlError {sqlState = "23505", sqlExecStatus = FatalError
-- , sqlErrorMsg = "duplicate key value violates unique constraint \"auth_user_username_idx1\""
-- , sqlErrorDetail = "Key (username)=(alfredo) already exists.", sqlErrorHint = ""
-- }
--
-- Postgres increments the underlying SERIAL for the user even if the request fails, see
-- https://stackoverflow.com/questions/37204749/serial-in-postgres-is-being-increased-even-though-i-added-on-conflict-do-nothing
-- This means that the next available ID is '3'.
x `shouldThrow` (\SqlError{..} -> sqlErrorDetail == "Key (username)=(alfredo) already exists.")
runEnv :: TestEnv -> TestMonad a -> PropertyM IO a
runEnv env act = run (flip runReaderT env $ runTestMonad act)
prop_userCreationRoundtrip :: TestEnv -> Property
prop_userCreationRoundtrip env = monadicIO $ do
nextAvailableCounter <- run (nextCounter $ test_usernameGen env)
nur <- pick (uniqueArbitraryNewUser nextAvailableCounter)
uid <- runEnv env (new_user nur)
ur' <- runEnv env (getUserId (UserName $ _nu_username nur))
run (Expected uid `shouldBe` Actual ur')
test/Parsers/Date.hs
View file @ f760d187
......@@ -18,7 +18,6 @@ module Parsers.Date where
import Test.Hspec
import Test.QuickCheck
import Control.Applicative ((<*>))
import Data.Either (Either(..))
import Data.Time (ZonedTime(..))
import Data.Text (pack, Text)
......
test/Parsers/Types.hs
View file @ f760d187
......@@ -25,7 +25,6 @@ import Test.QuickCheck.Instances ()
import Text.Parsec.Pos
import Text.Parsec.Error (ParseError, Message(..), newErrorMessage)
import Data.Time.LocalTime (ZonedTime (..), TimeZone (..), TimeOfDay(..), LocalTime(..))
import Data.Eq (Eq(..))
import Data.Either (Either(..))
deriving instance Eq ZonedTime
......
test/Utils/Jobs.hs
View file @ f760d187
......@@ -228,6 +228,7 @@ instance MonadJobStatus MyDummyMonad where
markFailure steps mb_msg jh = MyDummyMonad (markFailure steps mb_msg jh)
markComplete jh = MyDummyMonad (markComplete jh)
markFailed mb_msg jh = MyDummyMonad (markFailed mb_msg jh)
addMoreSteps steps jh = MyDummyMonad (addMoreSteps steps jh)
runMyDummyMonad :: Env -> MyDummyMonad a -> IO a
runMyDummyMonad env m = do
......
test/hspec/Main.hs 0 → 100644
View file @ f760d187
module Main where
import Gargantext.Prelude
import qualified Database.Operations as DB
import Test.Hspec
-- It's especially important to use Hspec for DB tests, because,
-- unlike 'tasty', 'Hspec' has explicit control over parallelism,
-- and it's important that DB tests are run according to a very
-- precise order, as they are not independent from each other.
-- Unfortunately it's not possibly to use the 'tasty-hspec' adapter
-- because by the time we get a 'TestTree' out of the adapter library,
-- the information about parallelism is lost.
main :: IO ()
main = hspec DB.tests
test/Main.hs → test/tasty/Main.hs
View file @ f760d187
{-|
{--|
Module : Main.hs
Description : Main for Gargantext Tests
Description : Main for Gargantext Tasty Tests
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
......@@ -8,6 +8,7 @@ Stability : experimental
Portability : POSIX
-}
module Main where
import Gargantext.Prelude
......@@ -44,5 +45,4 @@ main = do
, NgramsQuery.tests
, CorpusQuery.tests
, JSON.tests
, DB.tests
]
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment