{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
-- | This module is intended to be imported qualified
--
-- @
-- import qualified Ldap.Client as Ldap
-- @
module Ldap.Client
  ( with
  , Host(..)
  , defaultTlsSettings
  , insecureTlsSettings
  , PortNumber
  , Ldap
  , 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

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, Handler(..), bracket, throwIO, catch, catches)
import           Control.Monad (forever)
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)
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) #-}


newLdap :: IO Ldap
newLdap :: IO Ldap
newLdap = TQueue ClientMessage -> Ldap
Ldap
  (TQueue ClientMessage -> Ldap)
-> IO (TQueue ClientMessage) -> IO Ldap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (TQueue ClientMessage)
forall a. IO (TQueue a)
newTQueueIO

-- | 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)

newtype WrappedIOError = WrappedIOError IOError
    deriving (Int -> WrappedIOError -> ShowS
[WrappedIOError] -> ShowS
WrappedIOError -> String
(Int -> WrappedIOError -> ShowS)
-> (WrappedIOError -> String)
-> ([WrappedIOError] -> ShowS)
-> Show WrappedIOError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WrappedIOError -> ShowS
showsPrec :: Int -> WrappedIOError -> ShowS
$cshow :: WrappedIOError -> String
show :: WrappedIOError -> String
$cshowList :: [WrappedIOError] -> ShowS
showList :: [WrappedIOError] -> ShowS
Show, WrappedIOError -> WrappedIOError -> Bool
(WrappedIOError -> WrappedIOError -> Bool)
-> (WrappedIOError -> WrappedIOError -> Bool) -> Eq WrappedIOError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WrappedIOError -> WrappedIOError -> Bool
== :: WrappedIOError -> WrappedIOError -> Bool
$c/= :: WrappedIOError -> WrappedIOError -> Bool
/= :: WrappedIOError -> WrappedIOError -> Bool
Eq, Typeable)

instance Exception WrappedIOError

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

-- | The entrypoint into LDAP.
--
-- It catches all LDAP-related exceptions.
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
f = do
  ConnectionContext
context <- IO ConnectionContext
Conn.initConnectionContext
  IO Connection
