DB functions requires less effects

This important commit introduces the 'DbCmd' constraint set, allowing DB
functions to require only a connection pool and some `GargConfig`.

gargantext.cabal

@@ -920,6 +920,7 @@ test-suite garg-test
     , parsec
     , patches-class
     , patches-map
+    , postgresql-simple
     , quickcheck-instances
     , raw-strings-qq
     , recover-rtti
@@ -931,6 +932,7 @@ test-suite garg-test
     , tasty-quickcheck
     , text
     , time
+    , tmp-postgres
     , unordered-containers
     , validity
   default-language: Haskell2010

src/Gargantext/API/Node/Share.hs

@@ -91,7 +91,7 @@ api userInviting nId (ShareTeamParams user') = do
                   pure 0
                 False -> do
                   -- printDebug "[G.A.N.Share.api]" ("Your invitation is sent to: " <> user'')
-                  newUsers [user'']
+                  newUser user''
               pure ()
           pure u
 

src/Gargantext/Core/Mail.hs

@@ -12,6 +12,8 @@ Portability : POSIX
 module Gargantext.Core.Mail where
 
 import Control.Lens (view)
+import Control.Monad.Reader (MonadReader)
+import Control.Monad.Trans.Control (MonadBaseControl)
 import Network.URI.Encode (encodeText)
 import Data.Text (Text, unlines, splitOn)
 import Gargantext.Core.Types.Individu
@@ -19,7 +21,6 @@ import Gargantext.Database.Schema.User (UserLight(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (gc_url, gc_backend_name)
 import Gargantext.Database.Prelude
--- import Gargantext.Prelude.Config (gc_url)
 import Gargantext.Prelude.Mail (gargMail, GargMail(..))
 import Gargantext.Prelude.Mail.Types (MailConfig)
 import qualified Data.List as List
@@ -30,7 +31,7 @@ isEmail :: Text -> Bool
 isEmail = ((==) 2) . List.length . (splitOn "@")
 
 ------------------------------------------------------------------------
-data SendEmail    = SendEmail Bool
+newtype SendEmail = SendEmail Bool
 
 type EmailAddress  = Text
 type Name          = Text
@@ -45,8 +46,31 @@ data MailModel = Invitation { invitation_user :: NewUser GargPassword }
                             }
                | ForgotPassword { user :: UserLight }
 ------------------------------------------------------------------------
+
+-- | Execute the given input action 'act', sending an email notification
+-- only if 'SendEmail' says so.
+withNotification :: (MonadBaseControl IO m, HasConfig env, MonadReader env m)
+                 => SendEmail
+                 -> MailConfig
+                 -> (notificationBody -> MailModel)
+                -- ^ A function which can build a 'MailModel' out of
+                -- the returned type of the action.
+                 -> m (a, notificationBody)
+                -- ^ The action to run. Returns the value @a@ to return
+                -- upstream alongside anything needed to build a 'MailModel'.
+                 -> m a
+withNotification (SendEmail doSend) cfg mkNotification act = do
+  (r, notificationBody) <- act
+  when doSend $ mail cfg (mkNotification notificationBody)
+  pure r
+
 ------------------------------------------------------------------------
-mail :: (CmdM env err m) => MailConfig -> MailModel -> m ()
+mail :: (MonadBaseControl IO m, MonadReader env m, HasConfig env)
+     => MailConfig
+     -- ^ The configuration for the email
+     -> MailModel
+     -- ^ The notification we want to emit.
+     -> m ()
 mail mailCfg model = do
   cfg <- view hasConfig
   let

src/Gargantext/Database/Action/Node.hs

@@ -41,7 +41,7 @@ mkNodeWithParent :: (HasNodeError err, HasDBid NodeType)
                  -> Maybe ParentId
                  -> UserId
                  -> Name
-                 -> Cmd err [NodeId]
+                 -> DBCmd err [NodeId]
 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
 
 ------------------------------------------------------------------------
@@ -75,7 +75,7 @@ mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err, HasDBid NodeType)
                                     -> Maybe ParentId
                                     -> UserId
                                     -> Name
-                                    -> Cmd err [NodeId]
+                                    -> DBCmd err [NodeId]
 mkNodeWithParent_ConfigureHyperdata Notes (Just i) uId name =
   mkNodeWithParent_ConfigureHyperdata' Notes (Just i) uId name
 
@@ -99,7 +99,7 @@ mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType)
                                     -> Maybe ParentId
                                     -> UserId
                                     -> Name
