Implement connection pooling for LDAP

config/keter_testworx.yml

@@ -27,7 +27,10 @@ stanzas:
       - LDAPPASS
       - LDAPBASE
       - LDAPSCOPE
+      - LDAPSEARCHTIME
+      - LDAPSTRIPES
       - LDAPTIMEOUT
+      - LDAPLIMIT
       - DUMMY_LOGIN
       - DETAILED_LOGGING
       - LOG_ALL

config/keter_uni2work.yml

@@ -27,7 +27,10 @@ stanzas:
       - LDAPPASS
       - LDAPBASE
       - LDAPSCOPE
+      - LDAPSEARCHTIME
+      - LDAPSTRIPES
       - LDAPTIMEOUT
+      - LDAPLIMIT
       - DETAILED_LOGGING
       - LOG_ALL
       - LOGLEVEL

config/settings.yml

@@ -66,7 +66,11 @@ ldap:
   pass:    "_env:LDAPPASS:"
   baseDN:  "_env:LDAPBASE:"
   scope:   "_env:LDAPSCOPE:WholeSubtree"
-  timeout: "_env:LDAPTIMEOUT:5"
+  timeout: "_env:LDAPSEARCHTIME:5"
+  pool:
+    stripes: "_env:LDAPSTRIPES:1"
+    timeout: "_env:LDAPTIMEOUT:20"
+    limit:   "_env:LDAPLIMIT:10"
 
 smtp:
   host:    "_env:SMTPHOST:"

src/Application.hs

@@ -139,13 +139,14 @@ makeFoundation appSettings@AppSettings{..} = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..}
         -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
         tempFoundation = mkFoundation
           (error "connPool forced in tempFoundation")
           (error "smtpPool forced in tempFoundation")
+          (error "ldapPool forced in tempFoundation")
           (error "cryptoIDKey forced in tempFoundation")
           (error "sessionKey forced in tempFoundation")
           (error "secretBoxKey forced in tempFoundation")
@@ -166,6 +167,8 @@ makeFoundation appSettings@AppSettings{..} = do
       sqlPool <- createPostgresqlPool
         (pgConnStr  appDatabaseConf)
         (pgPoolSize appDatabaseConf)
+
+      ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) (poolLimit ldapPool)
     
       -- Perform database migration using our application's logging settings.
       migrateAll `runSqlPool` sqlPool
@@ -173,7 +176,7 @@ makeFoundation appSettings@AppSettings{..} = do
       appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
       appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
 
-      let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
+      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
 
       handleJobs foundation
 

src/Auth/LDAP.hs

@@ -17,6 +17,7 @@ import qualified Control.Monad.Catch as Exc
 
 import Utils.Form
 
+import Ldap.Client (Ldap)
 import qualified Ldap.Client as Ldap
 
 import qualified Data.Text.Encoding as Text
@@ -36,7 +37,7 @@ data CampusMessage = MsgCampusIdentNote
                    | MsgCampusInvalidCredentials
   
 
-findUser :: LdapConf -> Ldap.Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
+findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
 findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
   where
     userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
@@ -66,8 +67,8 @@ campusLogin :: forall site.
                , RenderMessage site CampusMessage
                , Button site SubmitButton
                , Show (ButtonCssClass site)
-               ) => LdapConf -> AuthPlugin site
+               ) => LdapConf -> LdapPool -> AuthPlugin site
-campusLogin conf@LdapConf{..} = AuthPlugin{..}
+campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
   where
     apName = "LDAP"
     apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
@@ -79,7 +80,7 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..}
           redirect LoginR
         FormMissing -> redirect LoginR
         FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
-          ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do
+          ldapResult <- withLdap pool $ \ldap -> do
             Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
             Ldap.bind ldap ldapDn ldapPassword
             findUser conf ldap campusIdent [userPrincipalName]
@@ -117,8 +118,8 @@ data CampusUserException = CampusUserLdapError Ldap.LdapError
 
 instance Exception CampusUserException
 
-campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList [])
+campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
-campusUser conf@LdapConf{..} Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
+campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
   Ldap.bind ldap ldapDn ldapPassword
   results <- case lookup "DN" credsExtra of
     Just userDN -> do

src/Foundation.hs

@@ -102,6 +102,7 @@ data UniWorX = UniWorX
     , appStatic          :: EmbeddedStatic -- ^ Settings for static file serving.
     , appConnPool        :: ConnectionPool -- ^ Database connection pool.
     , appSmtpPool        :: Maybe SMTPPool
+    , appLdapPool        :: Maybe LdapPool
     , appWidgetMemcached :: Maybe Memcached.Connection
     , appHttpManager     :: Manager
     , appLogger          :: (ReleaseKey, TVar Logger)
@@ -1581,11 +1582,11 @@ instance YesodAuth UniWorX where
         acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
 
       $logDebugS "auth" $ tshow Creds{..}
-      AppSettings{ appUserDefaults = UserDefaultConf{..},  ..} <- getsYesod appSettings
+      UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
 
-      flip catches excHandlers $ case appLdapConf of
+      flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
-        Just ldapConf -> fmap (either id id) . runExceptT $ do
+        Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
-          ldapData <- campusUser ldapConf $ Creds credsPlugin (CI.original userIdent) credsExtra
+          ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (CI.original userIdent) credsExtra
           $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
 
           let
