Introduce timeouts for all ldap actions

config/settings.yml

@@ -66,7 +66,8 @@ ldap:
   pass:    "_env:LDAPPASS:"
   baseDN:  "_env:LDAPBASE:"
   scope:   "_env:LDAPSCOPE:WholeSubtree"
-  timeout: "_env:LDAPSEARCHTIME:5"
+  timeout: "_env:LDAPTIMEOUT:5"
+  search-timeout: "_env:LDAPSEARCHTIME:5"
   pool:
     stripes: "_env:LDAPSTRIPES:1"
     timeout: "_env:LDAPTIMEOUT:20"

package.yaml

@@ -113,6 +113,7 @@ dependencies:
   - pkcs7
   - memcached-binary
   - directory-tree
+  - lifted-base
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Application.hs

@@ -168,7 +168,7 @@ makeFoundation appSettings@AppSettings{..} = do
         (pgConnStr  appDatabaseConf)
         (pgPoolSize appDatabaseConf)
 
-      ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) (poolLimit ldapPool)
+      ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
     
       -- Perform database migration using our application's logging settings.
       migrateAll `runSqlPool` sqlPool

src/Auth/LDAP.hs

@@ -44,7 +44,7 @@ findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSet
     userSearchSettings = mconcat
       [ Ldap.scope ldapScope
       , Ldap.size 2
-      , Ldap.time ldapTimeout
+      , Ldap.time ldapSearchTimeout
       , Ldap.derefAliases Ldap.DerefAlways
       ]
   
@@ -88,7 +88,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
             findUser conf ldap campusIdent [userPrincipalName]
           case ldapResult of
             Left err
-              | Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err
+              | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
                 -> do
                   $logDebugS "LDAP" "Invalid credentials"
                   loginErrorMessageI LoginR Msg.InvalidLogin
@@ -110,7 +110,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
       $(widgetFile "widgets/campus-login-form")
 
-data CampusUserException = CampusUserLdapError Ldap.LdapError
+data CampusUserException = CampusUserLdapError LdapPoolError
                          | CampusUserHostNotResolved String
                          | CampusUserLineTooLong
                          | CampusUserHostCannotConnect String [IOException]
@@ -129,7 +129,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
           userSearchSettings = mconcat
             [ Ldap.scope Ldap.BaseObject
             , Ldap.size 2
-            , Ldap.time ldapTimeout
+            , Ldap.time ldapSearchTimeout
             , Ldap.derefAliases Ldap.DerefAlways
             ]
       Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []

src/Ldap/Client/Pool.hs

@@ -3,6 +3,7 @@
 module Ldap.Client.Pool
   ( LdapPool
   , LdapExecutor, Ldap, LdapError
+  , LdapPoolError(..)
   , withLdap
   , createLdapPool
   ) where
@@ -19,17 +20,24 @@ import Data.Time.Clock (NominalDiffTime)
 
 import Data.Dynamic
 
+import System.Timeout.Lifted
+
 
 type LdapPool = Pool LdapExecutor
 data LdapExecutor = LdapExecutor
-  { ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
+  { ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError a)
   , ldapDestroy :: TMVar ()
   }
 
 instance Exception LdapError
 
+data LdapPoolError = LdapPoolTimeout | LdapError LdapError
+  deriving (Eq, Show, Generic, Typeable)
 
-withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapError a)
+instance Exception LdapPoolError
+
+
+withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapPoolError a)
 withLdap pool act = withResource pool $ \LdapExecutor{..} -> liftIO $ ldapExec act
 
 
@@ -37,10 +45,11 @@ createLdapPool :: ( MonadLoggerIO m, MonadIO m )
                => Ldap.Host
                -> Ldap.PortNumber
                -> Int -- ^ Stripes
-               -> NominalDiffTime -- ^ Timeout
+               -> NominalDiffTime -- ^ Connection Timeout
+               -> NominalDiffTime -- ^ Action Timeout
                -> Int -- ^ Limit
                -> m LdapPool
-createLdapPool host port stripes timeout limit = do
+createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) limit = do
   logFunc <- askLoggerIO
   
   let
@@ -50,16 +59,17 @@ createLdapPool host port stripes timeout limit = do
       ldapAct <- newEmptyTMVarIO
 
       let
-        ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
+        ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError 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 . LdapError . Ldap.ParseError
-          , Handler $ return . Left . Ldap.ResponseError
+          , Handler $ return . Left . LdapError . Ldap.ResponseError
-          , Handler $ return . Left . Ldap.IOError
+          , Handler $ return . Left . LdapError . Ldap.IOError
-          , Handler $ return . Left . Ldap.DisconnectError
+          , Handler $ return . Left . LdapError . Ldap.DisconnectError
+          , Handler $ return . Left . (id :: LdapPoolError -> LdapPoolError)
           ]
 
         go :: Maybe (TMVar (Maybe a)) -> Ldap -> LoggingT IO ()
@@ -71,7 +81,7 @@ createLdapPool host port stripes timeout limit = do
             Nothing -> $logDebugS "LdapExecutor" "Terminating"
             Just (act, returnRes) -> do
               $logDebugS "LdapExecutor" "Executing"
-              res <- try . liftIO $ act ldap
+              res <- try . withTimeout . liftIO $ act ldap
               didReturn <- atomically $ tryPutTMVar returnRes res
               unless didReturn $
                 $logErrorS "LdapExecutor" "Could not return result"
@@ -81,20 +91,25 @@ createLdapPool host port stripes timeout limit = do
                 ]
               go Nothing ldap
 
-      setup <- newEmptyTMVarIO
+      withTimeout $ do
-      void . fork . flip runLoggingT logFunc $ do
+        setup <- newEmptyTMVarIO
-        $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)
+        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
+  liftIO $ createPool mkExecutor delExecutor stripes timeoutConn limit
+  where
+    withTimeout :: forall m a. (MonadBaseControl IO m, MonadThrow m) => m a -> m a
+    withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct

src/Settings.hs

@@ -165,7 +165,8 @@ data LdapConf = LdapConf
   , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
   , ldapBase :: Ldap.Dn
   , ldapScope :: Ldap.Scope
-  , ldapTimeout :: Int32
+  , ldapTimeout :: NominalDiffTime
+  , ldapSearchTimeout :: Int32
   , ldapPool :: ResourcePoolConf
   } deriving (Show)
  
@@ -253,6 +254,7 @@ instance FromJSON LdapConf where
         ldapBase <- Ldap.Dn <$> o .: "baseDN"
         ldapScope <- o .: "scope"
         ldapTimeout <- o .: "timeout"
+        ldapSearchTimeout <- o .: "search-timeout"
         ldapPool <- o .: "pool"
         return LdapConf{..}