{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module is intended to be imported qualified
--
-- @
-- import qualified Ldap.Client as Ldap
-- @
module Ldap.Client
  ( with
  , with'
  , runsIn
  , runsInEither
  , open
  , openFromConnection
  , close
  , Host(..)
  , defaultTlsSettings
  , insecureTlsSettings
  , PortNumber
  , Ldap
  , LdapH
  , LdapError(..)
  , ResponseError(..)
  , Type.ResultCode(..)
    -- * Bind
  , Password(..)
  , bind
  , externalBind
    -- * Search
  , search
  , SearchEntry(..)
    -- ** Search modifiers
  , Search
  , Mod
  , Type.Scope(..)
  , scope
  , size
  , time
  , typesOnly
  , Type.DerefAliases(..)
  , derefAliases
  , Filter(..)
    -- * Modify
  , modify
  , Operation(..)
    -- * Add
  , add
    -- * Delete
  , delete
    -- * ModifyDn
  , RelativeDn(..)
  , modifyDn
    -- * Compare
  , compare
    -- * Extended
  , Oid(..)
  , extended
    -- * Miscellanous
  , Dn(..)
  , Attr(..)
  , AttrValue
  , AttrList
    -- * Re-exports
  , NonEmpty
  ) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative ((<$>))
#endif
import qualified Control.Concurrent.Async as Async
import           Control.Concurrent.STM (atomically, throwSTM)
import           Control.Concurrent.STM.TMVar (putTMVar)
import           Control.Concurrent.STM.TQueue (TQueue, newTQueueIO, writeTQueue, readTQueue)
import           Control.Exception (Exception, bracket, throwIO, SomeException, fromException, throw, Handler(..))
import           Control.Monad (forever)
import           Data.Void (Void)
import qualified Data.ASN1.BinaryEncoding as Asn1
import qualified Data.ASN1.Encoding as Asn1
import qualified Data.ASN1.Error as Asn1
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as ByteString.Lazy
import           Data.Foldable (asum)
import           Data.Function (fix)
import           Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.Map.Strict as Map
import           Data.Monoid (Endo(appEndo))
import           Data.Text (Text)
#if __GLASGOW_HASKELL__ < 710
import           Data.Traversable (traverse)
#endif
import           Data.Typeable (Typeable)
import           Network.Connection (Connection)
import qualified Network.Connection as Conn
import           Prelude hiding (compare)
import qualified System.IO.Error as IO

import           Ldap.Asn1.ToAsn1 (ToAsn1(toAsn1))
import           Ldap.Asn1.FromAsn1 (FromAsn1, parseAsn1)
import qualified Ldap.Asn1.Type as Type
import           Ldap.Client.Internal
import           Ldap.Client.Bind (Password(..), bind, externalBind)
import           Ldap.Client.Search
  ( search
  , Search
  , Mod
  , scope
  , size
  , time
  , typesOnly
  , derefAliases
  , Filter(..)
  , SearchEntry(..)
  )
import           Ldap.Client.Modify (Operation(..), modify, RelativeDn(..), modifyDn)
import           Ldap.Client.Add (add)
import           Ldap.Client.Delete (delete)
import           Ldap.Client.Compare (compare)
import           Ldap.Client.Extended (Oid(..), extended, noticeOfDisconnectionOid)

{-# ANN module ("HLint: ignore Use first" :: String) #-}


-- | Various failures that can happen when working with LDAP.
data LdapError
  = IOError !IOError             -- ^ Network failure.
  | ParseError !Asn1.ASN1Error   -- ^ Invalid ASN.1 data received from the server.
  | ResponseError !ResponseError -- ^ An LDAP operation failed.
  | DisconnectError !Disconnect  -- ^ Notice of Disconnection has been received.
    deriving (Int -> LdapError -> ShowS
[LdapError] -> ShowS
LdapError -> String
(Int -> LdapError -> ShowS)
-> (LdapError -> String)
-> ([LdapError] -> ShowS)
-> Show LdapError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LdapError -> ShowS
showsPrec :: Int -> LdapError -> ShowS
$cshow :: LdapError -> String
show :: LdapError -> String
$cshowList :: [LdapError] -> ShowS
showList :: [LdapError] -> ShowS
Show, LdapError -> LdapError -> Bool
(LdapError -> LdapError -> Bool)
-> (LdapError -> LdapError -> Bool) -> Eq LdapError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LdapError -> LdapError -> Bool
== :: LdapError -> LdapError -> Bool
$c/= :: LdapError -> LdapError -> Bool
/= :: LdapError -> LdapError -> Bool
Eq)

instance Exception LdapError

data Disconnect = Disconnect !Type.ResultCode !Dn !Text
    deriving (Int -> Disconnect -> ShowS
[Disconnect] -> ShowS
Disconnect -> String
(Int -> Disconnect -> ShowS)
-> (Disconnect -> String)
-> ([Disconnect] -> ShowS)
-> Show Disconnect
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Disconnect -> ShowS
showsPrec :: Int -> Disconnect -> ShowS
$cshow :: Disconnect -> String
show :: Disconnect -> String
$cshowList :: [Disconnect] -> ShowS
showList :: [Disconnect] -> ShowS
Show, Disconnect -> Disconnect -> Bool
(Disconnect -> Disconnect -> Bool)
-> (Disconnect -> Disconnect -> Bool) -> Eq Disconnect
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Disconnect -> Disconnect -> Bool
== :: Disconnect -> Disconnect -> Bool
$c/= :: Disconnect -> Disconnect -> Bool
/= :: Disconnect -> Disconnect -> Bool
Eq, Typeable)

instance Exception Disconnect

newtype LdapH = LdapH Ldap

-- | Provide a 'LdapH' to a function needing an 'Ldap' handle.
runsIn :: (Ldap -> IO a)
       -> LdapH
       -> IO a
runsIn :: forall a. (Ldap -> IO a) -> LdapH -> IO a
runsIn Ldap -> IO a
act (LdapH Ldap
ldap) = do
  Async a
actor <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
Async.async (Ldap -> IO a
act Ldap
ldap)
  Either (Either SomeException Void) (Either SomeException a)
r <- Async Void
-> Async a
-> IO (Either (Either SomeException Void) (Either SomeException a))
forall a b.
Async a
-> Async b
-> IO (Either (Either SomeException a) (Either SomeException b))
Async.waitEitherCatch (Ldap -> Async Void
workers Ldap
ldap) Async a
actor
  case Either (Either SomeException Void) (Either SomeException a)
r of
    Left (Right Void
_a) -> String -> IO a
forall a. HasCallStack => String -> a
error String
"Unreachable"
    Left (Left SomeException
e)   -> LdapError -> IO a
forall e a. Exception e => e -> IO a
throwIO (LdapError -> IO a) -> IO LdapError -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Handler LdapError] -> SomeException -> IO LdapError
forall a. [Handler a] -> SomeException -> IO a
catchesHandler [Handler LdapError]
workerErr SomeException
e
    Right (Right a
r') -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r'
    Right (Left SomeException
e)  -> LdapError -> IO a
forall e a. Exception e => e -> IO a
throwIO (LdapError -> IO a) -> IO LdapError -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Handler LdapError] -> SomeException -> IO LdapError
forall a. [Handler a] -> SomeException -> IO a
catchesHandler [Handler LdapError]
respErr SomeException
e

-- | Provide a 'LdapH' to a function needing an 'Ldap' handle
runsInEither :: (Ldap -> IO a)
             -> LdapH
             -> IO (Either LdapError a)
runsInEither :: forall a. (Ldap -> IO a) -> LdapH -> IO (Either LdapError a)
runsInEither Ldap -> IO a
act (LdapH Ldap
ldap) = do
  Async a
actor <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
Async.async (Ldap -> IO a
act Ldap
ldap)
  Either (Either SomeException Void) (Either SomeException a)
r <- Async Void
-> Async a
-> IO (Either (Either SomeException Void) (Either SomeException a))
forall a b.
Async a
-> Async b
-> IO (Either (Either SomeException a) (Either SomeException b))
Async.waitEitherCatch (Ldap -> Async Void
workers Ldap
ldap) Async a
actor
  case Either (Either SomeException Void) (Either SomeException a)
r of
    Left (Right Void
_a) -> String -> IO (Either LdapError a)
forall a. HasCallStack => String -> a
error String
"Unreachable"
    Left (Left SomeException
e)   -> do LdapError -> Either LdapError a
forall a b. a -> Either a b
Left (LdapError -> Either LdapError a)
-> IO LdapError -> IO (Either LdapError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Handler LdapError] -> SomeException -> IO LdapError
forall a. [Handler a] -> SomeException -> IO a
catchesHandler [Handler LdapError]
workerErr SomeException
e
    Right (Right a
r') -> Either LdapError a -> IO (Either LdapError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either LdapError a
forall a b. b -> Either a b
Right a
r')
    Right (Left SomeException
e)  -> do LdapError -> Either LdapError a
forall a b. a -> Either a b
Left (LdapError -> Either LdapError a)
-> IO LdapError -> IO (Either LdapError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Handler LdapError] -> SomeException -> IO LdapError
forall a. [Handler a] -> SomeException -> IO a
catchesHandler [Handler LdapError]
respErr SomeException
e


workerErr :: [Handler LdapError]
workerErr :: [Handler LdapError]
workerErr = [ (IOError -> IO LdapError) -> Handler LdapError
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(IOError
ex :: IOError) -> LdapError -> IO LdapError
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IOError -> LdapError
IOError IOError
ex))
            , (ASN1Error -> IO LdapError) -> Handler LdapError
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(ASN1Error
ex :: Asn1.ASN1Error) -> LdapError -> IO LdapError
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ASN1Error -> LdapError
ParseError ASN1Error
ex))
            , (Disconnect -> IO LdapError) -> Handler LdapError
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(Disconnect
ex :: Disconnect) -> LdapError -> IO LdapError
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Disconnect -> LdapError
DisconnectError Disconnect
ex))
            ]