@@ -1669,8 +1670,8 @@ instance YesodAuth UniWorX where
       where
         insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
 
-    authPlugins (appSettings -> AppSettings{..}) = catMaybes
+    authPlugins (UniWorX{ appSettings = AppSettings{..}, appLdapPool }) = catMaybes
-      [ campusLogin <$> appLdapConf
+      [ campusLogin <$> appLdapConf <*> appLdapPool
       , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
       , dummyLogin <$ guard appAuthDummyLogin
       ]

src/Import/NoFoundation.hs

@@ -50,6 +50,8 @@ import Control.Monad.Trans.Resource as Import (ReleaseKey)
 import Network.Mail.Mime.Instances as Import ()
 import Yesod.Core.Instances as Import ()
 
+import Ldap.Client.Pool as Import
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Ldap/Client/Pool.hs

@@ -0,0 +1,100 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Ldap.Client.Pool
+  ( LdapPool
+  , LdapExecutor, Ldap, LdapError
+  , withLdap
+  , createLdapPool
+  ) where
+
+import ClassyPrelude
+
+import Ldap.Client (Ldap, LdapError)
+import qualified Ldap.Client as Ldap
+
+import Data.Pool
+
+import Control.Monad.Logger
+import Data.Time.Clock (NominalDiffTime)
+
+import Data.Dynamic
+
+
+type LdapPool = Pool LdapExecutor
+data LdapExecutor = LdapExecutor
+  { ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
+  , ldapDestroy :: TMVar ()
+  }
+
+instance Exception LdapError
+
+
+withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapError a)
+withLdap pool act = withResource pool $ \LdapExecutor{..} -> liftIO $ ldapExec act
+
+
+createLdapPool :: ( MonadLoggerIO m, MonadIO m )
+               => Ldap.Host
+               -> Ldap.PortNumber
+               -> Int -- ^ Stripes
+               -> NominalDiffTime -- ^ Timeout
+               -> Int -- ^ Limit
+               -> m LdapPool
+createLdapPool host port stripes timeout limit = do
+  logFunc <- askLoggerIO
+  
+  let
+    mkExecutor :: IO LdapExecutor
+    mkExecutor = do
+      ldapDestroy <- newEmptyTMVarIO
+      ldapAct <- newEmptyTMVarIO
+
+      let
+        ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
+        ldapExec act = do
+          ldapAnswer <- newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic))
+          atomically $ putTMVar ldapAct (fmap toDyn . act, ldapAnswer)
+          either throwIO (return . Right . flip fromDyn (error "Could not cast dynamic")) =<< atomically (takeTMVar ldapAnswer)
+          `catches`
+          [ Handler $ return . Left . Ldap.ParseError
+          , Handler $ return . Left . Ldap.ResponseError
+          , Handler $ return . Left . Ldap.IOError
+          , Handler $ return . Left . Ldap.DisconnectError
+          ]
+
+        go :: Maybe (TMVar (Maybe a)) -> Ldap -> LoggingT IO ()
+        go waiting ldap = do
+          $logDebugS "LdapExecutor" "Waiting"
+          for_ waiting $ atomically . flip putTMVar Nothing
+          instruction <- atomically $ (Nothing <$ takeTMVar ldapDestroy) <|> (Just <$> takeTMVar ldapAct)
+          case instruction of
+            Nothing -> $logDebugS "LdapExecutor" "Terminating"
+            Just (act, returnRes) -> do
+              $logDebugS "LdapExecutor" "Executing"
+              res <- try . liftIO $ act ldap
+              didReturn <- atomically $ tryPutTMVar returnRes res
+              unless didReturn $
+                $logErrorS "LdapExecutor" "Could not return result"
+              either throwM (const $ return ()) res
+                `catches`
+                [ Handler (\(Ldap.ResponseError _) -> return ())
+                ]
+              go Nothing ldap
+
+      setup <- newEmptyTMVarIO
+      void . fork . flip runLoggingT logFunc $ do
+        $logDebugS "LdapExecutor" "Starting"
+        res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
+        case res of
+          Left exc -> do
+            $logWarnS "LdapExecutor" $ tshow exc
+            atomically . void . tryPutTMVar setup $ Just exc
+          Right res' -> return res'
+
+      maybe (return ()) throwM =<< atomically (takeTMVar setup)
+
+      return LdapExecutor{..}
+
+    delExecutor :: LdapExecutor -> IO ()
+    delExecutor LdapExecutor{..} = atomically . void $ tryPutTMVar ldapDestroy ()
+  liftIO $ createPool mkExecutor delExecutor stripes timeout limit

src/Settings.hs

@@ -162,6 +162,7 @@ data LdapConf = LdapConf
   , ldapBase :: Ldap.Dn
   , ldapScope :: Ldap.Scope
   , ldapTimeout :: Int32
+  , ldapPool :: ResourcePoolConf
   } deriving (Show)
  
 data SmtpConf = SmtpConf
@@ -248,6 +249,7 @@ instance FromJSON LdapConf where
         ldapBase <- Ldap.Dn <$> o .: "baseDN"
         ldapScope <- o .: "scope"
         ldapTimeout <- o .: "timeout"
+        ldapPool <- o .: "pool"
         return LdapConf{..}
 
 deriveFromJSON