-                                    -> Cmd err [NodeId]
+                                    -> DBCmd err [NodeId]
 mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
   maybeNodeId <- case nt of
      Notes -> insertNode Notes (Just name)   Nothing i uId

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)
+import Gargantext.Database.Prelude (Cmd, DBCmd)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.User
 import Gargantext.Database.Query.Table.Node.Error
@@ -40,7 +40,7 @@ getUserLightDB u = do
 ------------------------------------------------------------------------
 getUserId :: HasNodeError err
           => User
-          -> Cmd err UserId
+          -> DBCmd err UserId
 getUserId u = do
   maybeUser <- getUserId' u
   case maybeUser of
@@ -49,7 +49,7 @@ getUserId u = do
 
 getUserId' :: HasNodeError err
           => User
-          -> Cmd err (Maybe UserId)
+          -> DBCmd err (Maybe UserId)
 getUserId' (UserDBId uid) = pure (Just uid)
 getUserId' (RootId   rid) = do
   n <- getNode rid
@@ -68,7 +68,7 @@ getUserId' UserPublic = pure Nothing
 type Username = Text
 getUsername :: HasNodeError err
             => User
-            -> Cmd err Username
+            -> DBCmd err Username
 getUsername (UserName u) = pure u
 getUsername user@(UserDBId _) = do
   users <- getUsersWithId user

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

