Barebone DB testing code

gargantext.cabal

@@ -24,6 +24,7 @@ data-files:
     test-data/ngrams/GarganText_NgramsTerms-QuantumComputing.json
     test-data/phylo/bpa_phylo_test.json
     test-data/phylo/open_science.json
+    test-data/test_config.ini
     .clippy.dhall
 
 library
@@ -108,6 +109,7 @@ library
       Gargantext.Database.Prelude
       Gargantext.Database.Query.Table.NgramsPostag
       Gargantext.Database.Query.Table.Node
+      Gargantext.Database.Query.Table.Node.Error
       Gargantext.Database.Query.Table.Node.UpdateOpaleye
       Gargantext.Database.Query.Table.User
       Gargantext.Database.Schema.Ngrams
@@ -309,7 +311,6 @@ library
       Gargantext.Database.Query.Table.Node.Contact
       Gargantext.Database.Query.Table.Node.Document.Add
       Gargantext.Database.Query.Table.Node.Document.Insert
-      Gargantext.Database.Query.Table.Node.Error
       Gargantext.Database.Query.Table.Node.Select
       Gargantext.Database.Query.Table.Node.Update
       Gargantext.Database.Query.Table.Node.User
@@ -854,6 +855,7 @@ test-suite garg-test
       Core.Text.Examples
       Core.Text.Flow
       Core.Utils
+      Database.Operations
       Graph.Clustering
       Graph.Distance
       Ngrams.Lang
@@ -916,7 +918,9 @@ test-suite garg-test
     , hspec-expectations >= 0.8.3
     , http-client
     , http-client-tls
+    , monad-control
     , mtl
+    , lens
     , parsec
     , patches-class
     , patches-map
@@ -924,6 +928,7 @@ test-suite garg-test
     , quickcheck-instances
     , raw-strings-qq
     , recover-rtti
+    , resource-pool
     , servant-job
     , stm
     , tasty

src/Gargantext/Database/Action/User/New.hs

@@ -16,6 +16,8 @@ module Gargantext.Database.Action.User.New
     -- * Helper functions
   , guessUserName
     -- * Internal types and functions for testing
+  , new_user
+  , mkNewUser
   )
   where
 
@@ -42,10 +44,21 @@ newUser :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
         -> m Int64
 newUser emailAddress = do
   cfg <- view mailSettings
-  nur  <- newUserQuick emailAddress
-  affectedRows <- new_users [nur]
+  pwd <- gargPass
+  let nur = mkNewUser emailAddress (GargPassword pwd)
+  affectedRows <- new_user nur
   withNotification (SendEmail True) cfg Invitation $ pure (affectedRows, nur)
 
+------------------------------------------------------------------------
+-- | A DB-specific action to create a single user.
+-- This is an internal function and as such it /doesn't/ send out any email
+-- notification, and thus lives in the 'DbCmd' effect stack. You may want to
+-- use 'newUser' instead for standard Gargantext code.
+new_user :: HasNodeError err
+         => NewUser GargPassword
+         -> DBCmd err Int64
+new_user = new_users . (:[])
+
 ------------------------------------------------------------------------
 -- | A DB-specific action to bulk-create users.
 -- This is an internal function and as such it /doesn't/ send out any email
@@ -63,21 +76,20 @@ new_users us = do
 
 ------------------------------------------------------------------------
 newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
-         => [EmailAddress] -> m Int64
+         => [EmailAddress]
+         -> m Int64
 newUsers us = do
-  us' <- mapM newUserQuick us
   config <- view $ mailSettings
+  us' <- mapM (\ea -> mkNewUser ea . GargPassword <$> gargPass) us
   newUsers' config us'
 
 ------------------------------------------------------------------------
