{-# 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