Add test for duplicate user creation

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 ()

gargantext.cabal

@@ -123,6 +123,7 @@ 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.Database.Schema.User
@@ -339,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
@@ -929,7 +929,7 @@ test-suite garg-test
       NoImplicitPrelude
       OverloadedStrings
       RankNTypes
-  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N1
   build-depends:
       QuickCheck ^>= 2.14.2
     , aeson ^>= 1.5.6.0

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

test/Database/Operations.hs

 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE TupleSections        #-}
+{-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans      #-}
 
@@ -14,11 +15,9 @@ 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
@@ -29,7 +28,6 @@ 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
@@ -38,13 +36,16 @@ import qualified Database.Postgres.Temp as Tmp
 import qualified Shelly as SH
 
 import Paths_gargantext
+import Database.PostgreSQL.Simple
+import Gargantext.Database.Action.User
 
 -- | Keeps a log of usernames we have already generated, so that our
 -- roundtrip tests won't fail.
-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
+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
@@ -53,13 +54,24 @@ uniqueArbitraryNewUser alreadyTakenNames = do
 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 :: !(IORef (S.Set Username))
+  , test_usernameGen :: !Counter
   }
 
 newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
@@ -126,7 +138,7 @@ setup = do
       pool <- createPool (PG.connectPostgreSQL (Tmp.toConnectionString db))
                          (PG.close) 2 60 2
       bootstrapDB db pool gargConfig
-      ugen <- newIORef mempty
+      ugen <- emptyCounter
       pure $ TestEnv (DBHandle pool db) gargConfig ugen
 
 tests :: TestTree
@@ -136,18 +148,59 @@ tests = withResource setup teardown $
 unitTests :: IO TestEnv -> TestTree
 unitTests getEnv = testGroup "Read/Writes"
   [ testGroup "User creation" [
-      testCase     "Simple write" (write01 getEnv)
+      testCase     "Simple write/read" (writeRead01 getEnv)
+    , testCase     "Simple duplicate"  (mkUserDup getEnv)
     , testProperty "Read/Write roundtrip" $ prop_userCreationRoundtrip getEnv
     ]
   ]
 
-write01 :: IO TestEnv -> Assertion
-write01 getEnv = do
+data ExpectedActual a =
+    Expected a
+  | Actual a
+  deriving Show
+
+instance Eq a => Eq (ExpectedActual a) where
+  (Expected a) == (Actual b)   = a == b
+  (Actual a)   == (Expected b) = a == b
+  _ == _ = False
+
+
+writeRead01 :: IO TestEnv -> Assertion
+writeRead01 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
+    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 :: IO TestEnv -> Assertion
+mkUserDup getEnv = do
+  env <- getEnv
+  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)
@@ -155,10 +208,8 @@ 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)
+  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')