Merge branch 'dev' into 594-dev-ngrams-click-fixes

.gitlab-ci.yml

@@ -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

CHANGELOG.md

+## Version 0.0.6.9.9.7.6.3
+
+* [BACK][TESTS] Make a start on benchmarking, add more tests
+
 ## Version 0.0.6.9.9.7.6.2
 
 * [BACK][FIX] CI

bench/Main.hs

+{-# 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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -5,7 +5,7 @@ cabal-version: 2.0
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.6.9.9.7.6.2
+version: 0.0.6.9.9.7.6.3
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -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
@@ -926,6 +935,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
@@ -948,6 +1038,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
@@ -955,3 +1046,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

+{-# 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

@@ -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

@@ -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
+  us'   <- liftBase        $ mapM toUserHash us
+  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

@@ -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

@@ -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

@@ -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

@@ -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

 {-# 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_db          :: !DBHandle
+  , test_config      :: !GargConfig
+  , test_usernameGen :: !Counter
   }
 
 newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
@@ -52,7 +82,7 @@ newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
            , MonadBaseControl IO
            )
 
-data DBHandle = DBHandle { 
+data DBHandle = DBHandle {
     _DBHandle :: Pool PG.Connection
   , _DBTmp    :: Tmp.DB
   }
@@ -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
+
+data ExpectedActual a =
+    Expected a
+  | Actual a
+  deriving Show
 
-tests :: TestTree
-tests = withResource setup teardown $
-  \getEnv -> testGroup "Database" [unitTests getEnv]
+instance Eq a => Eq (ExpectedActual a) where
+  (Expected a) == (Actual b)   = a == b
+  (Actual a)   == (Expected b) = a == b
+  _ == _ = False
 
-unitTests :: IO TestEnv -> TestTree
-unitTests getEnv = testGroup "Read/Writes"
-  [ testCase "Simple write" (write01 getEnv)
-  ]
 
-write01 :: IO TestEnv -> Assertion
-write01 getEnv = do
-  env <- getEnv
+writeRead01 :: TestEnv -> Assertion
+writeRead01 env = do
   flip runReaderT env $ runTestMonad $ do
-    let nur = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
-    x <- new_user nur
-    liftBase $ x `shouldBe` 1
+    let nur1 = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
+    let nur2 = mkNewUser "paul@acme.com" (GargPassword "my_secret")
+
\ No newline at end of file
+    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")
+            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

@@ -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

@@ -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

@@ -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

+
+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

-{-|
+{--|
 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
     ]