From 4b8863c1e4ce7927b67c49947d17fee07aa954fc Mon Sep 17 00:00:00 2001 From: Matvey Aksenov Date: Wed, 1 Apr 2015 20:10:10 +0000 Subject: [PATCH] Support Add --- README.markdown | 6 ++--- src/Ldap/Asn1/FromAsn1.hs | 8 ++++++ src/Ldap/Asn1/ToAsn1.hs | 29 ++++++++++++++++++++++ src/Ldap/Asn1/Type.hs | 8 ++++++ src/Ldap/Client.hs | 52 +++++++++++++++++++++++++++++++++++++-- test/Ldap/ClientSpec.hs | 23 ++++++++++++++++- test/ldap.js | 9 ++++++- 7 files changed, 128 insertions(+), 7 deletions(-) diff --git a/README.markdown b/README.markdown index 3a98281..823e418 100644 --- a/README.markdown +++ b/README.markdown @@ -1,8 +1,8 @@ +**NOTE: This is work in progress. Don't use it! If you really need LDAP integration, check out [LDAP][LDAP]** + ldap-client =========== -**NOTE: This is work in progress. Don't use it! If you really need LDAP integration, check out [LDAP][LDAP]** - This library implements (the parts of) [RFC 4511][rfc4511] Feature | RFC Section | Support @@ -12,7 +12,7 @@ Unbind Operation | 4.3 | ✔ Notice of Disconnection | 4.4.1 | ✘ Search Operation | 4.5 | ✔ (partial) Modify Operation | 4.6 | ✘ -Add Operation | 4.7 | ✘ +Add Operation | 4.7 | ✔ Delete Operation | 4.8 | ✘ Modify DN Operation | 4.9 | ✘ Compare Operation | 4.10 | ✘ diff --git a/src/Ldap/Asn1/FromAsn1.hs b/src/Ldap/Asn1/FromAsn1.hs index b5121e3..04cb1a0 100644 --- a/src/Ldap/Asn1/FromAsn1.hs +++ b/src/Ldap/Asn1/FromAsn1.hs @@ -32,6 +32,8 @@ LDAPMessage ::= SEQUENCE { searchResEntry SearchResultEntry, searchResDone SearchResultDone, searchResRef SearchResultReference, + addRequest AddRequest, + addResponse AddResponse, ... }, controls [0] Controls OPTIONAL } -} @@ -252,6 +254,12 @@ instance FromAsn1 ProtocolServerOp where 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) ] {- | diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs index d2b34cf..3c0ff06 100644 --- a/src/Ldap/Asn1/ToAsn1.hs +++ b/src/Ldap/Asn1/ToAsn1.hs @@ -28,6 +28,8 @@ LDAPMessage ::= SEQUENCE { searchResEntry SearchResultEntry, searchResDone SearchResultDone, searchResRef SearchResultReference, + addRequest AddRequest, + addResponse AddResponse, ... }, controls [0] Controls OPTIONAL } -} @@ -85,6 +87,18 @@ AssertionValue ::= OCTET STRING instance ToAsn1 AssertionValue where toAsn1 (AssertionValue s) = single (Asn1.OctetString s) +{- | +PartialAttribute ::= SEQUENCE { + type AttributeDescription, + vals SET OF value AttributeValue } + +Attribute ::= PartialAttribute(WITH COMPONENTS { + ..., + vals (SIZE(1..MAX))}) +-} +instance ToAsn1 Attribute where + toAsn1 (Attribute d xs) = sequence (toAsn1 d <> set (foldMap toAsn1 xs)) + {- | MatchingRuleId ::= LDAPString -} @@ -136,6 +150,10 @@ SearchRequest ::= [APPLICATION 3] SEQUENCE { typesOnly BOOLEAN, filter Filter, attributes AttributeSelection } + +AddRequest ::= [APPLICATION 8] SEQUENCE { + entry LDAPDN, + attributes AttributeList } -} instance ToAsn1 ProtocolClientOp where toAsn1 (BindRequest v n a) = @@ -163,6 +181,8 @@ instance ToAsn1 ProtocolClientOp where DerefInSearching -> 1 DerefFindingBaseObject -> 2 DerefAlways -> 3 + toAsn1 (AddRequest dn as) = + application 8 (toAsn1 dn <> toAsn1 as) {- | AuthenticationChoice ::= CHOICE { @@ -237,9 +257,18 @@ instance ToAsn1 MatchingRuleAssertion where , context 4 (single (Asn1.Boolean b)) ]) +{- | +AttributeList ::= SEQUENCE OF attribute Attribute +-} +instance ToAsn1 AttributeList where + toAsn1 (AttributeList xs) = sequence (foldMap toAsn1 xs) + sequence :: Endo [ASN1] -> Endo [ASN1] sequence = construction Asn1.Sequence +set :: Endo [ASN1] -> Endo [ASN1] +set = construction Asn1.Set + application :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1] application = construction . Asn1.Container Asn1.Application diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs index 7d1473c..d57a90b 100644 --- a/src/Ldap/Asn1/Type.hs +++ b/src/Ldap/Asn1/Type.hs @@ -20,6 +20,7 @@ data ProtocolClientOp = BindRequest Int8 LdapDn AuthenticationChoice | UnbindRequest | SearchRequest LdapDn Scope DerefAliases Int32 Int32 Bool Filter AttributeSelection + | AddRequest LdapDn AttributeList deriving (Show, Eq, Ord) data ProtocolServerOp = @@ -27,6 +28,7 @@ data ProtocolServerOp = | SearchResultEntry LdapDn PartialAttributeList | SearchResultReference (NonEmpty Uri) | SearchResultDone (LdapResult) + | AddResponse LdapResult deriving (Show, Eq, Ord) data AuthenticationChoice = Simple ByteString @@ -76,6 +78,9 @@ newtype MatchingRuleId = MatchingRuleId LdapString newtype AttributeSelection = AttributeSelection [LdapString] deriving (Show, Eq, Ord) +newtype AttributeList = AttributeList [Attribute] + deriving (Show, Eq, Ord) + newtype PartialAttributeList = PartialAttributeList [PartialAttribute] deriving (Show, Eq, Ord) @@ -142,6 +147,9 @@ data AttributeValueAssertion = AttributeValueAssertion AttributeDescription Asse newtype AssertionValue = AssertionValue ByteString deriving (Show, Eq, Ord) +data Attribute = Attribute AttributeDescription (NonEmpty AttributeValue) + deriving (Show, Eq, Ord) + data PartialAttribute = PartialAttribute AttributeDescription (Set AttributeValue) deriving (Show, Eq, Ord) diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs index 39be663..08d3c98 100644 --- a/src/Ldap/Client.hs +++ b/src/Ldap/Client.hs @@ -37,6 +37,13 @@ module Ldap.Client -- * Unbind Request , unbindAsync , unbindAsyncSTM + -- * Add Request + , AttrList + , AddError(..) + , add + , addEither + , addAsync + , addAsyncSTM -- * Waiting for Request Completion , wait , waitSTM @@ -159,8 +166,9 @@ input inq conn = flip fix [] $ \loop chunks -> do loop [] output :: ToAsn1 a => TQueue a -> Connection -> IO b -output out conn = forever $ - Conn.connectionPut conn . encode . toAsn1 =<< atomically (readTQueue out) +output out conn = forever $ do + msg <- atomically (readTQueue out) + Conn.connectionPut conn (encode (toAsn1 msg)) where encode x = Asn1.encodeASN1' Asn1.DER (appEndo x []) @@ -184,6 +192,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.AddResponse {} -> do + traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results) + return (Map.delete mid got, Map.delete mid results, counter) ]) @@ -431,6 +442,43 @@ unbindAsyncSTM l = die = error "Ldap.Client: do not wait for the response to UnbindRequest" +type AttrList f = [(Attr, f ByteString)] + +data AddError = + AddInvalidResponse Response + | AddErrorCode Type.ResultCode + deriving (Show, Eq, Typeable) + +instance Exception AddError + +add :: Ldap -> Dn -> AttrList NonEmpty -> IO () +add l dn as = + raise =<< addEither l dn as + +addEither :: Ldap -> Dn -> AttrList NonEmpty -> IO (Either AddError ()) +addEither l dn as = + wait =<< addAsync l dn as + +addAsync :: Ldap -> Dn -> AttrList NonEmpty -> IO (Async AddError ()) +addAsync l dn as = + atomically (addAsyncSTM l dn as) + +addAsyncSTM :: Ldap -> Dn -> AttrList NonEmpty -> STM (Async AddError ()) +addAsyncSTM l (Dn dn) as = + sendRequest l addResult + (Type.AddRequest (Type.LdapDn (Type.LdapString dn)) + (Type.AttributeList (map f as))) + where + f (Attr x, xs) = Type.Attribute (Type.AttributeDescription (Type.LdapString x)) + (fmap Type.AttributeValue xs) + +addResult :: NonEmpty Type.ProtocolServerOp -> Either AddError () +addResult (Type.AddResponse (Type.LdapResult code _ _ _) :| []) + | Type.Success <- code = Right () + | otherwise = Left (AddErrorCode code) +addResult res = Left (AddInvalidResponse res) + + wait :: Async e a -> IO (Either e a) wait = atomically . waitSTM diff --git a/test/Ldap/ClientSpec.hs b/test/Ldap/ClientSpec.hs index c8e4da5..6c05fb1 100644 --- a/test/Ldap/ClientSpec.hs +++ b/test/Ldap/ClientSpec.hs @@ -13,10 +13,15 @@ import SpecHelper (port) spec :: Spec spec = do + let locally = Ldap.with localhost port - search l f = Ldap.search l (Dn "o=localhost") (Ldap.scope WholeSubtree <> Ldap.typesOnly True) f [] + search l f = Ldap.search l (Dn "o=localhost") + (Ldap.scope WholeSubtree <> Ldap.typesOnly True) + f + [] context "bind" $ do + it "binds as admin" $ do res <- locally $ \l -> do Ldap.bind l (Dn "cn=admin") (Password "secret") @@ -36,6 +41,7 @@ spec = do res `shouldBe` Right () context "search" $ do + it "cannot search as ‘pikachu’" $ do res <- locally $ \l -> do Ldap.bind l pikachu (Password "i-choose-you") @@ -136,6 +142,20 @@ spec = do , wartortle ] res `shouldBe` Right () + + context "add" $ do + + it "adds an entry" $ do + res <- locally $ \l -> do + Ldap.add l vulpix + [ (Attr "cn", ["vulpix"]) + , (Attr "evolution", ["0"]) + , (Attr "type", ["fire"]) + ] + res <- search l (Attr "cn" := "vulpix") + dns res `shouldBe` [vulpix] + res `shouldBe` Right () + where bulbasaur = Dn "cn=bulbasaur,o=localhost" ivysaur = Dn "cn=ivysaur,o=localhost" @@ -150,6 +170,7 @@ spec = do metapod = Dn "cn=metapod,o=localhost" butterfree = Dn "cn=butterfree,o=localhost" pikachu = Dn "cn=pikachu,o=localhost" + vulpix = Dn "cn=vulpix,o=localhost" localhost :: Ldap.Host localhost = Ldap.Plain "localhost" diff --git a/test/ldap.js b/test/ldap.js index 69925af..d75ecf4 100755 --- a/test/ldap.js +++ b/test/ldap.js @@ -43,7 +43,7 @@ var pokemon = [ attributes: { cn: 'butterfree', evolution: "2", type: ["bug", "flying"], } }, { dn: 'cn=pikachu,o=localhost', - attributes: { cn: 'pikachu', evolution: "0", type: ["electic"], password: "i-choose-you" } + attributes: { cn: 'pikachu', evolution: "0", type: ["electric"], password: "i-choose-you" } }, ]; @@ -85,6 +85,13 @@ server.search('o=localhost', [authorize], function(req, res, next) { return next(); }); +server.add('o=localhost', [], function(req, res, next) { + var attributes = req.toObject().attributes; + pokemon.push(req.toObject()) + res.end(); + return next(); +}); + server.listen(port, function() { console.log("ldap://localhost:%d", port); });