haskell/ldap-client
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Extract as much useful information as possible from errors

Browse Source
This commit is contained in:
Matvey Aksenov 2015-04-03 15:13:52 +00:00
parent 51f61cea6c
commit 1c9bd11626
16 changed files with 317 additions and 290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
ldap-client.cabal
View File

@ -29,6 +29,13 @@ library
Ldap.Asn1.ToAsn1
Ldap.Asn1.Type
Ldap.Client
Ldap.Client.Add
Ldap.Client.Bind
Ldap.Client.Compare
Ldap.Client.Delete
Ldap.Client.Internal
Ldap.Client.Modify
Ldap.Client.Search
build-depends:
asn1-encoding >= 0.9
, asn1-types >= 0.3
@ -52,7 +59,15 @@ test-suite spec
main-is:
Spec.hs
other-modules:
Ldap.ClientSpec
Ldap.Client
Ldap.Client.AddSpec
Ldap.Client.BindSpec
Ldap.Client.CompareSpec
Ldap.Client.DeleteSpec
Ldap.Client.InternalSpec
Ldap.Client.ModifySpec
Ldap.Client.SearchSpec
SpecHelper
build-depends:
base >= 4.7 && < 5
, hspec

32
src/Ldap/Client.hs
View File

@ -6,17 +6,16 @@ module Ldap.Client
, PortNumber
, Ldap
, LdapError(..)
, ResponseError(..)
, Type.ResultCode(..)
, Async
, with
-- * Bind Operation
, Dn(..)
, Password(..)
, BindError(..)
, bind
-- * Search Operation
, Attr(..)
, SearchError(..)
, search
, Search
, scope
@ -28,18 +27,14 @@ module Ldap.Client
, Filter(..)
, SearchEntry(..)
-- * Modify Operation
, ModifyError(..)
, Operation(..)
, modify
-- * Add Operation
, AttrList
, AddError(..)
, add
-- * Delete Operation
, DeleteError(..)
, delete
-- * Compare Operation
, CompareError(..)
, compare
-- * Waiting for Operation Completion
, wait
@ -71,10 +66,9 @@ 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 (BindError(..), bind, unbindAsync)
import Ldap.Client.Bind (bind, unbindAsync)
import Ldap.Client.Search
( SearchError(..)
, search
( search
, Search
, scope
, size
@ -84,8 +78,10 @@ import Ldap.Client.Search
, Filter(..)
, SearchEntry(..)
)
import Ldap.Client.Modify (ModifyError(..), Operation(..), modify)
import Ldap.Client.Compare (CompareError(..), compare)
import Ldap.Client.Modify (Operation(..), modify)
import Ldap.Client.Add (add)
import Ldap.Client.Delete (delete)
import Ldap.Client.Compare (compare)
newLdap :: IO Ldap
@ -95,12 +91,7 @@ newLdap = Ldap
data LdapError =
IOError IOError
| ParseError Asn1.ASN1Error
| BindError BindError
| SearchError SearchError
| ModifyError ModifyError
| AddError AddError
| DeleteError DeleteError
| CompareError CompareError
| ResponseError ResponseError
deriving (Show, Eq)
-- | The entrypoint into LDAP.
@ -119,12 +110,7 @@ with host port f = do
`catches`
[ Handler (return . Left . IOError)
, Handler (return . Left . ParseError)
, Handler (return . Left . BindError)
, Handler (return . Left . SearchError)
, Handler (return . Left . ModifyError)
, Handler (return . Left . AddError)
, Handler (return . Left . DeleteError)
, Handler (return . Left . CompareError)
, Handler (return . Left . ResponseError)
]
where
params = Conn.ConnectionParams

44
src/Ldap/Client/Add.hs Normal file
View File

@ -0,0 +1,44 @@
module Ldap.Client.Add
( add
, addEither
, addAsync
, addAsyncSTM
) where
import Control.Monad.STM (STM, atomically)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Ldap.Asn1.Type as Type
import Ldap.Client.Internal
add :: Ldap -> Dn -> AttrList NonEmpty -> IO ()
add l dn as =
raise =<< addEither l dn as
addEither :: Ldap -> Dn -> AttrList NonEmpty -> IO (Either ResponseError ())
addEither l dn as =
wait =<< addAsync l dn as
addAsync :: Ldap -> Dn -> AttrList NonEmpty -> IO (Async ())
addAsync l dn as =
atomically (addAsyncSTM l dn as)
addAsyncSTM :: Ldap -> Dn -> AttrList NonEmpty -> STM (Async ())
addAsyncSTM l dn as =
let req = addRequest dn as in sendRequest l (addResult req) req
addRequest :: Dn -> AttrList NonEmpty -> Request
addRequest (Dn dn) as =
Type.AddRequest (Type.LdapDn (Type.LdapString dn))
(Type.AttributeList (map f as))
where
f (Attr x, xs) = Type.Attribute (Type.AttributeDescription (Type.LdapString x))
(fmap Type.AttributeValue xs)
addResult :: Request -> Response -> Either ResponseError ()
addResult req (Type.AddResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))
(Type.LdapString msg) _) :| [])
| Type.Success <- code = Right ()
| otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
addResult req res = Left (ResponseInvalid req res)

