Support ModifyDN

README.markdown

@@ -15,7 +15,7 @@ Search Operation             | 4.5         | ✔\*
 Modify Operation             | 4.6         | ✔
 Add Operation                | 4.7         | ✔
 Delete Operation             | 4.8         | ✔
-Modify DN Operation          | 4.9         | ✘
+Modify DN Operation          | 4.9         | ✔
 Compare Operation            | 4.10        | ✔
 Abandon Operation            | 4.11        | ✘
 Extended Operation           | 4.12        | ✔

src/Ldap/Asn1/FromAsn1.hs

@@ -21,6 +21,9 @@ import qualified Data.Text.Encoding as Text
 
 import           Ldap.Asn1.Type
 
+{-# ANN module "HLint: ignore Use const" #-}
+{-# ANN module "HLint: ignore Avoid lambda" #-}
+
 
 class FromAsn1 a where
   fromAsn1 :: Parser [ASN1] a
@@ -262,6 +265,7 @@ instance FromAsn1 ProtocolServerOp where
     , fmap ModifyResponse (app 7)
     , fmap AddResponse (app 9)
     , fmap DeleteResponse (app 11)
+    , fmap ModifyDnResponse (app 13)
     , fmap CompareResponse (app 15)
     , do
       Asn1.Start (Asn1.Container Asn1.Application 24) <- next

src/Ldap/Asn1/ToAsn1.hs

@@ -61,6 +61,12 @@ 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
 -}
@@ -172,6 +178,12 @@ AddRequest ::= [APPLICATION 8] SEQUENCE {
 
 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 }
@@ -219,6 +231,15 @@ instance ToAsn1 ProtocolClientOp where
     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) =

src/Ldap/Asn1/Type.hs

@@ -19,10 +19,11 @@ data ProtocolClientOp =
     BindRequest Int8 LdapDn AuthenticationChoice
   | UnbindRequest
   | SearchRequest LdapDn Scope DerefAliases Int32 Int32 Bool Filter AttributeSelection
+  | ModifyRequest LdapDn [(Operation, PartialAttribute)]
   | AddRequest LdapDn AttributeList
   | DeleteRequest LdapDn
+  | ModifyDnRequest LdapDn RelativeLdapDn Bool (Maybe LdapDn)
   | CompareRequest LdapDn AttributeValueAssertion
-  | ModifyRequest LdapDn [(Operation, PartialAttribute)]
   | ExtendedRequest LdapOid (Maybe ByteString)
     deriving (Show, Eq, Ord)
 
@@ -34,6 +35,7 @@ data ProtocolServerOp =
   | ModifyResponse LdapResult
   | AddResponse LdapResult
   | DeleteResponse LdapResult
+  | ModifyDnResponse LdapResult
   | CompareResponse LdapResult
   | ExtendedResponse LdapResult (Maybe LdapOid) (Maybe ByteString)
     deriving (Show, Eq, Ord)
@@ -163,6 +165,9 @@ data PartialAttribute = PartialAttribute AttributeDescription [AttributeValue]
 newtype LdapDn = LdapDn LdapString
     deriving (Show, Eq, Ord)
 
+newtype RelativeLdapDn = RelativeLdapDn LdapString
+    deriving (Show, Eq, Ord)
+
 newtype ReferralUris = ReferralUris (NonEmpty Uri)
     deriving (Show, Eq, Ord)
 

src/Ldap/Client.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE NamedFieldPuns #-}
 module Ldap.Client
   ( Host(..)
@@ -35,6 +34,9 @@ module Ldap.Client
   , add
     -- * Delete Operation
   , delete
+    -- * ModifyDn Operation
+  , RelativeDn(..)
+  , modifyDn
     -- * Compare Operation
   , compare
     -- * Extended Operation
@@ -85,7 +87,7 @@ import           Ldap.Client.Search
   , Filter(..)
   , SearchEntry(..)
   )