@@ -8,9 +8,15 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-{-# OPTIONS_GHC -fno-warn-orphans        #-}
-
 module Gargantext.Database.Action.User.New
+  (
+    -- * Creating users
+    newUser
+  , newUsers
+    -- * Helper functions
+  , guessUserName
+    -- * Internal types and functions for testing
+  )
   where
 
 import Control.Lens (view)
@@ -29,35 +35,49 @@ import Gargantext.Prelude.Mail.Types (MailConfig)
 import qualified Data.Text as Text
 
 ------------------------------------------------------------------------
-newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
-         => [EmailAddress] -> m Int64
-newUsers us = do
-  us' <- mapM newUserQuick us
-  config <- view $ mailSettings
-  newUsers' config us'
+-- | Creates a new 'User' from the input 'EmailAddress', which needs to
+-- 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
+newUser emailAddress = do
+  cfg <- view mailSettings
+  nur  <- newUserQuick emailAddress
+  affectedRows <- new_users [nur]
+  withNotification (SendEmail True) cfg Invitation $ pure (affectedRows, nur)
 
 ------------------------------------------------------------------------
+-- | A DB-specific action to bulk-create users.
+-- 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 'newUsers' instead for standard Gargantext code.
+new_users :: HasNodeError err
+          => [NewUser GargPassword]
+          -- ^ A list of users to create.
+          -> DBCmd err Int64
+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
 
-updateUsersPassword :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
+------------------------------------------------------------------------
+newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
          => [EmailAddress] -> m Int64
-updateUsersPassword us = do
+newUsers us = do
   us' <- mapM newUserQuick us
   config <- view $ mailSettings
-  _ <- mapM (\u -> updateUser (SendEmail True) config u) us'
-  pure 1
+  newUsers' config us'
 
-------------------------------------------------------------------------
 ------------------------------------------------------------------------
 newUserQuick :: (MonadRandom m)
              => Text -> m (NewUser GargPassword)
-newUserQuick n = do
+newUserQuick emailAddress = do
   pass <- gargPass
-  let n' = Text.toLower n
-  let u = case guessUserName n of
+  let  username = case guessUserName emailAddress of
         Just  (u', _m) -> u'
         Nothing        -> panic "[G.D.A.U.N.newUserQuick]: Email invalid"
-  pure (NewUser u n' (GargPassword pass))
-------------------------------------------------------------------------
+  pure (NewUser username (Text.toLower emailAddress) (GargPassword pass))
 
 ------------------------------------------------------------------------
 -- | guessUserName
@@ -67,11 +87,8 @@ guessUserName n = case splitOn "@" n of
     [u',m'] -> if m' /= "" then Just (Text.toLower u',m')
                            else Nothing
     _       -> Nothing
-------------------------------------------------------------------------
-newUser' :: HasNodeError err
-        => MailConfig -> NewUser GargPassword -> Cmd err Int64
-newUser' cfg u = newUsers' cfg [u]
 
+------------------------------------------------------------------------
 newUsers' :: HasNodeError err
          => MailConfig -> [NewUser GargPassword] -> Cmd err Int64
 newUsers' cfg us = do
@@ -81,23 +98,33 @@ newUsers' cfg us = do
   _   <- mapM (\u -> mail cfg (Invitation u)) us
   -- printDebug "newUsers'" us
   pure r
+
 ------------------------------------------------------------------------
+-- | Updates a user's password, notifying the user via email, if necessary.
 updateUser :: HasNodeError err
-           => SendEmail -> MailConfig -> NewUser GargPassword -> Cmd err Int64
+            => SendEmail -> MailConfig -> NewUser GargPassword -> Cmd err Int64
 updateUser (SendEmail send) cfg u = do
   u' <- liftBase     $ toUserHash   u
   n  <- updateUserDB $ toUserWrite  u'
-  _  <- case send of
-     True  -> mail cfg (PassUpdate u)
-     False -> pure ()
+  when send $ mail cfg (PassUpdate u)
   pure n
 
 ------------------------------------------------------------------------
-rmUser :: HasNodeError err => User -> Cmd err Int64
-rmUser (UserName un) = deleteUsers [un]
-rmUser _ = nodeError NotImplYet
+_updateUsersPassword :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
+         => [EmailAddress] -> m Int64
+_updateUsersPassword us = do
+  us' <- mapM newUserQuick us
+  config <- view $ mailSettings
+  _ <- mapM (\u -> updateUser (SendEmail True) config u) us'
+  pure 1
+
+------------------------------------------------------------------------
+_rmUser :: HasNodeError err => User -> Cmd err Int64
+_rmUser (UserName un) = deleteUsers [un]
+_rmUser _ = nodeError NotImplYet
 
+------------------------------------------------------------------------
 -- TODO
-rmUsers :: HasNodeError err => [User] -> Cmd err Int64
-rmUsers [] = pure 0
-rmUsers _  = undefined
+_rmUsers :: HasNodeError err => [User] -> Cmd err Int64
+_rmUsers [] = pure 0
+_rmUsers _  = undefined

src/Gargantext/Database/Prelude.hs

@@ -69,20 +69,26 @@ type CmdM'' env err m =
   , MonadError          err m
   , MonadBaseControl IO     m
   , MonadRandom             m
-  --, MonadLogger             m
   )
 
 type CmdM' env err m =
   ( MonadReader     env     m
   , MonadError          err m
   , MonadBaseControl IO     m
-  --, MonadLogger             m
-  -- , MonadRandom             m
   )
 
-type CmdCommon env =
+-- | If possible, try to not add more constraints here. When performing
+-- a query/update on the DB, one shouldn't need more than being able to
+-- fetch from the underlying 'env' the connection pool and access the
+-- 'GargConfig' for some sensible defaults to store into the DB.
+type DbCommon env =
   ( HasConnectionPool env
   , HasConfig         env
+  )
+
+type CmdCommon env =
+  ( DbCommon          env
+  , HasConfig         env
   , HasMail           env
   , HasNLPServer      env )
 
@@ -93,8 +99,7 @@ type CmdM env err m =
 
 type CmdRandom env err m =
   ( CmdM'             env err m
-  , HasConnectionPool env
-  , HasConfig         env
+  , DbCommon          env
   , MonadRandom       m
   , HasMail           env
   )
@@ -103,14 +108,21 @@ type Cmd'' env err a = forall m.     CmdM''    env err m => m a
 type Cmd'  env err a = forall m.     CmdM'     env err m => m a
 type Cmd       err a = forall m env. CmdM      env err m => m a
 type CmdR      err a = forall m env. CmdRandom env err m => m a
-
-
+type DBCmd     err a = forall m env. DbCmd'    env err m => m a
+
+-- | Only the /minimum/ amount of class constraints required
+-- to use the Gargantext Database. It's important, to ease testability,
+-- that these constraints stays as few as possible.
+type DbCmd' env err m = (
+    CmdM' env err m
+  , DbCommon env
+  )
 
 fromInt64ToInt :: Int64 -> Int
 fromInt64ToInt = fromIntegral
 
 -- TODO: ideally there should be very few calls to this functions.
-mkCmd :: (Connection -> IO a) -> Cmd err a
+mkCmd :: (Connection -> IO a) -> DBCmd err a
 mkCmd k = do
   pool <- view connPool
   withResource pool (liftBase . k)
@@ -123,7 +135,7 @@ runCmd env m = runExceptT $ runReaderT m env
 
 runOpaQuery :: Default FromFields fields haskells
             => Select fields
-            -> Cmd err [haskells]
+            -> DBCmd err [haskells]
 runOpaQuery q = mkCmd $ \c -> runSelect c q
 
 runCountOpaQuery :: Select a -> Cmd err Int

src/Gargantext/Database/Query/Table/Node.hs

@@ -252,7 +252,7 @@ nodeExists :: (HasNodeError err) => NodeId -> Cmd err Bool
 nodeExists nId = (== [PGS.Only True])
   <$> runPGSQuery [sql|SELECT true FROM nodes WHERE id = ? |] (PGS.Only nId)
 
-getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
+getNode :: HasNodeError err => NodeId -> DBCmd err (Node Value)
 getNode nId = do
   maybeNode <- headMay <$> runOpaQuery (selectNode (pgNodeId nId))
   case maybeNode of
@@ -283,7 +283,7 @@ insertDefaultNodeIfNotExists nt p u = do
     xs -> pure xs
 
 insertNode :: HasDBid NodeType
-           => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
+           => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> DBCmd err [NodeId]
 insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 
 nodeW ::  HasDBid NodeType
@@ -313,7 +313,7 @@ node nodeType name hyperData parentId userId =
       typeId = toDBid nodeType
 
                   -------------------------------
-insertNodes :: [NodeWrite] -> Cmd err Int64
+insertNodes :: [NodeWrite] -> DBCmd err Int64
 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount Nothing
 
 {-
@@ -333,14 +333,14 @@ insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
               ) ns
 -}
 
-insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
+insertNodesR :: [NodeWrite] -> DBCmd err [NodeId]
 insertNodesR ns = mkCmd $ \conn ->
   runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
 
-insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
+insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> DBCmd err Int64
 insertNodesWithParent pid ns = insertNodes (set node_parent_id (pgNodeId <$> pid) <$> ns)
 
-insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
+insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> DBCmd err [NodeId]
 insertNodesWithParentR pid ns = insertNodesR (set node_parent_id (pgNodeId <$> pid) <$> ns)
 ------------------------------------------------------------------------
 -- TODO

src/Gargantext/Database/Query/Table/Node/UpdateOpaleye.hs

@@ -22,13 +22,13 @@ import Gargantext.Prelude
 import Gargantext.Database.Schema.Node
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude (Cmd, mkCmd)
+import Gargantext.Database.Prelude (Cmd, mkCmd, JSONB, DBCmd)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error
 
 import Debug.Trace (trace)
 
-updateHyperdata :: HyperdataC a => NodeId -> a -> Cmd err Int64
+updateHyperdata :: HyperdataC a => NodeId -> a -> DBCmd err Int64
 updateHyperdata i h = mkCmd $ \c -> putStrLn "before runUpdate_" >>
                                     runUpdate_ c (updateHyperdataQuery i h) >>= \res ->
                                     putStrLn "after runUpdate_" >> return res

