{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module Ldap.Client
( with
, Host(..)
, defaultTlsSettings
, insecureTlsSettings
, PortNumber
, Ldap
, LdapError(..)
, ResponseError(..)
, Type.ResultCode(..)
, Password(..)
, bind
, externalBind
, search
, SearchEntry(..)
, Search
, Mod
, Type.Scope(..)
, scope
, size
, time
, typesOnly
, Type.DerefAliases(..)
, derefAliases
, Filter(..)
, modify
, Operation(..)
, add
, delete
, RelativeDn(..)
, modifyDn
, compare
, Oid(..)
, extended
, Dn(..)
, Attr(..)
, AttrValue
, AttrList
, 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
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO (TQueue a)
newTQueueIO
data LdapError =
IOError !IOError
| ParseError !Asn1.ASN1Error
| ResponseError !ResponseError
| DisconnectError !Disconnect
deriving (Int -> LdapError -> ShowS
[LdapError] -> ShowS
LdapError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LdapError] -> ShowS
$cshowList :: [LdapError] -> ShowS
show :: LdapError -> String
$cshow :: LdapError -> String
showsPrec :: Int -> LdapError -> ShowS
$cshowsPrec :: Int -> LdapError -> ShowS
Show, LdapError -> LdapError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LdapError -> LdapError -> Bool
$c/= :: LdapError -> LdapError -> Bool
== :: LdapError -> LdapError -> Bool
$c== :: LdapError -> LdapError -> Bool
Eq)
newtype WrappedIOError = WrappedIOError IOError
deriving (Int -> WrappedIOError -> ShowS
[WrappedIOError] -> ShowS
WrappedIOError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WrappedIOError] -> ShowS
$cshowList :: [WrappedIOError] -> ShowS
show :: WrappedIOError -> String
$cshow :: WrappedIOError -> String
showsPrec :: Int -> WrappedIOError -> ShowS
$cshowsPrec :: Int -> WrappedIOError -> ShowS
Show, WrappedIOError -> WrappedIOError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WrappedIOError -> WrappedIOError -> Bool
$c/= :: WrappedIOError -> WrappedIOError -> Bool
== :: WrappedIOError -> WrappedIOError -> Bool
$c== :: WrappedIOError -> WrappedIOError -> Bool
Eq, Typeable)
instance Exception WrappedIOError
data Disconnect = Disconnect !Type.ResultCode !Dn !Text
deriving (Int -> Disconnect -> ShowS
[Disconnect] -> ShowS
Disconnect -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Disconnect] -> ShowS
$cshowList :: [Disconnect] -> ShowS
show :: Disconnect -> String
$cshow :: Disconnect -> String
showsPrec :: Int -> Disconnect -> ShowS
$cshowsPrec :: Int -> Disconnect -> ShowS
Show, Disconnect -> Disconnect -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Disconnect -> Disconnect -> Bool
$c/= :: Disconnect -> Disconnect -> Bool
== :: Disconnect -> Disconnect -> Bool
$c== :: Disconnect -> Disconnect -> Bool
Eq, Typeable)
instance Exception Disconnect
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
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 ->
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 <- forall a. IO (TQueue a)
newTQueueIO
TQueue (LdapMessage Request)
outq <- forall a. IO (TQueue a)
newTQueueIO
[Async a]
as <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. IO a -> IO (Async a)
Async.async
[ forall a b. FromAsn1 a => TQueue a -> Connection -> IO b
input TQueue (LdapMessage ProtocolServerOp)
inq Connection
conn
, forall a b. ToAsn1 a => TQueue a -> Connection -> IO b
output TQueue (LdapMessage Request)
outq Connection
conn
, 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
]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall a. [Async a] -> IO (Async a, a)
Async.waitAnyCancel [Async a]
as)))
forall a. IO a -> [Handler a] -> IO a
`catches`
[ forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(WrappedIOError IOError
e) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (IOError -> LdapError
IOError IOError
e)))
, forall a e. Exception e => (e -> IO a) -> Handler a
Handler (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASN1Error -> LdapError
ParseError)
, forall a e. Exception e => (e -> IO a) -> Handler a
Handler (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left 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
_ -> forall a. Maybe a
Nothing
Tls String
_ TLSSettings
settings -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TLSSettings
settings
, connectionUseSocks :: Maybe ProxySettings
Conn.connectionUseSocks = 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 = forall a. IO a -> IO a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> a) -> a
fix [] 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 -> 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" forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
Int
_ -> do
let chunks' :: [ByteString]
chunks' = ByteString
chunk forall a. a -> [a] -> [a]
: [ByteString]
chunks
case forall a.
ASN1Decoding a =>
a -> ByteString -> Either ASN1Error [ASN1]
Asn1.decodeASN1 BER
Asn1.BER ([ByteString] -> ByteString
ByteString.Lazy.fromChunks (forall a. [a] -> [a]
reverse [ByteString]
chunks')) of
Left ASN1Error
Asn1.ParsingPartial
-> [ByteString] -> IO b
loop [ByteString]
chunks'
Left ASN1Error
e -> forall e a. Exception e => e -> IO a
throwIO ASN1Error
e
Right [ASN1]
asn1 -> do
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> a) -> a
fix [ASN1]
asn1 forall a b. (a -> b) -> a -> b
$ \[ASN1] -> IO ()
loop' [ASN1]
asn1' ->
case forall a. FromAsn1 a => [ASN1] -> Maybe ([ASN1], a)
parseAsn1 [ASN1]
asn1' of
Maybe ([ASN1], a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ([ASN1]
asn1'', a
a) -> do
forall a. STM a -> IO a
atomically (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 = forall a. IO a -> IO a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
a
msg <- forall a. STM a -> IO a
atomically (forall a. TQueue a -> STM a
readTQueue TQueue a
out)
Connection -> ByteString -> IO ()
Conn.connectionPut Connection
conn (Endo [ASN1] -> ByteString
encode (forall a. ToAsn1 a => a -> Endo [ASN1]
toAsn1 a
msg))
where
encode :: Endo [ASN1] -> ByteString
encode Endo [ASN1]
x = forall a. ASN1Encoding a => a -> [ASN1] -> ByteString
Asn1.encodeASN1' DER
Asn1.DER (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 :: Ldap -> TQueue ClientMessage
client :: TQueue ClientMessage
client } TQueue (LdapMessage ProtocolServerOp)
inq TQueue (LdapMessage Request)
outq =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> a) -> a
fix (forall k a. Map k a
Map.empty, Int32
1) 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. STM a -> IO a
atomically (forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
[ do New Request
new TMVar (NonEmpty ProtocolServerOp)
var <- forall a. TQueue a -> STM a
readTQueue TQueue ClientMessage
client
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (LdapMessage Request)
outq (forall op. Id -> op -> Maybe Controls -> LdapMessage op
Type.LdapMessage (Int32 -> Id
Type.Id Int32
counter) Request
new forall a. Maybe a
Nothing)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall a. Num a => a -> a -> a
+ Int32
1)
, do Type.LdapMessage Id
mid ProtocolServerOp
op Maybe Controls
_
<- forall a. TQueue a -> STM a
readTQueue TQueue (LdapMessage ProtocolServerOp)
inq
Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
res <- case ProtocolServerOp
op of
Type.BindResponse {} -> 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 {} -> 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 {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
req
Type.SearchResultDone {} -> 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 {} -> 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 {} -> 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 {} -> 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 {} -> 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 {} -> 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 {} -> 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
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Id ([ProtocolServerOp], TMVar (NonEmpty ProtocolServerOp))
res, Int32
counter)
])
where
saveUp :: k -> a -> Map k ([a], b) -> m (Map k ([a], b))
saveUp k
mid a
op Map k ([a], b)
res =
forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\([a]
stack, b
var) -> (a
op 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 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Map k ([a], TMVar (NonEmpty a))
req
Just ([a]
stack, TMVar (NonEmpty a)
var) -> do
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (NonEmpty a)
var (a
op forall a. a -> [a] -> NonEmpty a
:| [a]
stack)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall a. Eq a => a -> a -> Bool
== Oid
noticeOfDisconnectionOid -> 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
_ -> 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 = 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 forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> WrappedIOError
WrappedIOError)