29
src/Ldap/Client/Bind.hs
View File

@ -1,6 +1,5 @@
module Ldap.Client.Bind
( BindError(..)
, bind
( bind
, bindEither
, bindAsync
, bindAsyncSTM
@ -8,40 +7,31 @@ module Ldap.Client.Bind
, unbindAsyncSTM
) where
import Control.Exception (Exception)
import Control.Monad (void)
import Control.Monad.STM (STM, atomically)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Typeable (Typeable)
import qualified Ldap.Asn1.Type as Type
import Ldap.Client.Internal
data BindError =
BindInvalidResponse Response
| BindErrorCode Type.ResultCode
deriving (Show, Eq, Typeable)
instance Exception BindError
-- | Throws 'BindError' on failure. Don't worry, the nearest 'with'
-- will catch it, so it won't destroy your program.
bind :: Ldap -> Dn -> Password -> IO ()
bind l username password =
raise =<< bindEither l username password
bindEither :: Ldap -> Dn -> Password -> IO (Either BindError ())
bindEither :: Ldap -> Dn -> Password -> IO (Either ResponseError ())
bindEither l username password =
wait =<< bindAsync l username password
bindAsync :: Ldap -> Dn -> Password -> IO (Async BindError ())
bindAsync :: Ldap -> Dn -> Password -> IO (Async ())
bindAsync l username password =
atomically (bindAsyncSTM l username password)
bindAsyncSTM :: Ldap -> Dn -> Password -> STM (Async BindError ())
bindAsyncSTM :: Ldap -> Dn -> Password -> STM (Async ())
bindAsyncSTM l username password =
sendRequest l bindResult (bindRequest username password)
let req = bindRequest username password in sendRequest l (bindResult req) req
bindRequest :: Dn -> Password -> Request
bindRequest (Dn username) (Password password) =
@ -51,11 +41,12 @@ bindRequest (Dn username) (Password password) =
where
ldapVersion = 3
bindResult :: Response -> Either BindError ()
bindResult (Type.BindResponse (Type.LdapResult code _ _ _) _ :| [])
bindResult :: Request -> Response -> Either ResponseError ()
bindResult req (Type.BindResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))
(Type.LdapString msg) _) _ :| [])
| Type.Success <- code = Right ()
| otherwise = Left (BindErrorCode code)
bindResult res = Left (BindInvalidResponse res)
| otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
bindResult req res = Left (ResponseInvalid req res)
-- | Note that 'unbindAsync' does not return an 'Async',

29
src/Ldap/Client/Compare.hs
View File

