Support Modify

README.markdown

@@ -10,8 +10,8 @@ This library implements (the parts of) [RFC 4511][rfc4511]
 Bind Operation               | 4.2         | ✔
 Unbind Operation             | 4.3         | ✔
 Notice of Disconnection      | 4.4.1       | ✘
-Search Operation             | 4.5         | ✔ (partial)
+Search Operation             | 4.5         | ✔†
-Modify Operation             | 4.6         | ✘
+Modify Operation             | 4.6         | ✔
 Add Operation                | 4.7         | ✔
 Delete Operation             | 4.8         | ✔
 Modify DN Operation          | 4.9         | ✘
@@ -22,6 +22,8 @@ IntermediateResponse Message | 4.13        | ✘
 StartTLS Operation           | 4.14        | ✘
 LDAP over TLS                | -           | ✔
 
+†: approximate and extensible matches are untested, so probably do not work
+
 ```
 % git grep '\bString\b' | wc -l
 2

src/Ldap/Asn1/FromAsn1.hs

@@ -6,13 +6,12 @@ module Ldap.Asn1.FromAsn1
   , next
   ) where
 
-import           Control.Applicative (Alternative(..), optional)
+import           Control.Applicative (Alternative(..), liftA2, optional)
-import           Control.Monad ((>=>), MonadPlus(..))
+import           Control.Monad (MonadPlus(..), (>=>), guard)
 import           Data.ASN1.Types (ASN1)
 import qualified Data.ASN1.Types as Asn1
 import           Data.Foldable (asum)
 import           Data.List.NonEmpty (some1)
-import qualified Data.Set as Set
 import qualified Data.Text.Encoding as Text
 
 import           Ldap.Asn1.Type
@@ -96,7 +95,7 @@ instance FromAsn1 PartialAttribute where
     vs <- many fromAsn1
     Asn1.End Asn1.Set <- next
     Asn1.End Asn1.Sequence <- next
-    return (PartialAttribute d (Set.fromList vs))
+    return (PartialAttribute d vs)
 
 {- |
 LDAPResult ::= SEQUENCE {
@@ -234,6 +233,8 @@ SearchResultEntry ::= [APPLICATION 4] SEQUENCE {
 
 SearchResultDone ::= [APPLICATION 5] LDAPResult
 
+ModifyResponse ::= [APPLICATION 7] LDAPResult
+
 AddResponse ::= [APPLICATION 9] LDAPResult
 
 DelResponse ::= [APPLICATION 11] LDAPResult
@@ -242,43 +243,22 @@ CompareResponse ::= [APPLICATION 15] LDAPResult
 -}
 instance FromAsn1 ProtocolServerOp where
   fromAsn1 = asum
-    [ do
+    [ fmap (\res -> BindResponse res Nothing) (app 1)
-      Asn1.Start (Asn1.Container Asn1.Application 1) <- next
+    , fmap (uncurry SearchResultEntry) (app 4)
-      result <- fromAsn1
+    , fmap SearchResultDone (app 5)
-      Asn1.End (Asn1.Container Asn1.Application 1) <- next
+    , fmap ModifyResponse (app 7)
-      return (BindResponse result Nothing)
+    , fmap AddResponse (app 9)
-
+    , fmap DeleteResponse (app 11)
-    , do
+    , fmap CompareResponse (app 15)
-      Asn1.Start (Asn1.Container Asn1.Application 4) <- next
-      ldapDn <- fromAsn1
-      partialAttributeList <- fromAsn1
-      Asn1.End (Asn1.Container Asn1.Application 4) <- next
-      return (SearchResultEntry ldapDn partialAttributeList)
-
-    , do
-      Asn1.Start (Asn1.Container Asn1.Application 5) <- next
-      result <- fromAsn1
-      Asn1.End (Asn1.Container Asn1.Application 5) <- next
-      return (SearchResultDone result)
-
-    , do
-      Asn1.Start (Asn1.Container Asn1.Application 9) <- next
-      result <- fromAsn1
-      Asn1.End (Asn1.Container Asn1.Application 9) <- next
-      return (AddResponse result)
-
-    , do
-      Asn1.Start (Asn1.Container Asn1.Application 11) <- next
-      result <- fromAsn1
-      Asn1.End (Asn1.Container Asn1.Application 11) <- next
-      return (DeleteResponse result)
-
-    , do
-      Asn1.Start (Asn1.Container Asn1.Application 15) <- next
-      result <- fromAsn1
-      Asn1.End (Asn1.Container Asn1.Application 15) <- next
-      return (CompareResponse result)
     ]
+   where
+    app l = do
+      Asn1.Start (Asn1.Container Asn1.Application x) <- next
+      guard (x == l)
+      res <- fromAsn1
+      Asn1.End (Asn1.Container Asn1.Application y) <- next
+      guard (y == l)
+      return res
 
 {- |
 PartialAttributeList ::= SEQUENCE OF partialAttribute PartialAttribute
@@ -290,6 +270,9 @@ instance FromAsn1 PartialAttributeList where
     Asn1.End Asn1.Sequence <- next
     return (PartialAttributeList xs)
 
+instance (FromAsn1 a, FromAsn1 b) => FromAsn1 (a, b) where
+  fromAsn1 = liftA2 (,) fromAsn1 fromAsn1
+
 
 newtype Parser s a = Parser { unParser :: s -> Maybe (s, a) }
 

src/Ldap/Asn1/ToAsn1.hs

@@ -9,7 +9,7 @@ import           Data.Foldable (fold, foldMap)
 import           Data.Maybe (Maybe, maybe)
 import           Data.Monoid (Endo(Endo), (<>), mempty)
 import qualified Data.Text.Encoding as Text
-import           Prelude ((.), fromIntegral)
+import           Prelude (Integer, (.), fromIntegral)
 
 import           Ldap.Asn1.Type
 
@@ -87,11 +87,16 @@ 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 (foldMap toAsn1 xs))
 
+{- |
 Attribute ::= PartialAttribute(WITH COMPONENTS {
      ...,
      vals (SIZE(1..MAX))})
@@ -151,6 +156,16 @@ SearchRequest ::= [APPLICATION 3] SEQUENCE {
      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 }
@@ -169,8 +184,8 @@ instance ToAsn1 ProtocolClientOp where
   toAsn1 (SearchRequest bo s da sl tl to f a) =
     application 3 (fold
       [ toAsn1 bo
-      , single (Asn1.Enumerated s')
+      , enum s'
-      , single (Asn1.Enumerated da')
+      , enum da'
       , single (Asn1.IntVal (fromIntegral sl))
       , single (Asn1.IntVal (fromIntegral tl))
       , single (Asn1.Boolean to)
@@ -187,6 +202,14 @@ instance ToAsn1 ProtocolClientOp where
       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))) =
@@ -294,5 +317,8 @@ other c t = single . Asn1.Other c t
 optional :: ToAsn1 a => Maybe a -> Endo [ASN1]
 optional = maybe mempty toAsn1
 
+enum :: Integer -> Endo [ASN1]
+enum = single . Asn1.Enumerated
+
 single :: a -> Endo [a]
 single x = Endo (x :)

src/Ldap/Asn1/Type.hs

@@ -3,7 +3,6 @@ module Ldap.Asn1.Type where
 import Data.ByteString (ByteString)
 import Data.Int (Int8, Int32)
 import Data.List.NonEmpty (NonEmpty)
-import Data.Set (Set)
 import Data.Text (Text)
 
 
@@ -23,6 +22,7 @@ data ProtocolClientOp =
   | AddRequest LdapDn AttributeList
   | DeleteRequest LdapDn
   | CompareRequest LdapDn AttributeValueAssertion
+  | ModifyRequest LdapDn [(Operation, PartialAttribute)]
     deriving (Show, Eq, Ord)
 
 data ProtocolServerOp =
@@ -30,6 +30,7 @@ data ProtocolServerOp =
   | SearchResultEntry LdapDn PartialAttributeList
   | SearchResultReference (NonEmpty Uri)
   | SearchResultDone (LdapResult)
+  | ModifyResponse LdapResult
   | AddResponse LdapResult
   | DeleteResponse LdapResult
   | CompareResponse LdapResult
@@ -154,7 +155,7 @@ newtype AssertionValue = AssertionValue ByteString
 data Attribute = Attribute AttributeDescription (NonEmpty AttributeValue)
     deriving (Show, Eq, Ord)
 
-data PartialAttribute = PartialAttribute AttributeDescription (Set AttributeValue)
+data PartialAttribute = PartialAttribute AttributeDescription [AttributeValue]
     deriving (Show, Eq, Ord)
 
 newtype LdapDn = LdapDn LdapString
@@ -166,6 +167,12 @@ newtype ReferralUris = ReferralUris (NonEmpty Uri)
 newtype Uri = Uri LdapString
     deriving (Show, Eq, Ord)
 
+data Operation =
+    Add
+  | Delete
+  | Replace
+    deriving (Show, Eq, Ord)
+
 -- | The LDAPString is a notational convenience to indicate that, although
 -- strings of LDAPString type encode as ASN.1 OCTET STRING types, the
 -- [ISO10646] character set (a superset of [Unicode]) is used, encoded

src/Ldap/Client.hs

@@ -9,12 +9,12 @@ module Ldap.Client
   , Type.ResultCode(..)
   , Async
   , with
-    -- * Bind Request
+    -- * Bind Operation
   , Dn(..)
   , Password(..)
   , BindError(..)
   , bind
-    -- * Search Request
+    -- * Search Operation
   , Attr(..)
   , SearchError(..)
   , search
@@ -27,17 +27,21 @@ module Ldap.Client
   , derefAliases
   , Filter(..)
   , SearchEntry(..)
-    -- * Add Request
+    -- * Modify Operation
+  , ModifyError(..)
+  , Operation(..)
+  , modify
+    -- * Add Operation
   , AttrList
   , AddError(..)
   , add
-    -- * Delete Request
+    -- * Delete Operation
   , DeleteError(..)
   , delete
-    -- * Compare Request
+    -- * Compare Operation
   , CompareError(..)
   , compare
-    -- * Waiting for Request Completion
+    -- * Waiting for Operation Completion
   , wait
   , waitSTM
   ) where
@@ -80,6 +84,7 @@ import           Ldap.Client.Search
   , Filter(..)
   , SearchEntry(..)
   )
+import           Ldap.Client.Modify (ModifyError(..), Operation(..), modify)
 import           Ldap.Client.Compare (CompareError(..), compare)
 
 
@@ -92,6 +97,7 @@ data LdapError =
   | ParseError Asn1.ASN1Error
   | BindError BindError
   | SearchError SearchError
+  | ModifyError ModifyError
   | AddError AddError
   | DeleteError DeleteError
   | CompareError CompareError
@@ -115,6 +121,7 @@ with host port f = do
   , Handler (return . Left . ParseError)
   , Handler (return . Left . BindError)
   , Handler (return . Left . SearchError)
+  , Handler (return . Left . ModifyError)
   , Handler (return . Left . AddError)
   , Handler (return . Left . DeleteError)
   , Handler (return . Left . CompareError)
@@ -194,6 +201,9 @@ dispatch Ldap { client } inq outq =
                let stack = Map.findWithDefault [] mid got
                traverse_ (\var -> putTMVar var (op :| stack)) (Map.lookup mid results)
                return (Map.delete mid got, Map.delete mid results, counter)
+             Type.ModifyResponse {} -> do
+               traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
+               return (Map.delete mid got, Map.delete mid results, counter)
              Type.AddResponse {} -> do
                traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
                return (Map.delete mid got, Map.delete mid results, counter)

src/Ldap/Client/Bind.hs

@@ -14,8 +14,8 @@ import           Control.Monad.STM (STM, atomically)
 import           Data.List.NonEmpty (NonEmpty((:|)))
 import           Data.Typeable (Typeable)
 
-import           Ldap.Client.Internal
 import qualified Ldap.Asn1.Type as Type
+import           Ldap.Client.Internal
 
 
 data BindError =

src/Ldap/Client/Modify.hs

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

src/Ldap/Client/Search.hs

@@ -23,8 +23,6 @@ import           Data.Int (Int32)
 import           Data.List.NonEmpty (NonEmpty((:|)))
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Maybe (mapMaybe)
-import           Data.Set (Set)
-import qualified Data.Set as Set
 import           Data.Typeable (Typeable)
 
 import qualified Ldap.Asn1.Type as Type
@@ -90,7 +88,7 @@ searchResult (Type.SearchResultDone (Type.LdapResult code _ _ _) :| xs)
     Just (SearchEntry (Dn dn) (map h ys))
   g _ = Nothing
   h (Type.PartialAttribute (Type.AttributeDescription (Type.LdapString x))
-                           y) = (Attr x, Set.map j y)
+                           y) = (Attr x, fmap j y)
   j (Type.AttributeValue x) = x
 searchResult res = Left (SearchInvalidResponse res)
 
@@ -193,5 +191,5 @@ data Filter =
   | Attr :=* (Maybe ByteString, [ByteString], Maybe ByteString)
   | (Maybe Attr, Maybe Attr, Bool) ::= ByteString
 
-data SearchEntry = SearchEntry Dn (AttrList Set)
+data SearchEntry = SearchEntry Dn (AttrList [])
     deriving (Show, Eq)

test/Ldap/Client/BindSpec.hs

@@ -9,17 +9,17 @@ import SpecHelper (locally)
 
 spec :: Spec
 spec = do
-  it "binds as admin" $ do
+  it "binds as ‘admin’" $ do
     res <- locally $ \l -> do
       Ldap.bind l (Dn "cn=admin") (Password "secret")
     res `shouldBe` Right ()
 
-  it "tries to bind as admin with the wrong password, unsuccessfully" $ do
+  it "tries to bind as ‘admin’ with the wrong password, unsuccessfully" $ do
     res <- locally $ \l -> do
       Ldap.bind l (Dn "cn=admin") (Password "public")
     res `shouldBe` Left (Ldap.BindError (Ldap.BindErrorCode Ldap.InvalidCredentials))
 
-  it "binds as pikachu" $ do
+  it "binds as ‘pikachu’" $ do
     res <- locally $ \l -> do
       Ldap.bind l (Dn "cn=admin") (Password "secret")
       Ldap.SearchEntry udn _ : []

test/Ldap/Client/ModifySpec.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Ldap.Client.ModifySpec (spec) where
+
+import Data.ByteString (ByteString)
+import Data.Monoid ((<>))
+import Test.Hspec
+import Ldap.Client as Ldap
+
+import SpecHelper (locally, charizard, pikachu)
+
+
+spec :: Spec
+spec = do
+  let go l f = Ldap.search l (Dn "o=localhost")
+                             (Ldap.scope WholeSubtree <> Ldap.typesOnly True)
+                             f
+                             []
+
+  context "delete" $ do
+    it "can land ‘charizard’" $ do
+      res <- locally $ \l -> do
+        [x] <- go l (Attr "cn" := "charizard")
+        lookupAttr (Attr "type") x `shouldBe` Just ["fire", "flying"]
+
+        Ldap.modify l charizard [Attr "type" `Delete` ["flying"]]
+
+        [y] <- go l (Attr "cn" := "charizard")
+        lookupAttr (Attr "type") y `shouldBe` Just ["fire"]
+      res `shouldBe` Right ()
+
+    it "tries to remove ‘pikachu’'s password, unsuccessfully" $ do
+      res <- locally $ \l -> do
+        Ldap.modify l pikachu [Attr "password" `Delete` []]
+      res `shouldBe` Left
+        (ModifyError (ModifyErrorCode UnwillingToPerform (Dn "o=localhost") "cannot delete password"))
+
+  context "add" $ do
+    it "can feed ‘charizard’" $ do
+      res <- locally $ \l -> do
+        [x] <- go l (Attr "cn" := "charizard")
+        lookupAttr (Attr "type") x `shouldBe` Just ["fire", "flying"]
+
+        Ldap.modify l charizard [Attr "type" `Add` ["fed"]]
+
+        [y] <- go l (Attr "cn" := "charizard")
+        lookupAttr (Attr "type") y `shouldBe` Just ["fire", "flying", "fed"]
+      res `shouldBe` Right ()
+
+  context "replace" $ do
+    it "can put ‘charizard’ to sleep" $ do
+      res <- locally $ \l -> do
+        [x] <- go l (Attr "cn" := "charizard")
+        lookupAttr (Attr "type") x `shouldBe` Just ["fire", "flying"]
+
+        Ldap.modify l charizard [Attr "type" `Replace` ["sleeping"]]
+
+        [y] <- go l (Attr "cn" := "charizard")
+        lookupAttr (Attr "type") y `shouldBe` Just ["sleeping"]
+      res `shouldBe` Right ()
+
+lookupAttr :: Attr -> SearchEntry -> Maybe [ByteString]
+lookupAttr a (SearchEntry _ as) = lookup a as

test/ldap.js

@@ -47,7 +47,7 @@ var pokemon = [
     attributes: { cn: 'butterfree', evolution: "2", type: ["bug", "flying"], }
   },
   { dn: 'cn=pikachu,o=localhost',
-    attributes: { cn: 'pikachu', evolution: "0", type: ["electric"], password: "i-choose-you" }
+    attributes: { cn: 'pikachu', evolution: "0", type: ["electric"], password: ["i-choose-you"] }
   },
   ];
 
@@ -133,6 +133,56 @@ server.compare('o=localhost', [], function(req, res, next) {
   return next(new ldapjs.NoSuchObjectError(req.dn.toString()));
 });
 
+// Javascript is helpless
+Array.prototype.diff = function(arr) {
+  return this.filter(function(idx) { return arr.indexOf(idx) < 0; });
+};
+
+server.modify('o=localhost', [], function(req, res, next) {
+  var dn = req.dn.toString();
+
+  for (var i = 0; i < pokemon.length; i++) {
+    if (pokemon[i].dn === dn) {
+      for (var j = 0; j < req.changes.length; j++) {
+        var m = req.changes[j].modification;
+
+        switch (req.changes[j].operation) {
+          case 'add':
+            pokemon[i].attributes[m.type] = pokemon[i].attributes[m.type].concat(m.vals);
+            break;
+          case 'delete':
+            if (m.type === "password") {
+              return next(new ldapjs.UnwillingToPerformError('cannot delete password'));
+            } else {
+              if (m.vals === 0) {
+                delete pokemon[i].attributes[m.type];
+              } else {
+                pokemon[i].attributes[m.type] = pokemon[i].attributes[m.type].diff(m.vals);
+                if (pokemon[i].attributes[m.type].length === 0) {
+                  delete pokemon[i].attributes[m.type];
+                }
+              }
+            }
+            break;
+          case 'replace':
+            if (m.vals === 0) {
+              delete pokemon[i].attributes[m.type];
+            } else {
+              pokemon[i].attributes[m.type] = m.vals;
+            }
+            break;
+        }
+      }
+
+      res.end();
+      return next();
+    }
+  }
+
+  res.end();
+  return next(new ldapjs.NoSuchObjectError(dn));
+});
+
 server.listen(port, function() {
   console.log("ldaps://localhost:%d", port);
 });