-import           Ldap.Client.Modify (Operation(..), modify)
+import           Ldap.Client.Modify (Operation(..), modify, modifyDn)
 import           Ldap.Client.Add (add)
 import           Ldap.Client.Delete (delete)
 import           Ldap.Client.Compare (compare)
@@ -177,37 +179,22 @@ dispatch
   -> TQueue (Type.LdapMessage Request)
   -> IO a
 dispatch Ldap { client } inq outq =
-  flip fix (Map.empty, Map.empty, 1) $ \loop (!got, !results, !counter) -> do
+  flip fix (Map.empty, Map.empty, 1) $ \loop (!got, !results, !counter) ->
     loop =<< atomically (asum
       [ do New new var <- readTQueue client
            writeTQueue outq (Type.LdapMessage (Type.Id counter) new Nothing)
            return (got, Map.insert (Type.Id counter) var results, counter + 1)
       , do Type.LdapMessage mid op _ <- readTQueue inq
            case op of
-             Type.BindResponse {} -> do
+             Type.SearchResultEntry {} ->
-               traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
-               return (Map.delete mid got, Map.delete mid results, counter)
-             Type.SearchResultEntry {} -> do
                return (Map.insertWith (++) mid [op] got, results, counter)
-             Type.SearchResultReference {} -> do
+             Type.SearchResultReference {} ->
                return (got, results, counter)
              Type.SearchResultDone {} -> do
                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
+             _ -> 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)
-             Type.DeleteResponse {} -> do
-               traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
-               return (Map.delete mid got, Map.delete mid results, counter)
-             Type.CompareResponse {} -> do
-               traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
-               return (Map.delete mid got, Map.delete mid results, counter)
-             Type.ExtendedResponse {} -> do
                traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
                return (Map.delete mid got, Map.delete mid results, counter)
       ])

src/Ldap/Client/Extended.hs

@@ -36,8 +36,8 @@ extendedAsyncSTM l oid mv =
   let req = extendedRequest oid mv in sendRequest l (extendedResult req) req
 
 extendedRequest :: Oid -> Maybe ByteString -> Request
-extendedRequest (Oid oid) mv =
+extendedRequest (Oid oid) =
-  Type.ExtendedRequest (Type.LdapOid oid) mv
+  Type.ExtendedRequest (Type.LdapOid oid)
 
 extendedResult :: Request -> Response -> Either ResponseError ()
 extendedResult req (Type.ExtendedResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))

src/Ldap/Client/Internal.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE NamedFieldPuns #-}
 module Ldap.Client.Internal
@@ -20,6 +19,7 @@ module Ldap.Client.Internal
   , raise
   , sendRequest
   , Dn(..)
+  , RelativeDn(..)
   , Password(..)
   , Attr(..)
   , unAttr
@@ -62,6 +62,9 @@ instance Functor Async where
 newtype Dn = Dn Text
     deriving (Show, Eq)
 
+newtype RelativeDn = RelativeDn Text
+    deriving (Show, Eq)
+
 newtype Oid = Oid ByteString
     deriving (Show, Eq)
 

src/Ldap/Client/Modify.hs

@@ -4,6 +4,10 @@ module Ldap.Client.Modify
   , modifyEither
   , modifyAsync
   , modifyAsyncSTM
+  , modifyDn
+  , modifyDnEither
+  , modifyDnAsync
+  , modifyDnAsyncSTM
   ) where
 
 import           Control.Monad.STM (STM, atomically)