@ -1,44 +1,34 @@
module Ldap.Client.Compare
( CompareError(..)
, compare
( compare
, compareEither
, compareAsync
, compareAsyncSTM
) where
import Control.Exception (Exception)
import Control.Monad.STM (STM, atomically)
import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Typeable (Typeable)
import Prelude hiding (compare)
import Ldap.Client.Internal
import qualified Ldap.Asn1.Type as Type
data CompareError =
CompareInvalidResponse Response
| CompareErrorCode Type.ResultCode
deriving (Show, Eq, Typeable)
instance Exception CompareError
compare :: Ldap -> Dn -> Attr -> ByteString -> IO Bool
compare l dn k v =
raise =<< compareEither l dn k v
compareEither :: Ldap -> Dn -> Attr -> ByteString -> IO (Either CompareError Bool)
compareEither :: Ldap -> Dn -> Attr -> ByteString -> IO (Either ResponseError Bool)
compareEither l dn k v =
wait =<< compareAsync l dn k v
compareAsync :: Ldap -> Dn -> Attr -> ByteString -> IO (Async CompareError Bool)
compareAsync :: Ldap -> Dn -> Attr -> ByteString -> IO (Async Bool)
compareAsync l dn k v =
atomically (compareAsyncSTM l dn k v)
compareAsyncSTM :: Ldap -> Dn -> Attr -> ByteString -> STM (Async CompareError Bool)
compareAsyncSTM :: Ldap -> Dn -> Attr -> ByteString -> STM (Async Bool)
compareAsyncSTM l dn k v =
sendRequest l compareResult (compareRequest dn k v)
let req = compareRequest dn k v in sendRequest l (compareResult req) req
compareRequest :: Dn -> Attr -> ByteString -> Request
compareRequest (Dn dn) (Attr k) v =
@ -47,9 +37,10 @@ compareRequest (Dn dn) (Attr k) v =
(Type.AttributeDescription (Type.LdapString k))
(Type.AssertionValue v))
compareResult :: Response -> Either CompareError Bool
compareResult (Type.CompareResponse (Type.LdapResult code _ _ _) :| [])
compareResult :: Request -> Response -> Either ResponseError Bool
compareResult req (Type.CompareResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))
(Type.LdapString msg) _) :| [])
| Type.CompareTrue <- code = Right True
| Type.CompareFalse <- code = Right False
| otherwise = Left (CompareErrorCode code)
compareResult res = Left (CompareInvalidResponse res)
| otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
compareResult req res = Left (ResponseInvalid req res)

40
src/Ldap/Client/Delete.hs Normal file
View File

@ -0,0 +1,40 @@
module Ldap.Client.Delete
( delete
, deleteEither
, deleteAsync
, deleteAsyncSTM
) where
import Control.Concurrent.STM (STM, atomically)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Ldap.Asn1.Type as Type
import Ldap.Client.Internal
delete :: Ldap -> Dn -> IO ()
delete l dn =
raise =<< deleteEither l dn
deleteEither :: Ldap -> Dn -> IO (Either ResponseError ())
deleteEither l dn =
wait =<< deleteAsync l dn
deleteAsync :: Ldap -> Dn -> IO (Async ())
deleteAsync l dn =
atomically (deleteAsyncSTM l dn)
deleteAsyncSTM :: Ldap -> Dn -> STM (Async ())
deleteAsyncSTM l dn =
let req = deleteRequest dn in sendRequest l (deleteResult req) req
deleteRequest :: Dn -> Request
deleteRequest (Dn dn) =
Type.DeleteRequest (Type.LdapDn (Type.LdapString dn))
deleteResult :: Request -> Response -> Either ResponseError ()
deleteResult req (Type.DeleteResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))
(Type.LdapString msg) _) :| [])
| Type.Success <- code = Right ()
| otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
deleteResult req res = Left (ResponseInvalid req res)

98
src/Ldap/Client/Internal.hs
View File