respErr :: [Handler LdapError]
respErr :: [Handler LdapError]
respErr = [ (ResponseError -> IO LdapError) -> Handler LdapError
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(ResponseError
ex :: ResponseError) -> LdapError -> IO LdapError
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseError -> LdapError
ResponseError ResponseError
ex))
          ]

catchesHandler :: [Handler a] -> SomeException -> IO a
catchesHandler :: forall a. [Handler a] -> SomeException -> IO a
catchesHandler [Handler a]
handlers SomeException
e = (Handler a -> IO a -> IO a) -> IO a -> [Handler a] -> IO a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Handler a -> IO a -> IO a
forall {a}. Handler a -> IO a -> IO a
tryHandler (SomeException -> IO a
forall a e. Exception e => e -> a
throw SomeException
e) [Handler a]
handlers
    where tryHandler :: Handler a -> IO a -> IO a
tryHandler (Handler e -> IO a
handler) IO a
res
              = case SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                Just e
e' -> e -> IO a
handler e
e'
                Maybe e
Nothing -> IO a
res

-- | The entrypoint into LDAP.
with' :: Host -> PortNumber -> (Ldap -> IO a) -> IO a
with' :: forall a. Host -> PortNumber -> (Ldap -> IO a) -> IO a
with' Host
host PortNumber
port Ldap -> IO a
act = IO LdapH -> (LdapH -> IO ()) -> (LdapH -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Host -> PortNumber -> IO LdapH
open Host
host PortNumber
port) LdapH -> IO ()
close ((Ldap -> IO a) -> LdapH -> IO a
forall a. (Ldap -> IO a) -> LdapH -> IO a
runsIn Ldap -> IO a
act)