-> (Connection -> IO ())
-> (Connection -> IO (Either LdapError a))
-> IO (Either LdapError a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (ConnectionContext -> ConnectionParams -> IO Connection
Conn.connectTo ConnectionContext
context ConnectionParams
params) Connection -> IO ()
Conn.connectionClose (\Connection
conn ->
    IO Ldap
-> (Ldap -> IO ())
-> (Ldap -> IO (Either LdapError a))
-> IO (Either LdapError a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Ldap
newLdap Ldap -> IO ()
unbindAsync (\Ldap
l -> do
      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
      [Async a]
as   <- (IO a -> IO (Async a)) -> [IO a] -> IO [Async a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
Async.async
        [ TQueue (LdapMessage ProtocolServerOp) -> Connection -> IO a
forall a b. FromAsn1 a => TQueue a -> Connection -> IO b
input TQueue (LdapMessage ProtocolServerOp)
inq Connection
conn
        , TQueue (LdapMessage Request) -> Connection -> IO a
forall a b. ToAsn1 a => TQueue a -> Connection -> IO b
output TQueue (LdapMessage Request)
outq Connection
conn
        , Ldap
-> TQueue (LdapMessage ProtocolServerOp)
-> TQueue (LdapMessage Request)
-> IO a
forall a.
Ldap
-> TQueue (LdapMessage ProtocolServerOp)
-> TQueue (LdapMessage Request)
-> IO a
dispatch Ldap
l TQueue (LdapMessage ProtocolServerOp)
inq TQueue (LdapMessage Request)
outq
        , Ldap -> IO a
f Ldap
l
        ]
      ((Async a, a) -> Either LdapError a)
-> IO (Async a, a) -> IO (Either LdapError a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Either LdapError a
forall a b. b -> Either a b
Right (a -> Either LdapError a)
-> ((Async a, a) -> a) -> (Async a, a) -> Either LdapError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Async a, a) -> a
forall a b. (a, b) -> b
snd) ([Async a] -> IO (Async a, a)
forall a. [Async a] -> IO (Async a, a)
Async.waitAnyCancel [Async a]
as)))
 IO (Either LdapError a)
-> [Handler (Either LdapError a)] -> IO (Either LdapError a)
forall a. IO a -> [Handler a] -> IO a
`catches`
  [ (WrappedIOError -> IO (Either LdapError a))
-> Handler (Either LdapError a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(WrappedIOError IOError
e) -> Either LdapError a -> IO (Either LdapError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LdapError -> Either LdapError a
forall a b. a -> Either a b
Left (IOError -> LdapError
IOError IOError
e)))
  , (ASN1Error -> IO (Either LdapError a))
-> Handler (Either LdapError a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (Either LdapError a -> IO (Either LdapError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LdapError a -> IO (Either LdapError a))
-> (ASN1Error -> Either LdapError a)
-> ASN1Error
-> IO (Either LdapError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LdapError -> Either LdapError a
forall a b. a -> Either a b
Left (LdapError -> Either LdapError a)
-> (ASN1Error -> LdapError) -> ASN1Error -> Either LdapError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Error -> LdapError
ParseError)
  , (ResponseError -> IO (Either LdapError a))
-> Handler (Either LdapError a)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (Either LdapError a -> IO (Either LdapError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LdapError a -> IO (Either LdapError a))
-> (ResponseError -> Either LdapError a)
-> ResponseError
-> IO (Either LdapError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LdapError -> Either LdapError a
forall a b. a -> Either a b
Left (LdapError -> Either LdapError a)
-> (ResponseError -> LdapError)
-> ResponseError
-> Either LdapError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseError -> LdapError
ResponseError)
  ]
 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
    }

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
  }

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 = IO b -> IO b
forall a. IO a -> IO a
wrap (IO b -> IO b)
-> ((([ByteString] -> IO b) -> [ByteString] -> IO b) -> IO b)
-> (([ByteString] -> IO b) -> [ByteString] -> IO b)
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((([ByteString] -> IO b) -> [ByteString] -> IO b)
 -> [ByteString] -> IO b)
-> [ByteString]
-> (([ByteString] -> IO b) -> [ByteString] -> IO b)
-> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([ByteString] -> IO b) -> [ByteString] -> IO b)
-> [ByteString] -> IO b
forall a. (a -> a) -> a
fix [] ((([ByteString] -> IO b) -> [ByteString] -> IO b) -> IO b)
-> (([ByteString] -> IO b) -> [ByteString] -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \[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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
              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 []

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 b -> IO b
forall a. IO a -> IO a
wrap (IO b -> IO b) -> (IO () -> IO b) -> IO () -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
  :: Ldap
  -> TQueue (Type.LdapMessage Type.ProtocolServerOp)
  -> TQueue (Type.LdapMessage Request)
  -> IO a
dispatch :: forall a.
Ldap
-> TQueue (LdapMessage ProtocolServerOp)
-> TQueue (LdapMessage Request)
-> IO a
dispatch Ldap { TQueue ClientMessage
client :: TQueue ClientMessage
client :: Ldap -> TQueue ClientMessage
client } TQueue (LdapMessage ProtocolServerOp)
inq TQueue (LdapMessage Request)
outq =
  ((((Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
    Int32)
   -> IO a)
  -> (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
      Int32)
  -> IO a)
 -> (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
     Int32)
 -> IO a)
-> (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
    Int32)
-> (((Map
        Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
      Int32)
     -> IO a)
    -> (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
        Int32)
    -> IO a)
-> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
   Int32)
  -> IO a)
 -> (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
     Int32)
 -> IO a)
-> (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
    Int32)
-> IO a
forall a. (a -> a) -> a
fix (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
forall k a. Map k a
Map.empty, Int32
1) ((((Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
    Int32)
   -> IO a)
  -> (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
      Int32)
  -> IO a)
 -> IO a)
-> (((Map
        Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
      Int32)
     -> IO a)
    -> (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
        Int32)
    -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ \(Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
 Int32)
-> IO a
loop (!Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req, !Int32
counter) ->
    (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
 Int32)
-> IO a
loop ((Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
  Int32)
 -> IO a)
-> IO
     (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp)),
      Int32)
-> IO a
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
client
           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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 {f :: * -> *} {k} {a} {b}.
(Applicative f, Ord k) =>
k -> a -> Map k ([a], b) -> f (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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 {f :: * -> *} {k} {a} {b}.
(Applicative f, Ord k) =>
k -> a -> Map k ([a], b) -> f (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 (f :: * -> *) a. Applicative f => a -> f a
pure (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
res, Int32
counter)
      ])
 where
  saveUp :: k -> a -> Map k ([a], b) -> f (Map k ([a], b))
saveUp k
mid a
op Map k ([a], b)
res =
    Map k ([a], b) -> f (Map k ([a], b))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((([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)

  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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure (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 (f :: * -> *) a. Applicative f => a -> f a
pure 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

wrap :: IO a -> IO a
wrap :: forall a. IO a -> IO a
wrap IO a
m = IO a
m IO a -> (IOError -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (WrappedIOError -> IO a
forall e a. Exception e => e -> IO a
throwIO (WrappedIOError -> IO a)
-> (IOError -> WrappedIOError) -> IOError -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> WrappedIOError
WrappedIOError)