Cleaned up the database prelude

src/Gargantext/Database/Prelude.hs

@@ -9,12 +9,50 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ConstraintKinds     #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-
-module Gargantext.Database.Prelude where
+{-# LANGUAGE TupleSections       #-}
+
+module Gargantext.Database.Prelude
+  ( -- * Types and Constraints
+    -- $typesAndConstraints
+    --
+    -- ** Environment Constraints
+    HasConnectionPool(..)
+  , IsDBEnv
+  , IsDBEnvExtra
+    -- ** Command Monad Constraints
+  , IsCmd
+  , IsDBCmd
+  , IsDBCmdExtra
+    -- ** Existential Versions of the Above Constraints, for Convenience
+  , Cmd
+  , CmdRandom
+  , DBCmd
+  , DBCmdWithEnv
+  , DBCmdExtra
+    -- ** Miscellaneous Type(s)
+  , JSONB
+    -- * Functions
+    -- ** Executing DB Queries
+    -- *** PostgreSQL.Simple
+  , execPGSQuery
+  , runPGSQuery
+  , runPGSQuery_
+    -- *** Opaleye
+  , runOpaQuery
+  , runCountOpaQuery
+    -- ** Other Functions
+  , runCmd
+  , createDBIfNotExists
+  , dbCheck
+  , formatPGSQuery
+  , fromField'
+  , mkCmd
+  , restrictMaybe
+  )
+where
 
 import Control.Exception.Safe (throw)
 import Control.Lens (Getter, view)
@@ -35,24 +73,37 @@ import Gargantext.Core.Config (HasConfig(..))
 import Gargantext.Core.Mail.Types (HasMail)
 import Gargantext.Core.NLP (HasNLPServer)
 import Gargantext.Prelude
-import Opaleye (Unpackspec, showSql, FromFields, Select, runSelect, SqlJsonb, DefaultFromField, toFields, matchMaybe, MaybeFields)
+import Opaleye (FromFields, Select, runSelect, SqlJsonb, DefaultFromField, toFields, matchMaybe, MaybeFields)
 import Opaleye.Aggregate (countRows)
 import Opaleye.Internal.Constant qualified
 import Opaleye.Internal.Operators qualified
 import Shelly qualified as SH
 
--------------------------------------------------------
+
+-- $typesAndConstraints
+--
+-- The names of the constraints and types in this module are chosen based on
+-- the following guidelines:
+-- * By default, constraints are relatively lenient. Stricter constraints are
+--   obtained by appending the `Extra` suffix to the minimal constraint name.
+-- * `IsDBEnv(Extra)` applies to the environment; the basic constraint allows
+--   access to the database, and the `Extra` variant offers some more
+--   capabilities such as access to mail.
+-- * `IsCmd` is the basic constraint for command monads. Append `DB` to it to get
+--   a monad of commands that can talk to the database. Append `Extra` to get
+--   the ability to send mail, make use of the NLP server and deal with central
+--   exchange notifications. Append `Random` to get access to randomness.
+-- * Existential versions of the constraints bear the same name as the constraint
+--   they are based on, but without the `Is` prefix.
+
 class HasConnectionPool env where
   connPool :: Getter env (Pool Connection)
 
 instance HasConnectionPool (Pool Connection) where
   connPool = identity
 
--------------------------------------------------------
-type JSONB = DefaultFromField SqlJsonb
--------------------------------------------------------
-
--- | If possible, try to not add more constraints here. When performing
+-- | The most basic constraints for an environment with a database.
+-- 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.
@@ -61,6 +112,8 @@ type IsDBEnv env =
   , HasConfig         env
   )
 
+-- | Constraints for a full-fledged environment, with a database, mail exchange,
+-- NLP processing, notifications.
 type IsDBEnvExtra env =
   ( IsDBEnv                            env
   , HasMail                            env
@@ -68,6 +121,9 @@ type IsDBEnvExtra env =
   , CET.HasCentralExchangeNotification env
   )
 
+-- | The most general constraints for commands. To interact with the database,
+-- or access extra features (such as sending mail), you'll need to add some more
+-- constraints (see the rest of this module)
 type IsCmd env err m =
   ( MonadReader     env     m
   , MonadError          err m
@@ -82,25 +138,41 @@ type IsDBCmd env err m =
   , IsDBEnv env
   )
 
