116 lines
4.0 KiB
Haskell
116 lines
4.0 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Ldap.Client.Pool
|
|
( LdapPool
|
|
, LdapExecutor, Ldap, LdapError
|
|
, LdapPoolError(..)
|
|
, 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
|
|
|
|
import System.Timeout.Lifted
|
|
|
|
|
|
type LdapPool = Pool LdapExecutor
|
|
data LdapExecutor = LdapExecutor
|
|
{ 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)
|
|
|
|
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
|
|
|
|
|
|
createLdapPool :: ( MonadLoggerIO m, MonadIO m )
|
|
=> Ldap.Host
|
|
-> Ldap.PortNumber
|
|
-> Int -- ^ Stripes
|
|
-> NominalDiffTime -- ^ Connection Timeout
|
|
-> NominalDiffTime -- ^ Action Timeout
|
|
-> Int -- ^ Limit
|
|
-> m LdapPool
|
|
createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) 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 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 . LdapError . Ldap.ParseError
|
|
, Handler $ return . Left . LdapError . Ldap.ResponseError
|
|
, Handler $ return . Left . LdapError . Ldap.IOError
|
|
, Handler $ return . Left . LdapError . Ldap.DisconnectError
|
|
, Handler $ return . Left . (id :: LdapPoolError -> LdapPoolError)
|
|
]
|
|
|
|
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 . withTimeout . 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
|
|
|
|
withTimeout $ do
|
|
setup <- newEmptyTMVarIO
|
|
|
|
void . fork . flip runLoggingT logFunc $ do
|
|
$logInfoS "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 timeoutConn limit
|
|
where
|
|
withTimeout :: forall m a. (MonadBaseControl IO m, MonadThrow m) => m a -> m a
|
|
withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct
|