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