From fcaf02b044202efd00545ffa403f7f3c633f45d5 Mon Sep 17 00:00:00 2001 From: Matvey Aksenov Date: Wed, 22 Apr 2015 21:36:24 +0000 Subject: [PATCH] Homegrown ASN.1 encoding. The main purpose of this is to allow `ToAsn1` instances to match the spec closer. It also lets us implement Abandon operation fairly easily (see the subsequent commit). --- README.markdown | 3 +- ldap-client.cabal | 14 + src/Ldap/Asn1/ToAsn1.hs | 596 +++++++++++---------------------- src/Ldap/Client.hs | 11 +- src/Ldap/Client/Asn1/ToAsn1.hs | 402 ++++++++++++++++++++++ test/Doctests.hs | 7 + test/Ldap/Client/SearchSpec.hs | 2 +- 7 files changed, 623 insertions(+), 412 deletions(-) create mode 100644 src/Ldap/Client/Asn1/ToAsn1.hs create mode 100644 test/Doctests.hs diff --git a/README.markdown b/README.markdown index 338d85d..8b91d37 100644 --- a/README.markdown +++ b/README.markdown @@ -11,7 +11,7 @@ Bind Operation | [4.2][4.2] | ✔ Unbind Operation | [4.3][4.3] | ✔ Unsolicited Notification | [4.4][4.4] | ✔ Notice of Disconnection | [4.4.1][4.4.1] | ✔ -Search Operation | [4.5][4.5] | ✔\* +Search Operation | [4.5][4.5] | ✔ Modify Operation | [4.6][4.6] | ✔ Add Operation | [4.7][4.7] | ✔ Delete Operation | [4.8][4.8] | ✔ @@ -23,7 +23,6 @@ IntermediateResponse Message | [4.13][4.13] | ✔ StartTLS Operation | [4.14][4.14] | ✔† LDAP over TLS | - | ✔ -\* The `:dn` thing is unsupported in Extensible matches † Only serves as an example of Extended Operation. It's useless for all practical purposes as it does not actually enable TLS. In other words, use LDAP over TLS instead. [rfc4511]: https://tools.ietf.org/html/rfc4511 diff --git a/ldap-client.cabal b/ldap-client.cabal index 8c1e0bc..2527a0e 100644 --- a/ldap-client.cabal +++ b/ldap-client.cabal @@ -35,6 +35,7 @@ library Ldap.Asn1.Type Ldap.Client Ldap.Client.Add + Ldap.Client.Asn1.ToAsn1 Ldap.Client.Bind Ldap.Client.Compare Ldap.Client.Delete @@ -81,3 +82,16 @@ test-suite spec , ldap-client , process , semigroups + +test-suite doctests + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + Doctests.hs + build-depends: + base >= 4.6 && < 5 + , doctest diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs index 5987294..47dafcd 100644 --- a/src/Ldap/Asn1/ToAsn1.hs +++ b/src/Ldap/Asn1/ToAsn1.hs @@ -1,429 +1,217 @@ --- | This module contains convertions from LDAP types to ASN.1. --- --- Various hacks are employed because "asn1-encoding" only encodes to DER, but --- LDAP demands BER-encoding. So, when a definition looks suspiciously different --- from the spec in the comment, that's why. I hope all that will be fixed --- eventually. +{-# LANGUAGE CPP #-} module Ldap.Asn1.ToAsn1 - ( ToAsn1(toAsn1) + ( Ber + , encode + , bool + , int32 + , enum + , octetstring + , null + , sequence + , set + , tagged + , Mod + , Tag + , application + , context + , tag ) where -import Data.ASN1.Types (ASN1, ASN1Class, ASN1Tag, ASN1ConstructionType) -import qualified Data.ASN1.Types as Asn1 -import Data.ByteString (ByteString) -import Data.Foldable (fold, foldMap) -import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (maybe) -import Data.Monoid (Endo(Endo), (<>), mempty) -import qualified Data.Text.Encoding as Text -import Prelude (Integer, (.), fromIntegral) +import Data.Bits (Bits((.&.), (.|.), shiftR)) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as ByteString.Lazy +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy.Builder (Builder) +import qualified Data.ByteString.Lazy.Builder as Builder +import Data.Int (Int64, Int32) +import Data.List.NonEmpty (NonEmpty((:|))) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (Monoid(..)) +#endif +import Data.Semigroup (Semigroup(..)) +import Data.Word (Word8) +import Prelude hiding (null, sequence) -import Ldap.Asn1.Type +-- $setup +-- >>> :set -XOverloadedStrings +data Ber = Ber !Int64 !Builder --- | Convert a LDAP type to ASN.1. +instance Semigroup Ber where + Ber l b <> Ber l' b' = Ber (l + l') (b <> b') + +instance Monoid Ber where + mempty = Ber 0 mempty + mappend = (<>) + +encode :: Ber -> ByteString +encode (Ber _ b) = Builder.toLazyByteString b + +-- | Encoding of a boolean value. -- --- When it's relevant, instances include the part of RFC describing the encoding. -class ToAsn1 a where - toAsn1 :: a -> Endo [ASN1] +-- >>> encode (bool mempty True) +-- "\SOH\SOH\255" +-- +-- >>> encode (bool mempty False) +-- "\SOH\SOH\NUL" +bool :: Mod -> Bool -> Ber +bool f b = fromBytes ((t .|. classBit f) : ts ++ [0x01, if b then 0xFF else 0x00]) + where + t :| ts = tagBits (tag 0x01 <> f) -{- | -@ -LDAPMessage ::= SEQUENCE { - messageID MessageID, - protocolOp CHOICE { - bindRequest BindRequest, - bindResponse BindResponse, - unbindRequest UnbindRequest, - searchRequest SearchRequest, - searchResEntry SearchResultEntry, - searchResDone SearchResultDone, - searchResRef SearchResultReference, - addRequest AddRequest, - addResponse AddResponse, - ... }, - controls [0] Controls OPTIONAL } -@ --} -instance ToAsn1 op => ToAsn1 (LdapMessage op) where - toAsn1 (LdapMessage i op mc) = - sequence (toAsn1 i <> toAsn1 op <> maybe mempty (context 0 . toAsn1) mc) - -{- | -@ -MessageID ::= INTEGER (0 .. maxInt) -@ --} -instance ToAsn1 Id where - toAsn1 (Id i) = single (Asn1.IntVal (fromIntegral i)) - -{- | -@ -LDAPString ::= OCTET STRING -- UTF-8 encoded -@ --} -instance ToAsn1 LdapString where - toAsn1 (LdapString s) = single (Asn1.OctetString (Text.encodeUtf8 s)) - -{- | -@ -LDAPOID ::= OCTET STRING -- Constrained to \ -@ --} -instance ToAsn1 LdapOid where - toAsn1 (LdapOid s) = single (Asn1.OctetString (Text.encodeUtf8 s)) - -{- | -@ -LDAPDN ::= LDAPString -- Constrained to \ -@ --} -instance ToAsn1 LdapDn where - toAsn1 (LdapDn s) = toAsn1 s - -{- | -@ -RelativeLDAPDN ::= LDAPString -- Constrained to \ -@ --} -instance ToAsn1 RelativeLdapDn where - toAsn1 (RelativeLdapDn s) = toAsn1 s - -{- | -@ -AttributeDescription ::= LDAPString -@ --} -instance ToAsn1 AttributeDescription where - toAsn1 (AttributeDescription s) = toAsn1 s - -{- | -@ -AttributeValue ::= OCTET STRING -@ --} -instance ToAsn1 AttributeValue where - toAsn1 (AttributeValue s) = single (Asn1.OctetString s) - -{- | -@ -AttributeValueAssertion ::= SEQUENCE { - attributeDesc AttributeDescription, - assertionValue AssertionValue } -@ --} -instance ToAsn1 AttributeValueAssertion where - toAsn1 (AttributeValueAssertion d v) = toAsn1 d <> toAsn1 v - -{- | -@ -AssertionValue ::= OCTET STRING -@ --} -instance ToAsn1 AssertionValue where - toAsn1 (AssertionValue s) = single (Asn1.OctetString s) - - -{- | -@ -PartialAttribute ::= SEQUENCE { - type AttributeDescription, - vals SET OF value AttributeValue } -@ --} -instance ToAsn1 PartialAttribute where - toAsn1 (PartialAttribute d xs) = sequence (toAsn1 d <> set (toAsn1 xs)) - -{- | -@ -Attribute ::= PartialAttribute(WITH COMPONENTS { - ..., - vals (SIZE(1..MAX))}) -@ --} -instance ToAsn1 Attribute where - toAsn1 (Attribute d xs) = sequence (toAsn1 d <> set (toAsn1 xs)) - -{- | -@ -MatchingRuleId ::= LDAPString -@ --} -instance ToAsn1 MatchingRuleId where - toAsn1 (MatchingRuleId s) = toAsn1 s - -{- | -@ -Controls ::= SEQUENCE OF control Control -@ --} -instance ToAsn1 Controls where - toAsn1 (Controls cs) = sequence (toAsn1 cs) - -{- | -@ -Control ::= SEQUENCE { - controlType LDAPOID, - criticality BOOLEAN DEFAULT FALSE, - controlValue OCTET STRING OPTIONAL } -@ --} -instance ToAsn1 Control where - toAsn1 (Control t c v) = - sequence (fold - [ toAsn1 t - , single (Asn1.Boolean c) - , maybe mempty (single . Asn1.OctetString) v - ]) - -{- | -@ -BindRequest ::= [APPLICATION 0] SEQUENCE { - version INTEGER (1 .. 127), - name LDAPDN, - authentication AuthenticationChoice } -@ - -@ -UnbindRequest ::= [APPLICATION 2] NULL -@ - -@ -SearchRequest ::= [APPLICATION 3] SEQUENCE { - baseObject LDAPDN, - scope ENUMERATED { - baseObject (0), - singleLevel (1), - wholeSubtree (2), - ... }, - derefAliases ENUMERATED { - neverDerefAliases (0), - derefInSearching (1), - derefFindingBaseObj (2), - derefAlways (3) }, - sizeLimit INTEGER (0 .. maxInt), - timeLimit INTEGER (0 .. maxInt), - typesOnly BOOLEAN, - filter Filter, - attributes AttributeSelection } -@ - -@ -ModifyRequest ::= [APPLICATION 6] SEQUENCE { - object LDAPDN, - changes SEQUENCE OF change SEQUENCE { - operation ENUMERATED { - add (0), - delete (1), - replace (2), - ... }, - modification PartialAttribute } } -@ - -@ -AddRequest ::= [APPLICATION 8] SEQUENCE { - entry LDAPDN, - attributes AttributeList } -@ - -@ -DelRequest ::= [APPLICATION 10] LDAPDN -@ - -@ -ModifyDNRequest ::= [APPLICATION 12] SEQUENCE { - entry LDAPDN, - newrdn RelativeLDAPDN, - deleteoldrdn BOOLEAN, - newSuperior [0] LDAPDN OPTIONAL } -@ - -@ -CompareRequest ::= [APPLICATION 14] SEQUENCE { - entry LDAPDN, - ava AttributeValueAssertion } -@ - -@ -ExtendedRequest ::= [APPLICATION 23] SEQUENCE { - requestName [0] LDAPOID, - requestValue [1] OCTET STRING OPTIONAL } -@ --} -instance ToAsn1 ProtocolClientOp where - toAsn1 (BindRequest v n a) = - application 0 (single (Asn1.IntVal (fromIntegral v)) <> toAsn1 n <> toAsn1 a) - toAsn1 UnbindRequest = - other Asn1.Application 2 mempty - toAsn1 (SearchRequest bo s da sl tl to f a) = - application 3 (fold - [ toAsn1 bo - , enum s' - , enum da' - , single (Asn1.IntVal (fromIntegral sl)) - , single (Asn1.IntVal (fromIntegral tl)) - , single (Asn1.Boolean to) - , toAsn1 f - , toAsn1 a - ]) +-- | Encoding of an integer value. +-- +-- >>> encode (int32 mempty 0) +-- "\STX\SOH\NUL" +-- +-- >>> encode (int32 mempty 127) +-- "\STX\SOH\DEL" +-- +-- >>> encode (int32 mempty 128) +-- "\STX\STX\NUL\128" +int32 :: Mod -> Int32 -> Ber +int32 f n = fromBytes ((t .|. classBit f) : ts ++ fromIntegral (length bytes) : bytes) + where + t :| ts = tagBits (tag 0x02 <> f) + bytes + | n .&. 0x80 == 0x80 = 0x00 : reverse (go n) + | otherwise = reverse (go n) where - s' = case s of - BaseObject -> 0 - SingleLevel -> 1 - WholeSubtree -> 2 - da' = case da of - NeverDerefAliases -> 0 - DerefInSearching -> 1 - DerefFindingBaseObject -> 2 - DerefAlways -> 3 - toAsn1 (ModifyRequest dn xs) = - application 6 (fold - [ toAsn1 dn - , sequence (foldMap (\(op, pa) -> sequence (enum (case op of - Add -> 0 - Delete -> 1 - Replace -> 2) <> toAsn1 pa)) xs) - ]) - toAsn1 (AddRequest dn as) = - application 8 (toAsn1 dn <> toAsn1 as) - toAsn1 (DeleteRequest (LdapDn (LdapString dn))) = - other Asn1.Application 10 (Text.encodeUtf8 dn) - toAsn1 (ModifyDnRequest dn rdn del new) = - application 12 (fold - [ toAsn1 dn - , toAsn1 rdn - , single (Asn1.Boolean del) - , maybe mempty - (\(LdapDn (LdapString dn')) -> other Asn1.Context 0 (Text.encodeUtf8 dn')) - new - ]) - toAsn1 (CompareRequest dn av) = - application 14 (toAsn1 dn <> sequence (toAsn1 av)) - toAsn1 (ExtendedRequest (LdapOid oid) mv) = - application 23 (fold - [ other Asn1.Context 0 (Text.encodeUtf8 oid) - , maybe mempty (other Asn1.Context 1) mv - ]) + go i + | i <= 0xff = return (fromIntegral i) + | otherwise = (fromIntegral i .&. 0xff) : go (i `shiftR` 8) -{- | -@ -AuthenticationChoice ::= CHOICE { - simple [0] OCTET STRING, - ... } -@ --} -instance ToAsn1 AuthenticationChoice where - toAsn1 (Simple s) = other Asn1.Context 0 s +-- | Encoding of an enumerated value. +-- +-- It is encoded exactly the same as an integer value, but the tag number is different. +enum :: Mod -> Int32 -> Ber +enum f = int32 (tag 0x0a <> f) -{- | -@ -AttributeSelection ::= SEQUENCE OF selector LDAPString -@ --} -instance ToAsn1 AttributeSelection where - toAsn1 (AttributeSelection as) = sequence (toAsn1 as) +-- | Encoding of an octet string. +octetstring :: Mod -> ByteString.ByteString -> Ber +octetstring f bs = Ber + (fromIntegral (ByteString.length bs) + 2 + fromIntegral (length ts)) + (Builder.word8 (t .|. classBit f) <> Builder.lazyByteString (ByteString.Lazy.pack ts) <> + Builder.byteString (ByteString.pack (encodeLength (ByteString.length bs))) <> + Builder.byteString bs) + where + t :| ts = tagBits (tag 0x04 <> f) -{- | -@ -Filter ::= CHOICE { - and [0] SET SIZE (1..MAX) OF filter Filter, - or [1] SET SIZE (1..MAX) OF filter Filter, - not [2] Filter, - equalityMatch [3] AttributeValueAssertion, - substrings [4] SubstringFilter, - greaterOrEqual [5] AttributeValueAssertion, - lessOrEqual [6] AttributeValueAssertion, - present [7] AttributeDescription, - approxMatch [8] AttributeValueAssertion, - extensibleMatch [9] MatchingRuleAssertion, - ... } -@ --} -instance ToAsn1 Filter where - toAsn1 f = case f of - And xs -> context 0 (toAsn1 xs) - Or xs -> context 1 (toAsn1 xs) - Not x -> context 2 (toAsn1 x) - EqualityMatch x -> context 3 (toAsn1 x) - Substrings x -> context 4 (toAsn1 x) - GreaterOrEqual x -> context 5 (toAsn1 x) - LessOrEqual x -> context 6 (toAsn1 x) - Present (AttributeDescription (LdapString x)) - -> other Asn1.Context 7 (Text.encodeUtf8 x) - ApproxMatch x -> context 8 (toAsn1 x) - ExtensibleMatch x -> context 9 (toAsn1 x) +-- | Encoding of NULL +-- +-- >>> encode (null mempty) +-- "\ENQ\NUL" +null :: Mod -> Ber +null f = fromBytes ((t .|. classBit f) : ts ++ [0]) + where + t :| ts = tagBits (tag 0x05 <> f) -{- | -@ -SubstringFilter ::= SEQUENCE { - type AttributeDescription, - substrings SEQUENCE SIZE (1..MAX) OF substring CHOICE { - initial [0] AssertionValue, -- can occur at most once - any [1] AssertionValue, - final [2] AssertionValue } -- can occur at most once - } -@ --} -instance ToAsn1 SubstringFilter where - toAsn1 (SubstringFilter ad ss) = - toAsn1 ad <> sequence (foldMap (\s -> case s of - Initial (AssertionValue v) -> other Asn1.Context 0 v - Any (AssertionValue v) -> other Asn1.Context 1 v - Final (AssertionValue v) -> other Asn1.Context 2 v) ss) +-- | Encoding of a sequence [of]. +-- +-- >>> encode (sequence mempty (octetstring mempty "Smith" <> bool mempty True)) +-- "0\n\EOT\ENQSmith\SOH\SOH\255" +sequence :: Mod -> Ber -> Ber +sequence m = tagged (tag 0x10 <> m) -{- | -@ -MatchingRuleAssertion ::= SEQUENCE { - matchingRule [1] MatchingRuleId OPTIONAL, - type [2] AttributeDescription OPTIONAL, - matchValue [3] AssertionValue, - dnAttributes [4] BOOLEAN DEFAULT FALSE } -@ --} -instance ToAsn1 MatchingRuleAssertion where - toAsn1 (MatchingRuleAssertion mmr mad (AssertionValue av) _) = fold - [ maybe mempty f mmr - , maybe mempty g mad - , other Asn1.Context 3 av - ] - where - f (MatchingRuleId (LdapString x)) = other Asn1.Context 1 (Text.encodeUtf8 x) - g (AttributeDescription (LdapString x)) = other Asn1.Context 2 (Text.encodeUtf8 x) +-- | Encoding of a set [of]. +-- +-- >>> encode (set mempty (octetstring mempty "Smith" <> bool mempty True)) +-- "1\n\EOT\ENQSmith\SOH\SOH\255" +set :: Mod -> Ber -> Ber +set m = tagged (tag 0x11 <> m) -{- | -@ -AttributeList ::= SEQUENCE OF attribute Attribute -@ --} -instance ToAsn1 AttributeList where - toAsn1 (AttributeList xs) = sequence (toAsn1 xs) +-- | Encoding of a (possibly tagged) constructed value. +tagged :: Mod -> Ber -> Ber +tagged f b@(Ber l _) = fromBytes ((t .|. constructedTag .|. classBit f) : ts ++ encodeLength l) <> b + where + t :| ts = tagBits f + constructedTag = 0x20 -instance ToAsn1 a => ToAsn1 [a] where - toAsn1 = foldMap toAsn1 +fromBytes :: [Word8] -> Ber +fromBytes xs = let bs = ByteString.Lazy.pack xs in Ber (ByteString.Lazy.length bs) (Builder.lazyByteString bs) -instance ToAsn1 a => ToAsn1 (NonEmpty a) where - toAsn1 = foldMap toAsn1 +defaultTag :: Tag +defaultTag = Tag Universal (Number 0) -sequence :: Endo [ASN1] -> Endo [ASN1] -sequence = construction Asn1.Sequence +newtype Mod = Mod (Tag -> Tag) -set :: Endo [ASN1] -> Endo [ASN1] -set = construction Asn1.Set +instance Semigroup Mod where + Mod f <> Mod g = Mod (g . f) -application :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1] -application = construction . Asn1.Container Asn1.Application +instance Monoid Mod where + mappend = (<>) + mempty = Mod id -context :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1] -context = construction . Asn1.Container Asn1.Context +data Class = + Universal + | Application + | Context + deriving (Show, Eq) -construction :: ASN1ConstructionType -> Endo [ASN1] -> Endo [ASN1] -construction t x = single (Asn1.Start t) <> x <> single (Asn1.End t) +data Tag = Tag !Class !Number + deriving (Show, Eq) -other :: ASN1Class -> ASN1Tag -> ByteString -> Endo [ASN1] -other c t = single . Asn1.Other c t +newtype Number = Number Word8 + deriving (Show, Eq) -enum :: Integer -> Endo [ASN1] -enum = single . Asn1.Enumerated +classBit :: Mod -> Word8 +classBit (Mod f) = case f defaultTag of + Tag Universal _ -> 0x00 + Tag Application _ -> 0x40 + Tag Context _ -> 0x80 -single :: a -> Endo [a] -single x = Endo (x :) +tagBits :: Mod -> NonEmpty Word8 +tagBits (Mod f) = case f defaultTag of Tag _ t -> encodeTagNumber t + +application, context :: Mod +application = class_ Application +context = class_ Context + +class_ :: Class -> Mod +class_ c = Mod (\(Tag _ t) -> Tag c t) + +tag :: Word8 -> Mod +tag t = Mod (\(Tag c _) -> Tag c (Number t)) + +-- | Small tag numbers (up to and including 30) are bit-OR'd +-- directly with the first Identifier byte, while the bigger ones +-- are encoded idiosyncratically. +-- +-- >>> encodeTagNumber (Number 19) +-- 19 :| [] +-- +-- >>> encodeTagNumber (Number 31) +-- 31 :| [31] +-- +-- >>> encodeTagNumber (Number 137) +-- 31 :| [129,9] +encodeTagNumber :: Number -> NonEmpty Word8 +encodeTagNumber (Number n) + | n < 30 = return n + | otherwise = 0x1f :| reverse (go n) + where + go x = fromIntegral (x .&. 0x7f) : go' (x `shiftR` 7) + go' 0 = [] + go' x = (fromIntegral (x .&. 0x7f) .|. 0x80) : go' (x `shiftR` 7) + +-- | Small lengths (up to and including 127) are returned as a single +-- byte equal to length itself, while the bigger one are encoded +-- idiosyncratically. +-- +-- >>> encodeLength 7 +-- [7] +-- +-- >>> encodeLength 12238 +-- [130,47,206] +-- +-- @ +-- encodeLength :: (Integral a, Bits a) => a -> NonEmpty Word8 +-- @ +encodeLength :: (Integral a, Bits a) => a -> [Word8] +encodeLength n + | n < 0x80 = [fromIntegral n] + | otherwise = let (l, xs) = go n in (l .|. 0x80) : reverse xs + where + go x + | x <= 0xff = (1, [fromIntegral x]) + | otherwise = let (l, xs) = go (x `shiftR` 8) in (l + 1, (fromIntegral x .&. 0xff) : xs) diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs index 4786c41..c4b207b 100644 --- a/src/Ldap/Client.hs +++ b/src/Ldap/Client.hs @@ -74,7 +74,9 @@ import Data.Foldable (asum) import Data.Function (fix) import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.Map.Strict as Map -import Data.Monoid (Endo(appEndo)) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mempty) +#endif import Data.String (fromString) import Data.Text (Text) #if __GLASGOW_HASKELL__ < 710 @@ -86,9 +88,10 @@ import qualified Network.Connection as Conn import Prelude hiding (compare) import qualified System.IO.Error as IO -import Ldap.Asn1.ToAsn1 (ToAsn1(toAsn1)) import Ldap.Asn1.FromAsn1 (FromAsn1, parseAsn1) +import Ldap.Asn1.ToAsn1 (encode) import qualified Ldap.Asn1.Type as Type +import Ldap.Client.Asn1.ToAsn1 (ToAsn1(toAsn1)) import Ldap.Client.Internal import Ldap.Client.Bind (Password(..), bind) import Ldap.Client.Search @@ -203,9 +206,7 @@ input inq conn = wrap . flip fix [] $ \loop chunks -> do output :: ToAsn1 a => TQueue a -> Connection -> IO b output out conn = wrap . forever $ do msg <- atomically (readTQueue out) - Conn.connectionPut conn (encode (toAsn1 msg)) - where - encode x = Asn1.encodeASN1' Asn1.DER (appEndo x []) + Conn.connectionPut conn (ByteString.Lazy.toStrict (encode (toAsn1 mempty msg))) dispatch :: Ldap diff --git a/src/Ldap/Client/Asn1/ToAsn1.hs b/src/Ldap/Client/Asn1/ToAsn1.hs new file mode 100644 index 0000000..b866f2f --- /dev/null +++ b/src/Ldap/Client/Asn1/ToAsn1.hs @@ -0,0 +1,402 @@ +-- | This module contains convertions from LDAP types to ASN.1. +module Ldap.Client.Asn1.ToAsn1 + ( ToAsn1(toAsn1) + ) where + +import Data.Bool (Bool(False)) +import Data.Foldable (foldMap) +import Data.Eq (Eq((==))) +import Data.List.NonEmpty (NonEmpty) +import Data.Monoid (Monoid(mempty), (<>)) +import qualified Data.Text.Encoding as Text +import Prelude (fromIntegral) + +import Ldap.Asn1.Type +import Ldap.Asn1.ToAsn1 + + +-- | Convert a LDAP type to ASN.1. +-- +-- When it's relevant, instances include the part of the RFC describing the encoding. +class ToAsn1 a where + toAsn1 :: Mod -> a -> Ber + +{- | +@ +LDAPMessage ::= SEQUENCE { + messageID MessageID, + protocolOp CHOICE { + bindRequest BindRequest, + bindResponse BindResponse, + unbindRequest UnbindRequest, + searchRequest SearchRequest, + searchResEntry SearchResultEntry, + searchResDone SearchResultDone, + searchResRef SearchResultReference, + addRequest AddRequest, + addResponse AddResponse, + ... }, + controls [0] Controls OPTIONAL } +@ +-} +instance ToAsn1 op => ToAsn1 (LdapMessage op) where + toAsn1 m (LdapMessage i op mc) = + sequence m + (toAsn1 mempty i <> + toAsn1 mempty op <> + foldMap (toAsn1 (context <> tag 0)) mc) + +{- | +@ +MessageID ::= INTEGER (0 .. maxInt) +@ +-} +instance ToAsn1 Id where + toAsn1 m (Id i) = int32 m i + +{- | +@ +LDAPString ::= OCTET STRING -- UTF-8 encoded +@ +-} +instance ToAsn1 LdapString where + toAsn1 m (LdapString s) = octetstring m (Text.encodeUtf8 s) + +{- | +@ +LDAPOID ::= OCTET STRING -- Constrained to \ +@ +-} +instance ToAsn1 LdapOid where + toAsn1 m (LdapOid s) = octetstring m (Text.encodeUtf8 s) + +{- | +@ +LDAPDN ::= LDAPString -- Constrained to \ +@ +-} +instance ToAsn1 LdapDn where + toAsn1 m (LdapDn s) = toAsn1 m s + +{- | +@ +RelativeLDAPDN ::= LDAPString -- Constrained to \ +@ +-} +instance ToAsn1 RelativeLdapDn where + toAsn1 m (RelativeLdapDn s) = toAsn1 m s + +{- | +@ +AttributeDescription ::= LDAPString +@ +-} +instance ToAsn1 AttributeDescription where + toAsn1 m (AttributeDescription s) = toAsn1 m s + +{- | +@ +AttributeValue ::= OCTET STRING +@ +-} +instance ToAsn1 AttributeValue where + toAsn1 m (AttributeValue s) = octetstring m s + +{- | +@ +AttributeValueAssertion ::= SEQUENCE { + attributeDesc AttributeDescription, + assertionValue AssertionValue } +@ +-} +instance ToAsn1 AttributeValueAssertion where + toAsn1 m (AttributeValueAssertion d v) = + sequence m (toAsn1 mempty d <> toAsn1 mempty v) + +{- | +@ +AssertionValue ::= OCTET STRING +@ +-} +instance ToAsn1 AssertionValue where + toAsn1 m (AssertionValue s) = octetstring m s + + +{- | +@ +PartialAttribute ::= SEQUENCE { + type AttributeDescription, + vals SET OF value AttributeValue } +@ +-} +instance ToAsn1 PartialAttribute where + toAsn1 m (PartialAttribute d xs) = + sequence m (toAsn1 mempty d <> set mempty (toAsn1 mempty xs)) + +{- | +@ +Attribute ::= PartialAttribute(WITH COMPONENTS { + ..., + vals (SIZE(1..MAX))}) +@ +-} +instance ToAsn1 Attribute where + toAsn1 m (Attribute d xs) = + sequence m (toAsn1 mempty d <> set mempty (toAsn1 mempty xs)) + +{- | +@ +MatchingRuleId ::= LDAPString +@ +-} +instance ToAsn1 MatchingRuleId where + toAsn1 m (MatchingRuleId s) = toAsn1 m s + +{- | +@ +Controls ::= SEQUENCE OF control Control +@ +-} +instance ToAsn1 Controls where + toAsn1 m (Controls cs) = sequence m (toAsn1 mempty cs) + +{- | +@ +Control ::= SEQUENCE { + controlType LDAPOID, + criticality BOOLEAN DEFAULT FALSE, + controlValue OCTET STRING OPTIONAL } +@ +-} +instance ToAsn1 Control where + toAsn1 m (Control t c v) = + sequence m + (toAsn1 mempty t <> + default_ False c (bool mempty c) <> + foldMap (octetstring mempty) v) + +{- | +@ +BindRequest ::= [APPLICATION 0] SEQUENCE { + version INTEGER (1 .. 127), + name LDAPDN, + authentication AuthenticationChoice } +@ + +@ +UnbindRequest ::= [APPLICATION 2] NULL +@ + +@ +SearchRequest ::= [APPLICATION 3] SEQUENCE { + baseObject LDAPDN, + scope ENUMERATED { + baseObject (0), + singleLevel (1), + wholeSubtree (2), + ... }, + derefAliases ENUMERATED { + neverDerefAliases (0), + derefInSearching (1), + derefFindingBaseObj (2), + derefAlways (3) }, + sizeLimit INTEGER (0 .. maxInt), + timeLimit INTEGER (0 .. maxInt), + typesOnly BOOLEAN, + filter Filter, + attributes AttributeSelection } +@ + +@ +ModifyRequest ::= [APPLICATION 6] SEQUENCE { + object LDAPDN, + changes SEQUENCE OF change SEQUENCE { + operation ENUMERATED { + add (0), + delete (1), + replace (2), + ... }, + modification PartialAttribute } } +@ + +@ +AddRequest ::= [APPLICATION 8] SEQUENCE { + entry LDAPDN, + attributes AttributeList } +@ + +@ +DelRequest ::= [APPLICATION 10] LDAPDN +@ + +@ +ModifyDNRequest ::= [APPLICATION 12] SEQUENCE { + entry LDAPDN, + newrdn RelativeLDAPDN, + deleteoldrdn BOOLEAN, + newSuperior [0] LDAPDN OPTIONAL } +@ + +@ +CompareRequest ::= [APPLICATION 14] SEQUENCE { + entry LDAPDN, + ava AttributeValueAssertion } +@ + +@ +ExtendedRequest ::= [APPLICATION 23] SEQUENCE { + requestName [0] LDAPOID, + requestValue [1] OCTET STRING OPTIONAL } +@ +-} +instance ToAsn1 ProtocolClientOp where + toAsn1 _ (BindRequest v n a) = + sequence (application <> tag 0) + (int32 mempty (fromIntegral v) <> + toAsn1 mempty n <> + toAsn1 mempty a) + toAsn1 _ UnbindRequest = + null (application <> tag 2) + toAsn1 _ (SearchRequest bo s da sl tl to f a) = + sequence (application <> tag 3) + (toAsn1 mempty bo <> + enum mempty s' <> + enum mempty da' <> + int32 mempty sl <> + int32 mempty tl <> + bool mempty to <> + toAsn1 mempty f <> + toAsn1 mempty a) + where + s' = case s of + BaseObject -> 0 + SingleLevel -> 1 + WholeSubtree -> 2 + da' = case da of + NeverDerefAliases -> 0 + DerefInSearching -> 1 + DerefFindingBaseObject -> 2 + DerefAlways -> 3 + toAsn1 _ (ModifyRequest dn xs) = + sequence (application <> tag 6) + (toAsn1 mempty dn <> + sequence mempty (foldMap (\(op, pa) -> sequence mempty (enum mempty (case op of + Add -> 0 + Delete -> 1 + Replace -> 2) <> toAsn1 mempty pa)) xs)) + toAsn1 _ (AddRequest dn as) = + sequence (application <> tag 8) (toAsn1 mempty dn <> toAsn1 mempty as) + toAsn1 _ (DeleteRequest dn) = + toAsn1 (application <> tag 10) dn + toAsn1 _ (ModifyDnRequest dn rdn del new) = + sequence (application <> tag 12) + (toAsn1 mempty dn <> + toAsn1 mempty rdn <> + bool mempty del <> + foldMap (toAsn1 (context <> tag 0)) new) + toAsn1 _ (CompareRequest dn av) = + sequence (application <> tag 14) (toAsn1 mempty dn <> toAsn1 mempty av) + toAsn1 _ (ExtendedRequest oid mv) = + sequence (application <> tag 23) + (toAsn1 (context <> tag 0) oid <> + foldMap (octetstring (context <> tag 1)) mv) + +{- | +@ +AuthenticationChoice ::= CHOICE { + simple [0] OCTET STRING, + ... } +@ +-} +instance ToAsn1 AuthenticationChoice where + toAsn1 _ (Simple s) = octetstring (context <> tag 0) s + +{- | +@ +AttributeSelection ::= SEQUENCE OF selector LDAPString +@ +-} +instance ToAsn1 AttributeSelection where + toAsn1 m (AttributeSelection as) = sequence m (toAsn1 mempty as) + +{- | +@ +Filter ::= CHOICE { + and [0] SET SIZE (1..MAX) OF filter Filter, + or [1] SET SIZE (1..MAX) OF filter Filter, + not [2] Filter, + equalityMatch [3] AttributeValueAssertion, + substrings [4] SubstringFilter, + greaterOrEqual [5] AttributeValueAssertion, + lessOrEqual [6] AttributeValueAssertion, + present [7] AttributeDescription, + approxMatch [8] AttributeValueAssertion, + extensibleMatch [9] MatchingRuleAssertion, + ... } +@ +-} +instance ToAsn1 Filter where + toAsn1 _ f = case f of + And xs -> set (context <> tag 0) (toAsn1 mempty xs) + Or xs -> set (context <> tag 1) (toAsn1 mempty xs) + Not x -> tagged (context <> tag 2) (toAsn1 mempty x) + EqualityMatch x -> toAsn1 (context <> tag 3) x + Substrings x -> toAsn1 (context <> tag 4) x + GreaterOrEqual x -> toAsn1 (context <> tag 5) x + LessOrEqual x -> toAsn1 (context <> tag 6) x + Present x -> toAsn1 (context <> tag 7) x + ApproxMatch x -> toAsn1 (context <> tag 8) x + ExtensibleMatch x -> toAsn1 (context <> tag 9) x + +{- | +@ +SubstringFilter ::= SEQUENCE { + type AttributeDescription, + substrings SEQUENCE SIZE (1..MAX) OF substring CHOICE { + initial [0] AssertionValue, -- can occur at most once + any [1] AssertionValue, + final [2] AssertionValue } -- can occur at most once + } +@ +-} +instance ToAsn1 SubstringFilter where + toAsn1 m (SubstringFilter ad ss) = + sequence m + (toAsn1 mempty ad <> + sequence mempty (foldMap (\s -> case s of + Initial v -> toAsn1 (context <> tag 0) v + Any v -> toAsn1 (context <> tag 1) v + Final v -> toAsn1 (context <> tag 2) v) ss)) + +{- | +@ +MatchingRuleAssertion ::= SEQUENCE { + matchingRule [1] MatchingRuleId OPTIONAL, + type [2] AttributeDescription OPTIONAL, + matchValue [3] AssertionValue, + dnAttributes [4] BOOLEAN DEFAULT FALSE } +@ +-} +instance ToAsn1 MatchingRuleAssertion where + toAsn1 m (MatchingRuleAssertion mmr mad av b) = sequence m + (foldMap (toAsn1 (context <> tag 1)) mmr <> + foldMap (toAsn1 (context <> tag 2)) mad <> + toAsn1 (context <> tag 3) av <> + default_ False b (bool (context <> tag 4) b)) + +{- | +@ +AttributeList ::= SEQUENCE OF attribute Attribute +@ +-} +instance ToAsn1 AttributeList where + toAsn1 m (AttributeList xs) = sequence m (toAsn1 mempty xs) + +instance ToAsn1 a => ToAsn1 [a] where + toAsn1 _ = foldMap (toAsn1 mempty) + +instance ToAsn1 a => ToAsn1 (NonEmpty a) where + toAsn1 _ = foldMap (toAsn1 mempty) + +default_ :: (Eq a, Monoid m) => a -> a -> m -> m +default_ a b c = if a == b then mempty else c diff --git a/test/Doctests.hs b/test/Doctests.hs new file mode 100644 index 0000000..679cb04 --- /dev/null +++ b/test/Doctests.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Test.DocTest (doctest) + + +main :: IO () +main = doctest ["src//Ldap/Asn1/ToAsn1.hs"] diff --git a/test/Ldap/Client/SearchSpec.hs b/test/Ldap/Client/SearchSpec.hs index 0ab9afb..dd4b81a 100644 --- a/test/Ldap/Client/SearchSpec.hs +++ b/test/Ldap/Client/SearchSpec.hs @@ -155,7 +155,7 @@ spec = do it "‘extensible’ filter" $ do res <- locally $ \l -> do - res <- go l ((Just (Attr "type"), Nothing, True) ::= "flying") + res <- go l ((Just (Attr "type"), Nothing, False) ::= "flying") dns res `shouldMatchList` [ butterfree , charizard