ldap-client 0.1.0 → 0.2.0

raw patch · 17 files changed

+181/−73 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +13/−0
• LICENSE +1/−1
• README.markdown +1/−0
• ldap-client.cabal +14/−2
• src/Ldap/Asn1/FromAsn1.hs +2/−2
• src/Ldap/Asn1/ToAsn1.hs +12/−1
• src/Ldap/Asn1/Type.hs +19/−12
• src/Ldap/Client.hs +30/−27
• src/Ldap/Client/Bind.hs +39/−0
• src/Ldap/Client/Extended.hs +17/−4
• src/Ldap/Client/Internal.hs +9/−10
• src/Ldap/Client/Modify.hs +3/−3
• src/Ldap/Client/Search.hs +1/−1
• test/Ldap/Client/BindSpec.hs +1/−1
• test/Ldap/Client/CompareSpec.hs +1/−1
• test/Ldap/Client/SearchSpec.hs +1/−1
• test/SpecHelper.hs +17/−7

@@ -0,0 +1,13 @@+next+====++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)

@@ -1,4 +1,4 @@-Copyright (c) 2015, Matvey Aksenov+Copyright (c) 2015-2017, Matvey Aksenov All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,5 +1,6 @@ ldap-client ===========+[![Hackage](https://budueba.com/hackage/ldap-client)](https://hackage.haskell.org/package/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]

@@ -1,5 +1,5 @@ name:                ldap-client-version:             0.1.0+version:             0.2.0 synopsis:            Pure Haskell LDAP Client Library description:   Pure Haskell LDAP client library implementing (the parts of) RFC 4511.@@ -16,15 +16,22 @@     GHC == 7.6.3   , GHC == 7.8.4   , GHC == 7.10.1+  , GHC == 8.0.1 extra-source-files:   README.markdown+  CHANGELOG.markdown  source-repository head   type:     git   location: git@github.com:supki/ldap-client-  tag:      0.1.0+  tag:      0.2.0  library+  ghc-options:+    -Wall+    -fwarn-incomplete-uni-patterns+    -fwarn-incomplete-record-updates+    -fwarn-unrecognised-pragmas   default-language:     Haskell2010   hs-source-dirs:@@ -56,6 +63,11 @@     , text  test-suite spec+  ghc-options:+    -Wall+    -fwarn-incomplete-uni-patterns+    -fwarn-incomplete-record-updates+    -fwarn-unrecognised-pragmas   default-language:     Haskell2010   type:

@@ -19,8 +19,8 @@  import           Ldap.Asn1.Type -{-# ANN module "HLint: ignore Use const" #-}-{-# ANN module "HLint: ignore Avoid lambda" #-}+{-# ANN module ("HLint: ignore Use const" :: String) #-}+{-# ANN module ("HLint: ignore Avoid lambda" :: String) #-}   -- | Convert a part of ASN.1 stream to a LDAP type returning the remainder of the stream.

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | This module contains convertions from LDAP types to ASN.1. -- -- Various hacks are employed because "asn1-encoding" only encodes to DER, but@@ -309,12 +310,22 @@ @ AuthenticationChoice ::= CHOICE {      simple                  [0] OCTET STRING,+     sasl                    [3] SaslCredentials,      ...  }+++SaslCredentials ::= SEQUENCE {+     mechanism               LDAPString,+     credentials             OCTET STRING OPTIONAL } @ -} instance ToAsn1 AuthenticationChoice where   toAsn1 (Simple s) = other Asn1.Context 0 s-+  toAsn1 (Sasl External c) =+    context 3 (fold+      [ toAsn1 (LdapString "EXTERNAL")+      , maybe mempty (toAsn1 . LdapString) c+      ]) {- | @ AttributeSelection ::= SEQUENCE OF selector LDAPString

@@ -37,7 +37,7 @@     BindResponse !LdapResult !(Maybe ByteString)   | SearchResultEntry !LdapDn !PartialAttributeList   | SearchResultReference !(NonEmpty Uri)-  | SearchResultDone !(LdapResult)+  | SearchResultDone !LdapResult   | ModifyResponse !LdapResult   | AddResponse !LdapResult   | DeleteResponse !LdapResult@@ -48,9 +48,16 @@     deriving (Show, Eq)  -- | Not really a choice until SASL is supported.-newtype AuthenticationChoice = Simple ByteString+data AuthenticationChoice =+    Simple !ByteString+  | Sasl !SaslMechanism !(Maybe Text)     deriving (Show, Eq) +-- | SASL Mechanism, for now only SASL EXTERNAL is supported+data SaslMechanism =+    External+    deriving (Show, Eq)+ -- | Scope of the search to be performed. data Scope =     BaseObject   -- ^ Constrained to the entry named by baseObject.@@ -70,16 +77,16 @@  -- | Conditions that must be fulfilled in order for the Search to match a given entry. data Filter =-    And !(NonEmpty Filter)                 -- ^ All filters evaluate to @TRUE@-  | Or !(NonEmpty Filter)                  -- ^ Any filter evaluates to @TRUE@-  | Not Filter                             -- ^ Filter evaluates to @FALSE@-  | EqualityMatch AttributeValueAssertion  -- ^ @EQUALITY@ rule returns @TRUE@-  | Substrings SubstringFilter             -- ^ @SUBSTR@ rule returns @TRUE@-  | GreaterOrEqual AttributeValueAssertion -- ^ @ORDERING@ rule returns @FALSE@-  | LessOrEqual AttributeValueAssertion    -- ^ @ORDERING@ or @EQUALITY@ rule returns @TRUE@-  | Present AttributeDescription           -- ^ Attribute is present in the entry-  | ApproxMatch AttributeValueAssertion    -- ^ Same as 'EqualityMatch' for most servers-  | ExtensibleMatch MatchingRuleAssertion+    And !(NonEmpty Filter)                  -- ^ All filters evaluate to @TRUE@+  | Or !(NonEmpty Filter)                   -- ^ Any filter evaluates to @TRUE@+  | Not !Filter                             -- ^ Filter evaluates to @FALSE@+  | EqualityMatch !AttributeValueAssertion  -- ^ @EQUALITY@ rule returns @TRUE@+  | Substrings !SubstringFilter             -- ^ @SUBSTR@ rule returns @TRUE@+  | GreaterOrEqual !AttributeValueAssertion -- ^ @ORDERING@ rule returns @FALSE@+  | LessOrEqual !AttributeValueAssertion    -- ^ @ORDERING@ or @EQUALITY@ rule returns @TRUE@+  | Present !AttributeDescription           -- ^ Attribute is present in the entry+  | ApproxMatch !AttributeValueAssertion    -- ^ Same as 'EqualityMatch' for most servers+  | ExtensibleMatch !MatchingRuleAssertion     deriving (Show, Eq)  data SubstringFilter = SubstringFilter !AttributeDescription !(NonEmpty Substring)

@@ -10,6 +10,8 @@ module Ldap.Client   ( with   , Host(..)+  , defaultTlsSettings+  , insecureTlsSettings   , PortNumber   , Ldap   , LdapError(..)@@ -18,6 +20,7 @@     -- * Bind   , Password(..)   , bind+  , externalBind     -- * Search   , search   , SearchEntry(..)@@ -75,7 +78,6 @@ import           Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.Map.Strict as Map import           Data.Monoid (Endo(appEndo))-import           Data.String (fromString) import           Data.Text (Text) #if __GLASGOW_HASKELL__ < 710 import           Data.Traversable (traverse)@@ -90,7 +92,7 @@ import           Ldap.Asn1.FromAsn1 (FromAsn1, parseAsn1) import qualified Ldap.Asn1.Type as Type import           Ldap.Client.Internal-import           Ldap.Client.Bind (Password(..), bind)+import           Ldap.Client.Bind (Password(..), bind, externalBind) import           Ldap.Client.Search   ( search   , Search@@ -107,9 +109,9 @@ import           Ldap.Client.Add (add) import           Ldap.Client.Delete (delete) import           Ldap.Client.Compare (compare)-import           Ldap.Client.Extended (Oid(..), extended)+import           Ldap.Client.Extended (Oid(..), extended, noticeOfDisconnectionOid) -{-# ANN module "HLint: ignore Use first" #-}+{-# ANN module ("HLint: ignore Use first" :: String) #-}   newLdap :: IO Ldap@@ -118,10 +120,10 @@  -- | 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.+    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 (Show, Eq)  newtype WrappedIOError = WrappedIOError IOError@@ -129,7 +131,7 @@  instance Exception WrappedIOError -data Disconnect = Disconnect Type.ResultCode Dn Text+data Disconnect = Disconnect !Type.ResultCode !Dn !Text     deriving (Show, Eq, Typeable)  instance Exception Disconnect@@ -160,26 +162,30 @@   params = Conn.ConnectionParams     { Conn.connectionHostname =         case host of-          Plain    h -> h-          Secure   h -> h-          Insecure h -> h+          Plain h -> h+          Tls   h _ -> h     , Conn.connectionPort = port     , Conn.connectionUseSecure =         case host of           Plain  _ -> Nothing-          Secure _ -> Just Conn.TLSSettingsSimple-            { Conn.settingDisableCertificateValidation = False-            , Conn.settingDisableSession = False-            , Conn.settingUseServerName = False-            }-          Insecure _ -> Just Conn.TLSSettingsSimple-            { Conn.settingDisableCertificateValidation = True-            , Conn.settingDisableSession = False-            , Conn.settingUseServerName = False-            }+          Tls _ settings -> pure settings     , Conn.connectionUseSocks = Nothing     } +defaultTlsSettings :: Conn.TLSSettings+defaultTlsSettings = Conn.TLSSettingsSimple+  { Conn.settingDisableCertificateValidation = False+  , Conn.settingDisableSession = False+  , Conn.settingUseServerName = False+  }++insecureTlsSettings :: Conn.TLSSettings+insecureTlsSettings = Conn.TLSSettingsSimple+  { Conn.settingDisableCertificateValidation = True+  , Conn.settingDisableSession = False+  , Conn.settingUseServerName = False+  }+ input :: FromAsn1 a => TQueue a -> Connection -> IO b input inq conn = wrap . flip fix [] $ \loop chunks -> do   chunk <- Conn.connectionGet conn 8192@@ -187,7 +193,7 @@     0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing)     _ -> do       let chunks' = chunk : chunks-      case Asn1.decodeASN1 Asn1.DER (ByteString.Lazy.fromChunks (reverse chunks')) of+      case Asn1.decodeASN1 Asn1.BER (ByteString.Lazy.fromChunks (reverse chunks')) of         Left  Asn1.ParsingPartial                    -> loop chunks'         Left  e    -> throwIO e@@ -255,12 +261,9 @@                      req =     case moid of       Just (Type.LdapOid oid)-        | oid == noticeOfDisconnection -> throwSTM (Disconnect code (Dn dn) reason)+        | Oid oid == noticeOfDisconnectionOid -> throwSTM (Disconnect code (Dn dn) reason)       _ -> return req   probablyDisconnect mid op req = done mid op req--  noticeOfDisconnection :: Text-  noticeOfDisconnection = fromString "1.3.6.1.4.1.1466.20036"  wrap :: IO a -> IO a wrap m = m `catch` (throwIO . WrappedIOError)

@@ -17,6 +17,10 @@   , bindEither   , bindAsync   , bindAsyncSTM+  , externalBind+  , externalBindEither+  , externalBindAsync+  , externalBindAsyncSTM   , Async   , wait   , waitSTM@@ -24,6 +28,7 @@  import           Control.Monad.STM (STM, atomically) import           Data.ByteString (ByteString)+import           Data.Text (Text) import           Data.List.NonEmpty (NonEmpty((:|)))  import qualified Ldap.Asn1.Type as Type@@ -73,3 +78,37 @@   | Type.Success <- code = Right ()   | otherwise = Left (ResponseErrorCode req code (Dn dn) msg) bindResult req res = Left (ResponseInvalid req res)++-- | Perform a SASL EXTERNAL Bind operation synchronously. Raises 'ResponseError' on failures.+externalBind :: Ldap -> Dn -> Maybe Text -> IO ()+externalBind l username mCredentials =+  raise =<< externalBindEither l username mCredentials++-- | Perform a SASL EXTERNAL Bind operation synchronously. Returns @Left e@ where+-- @e@ is a 'ResponseError' on failures.+externalBindEither :: Ldap -> Dn -> Maybe Text -> IO (Either ResponseError ())+externalBindEither l username mCredentials =+  wait =<< externalBindAsync l username mCredentials++-- | Perform the SASL EXTERNAL Bind operation asynchronously. Call 'Ldap.Client.wait' to wait+-- for its completion.+externalBindAsync :: Ldap -> Dn -> Maybe Text -> IO (Async ())+externalBindAsync l username mCredentials =+  atomically (externalBindAsyncSTM l username mCredentials)++-- | Perform the SASL EXTERNAL Bind operation asynchronously.+--+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the+-- same transaction you've performed it in.+externalBindAsyncSTM :: Ldap -> Dn -> Maybe Text -> STM (Async ())+externalBindAsyncSTM l username mCredentials =+  let req = externalBindRequest username mCredentials in sendRequest l (bindResult req) req++externalBindRequest :: Dn -> Maybe Text -> Request+externalBindRequest (Dn username) mCredentials =+  Type.BindRequest ldapVersion+                   (Type.LdapDn (Type.LdapString username))+                   (Type.Sasl Type.External mCredentials)+ where+  ldapVersion = 3+

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | <https://tools.ietf.org/html/rfc4511#section-4.12 Extended> operation. -- -- This operation comes in four flavours:@@ -18,11 +19,14 @@   , extendedEither   , extendedAsync   , extendedAsyncSTM-    -- ** StartTLS Operation+    -- * StartTLS Operation   , startTls   , startTlsEither   , startTlsAsync   , startTlsAsyncSTM+    -- * OIDs+  , noticeOfDisconnectionOid+  , startTlsOid   , Async   , wait   , waitSTM@@ -32,7 +36,7 @@ import           Control.Monad.STM (STM, atomically) import           Data.ByteString (ByteString) import           Data.List.NonEmpty (NonEmpty((:|)))-import           Data.String (fromString)+import           Data.String (IsString(fromString)) import           Data.Text (Text)  import qualified Ldap.Asn1.Type as Type@@ -43,6 +47,10 @@ newtype Oid = Oid Text     deriving (Show, Eq) +instance IsString Oid where+  fromString =+    Oid . fromString+ -- | Perform the Extended operation synchronously. Raises 'ResponseError' on failures. extended :: Ldap -> Oid -> Maybe ByteString -> IO () extended l oid mv =@@ -99,5 +107,10 @@ -- | An example of @Extended Operation@, cf. 'extendedAsyncSTM'. startTlsAsyncSTM :: Ldap -> STM (Async ()) startTlsAsyncSTM l =-  extendedAsyncSTM l (Oid (fromString "1.3.6.1.4.1.1466.20037"))-                     Nothing+  extendedAsyncSTM l startTlsOid Nothing++noticeOfDisconnectionOid :: Oid+noticeOfDisconnectionOid = "1.3.6.1.4.1.1466.20036"++startTlsOid :: Oid+startTlsOid = "1.3.6.1.4.1.1466.20037"

@@ -36,30 +36,29 @@ import           Data.Text (Text) import           Data.Typeable (Typeable) import           Network (PortNumber)+import           Network.Connection (TLSSettings)  import qualified Ldap.Asn1.Type as Type   -- | LDAP host. data Host =-    Plain String    -- ^ Plain LDAP. Do not use!-  | Insecure String -- ^ LDAP over TLS without the certificate validity check.-                    --   Only use for testing!-  | Secure String   -- ^ LDAP over TLS. Use!-    deriving (Show, Eq, Ord)+    Plain String           -- ^ Plain LDAP.+  | Tls String TLSSettings -- ^ LDAP over TLS.+    deriving (Show)  -- | A token. All functions that interact with the Directory require one.-data Ldap = Ldap+newtype Ldap = Ldap   { client  :: TQueue ClientMessage   } deriving (Eq) -data ClientMessage = New Request (TMVar (NonEmpty Type.ProtocolServerOp))+data ClientMessage = New !Request !(TMVar (NonEmpty Type.ProtocolServerOp)) type Request = Type.ProtocolClientOp type InMessage = Type.ProtocolServerOp type Response = NonEmpty InMessage  -- | Asynchronous LDAP operation. Use 'wait' or 'waitSTM' to wait for its completion.-data Async a = Async (STM (Either ResponseError a))+newtype Async a = Async (STM (Either ResponseError a))  instance Functor Async where   fmap f (Async stm) = Async (fmap (fmap f) stm)@@ -70,8 +69,8 @@  -- | Response indicates a failed operation. data ResponseError =-    ResponseInvalid Request Response -- ^ LDAP server did not follow the protocol, so @ldap-client@ couldn't make sense of the response.-  | ResponseErrorCode Request Type.ResultCode Dn Text -- ^ The response contains a result code indicating failure and an error message.+    ResponseInvalid !Request !Response -- ^ LDAP server did not follow the protocol, so @ldap-client@ couldn't make sense of the response.+  | ResponseErrorCode !Request !Type.ResultCode !Dn !Text -- ^ The response contains a result code indicating failure and an error message.     deriving (Show, Eq, Typeable)  instance Exception ResponseError

@@ -40,9 +40,9 @@  -- | Type of modification being performed. data Operation =-    Delete Attr [AttrValue] -- ^ Delete values from the attribute. Deletes the attribute if the list is empty or all current values are listed.-  | Add Attr [AttrValue] -- ^ Add values to the attribute, creating it if necessary.-  | Replace Attr [AttrValue] -- ^ Replace all existing values of the attribute with the new list. Deletes the attribute if the list is empty.+    Delete !Attr ![AttrValue]  -- ^ Delete values from the attribute. Deletes the attribute if the list is empty or all current values are listed.+  | Add !Attr ![AttrValue]     -- ^ Add values to the attribute, creating it if necessary.+  | Replace !Attr ![AttrValue] -- ^ Replace all existing values of the attribute with the new list. Deletes the attribute if the list is empty.     deriving (Show, Eq)  -- | Perform the Modify operation synchronously. Raises 'ResponseError' on failures.

@@ -215,7 +215,7 @@   | !Attr :~= !AttrValue    -- ^ Attribute's value approximately matches the assertion   | !Attr :=* !(Maybe AttrValue, [AttrValue], Maybe AttrValue)                             -- ^ Glob match-  | (Maybe Attr, Maybe Attr, Bool) ::= AttrValue+  | !(Maybe Attr, Maybe Attr, Bool) ::= !AttrValue                             -- ^ Extensible match  -- | Entry found during the Search.

@@ -30,7 +30,7 @@                                  (Ldap.Type.Simple "public"))           Ldap.InvalidCredentials           (Dn "cn=admin")-          "Invalid Credentials"))+          "InvalidCredentialsError"))    it "binds as ‘pikachu’" $ do     res <- locally $ \l -> do