@ -8,24 +8,13 @@ module Ldap.Client.Internal
, ClientMessage(..)
, Type.ResultCode(..)
, Async
-- * Add Request
, AttrList
, AddError(..)
, add
, addEither
, addAsync
, addAsyncSTM
-- * Delete Request
, DeleteError(..)
, delete
, deleteEither
, deleteAsync
, deleteAsyncSTM
-- * Waiting for Request Completion
, wait
, waitSTM
-- * Misc
, Response
, ResponseError(..)
, Request
, raise
, sendRequest
@ -40,9 +29,8 @@ import Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, readTMVar)
import Control.Concurrent.STM.TQueue (TQueue, writeTQueue)
import Control.Exception (Exception, throwIO)
import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Network (PortNumber)
import qualified Ldap.Asn1.Type as Type
@ -63,9 +51,9 @@ type Request = Type.ProtocolClientOp
type InMessage = Type.ProtocolServerOp
type Response = NonEmpty InMessage
data Async e a = Async (STM (Either e a))
data Async a = Async (STM (Either ResponseError a))
instance Functor (Async e) where
instance Functor Async where
fmap f (Async stm) = Async (fmap (fmap f) stm)
@ -75,6 +63,13 @@ newtype Password = Password ByteString
deriving (Show, Eq)
data ResponseError =
ResponseInvalid Request Response
| ResponseErrorCode Request Type.ResultCode Dn Text
deriving (Show, Eq)
instance Exception ResponseError
newtype Attr = Attr Text
@ -82,85 +77,20 @@ newtype Attr = Attr Text
type AttrList f = [(Attr, f ByteString)]
data AddError =
AddInvalidResponse Response
| AddErrorCode Type.ResultCode
deriving (Show, Eq, Typeable)
instance Exception AddError
add :: Ldap -> Dn -> AttrList NonEmpty -> IO ()
add l dn as =
raise =<< addEither l dn as
addEither :: Ldap -> Dn -> AttrList NonEmpty -> IO (Either AddError ())
addEither l dn as =
wait =<< addAsync l dn as
addAsync :: Ldap -> Dn -> AttrList NonEmpty -> IO (Async AddError ())
addAsync l dn as =
atomically (addAsyncSTM l dn as)
addAsyncSTM :: Ldap -> Dn -> AttrList NonEmpty -> STM (Async AddError ())
addAsyncSTM l (Dn dn) as =
sendRequest l addResult
(Type.AddRequest (Type.LdapDn (Type.LdapString dn))
(Type.AttributeList (map f as)))
where
f (Attr x, xs) = Type.Attribute (Type.AttributeDescription (Type.LdapString x))
(fmap Type.AttributeValue xs)
addResult :: Response -> Either AddError ()
addResult (Type.AddResponse (Type.LdapResult code _ _ _) :| [])
| Type.Success <- code = Right ()
| otherwise = Left (AddErrorCode code)
addResult res = Left (AddInvalidResponse res)
-- 'Attr' unwrapper. This is a separate function not to turn 'Attr''s
-- 'Show' instance into complete and utter shit.
unAttr :: Attr -> Text
unAttr (Attr a) = a
data DeleteError =
DeleteInvalidResponse Response
| DeleteErrorCode Type.ResultCode
deriving (Show, Eq, Typeable)
instance Exception DeleteError
delete :: Ldap -> Dn -> IO ()
delete l dn =
raise =<< deleteEither l dn
deleteEither :: Ldap -> Dn -> IO (Either DeleteError ())
deleteEither l dn =
wait =<< deleteAsync l dn
deleteAsync :: Ldap -> Dn -> IO (Async DeleteError ())
deleteAsync l dn =
atomically (deleteAsyncSTM l dn)
deleteAsyncSTM :: Ldap -> Dn -> STM (Async DeleteError ())
deleteAsyncSTM l (Dn dn) =
sendRequest l deleteResult
(Type.DeleteRequest (Type.LdapDn (Type.LdapString dn)))
deleteResult :: Response -> Either DeleteError ()
deleteResult (Type.DeleteResponse (Type.LdapResult code _ _ _) :| [])
| Type.Success <- code = Right ()
| otherwise = Left (DeleteErrorCode code)
deleteResult res = Left (DeleteInvalidResponse res)
wait :: Async e a -> IO (Either e a)
wait :: Async a -> IO (Either ResponseError a)
wait = atomically . waitSTM
waitSTM :: Async e a -> STM (Either e a)
waitSTM :: Async a -> STM (Either ResponseError a)
waitSTM (Async stm) = stm
sendRequest :: Ldap -> (Response -> Either e a) -> Request -> STM (Async e a)
sendRequest :: Ldap -> (Response -> Either ResponseError a) -> Request -> STM (Async a)
sendRequest l p msg =
do var <- newEmptyTMVar
writeRequest l var msg

37
src/Ldap/Client/Modify.hs
View File

