diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -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] diff --git a/ldap-client.cabal b/ldap-client.cabal --- a/ldap-client.cabal +++ b/ldap-client.cabal @@ -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: diff --git a/src/Ldap/Asn1/FromAsn1.hs b/src/Ldap/Asn1/FromAsn1.hs --- a/src/Ldap/Asn1/FromAsn1.hs +++ b/src/Ldap/Asn1/FromAsn1.hs @@ -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. diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs --- a/src/Ldap/Asn1/ToAsn1.hs +++ b/src/Ldap/Asn1/ToAsn1.hs @@ -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 diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs --- a/src/Ldap/Asn1/Type.hs +++ b/src/Ldap/Asn1/Type.hs @@ -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) diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs --- a/src/Ldap/Client.hs +++ b/src/Ldap/Client.hs @@ -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) diff --git a/src/Ldap/Client/Bind.hs b/src/Ldap/Client/Bind.hs --- a/src/Ldap/Client/Bind.hs +++ b/src/Ldap/Client/Bind.hs @@ -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 + diff --git a/src/Ldap/Client/Extended.hs b/src/Ldap/Client/Extended.hs --- a/src/Ldap/Client/Extended.hs +++ b/src/Ldap/Client/Extended.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- | 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" diff --git a/src/Ldap/Client/Internal.hs b/src/Ldap/Client/Internal.hs --- a/src/Ldap/Client/Internal.hs +++ b/src/Ldap/Client/Internal.hs @@ -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 diff --git a/src/Ldap/Client/Modify.hs b/src/Ldap/Client/Modify.hs --- a/src/Ldap/Client/Modify.hs +++ b/src/Ldap/Client/Modify.hs @@ -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. diff --git a/src/Ldap/Client/Search.hs b/src/Ldap/Client/Search.hs --- a/src/Ldap/Client/Search.hs +++ b/src/Ldap/Client/Search.hs @@ -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. diff --git a/test/Ldap/Client/BindSpec.hs b/test/Ldap/Client/BindSpec.hs --- a/test/Ldap/Client/BindSpec.hs +++ b/test/Ldap/Client/BindSpec.hs @@ -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 diff --git a/test/Ldap/Client/CompareSpec.hs b/test/Ldap/Client/CompareSpec.hs --- a/test/Ldap/Client/CompareSpec.hs +++ b/test/Ldap/Client/CompareSpec.hs @@ -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 diff --git a/test/Ldap/Client/SearchSpec.hs b/test/Ldap/Client/SearchSpec.hs --- a/test/Ldap/Client/SearchSpec.hs +++ b/test/Ldap/Client/SearchSpec.hs @@ -47,7 +47,7 @@ (Ldap.ResponseErrorCode req Ldap.InsufficientAccessRights (Dn "o=localhost") - "Insufficient Access Rights")) + "InsufficientAccessRightsError")) it "‘present’ filter" $ do res <- locally $ \l -> do diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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