Implement Extended Operation support

README.markdown

@@ -10,19 +10,22 @@ 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         | ✔†
+Search Operation             | 4.5         | ✔\*
 Modify Operation             | 4.6         | ✔
 Add Operation                | 4.7         | ✔
 Delete Operation             | 4.8         | ✔
 Modify DN Operation          | 4.9         | ✘
 Compare Operation            | 4.10        | ✔
 Abandon Operation            | 4.11        | ✘
-Extended Operation           | 4.12        | ✘
+Extended Operation           | 4.12        | ✔
 IntermediateResponse Message | 4.13        | ✘
-StartTLS Operation           | 4.14        | ✘
+StartTLS Operation           | 4.14        | ✔†
 LDAP over TLS                | -           | ✔
 
-†: approximate and extensible matches are untested, so probably do not work
+\*: approximate and extensible matches are untested, so probably do not work
+†: only serves as an example of Extended Operation, meaning that it does not change
+connection's state on success, so it's useless for all practical purposes.
+In other words, use LDAP over TLS instead.
 
 ```
 % git grep '\bString\b' | wc -l

src/Ldap/Asn1/FromAsn1.hs

@@ -62,6 +62,14 @@ instance FromAsn1 LdapString where
       Right t -> return (LdapString t)
       Left  _ -> empty
 
+{- |
+LDAPOID ::= OCTET STRING -- Constrained to <numericoid>
+-}
+instance FromAsn1 LdapOid where
+  fromAsn1 = do
+    Asn1.OctetString s <- next
+    return (LdapOid s)
+
 {- |
 LDAPDN ::= LDAPString
 -}
@@ -250,6 +258,17 @@ instance FromAsn1 ProtocolServerOp where
     , fmap AddResponse (app 9)
     , fmap DeleteResponse (app 11)
     , fmap CompareResponse (app 15)
+    , do
+      Asn1.Start (Asn1.Container Asn1.Application 24) <- next
+      res <- fromAsn1
+      name <- optional $ do
+        Asn1.Other Asn1.Context 0 s <- next
+        return s
+      value <- optional $ do
+        Asn1.Other Asn1.Context 1 s <- next
+        return s
+      Asn1.End (Asn1.Container Asn1.Application 24) <- next
+      return (ExtendedResponse res (fmap LdapOid name) value)
     ]
    where
     app l = do

src/Ldap/Asn1/ToAsn1.hs

@@ -175,6 +175,11 @@ DelRequest ::= [APPLICATION 10] LDAPDN
 CompareRequest ::= [APPLICATION 14] SEQUENCE {
      entry           LDAPDN,
      ava             AttributeValueAssertion }
+
+ExtendedRequest ::= [APPLICATION 23] SEQUENCE {
+     requestName      [0] LDAPOID,
+     requestValue     [1] OCTET STRING OPTIONAL }
+
 -}
 instance ToAsn1 ProtocolClientOp where
   toAsn1 (BindRequest v n a) =
@@ -216,6 +221,11 @@ instance ToAsn1 ProtocolClientOp where
     other Asn1.Application 10 (Text.encodeUtf8 dn)
   toAsn1 (CompareRequest dn av) =
     application 14 (toAsn1 dn <> sequence (toAsn1 av))
+  toAsn1 (ExtendedRequest (LdapOid oid) mv) =
+    application 23 (fold
+     [ other Asn1.Context 0 oid
+     , maybe mempty (other Asn1.Context 1) mv
+     ])
 
 {- |
 AuthenticationChoice ::= CHOICE {

src/Ldap/Asn1/Type.hs

@@ -23,6 +23,7 @@ data ProtocolClientOp =
   | DeleteRequest LdapDn
   | CompareRequest LdapDn AttributeValueAssertion
   | ModifyRequest LdapDn [(Operation, PartialAttribute)]
+  | ExtendedRequest LdapOid (Maybe ByteString)
     deriving (Show, Eq, Ord)
 
 data ProtocolServerOp =
@@ -34,6 +35,7 @@ data ProtocolServerOp =
   | AddResponse LdapResult
   | DeleteResponse LdapResult
   | CompareResponse LdapResult
+  | ExtendedResponse LdapResult (Maybe LdapOid) (Maybe ByteString)
     deriving (Show, Eq, Ord)
 
 data AuthenticationChoice = Simple ByteString

src/Ldap/Client.hs

@@ -36,6 +36,9 @@ module Ldap.Client
   , delete
     -- * Compare Operation
   , compare
+    -- * Extended Operation
+  , Oid(..)
+  , extended
     -- * Waiting for Operation Completion
   , wait
   , waitSTM
@@ -82,6 +85,7 @@ import           Ldap.Client.Modify (Operation(..), modify)
 import           Ldap.Client.Add (add)
 import           Ldap.Client.Delete (delete)
 import           Ldap.Client.Compare (compare)
+import           Ldap.Client.Extended (extended)
 
 
 newLdap :: IO Ldap
@@ -199,4 +203,7 @@ dispatch Ldap { client } inq outq =
              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

@@ -0,0 +1,64 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Ldap.Client.Extended
+  ( extended
+  , extendedEither
+  , extendedAsync
+  , extendedAsyncSTM
+  , startTls
+  , startTlsEither
+  , startTlsAsync
+  , startTlsAsyncSTM
+  ) where
+
+import           Control.Monad ((<=<))
+import           Control.Monad.STM (STM, atomically)
+import           Data.ByteString (ByteString)
+import           Data.List.NonEmpty (NonEmpty((:|)))
+
+import qualified Ldap.Asn1.Type as Type
+import           Ldap.Client.Internal
+
+
+extended :: Ldap -> Oid -> Maybe ByteString -> IO ()
+extended l oid mv =
+  raise =<< extendedEither l oid mv
+
+extendedEither :: Ldap -> Oid -> Maybe ByteString -> IO (Either ResponseError ())
+extendedEither l oid mv =
+  wait =<< extendedAsync l oid mv
+
+extendedAsync :: Ldap -> Oid -> Maybe ByteString -> IO (Async ())
+extendedAsync l oid mv =
+  atomically (extendedAsyncSTM l oid mv)
+
+extendedAsyncSTM :: Ldap -> Oid -> Maybe ByteString -> STM (Async ())
+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
+
+extendedResult :: Request -> Response -> Either ResponseError ()
+extendedResult req (Type.ExtendedResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))
+                                                                (Type.LdapString msg) _) _ _ :| [])
+  | Type.Success <- code = Right ()
+  | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
+extendedResult req res = Left (ResponseInvalid req res)
+
+
+startTls :: Ldap -> IO ()
+startTls =
+  raise <=< startTlsEither
+
+startTlsEither :: Ldap -> IO (Either ResponseError ())
+startTlsEither =
+  wait <=< startTlsAsync
+
+startTlsAsync :: Ldap -> IO (Async ())
+startTlsAsync =
+  atomically . startTlsAsyncSTM
+
+startTlsAsyncSTM :: Ldap -> STM (Async ())
+startTlsAsyncSTM l =
+  extendedAsyncSTM l (Oid "1.3.6.1.4.1.1466.20037") Nothing

src/Ldap/Client/Internal.hs

@@ -8,6 +8,7 @@ module Ldap.Client.Internal
   , ClientMessage(..)
   , Type.ResultCode(..)
   , Async
+  , Oid(..)
   , AttrList
     -- * Waiting for Request Completion
   , wait
@@ -59,6 +60,10 @@ instance Functor Async where
 
 newtype Dn = Dn Text
     deriving (Show, Eq)
+
+newtype Oid = Oid ByteString
+    deriving (Show, Eq)
+
 newtype Password = Password ByteString
     deriving (Show, Eq)
 

test/Ldap/Client/ExtendedSpec.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Ldap.Client.ExtendedSpec (spec) where
+
+import           Test.Hspec
+
+import           Ldap.Client as Ldap
+import           Ldap.Client.Extended as Ldap
+import qualified Ldap.Asn1.Type as Ldap.Type
+
+import           SpecHelper (locally )
+
+
+spec :: Spec
+spec = do
+  it "sends an extended request" $ do
+    res <- locally $ \l ->
+      Ldap.extended l (Oid "0") Nothing
+    res `shouldBe` Left
+      (ResponseError (ResponseErrorCode (Ldap.Type.ExtendedRequest (Ldap.Type.LdapOid "0") Nothing)
+                                        ProtocolError
+                                        (Dn "")
+                                        "0 not supported"))
+
+  it "sends a startTLS  request" $ do
+    res <- locally $ \l ->
+      Ldap.startTls l
+    res `shouldBe` Left
+      (ResponseError (ResponseErrorCode (Ldap.Type.ExtendedRequest (Ldap.Type.LdapOid "1.3.6.1.4.1.1466.20037")
+                                                                   Nothing)
+                                        ProtocolError
+                                        (Dn "")
+                                        "1.3.6.1.4.1.1466.20037 not supported"))

test/ldap.js

@@ -89,50 +89,6 @@ 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.del('o=localhost', [], function(req, res, next) {
-  for (var i = 0; i < pokemon.length; i++) {
-    if (req.dn.toString() === pokemon[i].dn) {
-      pokemon.splice(i, 1);
-      res.end();
-      return next();
-    }
-  }
-
-  return next(new ldapjs.NoSuchObjectError(req.dn.toString()));
-});
-
-server.compare('o=localhost', [], function(req, res, next) {
-  for (var i = 0; i < pokemon.length; i++) {
-    if (req.dn.toString() === pokemon[i].dn) {
-      for (var attribute in pokemon[i].attributes) {
-        if (attribute === req.attribute) {
-          for (var j = 0; j < pokemon[i].attributes[attribute].length; j++) {
-            if (pokemon[i].attributes[attribute][j] === req.value) {
-              res.end(true);
-              return next();
-            }
-          }
-
-          res.end(false);
-          return next();
-        }
-      }
-
-      res.end(false);
-      return 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; });
@@ -183,6 +139,50 @@ server.modify('o=localhost', [], function(req, res, next) {
   return next(new ldapjs.NoSuchObjectError(dn));
 });
 
+server.add('o=localhost', [], function(req, res, next) {
+  var attributes = req.toObject().attributes;
+  pokemon.push(req.toObject())
+  res.end();
+  return next();
+});
+
+server.del('o=localhost', [], function(req, res, next) {
+  for (var i = 0; i < pokemon.length; i++) {
+    if (req.dn.toString() === pokemon[i].dn) {
+      pokemon.splice(i, 1);
+      res.end();
+      return next();
+    }
+  }
+
+  return next(new ldapjs.NoSuchObjectError(req.dn.toString()));
+});
+
+server.compare('o=localhost', [], function(req, res, next) {
+  for (var i = 0; i < pokemon.length; i++) {
+    if (req.dn.toString() === pokemon[i].dn) {
+      for (var attribute in pokemon[i].attributes) {
+        if (attribute === req.attribute) {
+          for (var j = 0; j < pokemon[i].attributes[attribute].length; j++) {
+            if (pokemon[i].attributes[attribute][j] === req.value) {
+              res.end(true);
+              return next();
+            }
+          }
+
+          res.end(false);
+          return next();
+        }
+      }
+
+      res.end(false);
+      return next();
+    }
+  }
+
+  return next(new ldapjs.NoSuchObjectError(req.dn.toString()));
+});
+
 server.listen(port, function() {
   console.log("ldaps://localhost:%d", port);
 });