Support Add

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

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)
     ]
 
 {- |

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
 

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)
 

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
 

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"

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);
 });