From dd1a89d4268d3bdf659b0c5e95d788c35ebad44c Mon Sep 17 00:00:00 2001 From: Matvey Aksenov Date: Fri, 3 Apr 2015 22:27:35 +0000 Subject: [PATCH] Support ModifyDN --- README.markdown | 2 +- src/Ldap/Asn1/FromAsn1.hs | 4 ++++ src/Ldap/Asn1/ToAsn1.hs | 21 ++++++++++++++++++++ src/Ldap/Asn1/Type.hs | 7 ++++++- src/Ldap/Client.hs | 29 ++++++++------------------- src/Ldap/Client/Extended.hs | 4 ++-- src/Ldap/Client/Internal.hs | 5 ++++- src/Ldap/Client/Modify.hs | 34 ++++++++++++++++++++++++++++++++ test/Ldap/Client/AddSpec.hs | 6 +++--- test/Ldap/Client/BindSpec.hs | 6 +++--- test/Ldap/Client/DeleteSpec.hs | 2 +- test/Ldap/Client/ExtendedSpec.hs | 2 +- test/Ldap/Client/ModifySpec.hs | 26 ++++++++++++++++++++---- test/SpecHelper.hs | 4 ++++ test/ldap.js | 15 +++++++++++++- 15 files changed, 128 insertions(+), 39 deletions(-) diff --git a/README.markdown b/README.markdown index ff90d3e..78d9193 100644 --- a/README.markdown +++ b/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 | ✔ diff --git a/src/Ldap/Asn1/FromAsn1.hs b/src/Ldap/Asn1/FromAsn1.hs index bd03ed2..65a69d6 100644 --- a/src/Ldap/Asn1/FromAsn1.hs +++ b/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 diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs index 0e6b41b..e8c819f 100644 --- a/src/Ldap/Asn1/ToAsn1.hs +++ b/src/Ldap/Asn1/ToAsn1.hs @@ -61,6 +61,12 @@ 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 -} @@ -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) = diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs index 9fe6773..e41eae5 100644 --- a/src/Ldap/Asn1/Type.hs +++ b/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) diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs index c449551..3df7b19 100644 --- a/src/Ldap/Client.hs +++ b/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 - traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results) - return (Map.delete mid got, Map.delete mid results, counter) - Type.SearchResultEntry {} -> do + Type.SearchResultEntry {} -> 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 - 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 + _ -> do traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results) return (Map.delete mid got, Map.delete mid results, counter) ]) diff --git a/src/Ldap/Client/Extended.hs b/src/Ldap/Client/Extended.hs index a7e0d06..7a722bb 100644 --- a/src/Ldap/Client/Extended.hs +++ b/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 = - Type.ExtendedRequest (Type.LdapOid oid) mv +extendedRequest (Oid oid) = + Type.ExtendedRequest (Type.LdapOid oid) extendedResult :: Request -> Response -> Either ResponseError () extendedResult req (Type.ExtendedResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn)) diff --git a/src/Ldap/Client/Internal.hs b/src/Ldap/Client/Internal.hs index 2cd9a44..692f204 100644 --- a/src/Ldap/Client/Internal.hs +++ b/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) diff --git a/src/Ldap/Client/Modify.hs b/src/Ldap/Client/Modify.hs index 34af833..8b567ce 100644 --- a/src/Ldap/Client/Modify.hs +++ b/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) diff --git a/test/Ldap/Client/AddSpec.hs b/test/Ldap/Client/AddSpec.hs index 42bb0a1..3ecbbef 100644 --- a/test/Ldap/Client/AddSpec.hs +++ b/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 "evolution", (NonEmpty.fromList ["0"])) - , (Attr "type", (NonEmpty.fromList ["fire"])) + [ (Attr "cn", NonEmpty.fromList ["vulpix"]) + , (Attr "evolution", NonEmpty.fromList ["0"]) + , (Attr "type", NonEmpty.fromList ["fire"]) ] res <- go l (Attr "cn" := "vulpix") dns res `shouldBe` [vulpix] diff --git a/test/Ldap/Client/BindSpec.hs b/test/Ldap/Client/BindSpec.hs index 2465bf1..d1f1328 100644 --- a/test/Ldap/Client/BindSpec.hs +++ b/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") diff --git a/test/Ldap/Client/DeleteSpec.hs b/test/Ldap/Client/DeleteSpec.hs index 9141299..0ab9bac 100644 --- a/test/Ldap/Client/DeleteSpec.hs +++ b/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 diff --git a/test/Ldap/Client/ExtendedSpec.hs b/test/Ldap/Client/ExtendedSpec.hs index 6322be7..53cef1d 100644 --- a/test/Ldap/Client/ExtendedSpec.hs +++ b/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 diff --git a/test/Ldap/Client/ModifySpec.hs b/test/Ldap/Client/ModifySpec.hs index c187601..e2e947c 100644 --- a/test/Ldap/Client/ModifySpec.hs +++ b/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 diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 4d151e2..f0de15a 100644 --- a/test/SpecHelper.hs +++ b/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" diff --git a/test/ldap.js b/test/ldap.js index 8cb0965..5a13702 100755 --- a/test/ldap.js +++ b/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); });