@@ -55,3 +59,33 @@ modifyResult req (Type.ModifyResponse (Type.LdapResult code (Type.LdapDn (Type.L
   | Type.Success <- code = Right ()
   | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
 modifyResult req res = Left (ResponseInvalid req res)
+
+
+modifyDn :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO ()
+modifyDn l dn rdn del new =
+  raise =<< modifyDnEither l dn rdn del new
+
+modifyDnEither :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO (Either ResponseError ())
+modifyDnEither l dn rdn del new =
+  wait =<< modifyDnAsync l dn rdn del new
+
+modifyDnAsync :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO (Async ())
+modifyDnAsync l dn rdn del new =
+  atomically (modifyDnAsyncSTM l dn rdn del new)
+
+modifyDnAsyncSTM :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> STM (Async ())
+modifyDnAsyncSTM l dn rdn del new =
+  let req = modifyDnRequest dn rdn del new in sendRequest l (modifyDnResult req) req
+
+modifyDnRequest :: Dn -> RelativeDn -> Bool -> Maybe Dn -> Request
+modifyDnRequest (Dn dn) (RelativeDn rdn) del new =
+  Type.ModifyDnRequest (Type.LdapDn (Type.LdapString dn))
+                       (Type.RelativeLdapDn (Type.LdapString rdn))
+                       del
+                       (fmap (\(Dn dn') -> Type.LdapDn (Type.LdapString dn')) new)
+
+modifyDnResult :: Request -> Response -> Either ResponseError ()
+modifyDnResult req (Type.ModifyDnResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn)) (Type.LdapString msg) _) :| [])
+  | Type.Success <- code = Right ()
+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
+modifyDnResult req res = Left (ResponseInvalid req res)

test/Ldap/Client/AddSpec.hs

@@ -21,9 +21,9 @@ spec = do
   it "adds an entry" $ do
     res <- locally $ \l -> do
       Ldap.add l vulpix
-                 [ (Attr "cn",        (NonEmpty.fromList ["vulpix"]))
+                 [ (Attr "cn",        NonEmpty.fromList ["vulpix"])
-                 , (Attr "evolution", (NonEmpty.fromList ["0"]))
+                 , (Attr "evolution", NonEmpty.fromList ["0"])
-                 , (Attr "type",      (NonEmpty.fromList ["fire"]))
+                 , (Attr "type",      NonEmpty.fromList ["fire"])
                  ]
       res <- go l (Attr "cn" := "vulpix")
       dns res `shouldBe` [vulpix]

test/Ldap/Client/BindSpec.hs

@@ -11,12 +11,12 @@ import           SpecHelper (locally)
 spec :: Spec
 spec = do
   it "binds as ‘admin’" $ do
-    res <- locally $ \l -> do
+    res <- locally $ \l ->
       Ldap.bind l (Dn "cn=admin") (Password "secret")
     res `shouldBe` Right ()
 
   it "tries to bind as ‘admin’ with the wrong password, unsuccessfully" $ do
-    res <- locally $ \l -> do
+    res <- locally $ \l ->
       Ldap.bind l (Dn "cn=admin") (Password "public")
     res `shouldBe` Left
       (Ldap.ResponseError
@@ -31,7 +31,7 @@ spec = do
   it "binds as ‘pikachu’" $ do
     res <- locally $ \l -> do
       Ldap.bind l (Dn "cn=admin") (Password "secret")
-      Ldap.SearchEntry udn _ : []
+      [Ldap.SearchEntry udn _]
         <- Ldap.search l (Dn "o=localhost")
                          (scope WholeSubtree)
                          (Attr "cn" := "pikachu")

test/Ldap/Client/DeleteSpec.hs

@@ -26,7 +26,7 @@ spec = do
     res `shouldBe` Right ()
 
   it "tries to delete an non-existing entry, unsuccessfully" $ do
-    res <- locally $ \l -> do
+    res <- locally $ \l ->
       Ldap.delete l oddish
     res `shouldBe` Left
       (Ldap.ResponseError

test/Ldap/Client/ExtendedSpec.hs

@@ -21,7 +21,7 @@ spec = do
                                         (Dn "")
                                         "0 not supported"))
 
-  it "sends a startTLS  request" $ do
+  it "sends a StartTLS request" $ do
     res <- locally $ \l ->
       Ldap.startTls l
     res `shouldBe` Left

test/Ldap/Client/ModifySpec.hs

@@ -7,7 +7,7 @@ import           Test.Hspec
 import qualified Ldap.Asn1.Type as Ldap.Type
 import           Ldap.Client as Ldap
 
-import           SpecHelper (locally, charizard, pikachu)
+import           SpecHelper (locally, charizard, pikachu, raichu)
 
 
 spec :: Spec
@@ -30,7 +30,7 @@ spec = do
       res `shouldBe` Right ()
 
     it "tries to remove ‘pikachu’'s password, unsuccessfully" $ do
-      res <- locally $ \l -> do
+      res <- locally $ \l ->
         Ldap.modify l pikachu [Attr "password" `Delete` []]
       res `shouldBe` Left
         (ResponseError
@@ -45,7 +45,7 @@ spec = do
                                      (Dn "o=localhost")
                                      "cannot delete password"))
 
-  context "add" $ do
+  context "add" $
     it "can feed ‘charizard’" $ do
       res <- locally $ \l -> do
         [x] <- go l (Attr "cn" := "charizard")
@@ -57,7 +57,7 @@ spec = do
         lookupAttr (Attr "type") y `shouldBe` Just ["fire", "flying", "fed"]
       res `shouldBe` Right ()
 
-  context "replace" $ do
+  context "replace" $
     it "can put ‘charizard’ to sleep" $ do
       res <- locally $ \l -> do
         [x] <- go l (Attr "cn" := "charizard")
@@ -69,5 +69,23 @@ spec = do
         lookupAttr (Attr "type") y `shouldBe` Just ["sleeping"]
       res `shouldBe` Right ()
 
+  context "modify dn" $
+    it "evolves ‘pikachu’ into ‘raichu’" $ do
+      res <- locally $ \l -> do
+        [] <- go l (Attr "cn" := "raichu")
+
+        Ldap.modifyDn l pikachu (RelativeDn "cn=raichu") False Nothing
+        Ldap.modify l raichu [Attr "evolution" `Replace` ["1"]]
+
+        [res] <- go l (Attr "cn" := "raichu")
+        res `shouldBe`
+          SearchEntry raichu
+                      [ (Attr "cn",        ["raichu"])
+                      , (Attr "evolution", ["1"])
+                      , (Attr "type",      ["electric"])
+                      , (Attr "password",  ["i-choose-you"])
+                      ]
+      res `shouldBe` Right ()
+
 lookupAttr :: Attr -> SearchEntry -> Maybe [ByteString]
 lookupAttr a (SearchEntry _ as) = lookup a as

test/SpecHelper.hs

@@ -17,6 +17,7 @@ module SpecHelper
   , metapod
   , butterfree
   , pikachu
+  , raichu
   , vulpix
   , oddish
   ) where
