Skip to content

haskell-gargantext
haskell-gargantext
Commit 8a2cabfd authored by Alfredo Di Napoli's avatar Alfredo Di Napoli
Browse files
Options

Add test for duplicate user creation

parent 35cb5887
Hide whitespace changes
Inline Side-by-side
Showing with 104 additions and 48 deletions
bin/gargantext-admin/Main.hs
View file @ 8a2cabfd
......@@ -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
View file @ 8a2cabfd
......@@ -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
View file @ 8a2cabfd
......@@ -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
View file @ 8a2cabfd
......@@ -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 @ 8a2cabfd
......@@ -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 @ 8a2cabfd
......@@ -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
View file @ 8a2cabfd
{-# 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')
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