WIP connection pool

package.yaml

@@ -151,6 +151,8 @@ library:
   - logging-effect
   - matrix
   - monad-logger
+  - monad-control
+  - resource-pool
   - mtl
   - natural-transformation
   - opaleye

src/Gargantext/API/Settings.hs

@@ -306,11 +306,11 @@ withDevEnv iniPath k = do
   where
     newDevEnv = do
       param <- databaseParameters iniPath
-      conn  <- connect param
+      pool  <- newPool param
       repo  <- readRepoEnv
       setts <- devSettings devJwkFile
       pure $ DevEnv
-        { _dev_env_conn = conn
+        { _dev_env_pool = pool
         , _dev_env_repo = repo
         , _dev_env_settings = setts
         }

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

@@ -13,6 +13,8 @@ Add Documents/Contact to a Corpus/Annuaire.
 ------------------------------------------------------------------------
 {-# LANGUAGE DeriveDataTypeable   #-}
 {-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE NoImplicitPrelude    #-}
 {-# LANGUAGE OverloadedStrings    #-}

src/Gargantext/Database/Node/Update.hs

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

src/Gargantext/Database/Node/UpdateOpaleye.hs

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

src/Gargantext/Database/Schema/Ngrams.hs

@@ -13,6 +13,7 @@ Ngrams connection to the Database.
 
 {-# LANGUAGE Arrows                     #-}
 {-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE FunctionalDependencies     #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}

src/Gargantext/Database/Schema/NodeNode.hs

@@ -14,6 +14,7 @@ commentary with @some markup@.
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE QuasiQuotes            #-}

src/Gargantext/Database/Schema/Node_NodeNgramsNodeNgrams.hs

@@ -22,6 +22,7 @@ Next Step benchmark:
 -}
 
 {-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE FlexibleContexts       #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}

src/Gargantext/Database/Schema/User.hs

@@ -14,6 +14,7 @@ Functions to deal with users, database side.
 {-# OPTIONS_GHC -fno-warn-orphans        #-}
 
 {-# LANGUAGE TemplateHaskell             #-}
+{-# LANGUAGE FlexibleContexts            #-}
 {-# LANGUAGE FlexibleInstances           #-}
 {-# LANGUAGE MultiParamTypeClasses       #-}
 {-# LANGUAGE FunctionalDependencies      #-}

src/Gargantext/Database/Tree.hs

@@ -12,6 +12,7 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
 
 -}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE RankNTypes        #-}

src/Gargantext/Database/Triggers/NodeNodeNgrams.hs

@@ -11,6 +11,7 @@ Triggers on NodeNodeNgrams table.
 
 -}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}

src/Gargantext/Database/Triggers/Nodes.hs

@@ -11,6 +11,7 @@ Triggers on Nodes table.
 
 -}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}

src/Gargantext/Database/Triggers/NodesNodes.hs

@@ -11,6 +11,7 @@ Triggers on NodesNodes table.
 
 -}
 
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}

src/Gargantext/Database/Utils.hs

@@ -13,6 +13,7 @@ commentary with @some markup@.
 
 {-# LANGUAGE ConstraintKinds   #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -22,10 +23,11 @@ module Gargantext.Database.Utils where
 
 import Data.ByteString.Char8 (hPutStrLn)
 import System.IO (stderr)
-import Control.Exception 
+import Control.Exception
 import Control.Monad.Error.Class -- (MonadError(..), Error)
 import Control.Lens (Getter, view)
 import Control.Monad.Reader
+import Control.Monad.Trans.Control (MonadBaseControl)
 import Control.Monad.Except
 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
 import Data.Either.Extra (Either(Left, Right))
@@ -33,10 +35,12 @@ import Data.Ini (readIniFile, lookupValue)
 import qualified Data.List as DL
 import Data.Maybe (maybe)
 import Data.Monoid ((<>))
+import Data.Pool (Pool, withResource)
 import Data.Profunctor.Product.Default (Default)
 import Data.Text (unpack, pack)
 import Data.Typeable (Typeable)
 import Data.Word (Word16)
+--import Database.PostgreSQL.Simple (Connection, Pool, connect, withPoolConnection)
 import Database.PostgreSQL.Simple (Connection, connect)
 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
 import Database.PostgreSQL.Simple.Internal  (Field)
@@ -48,11 +52,11 @@ import Text.Read (read)
 import qualified Data.ByteString      as DB
 import qualified Database.PostgreSQL.Simple as PGS
 
-class HasConnection env where
-  connection :: Getter env Connection
+class HasConnectionPool env where
+  connPool :: Getter env (Pool Connection)
 
-instance HasConnection Connection where
-  connection = identity
+instance HasConnectionPool (Pool Connection) where
+  connPool = identity
 
 type CmdM' env err m =
   ( MonadReader env m
@@ -62,7 +66,8 @@ type CmdM' env err m =
 
 type CmdM env err m =
   ( CmdM' env err m
-  , HasConnection env
+  , MonadBaseControl IO m
+  , HasConnectionPool env
   )
 
 type Cmd' env err a = forall m. CmdM' env err m => m a
@@ -75,10 +80,10 @@ fromInt64ToInt = fromIntegral
 -- TODO: ideally there should be very few calls to this functions.
 mkCmd :: (Connection -> IO a) -> Cmd err a
 mkCmd k = do
-  conn <- view connection
-  liftIO $ k conn
+  pool <- view connPool
+  withResource pool (liftIO . k)
 
-runCmd :: (HasConnection env)
+runCmd :: (HasConnectionPool env)
        => env -> Cmd' env err a
        -> IO (Either err a)
 runCmd env m = runExceptT $ runReaderT m env
@@ -100,8 +105,8 @@ formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 
-runPGSQuery :: (MonadError err m, MonadReader env m,
-                PGS.FromRow r, PGS.ToRow q, MonadIO m, HasConnection env)
+runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
+                PGS.FromRow r, PGS.ToRow q, MonadIO m, HasConnectionPool env)
                 => PGS.Query -> q -> m [r]
 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
   where