@ -1,53 +1,44 @@
module Ldap.Client.Modify
( ModifyError(..)
, Operation(..)
( Operation(..)
, modify
, modifyEither
, modifyAsync
, modifyAsyncSTM
) where
import Control.Exception (Exception)
import Control.Monad.STM (STM, atomically)
import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Text (Text)
import Data.Typeable (Typeable)
import qualified Ldap.Asn1.Type as Type
import Ldap.Client.Internal
data ModifyError =
ModifyInvalidResponse Response
| ModifyErrorCode Type.ResultCode Dn Text
deriving (Show, Eq, Typeable)
data Operation =
Delete Attr [ByteString]
| Add Attr [ByteString]
| Replace Attr [ByteString]
deriving (Show, Eq)
instance Exception ModifyError
modify :: Ldap -> Dn -> [Operation] -> IO ()
modify l dn as =
raise =<< modifyEither l dn as
modifyEither :: Ldap -> Dn -> [Operation] -> IO (Either ModifyError ())
modifyEither :: Ldap -> Dn -> [Operation] -> IO (Either ResponseError ())
modifyEither l dn as =
wait =<< modifyAsync l dn as
modifyAsync :: Ldap -> Dn -> [Operation] -> IO (Async ModifyError ())
modifyAsync :: Ldap -> Dn -> [Operation] -> IO (Async ())
modifyAsync l dn as =
atomically (modifyAsyncSTM l dn as)
modifyAsyncSTM :: Ldap -> Dn -> [Operation] -> STM (Async ModifyError ())
modifyAsyncSTM l (Dn dn) xs =
sendRequest l modifyResult
(Type.ModifyRequest (Type.LdapDn (Type.LdapString dn)) (map f xs))
modifyAsyncSTM :: Ldap -> Dn -> [Operation] -> STM (Async ())
modifyAsyncSTM l dn xs =
let req = modifyRequest dn xs in sendRequest l (modifyResult req) req
modifyRequest :: Dn -> [Operation] -> Request
modifyRequest (Dn dn) xs =
Type.ModifyRequest (Type.LdapDn (Type.LdapString dn)) (map f xs)
where
f (Delete (Attr k) vs) =
(Type.Delete, Type.PartialAttribute (Type.AttributeDescription (Type.LdapString k))
@ -59,8 +50,8 @@ modifyAsyncSTM l (Dn dn) xs =
(Type.Replace, Type.PartialAttribute (Type.AttributeDescription (Type.LdapString k))
(map Type.AttributeValue vs))
modifyResult :: Response -> Either ModifyError ()
modifyResult (Type.ModifyResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn)) (Type.LdapString msg) _) :| [])
modifyResult :: Request -> Response -> Either ResponseError ()
modifyResult req (Type.ModifyResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn)) (Type.LdapString msg) _) :| [])
| Type.Success <- code = Right ()
| otherwise = Left (ModifyErrorCode code (Dn dn) msg)
modifyResult res = Left (ModifyInvalidResponse res)
| otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
modifyResult req res = Left (ResponseInvalid req res)