@@ -90,6 +91,9 @@ butterfree = Dn "cn=butterfree,o=localhost"
 pikachu :: Dn
 pikachu = Dn "cn=pikachu,o=localhost"
 
+raichu :: Dn
+raichu = Dn "cn=raichu,o=localhost"
+
 vulpix :: Dn
 vulpix = Dn "cn=vulpix,o=localhost"
 

test/ldap.js

@@ -158,6 +158,19 @@ server.del('o=localhost', [], function(req, res, next) {
   return next(new ldapjs.NoSuchObjectError(req.dn.toString()));
 });
 
+server.modifyDN('o=localhost', [], function(req, res, next) {
+  for (var i = 0; i < pokemon.length; i++) {
+    if (req.dn.toString() === pokemon[i].dn) {
+      req.dn.rdns[0] = req.newRdn.rdns[0];
+      pokemon[i].dn = req.dn.toString();
+      pokemon[i].attributes.cn = req.newRdn.rdns[0].cn;
+    }
+  }
+
+  res.end();
+  return next();
+});
+
 server.compare('o=localhost', [], function(req, res, next) {
   for (var i = 0; i < pokemon.length; i++) {
     if (req.dn.toString() === pokemon[i].dn) {
@@ -183,6 +196,6 @@ server.compare('o=localhost', [], function(req, res, next) {
   return next(new ldapjs.NoSuchObjectError(req.dn.toString()));
 });
 
-server.listen(port, '0.0.0.0', function() {
+server.listen(port, function() {
   console.log("ldaps://localhost:%d", port);
 });