with :: Host -> PortNumber -> (Ldap -> IO a) -> IO (Either LdapError a)
with :: forall a.
Host -> PortNumber -> (Ldap -> IO a) -> IO (Either LdapError a)
with Host
host PortNumber
port Ldap -> IO a
act = IO LdapH
-> (LdapH -> IO ())
-> (LdapH -> IO (Either LdapError a))
-> IO (Either LdapError a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Host -> PortNumber -> IO LdapH
open Host
host PortNumber
port) LdapH -> IO ()
close ((Ldap -> IO a) -> LdapH -> IO (Either LdapError a)
forall a. (Ldap -> IO a) -> LdapH -> IO (Either LdapError a)
runsInEither Ldap -> IO a
act)

-- | Creates an LDAP handle. This action is useful for creating your own resource
-- management, such as with 'resource-pool'. The handle must be manually closed
-- with 'close'.
open :: Host -> PortNumber -> IO (LdapH)
open :: Host -> PortNumber -> IO LdapH
open Host
host PortNumber
port = do
  ConnectionContext
context <- IO ConnectionContext
Conn.initConnectionContext
  Connection
conn <- ConnectionContext -> ConnectionParams -> IO Connection
Conn.connectTo ConnectionContext
context ConnectionParams
params
  Connection -> IO LdapH