+-- | Full-fledged command class. Types in this class provide commands that can
+-- interact with the database, perform NLP processing, etc.
 type IsDBCmdExtra env err m =
   ( IsCmd        env err m
   , IsDBEnvExtra env
   )
 
+-- | Basic command with access to randomness. It feels a little ad hoc to have
+-- such a constraint instead of substituting it (and its counterpart existential
+-- type `CmdRandom`) with its definition every time it appears in the codebase,
+-- but I tried to doing that substitution and it wasn't so easy.
 type IsCmdRandom env err m =
-  ( MonadReader     env     m
-  , MonadError          err m
-  , MonadBaseControl IO     m
-  , MonadRandom             m
+  ( IsCmd env err m
+  , MonadRandom   m
   )
 
+-- | Barebones command type, without any built-in ability to interact with the
+-- database or do stuff like email exchanges.
+type Cmd env err a = forall m. IsCmd env err m => m a
 
-type CmdRandom    env err a = forall m.     IsCmdRandom  env err m => m a
-type Cmd          env err a = forall m.     IsCmd        env err m => m a
-type DBCmdExtra       err a = forall m env. IsDBCmdExtra env err m => m a
-type DBCmdWithEnv env err a = forall m.     IsDBCmd      env err m => m a
-type DBCmd            err a = forall m env. IsDBCmd      env err m => m a
+-- | Basic command type with access to randomness
+type CmdRandom env err a = forall m. IsCmdRandom  env err m => m a
 
+-- | Command type that allows for interaction with the database.
+type DBCmd err a = forall m env. IsDBCmd env err m => m a
+
+-- | Command type that allows for interaction with the database. Similar to
+-- `DBCmd`, except you can constraint the environment type some more.
+type DBCmdWithEnv env err a = forall m. IsDBCmd env err m => m a
+
+-- | Full-fledged command types, with access to the database, mail, NLP
+-- processing and central exchange notifications.
+type DBCmdExtra err a = forall m env. IsDBCmdExtra env err m => m a
+
+type JSONB = DefaultFromField SqlJsonb
 
 fromInt64ToInt :: Int64 -> Int
 fromInt64ToInt = fromIntegral
@@ -130,10 +202,6 @@ runCountOpaQuery q = do
 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err DB.ByteString
 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 
--- TODO use runPGSQueryDebug everywhere
-runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> DBCmd err [b]
-runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
-
 runPGSQuery :: ( PGS.FromRow r, PGS.ToRow q )
             => PGS.Query -> q -> DBCmd err [r]
 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
@@ -143,22 +211,6 @@ runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
       hPutStrLn stderr q'
       throw (SomeException e)
 
-{-
--- TODO
-runPGSQueryFold :: ( CmdM env err m
-               , PGS.FromRow r
-               )
-               => PGS.Query -> a -> (a -> r -> IO a) -> m a
-runPGSQueryFold q initialState consume = mkCmd $ \conn -> catch (PGS.fold_ conn initialState consume) (printError conn)
-  where
-    printError c (SomeException e) = do
-      q' <- PGS.formatQuery c q
-      hPutStrLn stderr q'
-      throw (SomeException e)
--}
-
-
-
 -- | TODO catch error
 runPGSQuery_ :: ( PGS.FromRow r )
              => PGS.Query -> DBCmd err [r]
@@ -171,10 +223,6 @@ runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> DBCmd err Int64
 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 
-------------------------------------------------------------------------
-
--- connectGargandb :: SettingsFile -> IO Connection
--- connectGargandb sf = readConfig sf >>= \params -> connect (DBConfig.unTOMLConnectInfo params)
 
 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 fromField' field mb = do
@@ -188,9 +236,6 @@ fromField' field mb = do
                                       , show v
                                       ]
 
-printSqlOpa :: Default Unpackspec a a => Select a -> IO ()
-printSqlOpa = putStrLn . maybe "Empty query" identity . showSql
-
 dbCheck :: DBCmd err Bool
 dbCheck = do
   r :: [PGS.Only Text] <- runPGSQuery_ "select username from public.auth_user"