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

@@ -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

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

src/Ldap/Asn1/ToAsn1.hs

@@ -1,429 +1,217 @@
--- | This module contains convertions from LDAP types to ASN.1.
+{-# LANGUAGE CPP #-}
---
--- 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.
 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           Data.Bits (Bits((.&.), (.|.), shiftR))
-import qualified Data.ASN1.Types as Asn1
+import qualified Data.ByteString as ByteString
-import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as ByteString.Lazy
-import           Data.Foldable (fold, foldMap)
+import           Data.ByteString.Lazy (ByteString)
-import           Data.List.NonEmpty (NonEmpty)
+import           Data.ByteString.Lazy.Builder (Builder)
-import           Data.Maybe (maybe)
+import qualified Data.ByteString.Lazy.Builder as Builder
-import           Data.Monoid (Endo(Endo), (<>), mempty)
+import           Data.Int (Int64, Int32)
-import qualified Data.Text.Encoding as Text
+import           Data.List.NonEmpty (NonEmpty((:|)))
-import           Prelude (Integer, (.), fromIntegral)
+#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.
+-- >>> encode (bool mempty True)
-class ToAsn1 a where
+-- "\SOH\SOH\255"
-  toAsn1 :: a -> Endo [ASN1]
+--
+-- >>> 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)
 
-{- |
+-- | Encoding of an integer value.
-@
+--
-LDAPMessage ::= SEQUENCE {
+-- >>> encode (int32 mempty 0)
-     messageID       MessageID,
+-- "\STX\SOH\NUL"
-     protocolOp      CHOICE {
+--
-          bindRequest           BindRequest,
+-- >>> encode (int32 mempty 127)
-          bindResponse          BindResponse,
+-- "\STX\SOH\DEL"
-          unbindRequest         UnbindRequest,
+--
-          searchRequest         SearchRequest,
+-- >>> encode (int32 mempty 128)
-          searchResEntry        SearchResultEntry,
+-- "\STX\STX\NUL\128"
-          searchResDone         SearchResultDone,
+int32 :: Mod -> Int32 -> Ber
-          searchResRef          SearchResultReference,
+int32 f n = fromBytes ((t .|. classBit f) : ts ++ fromIntegral (length bytes) : bytes)
-          addRequest            AddRequest,
+ where
-          addResponse           AddResponse,
+  t :| ts = tagBits (tag 0x02 <> f)
-          ... },
+  bytes
-     controls       [0] Controls OPTIONAL }
+    | n .&. 0x80 == 0x80 = 0x00 : reverse (go n)
-@
+    | otherwise = reverse (go n)
--}
-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 \<numericoid\>
-@
--}
-instance ToAsn1 LdapOid where
-  toAsn1 (LdapOid s) = single (Asn1.OctetString (Text.encodeUtf8 s))
-
-{- |
-@
-LDAPDN ::= LDAPString -- Constrained to \<distinguishedName\>
-@
--}
-instance ToAsn1 LdapDn where
-  toAsn1 (LdapDn s) = toAsn1 s
-
-{- |
-@
-RelativeLDAPDN ::= LDAPString -- Constrained to \<name-component\>
-@
--}
-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
-      ])
    where
-    s' = case s of
+    go i
-      BaseObject   -> 0
+      | i <= 0xff = return (fromIntegral i)
-      SingleLevel  -> 1
+      | otherwise = (fromIntegral i .&. 0xff) : go (i `shiftR` 8)
-      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
-     ])
 
-{- |
+-- | Encoding of an enumerated value.
-@
+--
-AuthenticationChoice ::= CHOICE {
+-- It is encoded exactly the same as an integer value, but the tag number is different.
-     simple                  [0] OCTET STRING,
+enum :: Mod -> Int32 -> Ber
-     ...  }
+enum f = int32 (tag 0x0a <> f)
-@
--}
-instance ToAsn1 AuthenticationChoice where
-  toAsn1 (Simple s) = other Asn1.Context 0 s
 
-{- |
+-- | Encoding of an octet string.
-@
+octetstring :: Mod -> ByteString.ByteString -> Ber
-AttributeSelection ::= SEQUENCE OF selector LDAPString
+octetstring f bs = Ber
-@
+  (fromIntegral (ByteString.length bs) + 2 + fromIntegral (length ts))
--}
+  (Builder.word8 (t .|. classBit f) <> Builder.lazyByteString (ByteString.Lazy.pack ts) <>
-instance ToAsn1 AttributeSelection where
+   Builder.byteString (ByteString.pack (encodeLength (ByteString.length bs))) <>
-  toAsn1 (AttributeSelection as) = sequence (toAsn1 as)
+   Builder.byteString bs)
+ where
+  t :| ts = tagBits (tag 0x04 <> f)
 