openFromConnection Connection
conn
 where
  params :: ConnectionParams
params = Conn.ConnectionParams
    { connectionHostname :: String
Conn.connectionHostname =
        case Host
host of
          Plain String
h -> String
h
          Tls   String
h TLSSettings
_ -> String
h
    , connectionPort :: PortNumber
Conn.connectionPort = PortNumber
port
    , connectionUseSecure :: Maybe TLSSettings
Conn.connectionUseSecure =
        case Host
host of
          Plain  String
_ -> Maybe TLSSettings
forall a. Maybe a
Nothing
          Tls String
_ TLSSettings
settings -> TLSSettings -> Maybe TLSSettings
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TLSSettings
settings
    , connectionUseSocks :: Maybe ProxySettings
Conn.connectionUseSocks = Maybe ProxySettings
forall a. Maybe a
Nothing
    }

openFromConnection :: Connection -> IO (LdapH)
openFromConnection :: Connection -> IO LdapH
openFromConnection Connection
conn = do
  TQueue ClientMessage
reqQ <- IO (TQueue ClientMessage)
forall a. IO (TQueue a)
newTQueueIO
  TQueue (LdapMessage ProtocolServerOp)
inQ  <- IO (TQueue (LdapMessage ProtocolServerOp))
forall a. IO (TQueue a)
newTQueueIO
  TQueue (LdapMessage Request)
outQ <- IO (TQueue (LdapMessage Request))
forall a. IO (TQueue a)
newTQueueIO

  -- The input worker that reads data off the network.
  (Async Void
inW :: Async.Async Void)   <- IO Void -> IO (Async Void)
forall a. IO a -> IO (Async a)
Async.async (TQueue (LdapMessage ProtocolServerOp) -> Connection -> IO Void
forall a b. FromAsn1 a => TQueue a -> Connection -> IO b
input TQueue (LdapMessage ProtocolServerOp)
inQ Connection
conn)

  -- The output worker that sends data onto the network.
  (Async Void
outW :: Async.Async Void)  <- IO Void -> IO (Async Void)
forall a. IO a -> IO (Async a)
Async.async (TQueue (LdapMessage Request) -> Connection -> IO Void
forall a b. ToAsn1 a => TQueue a -> Connection -> IO b
output TQueue (LdapMessage Request)
outQ Connection
conn)

  -- The dispatch worker that sends data between the three queues.
  (Async Void
dispW :: Async.Async Void) <- IO Void -> IO (Async Void)
forall a. IO a -> IO (Async a)
Async.async (TQueue ClientMessage
-> TQueue (LdapMessage ProtocolServerOp)
-> TQueue (LdapMessage Request)
-> IO Void
forall a.
TQueue ClientMessage
-> TQueue (LdapMessage ProtocolServerOp)
-> TQueue (LdapMessage Request)
-> IO a
dispatch TQueue ClientMessage
reqQ TQueue (LdapMessage ProtocolServerOp)
inQ TQueue (LdapMessage Request)
outQ)

  -- We use this to propagate exceptions between the workers. The `workers` Async is just a tool to
  -- exchange exceptions between the entire worker group and another thread.
  Async Void
