Add user write/read roundtrip test

gargantext.cabal

@@ -105,6 +105,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
@@ -117,8 +118,9 @@ library
       Gargantext.Database.Query.Table.Node.UpdateOpaleye
       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 +283,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
@@ -346,7 +347,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

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

test/Database/Operations.hs

@@ -5,33 +5,47 @@
 
 module Database.Operations 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 Gargantext.Core.Types.Individu
+import Gargantext.Database.Action.User hiding (Username)
 import Gargantext.Database.Action.User.New
 import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node.Error
+import Gargantext.Database.Schema.User
 import Gargantext.Prelude
 import Gargantext.Prelude.Config
 import Prelude
-import Shelly hiding (FilePath)
+import Shelly hiding (FilePath, run)
+import Test.QuickCheck.Monadic
 import Test.Tasty
-import Test.Tasty.HUnit
+import Test.Tasty.HUnit hiding (assert)
 import Test.Tasty.Hspec
+import Test.Tasty.QuickCheck
 import qualified Data.Pool as Pool
+import qualified Data.Set as S
 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
 
+uniqueArbitraryNewUser :: S.Set Username -> Gen (NewUser GargPassword)
+uniqueArbitraryNewUser alreadyTakenNames = do
+  ur <- ascii_txt `suchThat` (not . flip S.member alreadyTakenNames)
+  NewUser <$> pure ur <*> ascii_txt <*> elements arbitraryPassword
+  where
+   ascii_txt :: Gen T.Text
+   ascii_txt = fmap (T.pack . getPrintableString) arbitrary
 
 -- | Test DB settings.
 dbUser, dbPassword, dbName :: String
@@ -41,8 +55,9 @@ dbName = "gargandbV5"
 
 
 data TestEnv = TestEnv {
-    test_db     :: !DBHandle
-  , test_config :: !GargConfig
+    test_db          :: !DBHandle
+  , test_config      :: !GargConfig
+  , test_usernameGen :: !(IORef (S.Set Username))
   }
 
 newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
@@ -52,7 +67,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
   }
@@ -87,7 +102,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,12 +122,10 @@ 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 <- newIORef mempty
+      pure $ TestEnv (DBHandle pool db) gargConfig ugen
 
 tests :: TestTree
 tests = withResource setup teardown $
@@ -120,7 +133,10 @@ tests = withResource setup teardown $
 
 unitTests :: IO TestEnv -> TestTree
 unitTests getEnv = testGroup "Read/Writes"
-  [ testCase "Simple write" (write01 getEnv)
+  [ testGroup "User creation" [
+      testCase     "Simple write" (write01 getEnv)
+    , testProperty "Read/Write roundtrip" $ withMaxSuccess 50 (prop_userCreationRoundtrip getEnv)
+    ]
   ]
 
 write01 :: IO TestEnv -> Assertion
@@ -129,4 +145,18 @@ write01 getEnv = do
   flip runReaderT env $ runTestMonad $ do
     let nur = mkNewUser "alfredo@well-typed.com" (GargPassword "my_secret")
     x <- new_user nur
-    liftBase $ x `shouldBe` 1
+    liftBase $ x `shouldBe` 1
\ No newline at end of file
+
+runEnv :: TestEnv -> TestMonad a -> PropertyM IO a
+runEnv env act = run (flip runReaderT env $ runTestMonad act)
+
+prop_userCreationRoundtrip :: IO TestEnv -> Property
+prop_userCreationRoundtrip getEnv = monadicIO $ do
+  env  <- run getEnv
+  alreadyTakenUsernames <- run (readIORef $ test_usernameGen env)
+  nur  <- pick (uniqueArbitraryNewUser alreadyTakenUsernames)
+  void $ runEnv env (new_user nur)
+  ur' <- runEnv env (getUserLightDB (UserName $ _nu_username nur))
+  assert (userLight_username ur' == _nu_username nur)
+  assert (userLight_email ur'    == _nu_email nur)
+  run (writeIORef (test_usernameGen env) $ S.insert (_nu_username nur) alreadyTakenUsernames)

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