Compare commits

..

2 Commits

Author SHA1 Message Date
Brian Jones
705ce543fb Bump version, add contributor notes 2019-11-06 13:50:55 -09:00
Brian Jones
8d5cc33429 Update library to latest compiler(s)
Built with GHC 8.2.2, 8.4.4, 8.6.5
2019-11-06 13:50:45 -09:00
17 changed files with 140 additions and 203 deletions

View File

@ -6,4 +6,3 @@ release-branch=master
since-tag=0.2.0 since-tag=0.2.0
header=# LDAP Client Changelog header=# LDAP Client Changelog
exclude-labels=documentation

1
.gitignore vendored
View File

@ -1,5 +1,4 @@
dist/ dist/
dist-newstyle/
.cabal-sandbox/ .cabal-sandbox/
cabal.sandbox.config cabal.sandbox.config
node_modules node_modules

14
CHANGELOG.markdown Normal file
View File

@ -0,0 +1,14 @@
Original Changelog
====
* See `CHANGELOG.md` for recent changes
0.2.0
=====
* Supported SASL authentication via the EXTERNAL mechanism. (https://github.com/supki/ldap-client/pull/9)
* Added the `SecureWithTLSSettings` constructor to the `Host` datatype for the
cases where the user needs more control over TLS connection settings.
(https://github.com/supki/ldap-client/issues/5, https://github.com/supki/ldap-client/pull/6)
* Switched the decoding of server's messages to BER (See https://tools.ietf.org/html/rfc4511#section-5.1) (https://github.com/supki/ldap-client/pull/11)

View File

@ -1,18 +1,13 @@
# LDAP Client Changelog # LDAP Client Changelog
## [Unreleased](https://github.com/alasconnect/ldap-client/tree/HEAD)
## [0.4.0](https://github.com/alasconnect/ldap-client/tree/0.4.0) (2019-11-07) [Full Changelog](https://github.com/alasconnect/ldap-client/compare/0.2.0...HEAD)
[Full Changelog](https://github.com/alasconnect/ldap-client/compare/0.3.0...0.4.0)
**Merged pull requests:** **Merged pull requests:**
- Poolable [\#1](https://github.com/alasconnect/ldap-client/pull/1) ([dminuoso](https://github.com/dminuoso)) - Poolable [\#1](https://github.com/alasconnect/ldap-client/pull/1) ([dminuoso](https://github.com/dminuoso))
## [0.3.0](https://github.com/alasconnect/ldap-client/tree/0.3.0) (2019-11-06)
[Full Changelog](https://github.com/alasconnect/ldap-client/compare/0.2.0...0.3.0)
\* *This Changelog was automatically generated by [github_changelog_generator](https://github.com/github-changelog-generator/github-changelog-generator)* \* *This Changelog was automatically generated by [github_changelog_generator](https://github.com/github-changelog-generator/github-changelog-generator)*

View File

@ -1,7 +1,7 @@
ldap-client ldap-client
=========== ===========
[![Hackage](https://budueba.com/hackage/ldap-client)](https://hackage.haskell.org/package/ldap-client) [![Hackage](https://budueba.com/hackage/ldap-client)](https://hackage.haskell.org/package/ldap-client)
[![Build Status](https://travis-ci.org/alasconnect/ldap-client.svg?branch=master)](https://travis-ci.org/alasconnect/ldap-client) [![Build Status](https://travis-ci.org/supki/ldap-client.svg?branch=master)](https://travis-ci.org/supki/ldap-client)
This library implements (the parts of) [RFC 4511][rfc4511] This library implements (the parts of) [RFC 4511][rfc4511]

View File

@ -31,7 +31,7 @@ import qualified System.IO as IO -- base
data Conf = Conf data Conf = Conf
{ host :: String { host :: String
, port :: Int , port :: PortNumber
, dn :: Dn , dn :: Dn
, password :: Password , password :: Password
, base :: Dn , base :: Dn

View File

@ -1,9 +1,9 @@
name: ldap-client name: ldap-client
version: 0.4.0 version: 0.3.0
synopsis: Pure Haskell LDAP Client Library synopsis: Pure Haskell LDAP Client Library
description: description:
Pure Haskell LDAP client library implementing (the parts of) RFC 4511. Pure Haskell LDAP client library implementing (the parts of) RFC 4511.
homepage: https://github.com/alasconnect/ldap-client homepage: https://supki.github.io/ldap-client
license: BSD2 license: BSD2
license-file: LICENSE license-file: LICENSE
author: Matvey Aksenov, AlasConnect LLC author: Matvey Aksenov, AlasConnect LLC
@ -18,13 +18,13 @@ tested-with:
, GHC == 8.4.4 , GHC == 8.4.4
, GHC == 8.6.5 , GHC == 8.6.5
extra-source-files: extra-source-files:
README.md README.markdown
CHANGELOG.md CHANGELOG.markdown
source-repository head source-repository head
type: git type: git
location: git@github.com:alasconnect/ldap-client location: git@github.com:alasconnect/ldap-client
tag: 0.4.0 tag: 0.3.0
library library
ghc-options: ghc-options:

View File

@ -4,7 +4,7 @@
}: }:
mkDerivation { mkDerivation {
pname = "ldap-client"; pname = "ldap-client";
version = "0.4.0"; version = "0.1.0";
src = ./.; src = ./.;
buildDepends = [ buildDepends = [
asn1-encoding asn1-types async base bytestring connection asn1-encoding asn1-types async base bytestring connection

View File

@ -2,8 +2,6 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module is intended to be imported qualified -- | This module is intended to be imported qualified
-- --
-- @ -- @
@ -11,17 +9,11 @@
-- @ -- @
module Ldap.Client module Ldap.Client
( with ( with
, with'
, runsIn
, runsInEither
, open
, close
, Host(..) , Host(..)
, defaultTlsSettings , defaultTlsSettings
, insecureTlsSettings , insecureTlsSettings
, PortNumber , PortNumber
, Ldap , Ldap
, LdapH
, LdapError(..) , LdapError(..)
, ResponseError(..) , ResponseError(..)
, Type.ResultCode(..) , Type.ResultCode(..)
@ -74,9 +66,8 @@ import qualified Control.Concurrent.Async as Async
import Control.Concurrent.STM (atomically, throwSTM) import Control.Concurrent.STM (atomically, throwSTM)
import Control.Concurrent.STM.TMVar (putTMVar) import Control.Concurrent.STM.TMVar (putTMVar)
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO, writeTQueue, readTQueue) import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO, writeTQueue, readTQueue)
import Control.Exception (Exception, bracket, throwIO, SomeException, fromException, throw, Handler(..)) import Control.Exception (Exception, Handler(..), bracket, throwIO, catch, catches)
import Control.Monad (forever) import Control.Monad (forever)
import Data.Void (Void)
import qualified Data.ASN1.BinaryEncoding as Asn1 import qualified Data.ASN1.BinaryEncoding as Asn1
import qualified Data.ASN1.Encoding as Asn1 import qualified Data.ASN1.Encoding as Asn1
import qualified Data.ASN1.Error as Asn1 import qualified Data.ASN1.Error as Asn1
@ -123,99 +114,50 @@ import Ldap.Client.Extended (Oid(..), extended, noticeOfDisconnectionO
{-# ANN module ("HLint: ignore Use first" :: String) #-} {-# ANN module ("HLint: ignore Use first" :: String) #-}
newLdap :: IO Ldap
newLdap = Ldap
<$> newTQueueIO
-- | Various failures that can happen when working with LDAP. -- | Various failures that can happen when working with LDAP.
data LdapError data LdapError =
= IOError !IOError -- ^ Network failure. IOError !IOError -- ^ Network failure.
| ParseError !Asn1.ASN1Error -- ^ Invalid ASN.1 data received from the server. | ParseError !Asn1.ASN1Error -- ^ Invalid ASN.1 data received from the server.
| ResponseError !ResponseError -- ^ An LDAP operation failed. | ResponseError !ResponseError -- ^ An LDAP operation failed.
| DisconnectError !Disconnect -- ^ Notice of Disconnection has been received. | DisconnectError !Disconnect -- ^ Notice of Disconnection has been received.
deriving (Show, Eq) deriving (Show, Eq)
instance Exception LdapError newtype WrappedIOError = WrappedIOError IOError
deriving (Show, Eq, Typeable)
instance Exception WrappedIOError
data Disconnect = Disconnect !Type.ResultCode !Dn !Text data Disconnect = Disconnect !Type.ResultCode !Dn !Text
deriving (Show, Eq, Typeable) deriving (Show, Eq, Typeable)
instance Exception Disconnect 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 act (LdapH ldap) = do
actor <- Async.async (act ldap)
r <- Async.waitEitherCatch (workers ldap) actor
case r of
Left (Right _a) -> error "Unreachable"
Left (Left e) -> throwIO =<< catchesHandler workerErr e
Right (Right r') -> pure r'
Right (Left e) -> throwIO =<< catchesHandler respErr e
-- | Provide a 'LdapH' to a function needing an 'Ldap' handle
runsInEither :: (Ldap -> IO a)
-> LdapH
-> IO (Either LdapError a)
runsInEither act (LdapH ldap) = do
actor <- Async.async (act ldap)
r <- Async.waitEitherCatch (workers ldap) actor
case r of
Left (Right _a) -> error "Unreachable"
Left (Left e) -> do Left <$> catchesHandler workerErr e
Right (Right r') -> pure (Right r')
Right (Left e) -> do Left <$> catchesHandler respErr e
workerErr :: [Handler LdapError]
workerErr = [ Handler (\(ex :: IOError) -> pure (IOError ex))
, Handler (\(ex :: Asn1.ASN1Error) -> pure (ParseError ex))
, Handler (\(ex :: Disconnect) -> pure (DisconnectError ex))
]
respErr :: [Handler LdapError]
respErr = [ Handler (\(ex :: ResponseError) -> pure (ResponseError ex))
]
catchesHandler :: [Handler a] -> SomeException -> IO a
catchesHandler handlers e = foldr tryHandler (throw e) handlers
where tryHandler (Handler handler) res
= case fromException e of
Just e' -> handler e'
Nothing -> res
-- | The entrypoint into LDAP. -- | The entrypoint into LDAP.
with' :: Host -> PortNumber -> (Ldap -> IO a) -> IO a --
with' host port act = bracket (open host port) close (runsIn act) -- It catches all LDAP-related exceptions.
with :: Host -> PortNumber -> (Ldap -> IO a) -> IO (Either LdapError a) with :: Host -> PortNumber -> (Ldap -> IO a) -> IO (Either LdapError a)
with host port act = bracket (open host port) close (runsInEither act) with host port f = do
-- | 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 port = do
context <- Conn.initConnectionContext context <- Conn.initConnectionContext
conn <- Conn.connectTo context params bracket (Conn.connectTo context params) Conn.connectionClose (\conn ->
reqQ <- newTQueueIO bracket newLdap unbindAsync (\l -> do
inQ <- newTQueueIO inq <- newTQueueIO
outQ <- newTQueueIO outq <- newTQueueIO
as <- traverse Async.async
-- The input worker that reads data off the network. [ input inq conn
(inW :: Async.Async Void) <- Async.async (input inQ conn) , output outq conn
, dispatch l inq outq
-- The output worker that sends data onto the network. , f l
(outW :: Async.Async Void) <- Async.async (output outQ conn) ]
fmap (Right . snd) (Async.waitAnyCancel as)))
-- The dispatch worker that sends data between the three queues. `catches`
(dispW :: Async.Async Void) <- Async.async (dispatch reqQ inQ outQ) [ Handler (\(WrappedIOError e) -> return (Left (IOError e)))
, Handler (return . Left . ParseError)
-- We use this to propagate exceptions between the workers. The `workers` Async is just a tool to , Handler (return . Left . ResponseError)
-- exchange exceptions between the entire worker group and another thread. ]
workers <- Async.async (snd <$> Async.waitAnyCancel [inW, outW, dispW])
pure (LdapH (Ldap reqQ workers conn))
where where
params = Conn.ConnectionParams params = Conn.ConnectionParams
{ Conn.connectionHostname = { Conn.connectionHostname =
@ -230,14 +172,6 @@ open host port = do
, Conn.connectionUseSocks = Nothing , Conn.connectionUseSocks = Nothing
} }
-- | Closes an LDAP connection.
-- This is to be used in together with 'open'.
close :: LdapH -> IO ()
close (LdapH ldap) = do
unbindAsync ldap
Conn.connectionClose (conn ldap)
Async.cancel (workers ldap)
defaultTlsSettings :: Conn.TLSSettings defaultTlsSettings :: Conn.TLSSettings
defaultTlsSettings = Conn.TLSSettingsSimple defaultTlsSettings = Conn.TLSSettingsSimple
{ Conn.settingDisableCertificateValidation = False { Conn.settingDisableCertificateValidation = False
@ -252,85 +186,84 @@ insecureTlsSettings = Conn.TLSSettingsSimple
, Conn.settingUseServerName = False , Conn.settingUseServerName = False
} }
-- | Reads Asn1 BER encoded chunks off a connection into a TQueue.
input :: FromAsn1 a => TQueue a -> Connection -> IO b input :: FromAsn1 a => TQueue a -> Connection -> IO b
input inq conn = loop [] input inq conn = wrap . flip fix [] $ \loop chunks -> do
where chunk <- Conn.connectionGet conn 8192
loop chunks = do case ByteString.length chunk of
chunk <- Conn.connectionGet conn 8192 0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing)
case ByteString.length chunk of _ -> do
0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing) let chunks' = chunk : chunks
_ -> do case Asn1.decodeASN1 Asn1.BER (ByteString.Lazy.fromChunks (reverse chunks')) of
let chunks' = chunk : chunks Left Asn1.ParsingPartial
case Asn1.decodeASN1 Asn1.BER (ByteString.Lazy.fromChunks (reverse chunks')) of -> loop chunks'
Left Asn1.ParsingPartial Left e -> throwIO e
-> loop chunks' Right asn1 -> do
Left e -> throwIO e flip fix asn1 $ \loop' asn1' ->
Right asn1 -> do case parseAsn1 asn1' of
flip fix asn1 $ \loop' asn1' -> Nothing -> return ()
case parseAsn1 asn1' of Just (asn1'', a) -> do
Nothing -> return () atomically (writeTQueue inq a)
Just (asn1'', a) -> do loop' asn1''
atomically (writeTQueue inq a) loop []
loop' asn1''
loop []
-- | Transmits Asn1 DER encoded data from a TQueue into a Connection.
output :: ToAsn1 a => TQueue a -> Connection -> IO b output :: ToAsn1 a => TQueue a -> Connection -> IO b
output out conn = forever $ do output out conn = wrap . forever $ do
msg <- atomically (readTQueue out) msg <- atomically (readTQueue out)
Conn.connectionPut conn (encode (toAsn1 msg)) Conn.connectionPut conn (encode (toAsn1 msg))
where where
encode x = Asn1.encodeASN1' Asn1.DER (appEndo x []) encode x = Asn1.encodeASN1' Asn1.DER (appEndo x [])
dispatch dispatch
:: TQueue ClientMessage :: Ldap
-> TQueue (Type.LdapMessage Type.ProtocolServerOp) -> TQueue (Type.LdapMessage Type.ProtocolServerOp)
-> TQueue (Type.LdapMessage Request) -> TQueue (Type.LdapMessage Request)
-> IO a -> IO a
dispatch reqq inq outq = loop (Map.empty, 1) dispatch Ldap { client } inq outq =
where flip fix (Map.empty, 1) $ \loop (!req, !counter) ->
saveUp mid op res = return (Map.adjust (\(stack, var) -> (op : stack, var)) mid res) loop =<< atomically (asum
[ do New new var <- readTQueue client
writeTQueue outq (Type.LdapMessage (Type.Id counter) new Nothing)
return (Map.insert (Type.Id counter) ([], var) req, counter + 1)
, do Type.LdapMessage mid op _
<- readTQueue inq
res <- case op of
Type.BindResponse {} -> done mid op req
Type.SearchResultEntry {} -> saveUp mid op req
Type.SearchResultReference {} -> return req
Type.SearchResultDone {} -> done mid op req
Type.ModifyResponse {} -> done mid op req
Type.AddResponse {} -> done mid op req
Type.DeleteResponse {} -> done mid op req
Type.ModifyDnResponse {} -> done mid op req
Type.CompareResponse {} -> done mid op req
Type.ExtendedResponse {} -> probablyDisconnect mid op req
Type.IntermediateResponse {} -> saveUp mid op req
return (res, counter)
])
where
saveUp mid op res =
return (Map.adjust (\(stack, var) -> (op : stack, var)) mid res)
loop (!req, !counter) = done mid op req =
loop =<< atomically (asum case Map.lookup mid req of
[ do New new var <- readTQueue reqq Nothing -> return req
writeTQueue outq (Type.LdapMessage (Type.Id counter) new Nothing) Just (stack, var) -> do
return (Map.insert (Type.Id counter) ([], var) req, counter + 1) putTMVar var (op :| stack)
, do Type.LdapMessage mid op _ return (Map.delete mid req)
<- readTQueue inq
res <- case op of
Type.BindResponse {} -> done mid op req
Type.SearchResultEntry {} -> saveUp mid op req
Type.SearchResultReference {} -> return req
Type.SearchResultDone {} -> done mid op req
Type.ModifyResponse {} -> done mid op req
Type.AddResponse {} -> done mid op req
Type.DeleteResponse {} -> done mid op req
Type.ModifyDnResponse {} -> done mid op req
Type.CompareResponse {} -> done mid op req
Type.ExtendedResponse {} -> probablyDisconnect mid op req
Type.IntermediateResponse {} -> saveUp mid op req
return (res, counter)
])
done mid op req = probablyDisconnect (Type.Id 0)
case Map.lookup mid req of (Type.ExtendedResponse
Nothing -> return req (Type.LdapResult code
Just (stack, var) -> do (Type.LdapDn (Type.LdapString dn))
putTMVar var (op :| stack) (Type.LdapString reason)
return (Map.delete mid req) _)
moid _)
req =
case moid of
Just (Type.LdapOid oid)
| Oid oid == noticeOfDisconnectionOid -> throwSTM (Disconnect code (Dn dn) reason)
_ -> return req
probablyDisconnect mid op req = done mid op req
probablyDisconnect (Type.Id 0) wrap :: IO a -> IO a
(Type.ExtendedResponse wrap m = m `catch` (throwIO . WrappedIOError)
(Type.LdapResult code
(Type.LdapDn (Type.LdapString dn))
(Type.LdapString reason)
_)
moid _)
req =
case moid of
Just (Type.LdapOid oid)
| Oid oid == noticeOfDisconnectionOid -> throwSTM (Disconnect code (Dn dn) reason)
_ -> return req
probablyDisconnect mid op req = done mid op req

View File

@ -31,7 +31,7 @@ import Ldap.Client.Internal
-- | Perform the Add operation synchronously. Raises 'ResponseError' on failures. -- | Perform the Add operation synchronously. Raises 'ResponseError' on failures.
add :: Ldap -> Dn -> AttrList NonEmpty -> IO () add :: Ldap -> Dn -> AttrList NonEmpty -> IO ()
add l dn as = add l dn as =
eitherToIO =<< addEither l dn as raise =<< addEither l dn as
-- | Perform the Add operation synchronously. Returns @Left e@ where -- | Perform the Add operation synchronously. Returns @Left e@ where
-- @e@ is a 'ResponseError' on failures. -- @e@ is a 'ResponseError' on failures.

View File

@ -42,7 +42,7 @@ newtype Password = Password ByteString
-- | Perform the Bind operation synchronously. Raises 'ResponseError' on failures. -- | Perform the Bind operation synchronously. Raises 'ResponseError' on failures.
bind :: Ldap -> Dn -> Password -> IO () bind :: Ldap -> Dn -> Password -> IO ()
bind l username password = bind l username password =
eitherToIO =<< bindEither l username password raise =<< bindEither l username password
-- | Perform the Bind operation synchronously. Returns @Left e@ where -- | Perform the Bind operation synchronously. Returns @Left e@ where
-- @e@ is a 'ResponseError' on failures. -- @e@ is a 'ResponseError' on failures.
@ -82,7 +82,7 @@ bindResult req res = Left (ResponseInvalid req res)
-- | Perform a SASL EXTERNAL Bind operation synchronously. Raises 'ResponseError' on failures. -- | Perform a SASL EXTERNAL Bind operation synchronously. Raises 'ResponseError' on failures.
externalBind :: Ldap -> Dn -> Maybe Text -> IO () externalBind :: Ldap -> Dn -> Maybe Text -> IO ()
externalBind l username mCredentials = externalBind l username mCredentials =
eitherToIO =<< externalBindEither l username mCredentials raise =<< externalBindEither l username mCredentials
-- | Perform a SASL EXTERNAL Bind operation synchronously. Returns @Left e@ where -- | Perform a SASL EXTERNAL Bind operation synchronously. Returns @Left e@ where
-- @e@ is a 'ResponseError' on failures. -- @e@ is a 'ResponseError' on failures.

View File

@ -33,7 +33,7 @@ import qualified Ldap.Asn1.Type as Type
-- | Perform the Compare operation synchronously. Raises 'ResponseError' on failures. -- | Perform the Compare operation synchronously. Raises 'ResponseError' on failures.
compare :: Ldap -> Dn -> Attr -> AttrValue -> IO Bool compare :: Ldap -> Dn -> Attr -> AttrValue -> IO Bool
compare l dn k v = compare l dn k v =
eitherToIO =<< compareEither l dn k v raise =<< compareEither l dn k v
-- | Perform the Compare operation synchronously. Returns @Left e@ where -- | Perform the Compare operation synchronously. Returns @Left e@ where
-- @e@ is a 'ResponseError' on failures. -- @e@ is a 'ResponseError' on failures.

View File

@ -31,7 +31,7 @@ import Ldap.Client.Internal
-- | Perform the Delete operation synchronously. Raises 'ResponseError' on failures. -- | Perform the Delete operation synchronously. Raises 'ResponseError' on failures.
delete :: Ldap -> Dn -> IO () delete :: Ldap -> Dn -> IO ()
delete l dn = delete l dn =
eitherToIO =<< deleteEither l dn raise =<< deleteEither l dn
-- | Perform the Delete operation synchronously. Returns @Left e@ where -- | Perform the Delete operation synchronously. Returns @Left e@ where
-- @e@ is a 'ResponseError' on failures. -- @e@ is a 'ResponseError' on failures.

View File

@ -54,7 +54,7 @@ instance IsString Oid where
-- | Perform the Extended operation synchronously. Raises 'ResponseError' on failures. -- | Perform the Extended operation synchronously. Raises 'ResponseError' on failures.
extended :: Ldap -> Oid -> Maybe ByteString -> IO () extended :: Ldap -> Oid -> Maybe ByteString -> IO ()
extended l oid mv = extended l oid mv =
eitherToIO =<< extendedEither l oid mv raise =<< extendedEither l oid mv
-- | Perform the Extended operation synchronously. Returns @Left e@ where -- | Perform the Extended operation synchronously. Returns @Left e@ where
-- @e@ is a 'ResponseError' on failures. -- @e@ is a 'ResponseError' on failures.
@ -92,7 +92,7 @@ extendedResult req res = Left (ResponseInvalid req res)
-- | An example of @Extended Operation@, cf. 'extended'. -- | An example of @Extended Operation@, cf. 'extended'.
startTls :: Ldap -> IO () startTls :: Ldap -> IO ()
startTls = startTls =
eitherToIO <=< startTlsEither raise <=< startTlsEither
-- | An example of @Extended Operation@, cf. 'extendedEither'. -- | An example of @Extended Operation@, cf. 'extendedEither'.
startTlsEither :: Ldap -> IO (Either ResponseError ()) startTlsEither :: Ldap -> IO (Either ResponseError ())

View File

@ -16,7 +16,7 @@ module Ldap.Client.Internal
, Response , Response
, ResponseError(..) , ResponseError(..)
, Request , Request
, eitherToIO , raise
, sendRequest , sendRequest
, Dn(..) , Dn(..)
, Attr(..) , Attr(..)
@ -27,7 +27,6 @@ module Ldap.Client.Internal
, unbindAsyncSTM , unbindAsyncSTM
) where ) where
import qualified Control.Concurrent.Async as Async (Async)
import Control.Concurrent.STM (STM, atomically) import Control.Concurrent.STM (STM, atomically)
import Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, readTMVar) import Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, readTMVar)
import Control.Concurrent.STM.TQueue (TQueue, writeTQueue) import Control.Concurrent.STM.TQueue (TQueue, writeTQueue)
@ -42,8 +41,7 @@ import Network.Socket (PortNumber)
#else #else
import Network (PortNumber) import Network (PortNumber)
#endif #endif
import Network.Connection (TLSSettings, Connection) import Network.Connection (TLSSettings)
import Data.Void (Void)
import qualified Ldap.Asn1.Type as Type import qualified Ldap.Asn1.Type as Type
@ -54,12 +52,10 @@ data Host =
| Tls String TLSSettings -- ^ LDAP over TLS. | Tls String TLSSettings -- ^ LDAP over TLS.
deriving (Show) deriving (Show)
-- | An LDAP connection handle -- | A token. All functions that interact with the Directory require one.
data Ldap = Ldap newtype Ldap = Ldap
{ reqQ :: !(TQueue ClientMessage) -- ^ Request queue for client messages to be send. { client :: TQueue ClientMessage
, workers :: !(Async.Async Void) -- ^ Workers group for communicating with the server. } deriving (Eq)
, conn :: !Connection -- ^ Network connection to the server.
}
data ClientMessage = New !Request !(TMVar (NonEmpty Type.ProtocolServerOp)) data ClientMessage = New !Request !(TMVar (NonEmpty Type.ProtocolServerOp))
type Request = Type.ProtocolClientOp type Request = Type.ProtocolClientOp
@ -120,10 +116,11 @@ sendRequest l p msg =
return (Async (fmap p (readTMVar var))) return (Async (fmap p (readTMVar var)))
writeRequest :: Ldap -> TMVar Response -> Request -> STM () writeRequest :: Ldap -> TMVar Response -> Request -> STM ()
writeRequest Ldap { reqQ } var msg = writeTQueue reqQ (New msg var) writeRequest Ldap { client } var msg = writeTQueue client (New msg var)
raise :: Exception e => Either e a -> IO a
raise = either throwIO return
eitherToIO :: Exception e => Either e a -> IO a
eitherToIO = either throwIO pure
-- | Terminate the connection to the Directory. -- | Terminate the connection to the Directory.
-- --

View File

@ -48,7 +48,7 @@ data Operation =
-- | Perform the Modify operation synchronously. Raises 'ResponseError' on failures. -- | Perform the Modify operation synchronously. Raises 'ResponseError' on failures.
modify :: Ldap -> Dn -> [Operation] -> IO () modify :: Ldap -> Dn -> [Operation] -> IO ()
modify l dn as = modify l dn as =
eitherToIO =<< modifyEither l dn as raise =<< modifyEither l dn as
-- | Perform the Modify operation synchronously. Returns @Left e@ where -- | Perform the Modify operation synchronously. Returns @Left e@ where
-- @e@ is a 'ResponseError' on failures. -- @e@ is a 'ResponseError' on failures.
@ -98,7 +98,7 @@ newtype RelativeDn = RelativeDn Text
-- | Perform the Modify DN operation synchronously. Raises 'ResponseError' on failures. -- | Perform the Modify DN operation synchronously. Raises 'ResponseError' on failures.
modifyDn :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO () modifyDn :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO ()
modifyDn l dn rdn del new = modifyDn l dn rdn del new =
eitherToIO =<< modifyDnEither l dn rdn del new raise =<< modifyDnEither l dn rdn del new
-- | Perform the Modify DN operation synchronously. Returns @Left e@ where -- | Perform the Modify DN operation synchronously. Returns @Left e@ where
-- @e@ is a 'ResponseError' on failures. -- @e@ is a 'ResponseError' on failures.

View File

@ -52,7 +52,7 @@ import Ldap.Client.Internal
-- | Perform the Search operation synchronously. Raises 'ResponseError' on failures. -- | Perform the Search operation synchronously. Raises 'ResponseError' on failures.
search :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry] search :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry]
search l base opts flt attributes = search l base opts flt attributes =
eitherToIO =<< searchEither l base opts flt attributes raise =<< searchEither l base opts flt attributes
-- | Perform the Search operation synchronously. Returns @Left e@ where -- | Perform the Search operation synchronously. Returns @Left e@ where
-- @e@ is a 'ResponseError' on failures. -- @e@ is a 'ResponseError' on failures.