workers <- IO Void -> IO (Async Void)
forall a. IO a -> IO (Async a)
Async.async ((Async Void, Void) -> Void
forall a b. (a, b) -> b
snd ((Async Void, Void) -> Void) -> IO (Async Void, Void) -> IO Void
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Async Void] -> IO (Async Void, Void)
forall a. [Async a] -> IO (Async a, a)
Async.waitAnyCancel [Async Void
inW, Async Void
outW, Async Void
dispW])

  LdapH -> IO LdapH
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ldap -> LdapH
LdapH (TQueue ClientMessage -> Async Void -> Connection -> Ldap
Ldap TQueue ClientMessage
reqQ Async Void
workers Connection
conn))

-- | Closes an LDAP connection.
-- This is to be used in together with 'open'.
close :: LdapH -> IO ()
close :: LdapH -> IO ()
close (LdapH Ldap
ldap) = do
  Ldap -> IO ()
unbindAsync Ldap
ldap
  Connection -> IO ()
Conn.connectionClose (Ldap -> Connection
conn Ldap
ldap)
  Async Void -> IO ()
forall a. Async a -> IO ()
Async.cancel (Ldap -> Async Void
workers Ldap
ldap)

defaultTlsSettings :: Conn.TLSSettings
defaultTlsSettings :: TLSSettings
defaultTlsSettings = Conn.TLSSettingsSimple
  { settingDisableCertificateValidation :: Bool
Conn.settingDisableCertificateValidation = Bool
False
  , settingDisableSession :: Bool
Conn.settingDisableSession = Bool
False
  , settingUseServerName :: Bool
Conn.settingUseServerName = Bool
False
  }

insecureTlsSettings :: Conn.TLSSettings
insecureTlsSettings :: TLSSettings
insecureTlsSettings = Conn.TLSSettingsSimple
  { settingDisableCertificateValidation :: Bool
Conn.settingDisableCertificateValidation = Bool
True
  , settingDisableSession :: Bool
Conn.settingDisableSession = Bool
False
  , settingUseServerName :: Bool
Conn.settingUseServerName = Bool
False
  }

-- | Reads Asn1 BER encoded chunks off a connection into a TQueue.
input :: FromAsn1 a => TQueue a -> Connection -> IO b
input :: forall a b. FromAsn1 a => TQueue a -> Connection -> IO b
input TQueue a
inq Connection
conn = [ByteString] -> IO b
forall {b}. [ByteString] -> IO b
loop []
  where
    loop :: [ByteString] -> IO b
loop [ByteString]
chunks = do
      ByteString
chunk <- Connection -> Int -> IO ByteString
Conn.connectionGet Connection
conn Int
8192
      case ByteString -> Int
ByteString.length ByteString
chunk of
        Int