-newUserQuick :: (MonadRandom m)
-             => Text -> m (NewUser GargPassword)
-newUserQuick emailAddress = do
-  pass <- gargPass
+mkNewUser :: EmailAddress -> GargPassword -> NewUser GargPassword
+mkNewUser emailAddress pass =
   let  username = case guessUserName emailAddress of
         Just  (u', _m) -> u'
         Nothing        -> panic "[G.D.A.U.N.newUserQuick]: Email invalid"
-  pure (NewUser username (Text.toLower emailAddress) (GargPassword pass))
+  in (NewUser username (Text.toLower emailAddress) pass)
 
 ------------------------------------------------------------------------
 -- | guessUserName
@@ -113,7 +125,7 @@ updateUser (SendEmail send) cfg u = do
 _updateUsersPassword :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
          => [EmailAddress] -> m Int64
 _updateUsersPassword us = do
-  us' <- mapM newUserQuick us
+  us' <- mapM (\ea -> mkNewUser ea . GargPassword <$> gargPass) us
   config <- view $ mailSettings
   _ <- mapM (\u -> updateUser (SendEmail True) config u) us'
   pure 1

test/Database/Operations.hs

+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans      #-}
+
+module Database.Operations where
+
+import Control.Exception
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Data.Pool hiding (withResource)
+import Gargantext.Database.Action.User.New
+import Gargantext.Database.Prelude
+import Gargantext.Prelude
+import Gargantext.Prelude.Config
+import Prelude
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.Hspec
+import qualified Database.PostgreSQL.Simple as PG
+import qualified Database.Postgres.Temp as Tmp
+
+import Paths_gargantext
+import Control.Lens
+import Gargantext.Database.Query.Table.Node.Error
+import Gargantext.Core.Types.Individu
+
+data TestEnv = TestEnv {
+    test_db     :: !DBHandle
+  , test_config :: !GargConfig
+  }
+
+newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
+  deriving ( Functor, Applicative, Monad
+           , MonadReader TestEnv, MonadError IOException
+           , MonadBase IO
+           , MonadBaseControl IO
+           )
+
+data DBHandle = DBHandle { 
+    _DBHandle :: Pool PG.Connection
+  , _DBTmp    :: Tmp.DB
+  }
+
+instance HasNodeError IOException where
+  _NodeError = prism' (userError . show) (const Nothing)
+
+instance HasConnectionPool TestEnv where
+  connPool = to (_DBHandle . test_db)
+
+instance HasConfig TestEnv where
+  hasConfig = to test_config
+
+fakeIniPath :: IO FilePath
+fakeIniPath = getDataFileName "test-data/test_config.ini"
+
+teardown :: TestEnv -> IO ()
+teardown TestEnv{..} = do
+  destroyAllResources $ _DBHandle test_db
+  Tmp.stop $ _DBTmp test_db
+
+setup :: IO TestEnv
+setup = do
+  res <- Tmp.startConfig Tmp.defaultConfig
+  case res of
+    Left err -> fail $ show err
+    Right db -> do
+      pool <- createPool (PG.connectPostgreSQL (Tmp.toConnectionString db))
+                         (PG.close)
+                         2
+                         60
+                         2
+      TestEnv <$> (pure $ DBHandle pool db) <*> (fakeIniPath >>= readConfig)
+
+tests :: TestTree
+tests = withResource setup teardown $
+  \getEnv -> testGroup "Database" [unitTests getEnv]
+
+unitTests :: IO TestEnv -> TestTree
+unitTests getEnv = testGroup "Read/Writes"
+  [ testCase "Simple write" (write01 getEnv)
+  ]
+
+write01 :: IO TestEnv -> Assertion
+write01 getEnv = do
+  env <- getEnv
+  flip runReaderT env $ runTestMonad $ do
+    let nur = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
+    x <- new_user nur
+    liftBase $ x `shouldBe` 1
\ No newline at end of file

test/Main.hs

@@ -12,17 +12,15 @@ Portability : POSIX
 import Gargantext.Prelude
 
 import qualified Core.Text.Corpus.Query  as CorpusQuery
-import qualified Core.Utils as Utils
---import qualified Ngrams.Lang.Fr as Fr
---import qualified Ngrams.Lang as Lang
+import qualified Core.Utils              as Utils
+import qualified Database.Operations     as DB
+import qualified Graph.Clustering        as Graph
 import qualified Ngrams.NLP              as NLP
 import qualified Ngrams.Query            as NgramsQuery
+import qualified Offline.JSON            as JSON
 import qualified Parsers.Date            as PD
--- import qualified Graph.Distance          as GD
-import qualified Graph.Clustering        as Graph
 import qualified Utils.Crypto            as Crypto
 import qualified Utils.Jobs              as Jobs
-import qualified Offline.JSON            as JSON
 
 import Test.Tasty
 import Test.Tasty.Hspec
@@ -46,9 +44,5 @@ main = do
     , NgramsQuery.tests
     , CorpusQuery.tests
     , JSON.tests
+    , DB.tests
     ]
---    Occ.parsersTest
---    Lang.ngramsExtractionTest FR
---    Lang.ngramsExtractionTest EN
---    Metrics.main
---    GD.test