@@ -16,7 +16,7 @@       res `shouldBe` True     res `shouldBe` Right () -  it "compares and looses" $ do+  it "compares and loses" $ do     res <- locally $ \l -> do       res <- Ldap.compare l charmander (Attr "type") "flying"       res `shouldBe` False

@@ -47,7 +47,7 @@         (Ldap.ResponseErrorCode req                                 Ldap.InsufficientAccessRights                                 (Dn "o=localhost")-                                "Insufficient Access Rights"))+                                "InsufficientAccessRightsError"))    it "‘present’ filter" $ do     res <- locally $ \l -> do

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module SpecHelper   ( locally@@ -22,8 +23,15 @@   , oddish   ) where +#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$))+#endif+import Control.Monad (forever)+import Control.Concurrent (forkIO) import Control.Exception (bracket)+import System.Environment (getEnvironment) import System.IO (hGetLine)+import System.IO.Error (tryIOError) import System.Process (runInteractiveProcess, terminateProcess, waitForProcess)  import Ldap.Client as Ldap@@ -31,19 +39,21 @@  locally :: (Ldap -> IO a) -> IO (Either LdapError a) locally f =-  bracket (do (_, out, _, h) <- runInteractiveProcess "./test/ldap.js" [] Nothing-                                  (Just [ ("PORT", show port)-                                        , ("SSL_CERT", "./ssl/cert.pem")-                                        , ("SSL_KEY", "./ssl/key.pem")-                                        ])-              hGetLine out+  bracket (do env <- getEnvironment+              (_, out, _, h) <- runInteractiveProcess "./test/ldap.js" [] Nothing+                                  (Just (("PORT", show (port :: Int)) :+                                         ("SSL_CERT", "./ssl/cert.pem") :+                                         ("SSL_KEY", "./ssl/key.pem") :+                                         env))+              _ <- hGetLine out+              _ <- forkIO (() <$ tryIOError (forever (hGetLine out >>= putStrLn)))               return h)           (\h -> do terminateProcess h                     waitForProcess h)           (\_ -> Ldap.with localhost port f)  localhost :: Host-localhost = Insecure "localhost"+localhost = Tls "localhost" insecureTlsSettings  port :: Num a => a port = 24620