79
src/Ldap/Client/Search.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE NamedFieldPuns #-}
module Ldap.Client.Search
( SearchError(..)
, search
( search
, searchEither
, searchAsync
, searchAsyncSTM
@ -16,33 +15,19 @@ module Ldap.Client.Search
, SearchEntry(..)
) where
import Control.Exception (Exception)
import Control.Monad.STM (STM, atomically)
import Data.ByteString (ByteString)
import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (mapMaybe)
import Data.Typeable (Typeable)
import Data.Semigroup (Semigroup(..))
import qualified Ldap.Asn1.Type as Type
import Ldap.Client.Internal
data SearchError =
SearchInvalidResponse Response
| SearchErrorCode Type.ResultCode
deriving (Show, Eq, Typeable)
instance Exception SearchError
search
:: Ldap
-> Dn
-> Mod Search
-> Filter
-> [Attr]
-> IO [SearchEntry]
search :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry]
search l base opts flt attributes =
raise =<< searchEither l base opts flt attributes
@ -52,45 +37,17 @@ searchEither
-> Mod Search
-> Filter
-> [Attr]
-> IO (Either SearchError [SearchEntry])
-> IO (Either ResponseError [SearchEntry])
searchEither l base opts flt attributes =
wait =<< searchAsync l base opts flt attributes
searchAsync
:: Ldap
-> Dn
-> Mod Search
-> Filter
-> [Attr]
-> IO (Async SearchError [SearchEntry])
searchAsync :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO (Async [SearchEntry])
searchAsync l base opts flt attributes =
atomically (searchAsyncSTM l base opts flt attributes)
searchAsyncSTM
:: Ldap
-> Dn
-> Mod Search
-> Filter
-> [Attr]
-> STM (Async SearchError [SearchEntry])
searchAsyncSTM :: Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> STM (Async [SearchEntry])
searchAsyncSTM l base opts flt attributes =
sendRequest l searchResult (searchRequest base opts flt attributes)
searchResult :: Response -> Either SearchError [SearchEntry]
searchResult (Type.SearchResultDone (Type.LdapResult code _ _ _) :| xs)
| Type.Success <- code = Right (mapMaybe g xs)
| Type.AdminLimitExceeded <- code = Right (mapMaybe g xs)
| Type.SizeLimitExceeded <- code = Right (mapMaybe g xs)
| otherwise = Left (SearchErrorCode code)
where
g (Type.SearchResultEntry (Type.LdapDn (Type.LdapString dn))
(Type.PartialAttributeList ys)) =
Just (SearchEntry (Dn dn) (map h ys))
g _ = Nothing
h (Type.PartialAttribute (Type.AttributeDescription (Type.LdapString x))
y) = (Attr x, fmap j y)
j (Type.AttributeValue x) = x
searchResult res = Left (SearchInvalidResponse res)
let req = searchRequest base opts flt attributes in sendRequest l (searchResult req) req
searchRequest :: Dn -> Mod Search -> Filter -> [Attr] -> Request
searchRequest (Dn base) (Mod m) flt attributes =
@ -141,6 +98,23 @@ searchRequest (Dn base) (Mod m) flt attributes =
(Type.AssertionValue y)
b)
searchResult :: Request -> Response -> Either ResponseError [SearchEntry]
searchResult req (Type.SearchResultDone (Type.LdapResult code (Type.LdapDn (Type.LdapString dn'))
(Type.LdapString msg) _) :| xs)
| Type.Success <- code = Right (mapMaybe g xs)
| Type.AdminLimitExceeded <- code = Right (mapMaybe g xs)
| Type.SizeLimitExceeded <- code = Right (mapMaybe g xs)
| otherwise = Left (ResponseErrorCode req code (Dn dn') msg)
where
g (Type.SearchResultEntry (Type.LdapDn (Type.LdapString dn))
(Type.PartialAttributeList ys)) =
Just (SearchEntry (Dn dn) (map h ys))
g _ = Nothing
h (Type.PartialAttribute (Type.AttributeDescription (Type.LdapString x))
y) = (Attr x, fmap j y)
j (Type.AttributeValue x) = x
searchResult req res = Left (ResponseInvalid req res)
data Search = Search
{ _scope :: Type.Scope
, _derefAliases :: Type.DerefAliases
@ -175,9 +149,12 @@ derefAliases x = Mod (\y -> y { _derefAliases = x })
newtype Mod a = Mod (a -> a)
instance Semigroup (Mod a) where
Mod f <> Mod g = Mod (g . f)
instance Monoid (Mod a) where
mempty = Mod id
Mod f `mappend` Mod g = Mod (g . f)
mappend = (<>)
data Filter =
Not Filter

30
test/Ldap/Client/AddSpec.hs Normal file
View File

@ -0,0 +1,30 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module Ldap.Client.AddSpec (spec) where
import Data.Monoid ((<>))
import Test.Hspec
import Ldap.Client (Dn(..), Filter(..), Scope(..), Attr(..))
import qualified Ldap.Client as Ldap
import SpecHelper (locally , dns , vulpix)
spec :: Spec
spec = do
let go l f = Ldap.search l (Dn "o=localhost")
(Ldap.scope WholeSubtree <> Ldap.typesOnly True)
f
[]
it "adds an entry" $ do
res <- locally $ \l -> do
Ldap.add l vulpix
[ (Attr "cn", ["vulpix"])
, (Attr "evolution", ["0"])
, (Attr "type", ["fire"])
]
res <- go l (Attr "cn" := "vulpix")
dns res `shouldBe` [vulpix]
res `shouldBe` Right ()

17
test/Ldap/Client/BindSpec.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
module Ldap.Client.BindSpec (spec) where
import Test.Hspec
import Ldap.Client as Ldap
import Test.Hspec
import qualified Ldap.Asn1.Type as Ldap.Type
import Ldap.Client as Ldap
import SpecHelper (locally)
import SpecHelper (locally)
spec :: Spec
@ -17,7 +18,15 @@ spec = do
it "tries to bind as ‘admin’ with the wrong password, unsuccessfully" $ do
res <- locally $ \l -> do
Ldap.bind l (Dn "cn=admin") (Password "public")
res `shouldBe` Left (Ldap.BindError (Ldap.BindErrorCode Ldap.InvalidCredentials))
res `shouldBe` Left
(Ldap.ResponseError
(Ldap.ResponseErrorCode
(Ldap.Type.BindRequest 3
(Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=admin"))
(Ldap.Type.Simple "public"))
Ldap.InvalidCredentials
(Dn "cn=admin")
"Invalid Credentials"))
it "binds as ‘pikachu’" $ do
res <- locally $ \l -> do

17
test/Ldap/Client/CompareSpec.hs
View File

@ -1,8 +1,9 @@
{-# LANGUAGE OverloadedStrings #-}
module Ldap.Client.CompareSpec (spec) where
import Test.Hspec
import Ldap.Client as Ldap
import Test.Hspec
import qualified Ldap.Asn1.Type as Ldap.Type
import Ldap.Client as Ldap
import SpecHelper (locally, charmander, charizard)
@ -25,4 +26,14 @@ spec = do
res <- locally $ \l -> do
res <- Ldap.compare l (Dn "cn=nope") (Attr "type") "flying"
res `shouldBe` False
res `shouldBe` Left (CompareError (CompareErrorCode NoSuchObject))
res `shouldBe` Left
(Ldap.ResponseError
(Ldap.ResponseErrorCode
(Ldap.Type.CompareRequest
(Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=nope"))
(Ldap.Type.AttributeValueAssertion
(Ldap.Type.AttributeDescription (Ldap.Type.LdapString "type"))
(Ldap.Type.AssertionValue "flying")))
Ldap.NoSuchObject
(Dn "")
"No tree found for: cn=nope"))

38
test/Ldap/Client/DeleteSpec.hs Normal file
View File

@ -0,0 +1,38 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module Ldap.Client.DeleteSpec (spec) where
import Data.Monoid ((<>))
import Test.Hspec
import Ldap.Client (Dn(..), Filter(..), Scope(..), Attr(..))
import qualified Ldap.Client as Ldap
import qualified Ldap.Asn1.Type as Ldap.Type
import SpecHelper (locally, dns, pikachu, oddish)
spec :: Spec
spec = do
let go l f = Ldap.search l (Dn "o=localhost")
(Ldap.scope WholeSubtree <> Ldap.typesOnly True)
f
[]
it "deletes an entry" $ do
res <- locally $ \l -> do
Ldap.delete l pikachu
res <- go l (Attr "cn" := "pikachu")
dns res `shouldBe` []
res `shouldBe` Right ()
it "tries to delete an non-existing entry, unsuccessfully" $ do
res <- locally $ \l -> do
Ldap.delete l oddish
res `shouldBe` Left
(Ldap.ResponseError
(Ldap.ResponseErrorCode (Ldap.Type.DeleteRequest
(Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=oddish,o=localhost")))
Ldap.NoSuchObject
(Dn "o=localhost")
"cn=oddish,o=localhost"))

23
test/Ldap/Client/ModifySpec.hs
View File

@ -1,12 +1,13 @@
{-# LANGUAGE OverloadedStrings #-}
module Ldap.Client.ModifySpec (spec) where
import Data.ByteString (ByteString)
import Data.Monoid ((<>))
import Test.Hspec
import Ldap.Client as Ldap
import Data.ByteString (ByteString)
import Data.Monoid ((<>))
import Test.Hspec
import qualified Ldap.Asn1.Type as Ldap.Type
import Ldap.Client as Ldap
import SpecHelper (locally, charizard, pikachu)
import SpecHelper (locally, charizard, pikachu)
spec :: Spec
@ -32,7 +33,17 @@ spec = do
res <- locally $ \l -> do
Ldap.modify l pikachu [Attr "password" `Delete` []]
res `shouldBe` Left
(ModifyError (ModifyErrorCode UnwillingToPerform (Dn "o=localhost") "cannot delete password"))
(ResponseError
(ResponseErrorCode
(Ldap.Type.ModifyRequest (Ldap.Type.LdapDn (Ldap.Type.LdapString "cn=pikachu,o=localhost"))
[( Ldap.Type.Delete
, Ldap.Type.PartialAttribute
(Ldap.Type.AttributeDescription (Ldap.Type.LdapString "password"))
[]
)])
UnwillingToPerform
(Dn "o=localhost")
"cannot delete password"))
context "add" $ do
it "can feed ‘charizard’" $ do

25
test/Ldap/Client/SearchSpec.hs
View File

@ -2,11 +2,12 @@
{-# LANGUAGE OverloadedStrings #-}
module Ldap.Client.SearchSpec (spec) where
import Data.Monoid ((<>))
import Test.Hspec
import Ldap.Client as Ldap
import Data.Monoid ((<>))
import Test.Hspec
import Ldap.Client as Ldap
import qualified Ldap.Asn1.Type as Ldap.Type
import SpecHelper
import SpecHelper
( locally
, dns
, bulbasaur
@ -36,7 +37,21 @@ spec = do
res <- locally $ \l -> do
Ldap.bind l pikachu (Password "i-choose-you")
go l (Present (Attr "password"))
res `shouldBe` Left (Ldap.SearchError (Ldap.SearchErrorCode Ldap.InsufficientAccessRights))
let req = Ldap.Type.SearchRequest
(Ldap.Type.LdapDn (Ldap.Type.LdapString "o=localhost"))
Ldap.Type.WholeSubtree
Ldap.Type.NeverDerefAliases
0
0
True
(Ldap.Type.Present (Ldap.Type.AttributeDescription (Ldap.Type.LdapString "password")))
(Ldap.Type.AttributeSelection [])
res `shouldBe` Left
(Ldap.ResponseError
(Ldap.ResponseErrorCode req
Ldap.InsufficientAccessRights
(Dn "o=localhost")
"Insufficient Access Rights"))
it "‘present’ filter" $ do
res <- locally $ \l -> do

52
test/Ldap/ClientSpec.hs
View File

@ -1,52 +0,0 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module Ldap.ClientSpec (spec) where
import Data.Monoid ((<>))
import Test.Hspec
import Ldap.Client (Dn(..), Filter(..), Scope(..), Attr(..))
import qualified Ldap.Client as Ldap
import SpecHelper
( locally
, dns
, pikachu
, vulpix
, oddish
)
spec :: Spec
spec = do
let go l f = Ldap.search l (Dn "o=localhost")
(Ldap.scope WholeSubtree <> Ldap.typesOnly True)
f
[]
context "add" $ do
it "adds an entry" $ do
res <- locally $ \l -> do
Ldap.add l vulpix
[ (Attr "cn", ["vulpix"])
, (Attr "evolution", ["0"])
, (Attr "type", ["fire"])
]
res <- go l (Attr "cn" := "vulpix")
dns res `shouldBe` [vulpix]
res `shouldBe` Right ()
context "delete" $ do
it "deletes an entry" $ do
res <- locally $ \l -> do
Ldap.delete l pikachu
res <- go l (Attr "cn" := "pikachu")
dns res `shouldBe` []
res `shouldBe` Right ()
it "tries to delete an non-existing entry, unsuccessfully" $ do
res <- locally $ \l -> do
Ldap.delete l oddish
res `shouldBe` Left (Ldap.DeleteError (Ldap.DeleteErrorCode Ldap.NoSuchObject))