WIP connection pool

src/Gargantext/API.hs

@@ -86,7 +86,7 @@ import Gargantext.API.Types
 import Gargantext.Database.Node.Contact (HyperdataContact)
 import Gargantext.Database.Types.Node
 import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
-import Gargantext.Database.Utils (HasConnection)
+import Gargantext.Database.Utils (HasConnectionPool)
 import Gargantext.Prelude
 import Gargantext.Viz.Graph.API
 import Network.HTTP.Types hiding (Query)
@@ -334,7 +334,7 @@ type API = SwaggerAPI
 type GargServerM env err = ReaderT env (ExceptT err IO)
 
 type EnvC env =
-  ( HasConnection env
+  ( HasConnectionPool env
   , HasRepo env
   , HasSettings env
   , HasJobEnv env ScraperStatus ScraperStatus

src/Gargantext/API/Auth.hs

@@ -50,7 +50,7 @@ import Gargantext.API.Types (HasJoseError(..), joseError, HasServerError, GargSe
 import Gargantext.Database.Root (getRoot)
 import Gargantext.Database.Tree (isDescendantOf, isIn)
 import Gargantext.Database.Types.Node (NodePoly(_node_id), NodeId(..), UserId, ListId, DocId)
-import Gargantext.Database.Utils (Cmd', CmdM, HasConnection)
+import Gargantext.Database.Utils (Cmd', CmdM, HasConnectionPool)
 import Gargantext.Prelude hiding (reverse)
 import Test.QuickCheck (elements, oneof)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
@@ -96,7 +96,7 @@ makeTokenForUser uid = do
   either joseError (pure . toStrict . decodeUtf8) e
   -- TODO not sure about the encoding...
 
-checkAuthRequest :: (HasSettings env, HasConnection env, HasJoseError err)
+checkAuthRequest :: (HasSettings env, HasConnectionPool env, HasJoseError err)
                  => Username -> Password -> Cmd' env err CheckAuth
 checkAuthRequest u p
   | not (u `elem` arbitraryUsername) = pure InvalidUser
@@ -109,7 +109,7 @@ checkAuthRequest u p
           token <- makeTokenForUser uid
           pure $ Valid token uid
 
-auth :: (HasSettings env, HasConnection env, HasJoseError err)
+auth :: (HasSettings env, HasConnectionPool env, HasJoseError err)
      => AuthRequest -> Cmd' env err AuthResponse
 auth (AuthRequest u p) = do
   checkAuthRequest' <- checkAuthRequest u p

src/Gargantext/API/Ngrams.hs

@@ -122,6 +122,7 @@ import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=)
 import Control.Monad.Error.Class (MonadError)
 import Control.Monad.Reader
 import Control.Monad.State
+import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson hiding ((.=))
 import Data.Aeson.TH (deriveJSON)
 import Data.Either(Either(Left))
@@ -140,7 +141,7 @@ import Gargantext.Database.Config (userMaster)
 import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Database.Types.Node (NodeType(..))
-import Gargantext.Database.Utils (fromField', HasConnection)
+import Gargantext.Database.Utils (fromField', HasConnectionPool)
 import Gargantext.Database.Node.Select
 import Gargantext.Database.Ngrams
 --import Gargantext.Database.Lists (listsWith)
@@ -796,7 +797,8 @@ instance HasRepoSaver RepoEnv where
 type RepoCmdM   env err m =
   ( MonadReader env     m
   , MonadError      err m
-  , MonadIO             m
+  , MonadIO             m -- TODO liftIO -> liftBase
+  , MonadBaseControl IO m
   , HasRepo     env
   )
 ------------------------------------------------------------------------
@@ -1023,7 +1025,7 @@ getTime' = liftIO $ getTime ProcessCPUTime
 
 
 getTableNgrams :: forall env err m.
-                  (RepoCmdM env err m, HasNodeError err, HasConnection env)
+                  (RepoCmdM env err m, HasNodeError err, HasConnectionPool env)
                => NodeType -> NodeId -> TabType
                -> ListId -> Limit -> Maybe Offset
                -> Maybe ListType
@@ -1184,7 +1186,7 @@ type TableNgramsApi =  TableNgramsApiGet
                   :<|> TableNgramsApiPut
                   :<|> TableNgramsApiPost
 
-getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
+getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env)
                => NodeId -> TabType
                -> ListId -> Limit -> Maybe Offset
                -> Maybe ListType
@@ -1198,7 +1200,7 @@ getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize o
       searchQuery = maybe (const True) isInfixOf mt
 
 -- | Text search is deactivated for now for ngrams by doc only
-getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
+getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env)
                => DocId -> TabType
                -> ListId -> Limit -> Maybe Offset
                -> Maybe ListType
@@ -1218,7 +1220,7 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
 apiNgramsTableCorpus :: ( RepoCmdM env err m
                         , HasNodeError err
                         , HasInvalidError err
-                        , HasConnection env
+                        , HasConnectionPool env
                         )
                      => NodeId -> ServerT TableNgramsApi m
 apiNgramsTableCorpus cId =  getTableNgramsCorpus cId
@@ -1229,7 +1231,7 @@ apiNgramsTableCorpus cId =  getTableNgramsCorpus cId
 apiNgramsTableDoc :: ( RepoCmdM env err m
                      , HasNodeError err
                      , HasInvalidError err
-                     , HasConnection env
+                     , HasConnectionPool env
                      )
                   => DocId -> ServerT TableNgramsApi m
 apiNgramsTableDoc dId =  getTableNgramsDoc dId

src/Gargantext/API/Ngrams/Tools.hs

@@ -9,6 +9,7 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}

src/Gargantext/API/Settings.hs

@@ -35,13 +35,14 @@ import System.Environment (lookupEnv)
 import System.IO (FilePath, hClose)
 import System.IO.Temp (withTempFile)
 import System.FileLock (tryLockFile, unlockFile, SharedExclusive(Exclusive))
-import Database.PostgreSQL.Simple (Connection, connect, close, PGSConnectInfo)
+import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
 import Network.HTTP.Client (Manager)
 import Network.HTTP.Client.TLS (newTlsManager)
 
 import Data.Aeson
 import Data.Maybe (fromMaybe)
 import Data.Either (either)
+import Data.Pool (Pool, createPool)
 import Data.Text
 --import Data.Text.Encoding (encodeUtf8)
 import Data.ByteString (ByteString)
@@ -61,7 +62,7 @@ import Control.Monad.Logger
 import Control.Monad.Reader
 import Control.Lens
 import Gargantext.Prelude
-import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
+import Gargantext.Database.Utils (databaseParameters, HasConnectionPool(..), Cmd', runCmd)
 import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..), r_version, saveRepo, initRepo, renv_var, renv_lock)
 import Gargantext.API.Orchestrator.Types
 
@@ -141,7 +142,7 @@ data FireWall = FireWall { unFireWall :: Bool }
 data Env = Env
   { _env_settings :: !Settings
   , _env_logger   :: !LoggerSet
-  , _env_conn     :: !Connection
+  , _env_pool     :: !(Pool Connection)
   , _env_repo     :: !RepoEnv
   , _env_manager  :: !Manager
   , _env_self_url :: !BaseUrl
@@ -151,8 +152,8 @@ data Env = Env
 
 makeLenses ''Env
 
-instance HasConnection Env where
-  connection = env_conn
+instance HasConnectionPool Env where
+  connPool = env_pool
 
 instance HasRepoVar Env where
   repoVar = repoEnv . repoVar
@@ -254,7 +255,7 @@ newEnv port file = do
 
   self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
   param    <- databaseParameters file
-  conn     <- connect param
+  pool     <- newPool param
   repo     <- readRepoEnv
   scrapers_env <- newJobEnv defaultSettings manager
   logger <- newStderrLoggerSet defaultBufSize
@@ -262,26 +263,26 @@ newEnv port file = do
   pure $ Env
     { _env_settings   = settings
     , _env_logger     = logger
-    , _env_conn       = conn
+    , _env_pool       = pool
     , _env_repo       = repo
     , _env_manager    = manager
     , _env_scrapers   = scrapers_env
     , _env_self_url   = self_url
     }
 
-newPool :: PGSConnectInfo -> IO (Pool a)
+newPool :: ConnectInfo -> IO (Pool Connection)
 newPool param = createPool (connect param) close 1 (60*60) 8
 
 data DevEnv = DevEnv
-  { _dev_env_conn :: !Connection
+  { _dev_env_pool :: !(Pool Connection)
   , _dev_env_repo :: !RepoEnv
   , _dev_env_settings :: !Settings
   }
 
 makeLenses ''DevEnv
 
-instance HasConnection DevEnv where
-  connection = dev_env_conn
+instance HasConnectionPool DevEnv where
+  connPool = dev_env_pool
 
 instance HasRepoVar DevEnv where
   repoVar = repoEnv . repoVar
@@ -329,7 +330,7 @@ runCmdReplServantErr = runCmdRepl
 -- In particular this writes the repo file after running
 -- the command.
 -- This function is constrained to the DevEnv rather than
--- using HasConnection and HasRepoVar.
+-- using HasConnectionPool and HasRepoVar.
 runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
 runCmdDev env f =
   (either (fail . show) pure =<< runCmd env f)

src/Gargantext/Core/Flow/Types.hs

@@ -10,6 +10,7 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE ConstrainedClassMethods #-}

src/Gargantext/Database/Flow/Pairing.hs

@@ -9,6 +9,7 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}

src/Gargantext/Database/Flow/Utils.hs

@@ -9,6 +9,7 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}

src/Gargantext/Database/Init.hs

@@ -11,6 +11,7 @@ Ngrams by node enable contextual metrics.
 
 -}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}

src/Gargantext/Database/Metrics/NgramsByNode.hs

@@ -11,6 +11,7 @@ Ngrams by node enable contextual metrics.
 
 -}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}

src/Gargantext/Database/Node/Document/Insert.hs

@@ -49,6 +49,7 @@ the concatenation of the parameters defined by @shaParameters@.
 -}
 ------------------------------------------------------------------------
 {-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE NoImplicitPrelude    #-}
 {-# LANGUAGE OverloadedStrings    #-}

src/Gargantext/Database/Schema/NodeNgrams.hs

@@ -15,6 +15,7 @@ NodeNgrams register Context of Ngrams (named Cgrams then)
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE QuasiQuotes            #-}

src/Gargantext/Database/Schema/NodeNodeNgrams.hs

@@ -12,6 +12,7 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}

src/Gargantext/Database/Schema/NodeNodeNgrams2.hs

@@ -12,6 +12,7 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}

src/Gargantext/Database/Schema/NodesNgramsRepo.hs

@@ -13,6 +13,7 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-orphans   #-}
 
 {-# LANGUAGE Arrows                     #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE FunctionalDependencies     #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}

src/Gargantext/Database/TextSearch.hs

@@ -9,6 +9,7 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE Arrows            #-}
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}