-{- |
+-- | Encoding of NULL
-@
+--
-Filter ::= CHOICE {
+-- >>> encode (null mempty)
-     and             [0] SET SIZE (1..MAX) OF filter Filter,
+-- "\ENQ\NUL"
-     or              [1] SET SIZE (1..MAX) OF filter Filter,
+null :: Mod -> Ber
-     not             [2] Filter,
+null f = fromBytes ((t .|. classBit f) : ts ++ [0])
-     equalityMatch   [3] AttributeValueAssertion,
+ where
-     substrings      [4] SubstringFilter,
+  t :| ts = tagBits (tag 0x05 <> f)
-     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 a sequence [of].
-@
+--
-SubstringFilter ::= SEQUENCE {
+-- >>> encode (sequence mempty (octetstring mempty "Smith" <> bool mempty True))
-     type           AttributeDescription,
+-- "0\n\EOT\ENQSmith\SOH\SOH\255"
-     substrings     SEQUENCE SIZE (1..MAX) OF substring CHOICE {
+sequence :: Mod -> Ber -> Ber
-          initial [0] AssertionValue,  -- can occur at most once
+sequence m = tagged (tag 0x10 <> m)
-          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 set [of].
-@
+--
-MatchingRuleAssertion ::= SEQUENCE {
+-- >>> encode (set mempty (octetstring mempty "Smith" <> bool mempty True))
-     matchingRule    [1] MatchingRuleId OPTIONAL,
+-- "1\n\EOT\ENQSmith\SOH\SOH\255"
-     type            [2] AttributeDescription OPTIONAL,
+set :: Mod -> Ber -> Ber
-     matchValue      [3] AssertionValue,
+set m = tagged (tag 0x11 <> m)
-     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 (possibly tagged) constructed value.
-@
+tagged :: Mod -> Ber -> Ber
-AttributeList ::= SEQUENCE OF attribute Attribute
+tagged f b@(Ber l _) = fromBytes ((t .|. constructedTag .|. classBit f) : ts ++ encodeLength l) <> b
-@
+ where
--}
+  t :| ts = tagBits f
-instance ToAsn1 AttributeList where
+  constructedTag = 0x20
-  toAsn1 (AttributeList xs) = sequence (toAsn1 xs)
 
-instance ToAsn1 a => ToAsn1 [a] where
+fromBytes :: [Word8] -> Ber
-  toAsn1 = foldMap toAsn1
+fromBytes xs = let bs = ByteString.Lazy.pack xs in Ber (ByteString.Lazy.length bs) (Builder.lazyByteString bs)
 
-instance ToAsn1 a => ToAsn1 (NonEmpty a) where
+defaultTag :: Tag
-  toAsn1 = foldMap toAsn1
+defaultTag = Tag Universal (Number 0)
 
-sequence :: Endo [ASN1] -> Endo [ASN1]
+newtype Mod = Mod (Tag -> Tag)
-sequence = construction Asn1.Sequence
 
-set :: Endo [ASN1] -> Endo [ASN1]
+instance Semigroup Mod where
-set = construction Asn1.Set
+  Mod f <> Mod g = Mod (g . f)
 
-application :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]
+instance Monoid Mod where
-application = construction . Asn1.Container Asn1.Application
+  mappend = (<>)
+  mempty = Mod id
 
-context :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]
+data Class =
-context = construction . Asn1.Container Asn1.Context
+    Universal
+  | Application
+  | Context
+    deriving (Show, Eq)
 
-construction :: ASN1ConstructionType -> Endo [ASN1] -> Endo [ASN1]
+data Tag = Tag !Class !Number
-construction t x = single (Asn1.Start t) <> x <> single (Asn1.End t)
+    deriving (Show, Eq)
 
-other :: ASN1Class -> ASN1Tag -> ByteString -> Endo [ASN1]
+newtype Number = Number Word8
-other c t = single . Asn1.Other c t
+    deriving (Show, Eq)
 
-enum :: Integer -> Endo [ASN1]
+classBit :: Mod -> Word8
-enum = single . Asn1.Enumerated
+classBit (Mod f) = case f defaultTag of
+  Tag Universal _   -> 0x00
+  Tag Application _ -> 0x40
+  Tag Context _     -> 0x80
 
-single :: a -> Endo [a]
+tagBits :: Mod -> NonEmpty Word8
-single x = Endo (x :)
+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)

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))
+  Conn.connectionPut conn (ByteString.Lazy.toStrict (encode (toAsn1 mempty msg)))
- where
-  encode x = Asn1.encodeASN1' Asn1.DER (appEndo x [])
 
 dispatch
   :: Ldap

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 \<numericoid\>
+@
+-}
+instance ToAsn1 LdapOid where
+  toAsn1 m (LdapOid s) = octetstring m (Text.encodeUtf8 s)
+
+{- |
+@
+LDAPDN ::= LDAPString -- Constrained to \<distinguishedName\>
+@
+-}
+instance ToAsn1 LdapDn where
+  toAsn1 m (LdapDn s) = toAsn1 m s
+
+{- |
+@
+RelativeLDAPDN ::= LDAPString -- Constrained to \<name-component\>
+@
+-}
+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

test/Doctests.hs

@@ -0,0 +1,7 @@
+module Main (main) where
+
+import Test.DocTest (doctest)
+
+
+main :: IO ()
+main = doctest ["src//Ldap/Asn1/ToAsn1.hs"]

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