0 -> IOError -> IO b
forall e a. Exception e => e -> IO a
throwIO (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
IO.mkIOError IOErrorType
IO.eofErrorType String
"Ldap.Client.input" Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
        Int
_ -> do
          let chunks' :: [ByteString]
chunks' = ByteString
chunk ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
chunks
          case BER -> ByteString -> Either ASN1Error [ASN1]
forall a.
ASN1Decoding a =>
a -> ByteString -> Either ASN1Error [ASN1]
Asn1.decodeASN1 BER
Asn1.BER ([ByteString] -> ByteString
ByteString.Lazy.fromChunks ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
chunks')) of
            Left  ASN1Error
Asn1.ParsingPartial
                      -> [ByteString] -> IO b
loop [ByteString]
chunks'
            Left  ASN1Error
e    -> ASN1Error -> IO b
forall e a. Exception e => e -> IO a
throwIO ASN1Error
e
            Right [ASN1]
asn1 -> do
              ((([ASN1] -> IO ()) -> [ASN1] -> IO ()) -> [ASN1] -> IO ())
-> [ASN1] -> (([ASN1] -> IO ()) -> [ASN1] -> IO ()) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([ASN1] -> IO ()) -> [ASN1] -> IO ()) -> [ASN1] -> IO ()
forall a. (a -> a) -> a
fix [ASN1]
asn1 ((([ASN1] -> IO ()) -> [ASN1] -> IO ()) -> IO ())
-> (([ASN1] -> IO ()) -> [ASN1] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[ASN1] -> IO ()
loop' [ASN1]
asn1' ->
                case [ASN1] -> Maybe ([ASN1], a)
forall a. FromAsn1 a => [ASN1] -> Maybe ([ASN1], a)
parseAsn1 [ASN1]
asn1' of
                  Maybe ([ASN1], a)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Just ([ASN1]
asn1'', a
a) -> do
                    STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue a
inq a
a)
                    [ASN1] -> IO ()
loop' [ASN1]
asn1''
              [ByteString] -> IO b
loop []

-- | Transmits Asn1 DER encoded data from a TQueue into a Connection.
output :: ToAsn1 a => TQueue a -> Connection -> IO b
output :: forall a b. ToAsn1 a => TQueue a -> Connection -> IO b
output TQueue a
out Connection
conn = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
  a
msg <- STM a -> IO a
forall a. STM a -> IO a
atomically (TQueue a -> STM a
forall a. TQueue a -> STM a
readTQueue TQueue a
out)
  Connection -> ByteString -> IO ()
Conn.connectionPut Connection
conn (Endo [ASN1] -> ByteString
encode (a -> Endo [ASN1]
forall a. ToAsn1 a => a -> Endo [ASN1]
toAsn1 a
msg))
 where
  encode :: Endo [ASN1] -> ByteString
encode Endo [ASN1]
x = DER -> [ASN1] -> ByteString
forall a. ASN1Encoding a => a -> [ASN1] -> ByteString
Asn1.encodeASN1' DER
Asn1.DER (Endo [ASN1] -> [ASN1] -> [ASN1]
forall a. Endo a -> a -> a
appEndo Endo [ASN1]
x [])

dispatch
  :: TQueue ClientMessage
  -> TQueue (Type.LdapMessage Type.ProtocolServerOp)
  -> TQueue (Type.LdapMessage Request)
  -> IO a
dispatch :: forall a.
TQueue ClientMessage
-> TQueue (LdapMessage ProtocolServerOp)
-> TQueue (LdapMessage Request)
-> IO a
dispatch TQueue ClientMessage
reqq TQueue (LdapMessage ProtocolServerOp)
inq TQueue (LdapMessage Request)
outq = (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
 Int32)
-> IO a
forall {b}.
(Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
 Int32)
-> IO b
loop (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
forall k a. Map k a
Map.empty, Int32
1)
  where
    saveUp :: k -> a -> Map k ([a], b) -> m (Map k ([a], b))
saveUp k
mid a
op Map k ([a], b)
res = Map k ([a], b) -> m (Map k ([a], b))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((([a], b) -> ([a], b)) -> k -> Map k ([a], b) -> Map k ([a], b)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\([a]
stack, b
var) -> (a
op a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
stack, b
var)) k
mid Map k ([a], b)
res)

    loop :: (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
 Int32)
-> IO b
loop (!Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req, !Int32
counter) =
      (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
 Int32)
-> IO b
loop ((Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
  Int32)
 -> IO b)
-> IO
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
      Int32)
-> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM
  (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
   Int32)
-> IO
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
      Int32)
forall a. STM a -> IO a
atomically ([STM
   (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
    Int32)]
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
      Int32)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ do New Request
new TMVar (NonEmpty ProtocolServerOp)
var <- TQueue ClientMessage -> STM ClientMessage
forall a. TQueue a -> STM a
readTQueue TQueue ClientMessage
reqq
             TQueue (LdapMessage Request) -> LdapMessage Request -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (LdapMessage Request)
outq (Id -> Request -> Maybe Controls -> LdapMessage Request
forall op. Id -> op -> Maybe Controls -> LdapMessage op
Type.LdapMessage (Int32 -> Id
Type.Id Int32
counter) Request
new Maybe Controls
forall a. Maybe a
Nothing)
             (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
 Int32)
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
      Int32)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
-> ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Int32 -> Id
Type.Id Int32
counter) ([], TMVar (NonEmpty ProtocolServerOp)
var) Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req, Int32
counter Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1)
        , do Type.LdapMessage Id
mid ProtocolServerOp
op Maybe Controls
_
                <- TQueue (LdapMessage ProtocolServerOp)
-> STM (LdapMessage ProtocolServerOp)
forall a. TQueue a -> STM a
readTQueue TQueue (LdapMessage ProtocolServerOp)
inq
             Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
res <- case ProtocolServerOp
op of
               Type.BindResponse {}          -> Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall {k} {a}.
Ord k =>
k
-> a
-> Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
done Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
               Type.SearchResultEntry {}     -> Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall {m :: * -> *} {k} {a} {b}.
(Monad m, Ord k) =>
k -> a -> Map k ([a], b) -> m (Map k ([a], b))
saveUp Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
               Type.SearchResultReference {} -> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
               Type.SearchResultDone {}      -> Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall {k} {a}.
Ord k =>
k
-> a
-> Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
done Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
               Type.ModifyResponse {}        -> Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall {k} {a}.
Ord k =>
k
-> a
-> Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
done Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
               Type.AddResponse {}           -> Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall {k} {a}.
Ord k =>
k
-> a
-> Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
done Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
               Type.DeleteResponse {}        -> Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall {k} {a}.
Ord k =>
k
-> a
-> Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
done Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
               Type.ModifyDnResponse {}      -> Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall {k} {a}.
Ord k =>
k
-> a
-> Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
done Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
               Type.CompareResponse {}       -> Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall {k} {a}.
Ord k =>
k
-> a
-> Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
done Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
               Type.ExtendedResponse {}      -> Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
probablyDisconnect Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
               Type.IntermediateResponse {}  -> Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall {m :: * -> *} {k} {a} {b}.
(Monad m, Ord k) =>
k -> a -> Map k ([a], b) -> m (Map k ([a], b))
saveUp Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
             (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
 Int32)
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
      Int32)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
res, Int32
counter)
        ])

    done :: k
-> a
-> Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
done k
mid a
op Map k ([a], TMVar (NonEmpty a))
req =
      case k
-> Map k ([a], TMVar (NonEmpty a))
-> Maybe ([a], TMVar (NonEmpty a))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
mid Map k ([a], TMVar (NonEmpty a))
req of
        Maybe ([a], TMVar (NonEmpty a))
Nothing -> Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Map k ([a], TMVar (NonEmpty a))
req
        Just ([a]
stack, TMVar (NonEmpty a)
var) -> do
          TMVar (NonEmpty a) -> NonEmpty a -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (NonEmpty a)
var (a
op a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
stack)
          Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (k
-> Map k ([a], TMVar (NonEmpty a))
-> Map k ([a], TMVar (NonEmpty a))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
mid Map k ([a], TMVar (NonEmpty a))
req)

    probablyDisconnect :: Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
probablyDisconnect (Type.Id Int32
0)
                      (Type.ExtendedResponse
                        (Type.LdapResult ResultCode
code
                                          (Type.LdapDn (Type.LdapString Text
dn))
                                          (Type.LdapString Text
reason)
                                          Maybe ReferralUris
_)
                        Maybe LdapOid
moid Maybe ByteString
_)
                      Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req =
      case Maybe LdapOid
moid of
        Just (Type.LdapOid Text
oid)
          | Text -> Oid
Oid Text
oid Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
== Oid
noticeOfDisconnectionOid -> Disconnect
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall e a. Exception e => e -> STM a
throwSTM (ResultCode -> Dn -> Text -> Disconnect
Disconnect ResultCode
code (Text -> Dn
Dn Text
dn) Text
reason)
        Maybe LdapOid
_ -> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
    probablyDisconnect Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req = Id
-> ProtocolServerOp
-> Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
-> STM
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)))
forall {k} {a}.
Ord k =>
k
-> a
-> Map k ([a], TMVar (NonEmpty a))
-> STM (Map k ([a], TMVar (NonEmpty a)))
done Id
mid ProtocolServerOp
op Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req