src/Gargantext/Database/Query/Table/User.hs

@@ -71,7 +71,7 @@ import Gargantext.Database.Admin.Config (nodeTypeId)
 
 ------------------------------------------------------------------------
 -- TODO: on conflict, nice message
-insertUsers :: [UserWrite] -> Cmd err Int64
+insertUsers :: [UserWrite] -> DBCmd err Int64
 insertUsers us = mkCmd $ \c -> runInsert_ c insert
   where
     insert = Insert userTable us rCount Nothing
@@ -147,7 +147,7 @@ selectUsersLightWithForgotPasswordUUID uuid = proc () -> do
       returnA  -< row
 
 ----------------------------------------------------------
-getUsersWithId :: User -> Cmd err [UserLight]
+getUsersWithId :: User -> DBCmd err [UserLight]
 getUsersWithId (UserDBId i) = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
   where
     selectUsersLightWithId :: Int -> Select UserRead
@@ -293,13 +293,13 @@ userLightWithUsername t xs = userWith userLight_username t xs
 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 userLightWithId t xs = userWith userLight_id t xs
 ----------------------------------------------------------------------
-users :: Cmd err [UserDB]
+users :: DBCmd err [UserDB]
 users = runOpaQuery queryUserTable
 
-usersLight :: Cmd err [UserLight]
+usersLight :: DBCmd err [UserLight]
 usersLight = map toUserLight <$> users
 
-getUser :: Username -> Cmd err (Maybe UserLight)
+getUser :: Username -> DBCmd err (Maybe UserLight)
 getUser u = userLightWithUsername u <$> usersLight
 
 ----------------------------------------------------------------------

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)
+import Gargantext.Database.Prelude (Cmd, runOpaQuery, DBCmd)
 import Gargantext.Database.Query.Table.Node
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
@@ -41,12 +41,12 @@ getRootId u = do
     Nothing -> nodeError $ NodeError "[G.D.Q.T.R.getRootId] No root id"
     Just  r -> pure (_node_id r)
 
-getRoot :: User -> Cmd err [Node HyperdataUser]
+getRoot :: User -> DBCmd err [Node HyperdataUser]
 getRoot = runOpaQuery . selectRoot
 
 getOrMkRoot :: (HasNodeError err)
             => User
-            -> Cmd err (UserId, RootId)
+            -> DBCmd err (UserId, RootId)
 getOrMkRoot user = do
   userId <- getUserId user
 
@@ -91,7 +91,7 @@ getOrMk_RootWithCorpus user cName c = do
 
 mkRoot :: HasNodeError err
        => User
-       -> Cmd err [RootId]
+       -> DBCmd err [RootId]
 mkRoot user = do
 
   -- TODO

stack.yaml

@@ -133,6 +133,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
+- tmp-postgres-1.34.1.0
 - vector-0.12.3.0@sha256:0ae2c1ba86f0077910be242ec6802cc3d7725fe7b2bea6987201aa3737b239b5,7953
 - xmlbf-0.6.1@sha256:57867fcb39e0514d17b3328ff5de8d241a18482fc89bb742d9ed820a6a2a5187,1540
 - xmlbf-xeno-0.2@sha256:39f70fced6052524c290cf595f114661c721452e65fc3e0953a44e7682a6a6b0,950