Support IntermediateResponse

README.markdown

@@ -20,7 +20,7 @@ Modify DN Operation          | 4.9         | ✔
 Compare Operation            | 4.10        | ✔
 Abandon Operation            | 4.11        | ✘
 Extended Operation           | 4.12        | ✔
-IntermediateResponse Message | 4.13        | ✘
+IntermediateResponse Message | 4.13        | ✔
 StartTLS Operation           | 4.14        | ✔†
 LDAP over TLS                | -           | ✔
 

src/Ldap/Asn1/FromAsn1.hs

@@ -294,9 +294,26 @@ AddResponse ::= [APPLICATION 9] LDAPResult
 DelResponse ::= [APPLICATION 11] LDAPResult
 @
 
+@
+ModifyDNResponse ::= [APPLICATION 13] LDAPResult
+@
+
 @
 CompareResponse ::= [APPLICATION 15] LDAPResult
 @
+
+@
+ExtendedResponse ::= [APPLICATION 24] SEQUENCE {
+     COMPONENTS OF LDAPResult,
+     responseName     [10] LDAPOID OPTIONAL,
+     responseValue    [11] OCTET STRING OPTIONAL }
+@
+
+@
+IntermediateResponse ::= [APPLICATION 25] SEQUENCE {
+     responseName     [0] LDAPOID OPTIONAL,
+     responseValue    [1] OCTET STRING OPTIONAL }
+@
 -}
 instance FromAsn1 ProtocolServerOp where
   fromAsn1 = asum
@@ -326,6 +343,15 @@ instance FromAsn1 ProtocolServerOp where
         return s
       Asn1.End (Asn1.Container Asn1.Application 24) <- next
       return (ExtendedResponse res (fmap LdapOid name) value)
+
+    , do
+      Asn1.Start (Asn1.Container Asn1.Application 25) <- next
+      name  <- optional fromAsn1
+      value <- optional $ do
+        Asn1.OctetString s <- next
+        return s
+      Asn1.End (Asn1.Container Asn1.Application 25) <- next
+      return (IntermediateResponse name value)
     ]
    where
     app l = do

src/Ldap/Asn1/ToAsn1.hs

@@ -372,11 +372,11 @@ MatchingRuleAssertion ::= SEQUENCE {
 @
 -}
 instance ToAsn1 MatchingRuleAssertion where
-  toAsn1 (MatchingRuleAssertion mmr mad (AssertionValue av) _) = (fold
+  toAsn1 (MatchingRuleAssertion mmr mad (AssertionValue av) _) = fold
     [ maybe mempty f mmr
     , maybe mempty g mad
     , other Asn1.Context 3 av
-    ])
+    ]
    where
     f (MatchingRuleId (LdapString x)) = other Asn1.Context 1 (Text.encodeUtf8 x)
     g (AttributeDescription (LdapString x)) = other Asn1.Context 2 (Text.encodeUtf8 x)

src/Ldap/Asn1/Type.hs

@@ -38,6 +38,7 @@ data ProtocolServerOp =
   | ModifyDnResponse LdapResult
   | CompareResponse LdapResult
   | ExtendedResponse LdapResult (Maybe LdapOid) (Maybe ByteString)
+  | IntermediateResponse (Maybe LdapOid) (Maybe ByteString)
     deriving (Show, Eq, Ord)
 
 data AuthenticationChoice = Simple ByteString

src/Ldap/Client.hs

@@ -65,7 +65,7 @@ import qualified Data.ASN1.Encoding as Asn1
 import qualified Data.ASN1.Error as Asn1
 import qualified Data.ByteString as ByteString
 import qualified Data.ByteString.Lazy as ByteString.Lazy
-import           Data.Foldable (traverse_, asum)
+import           Data.Foldable (asum)
 import           Data.Function (fix)
 import           Data.List.NonEmpty (NonEmpty((:|)))
 import qualified Data.Map.Strict as Map
@@ -98,6 +98,8 @@ import           Ldap.Client.Delete (delete)
 import           Ldap.Client.Compare (compare)
 import           Ldap.Client.Extended (extended)
 
+{-# ANN module "HLint: ignore Use first" #-}
+
 
 newLdap :: IO Ldap
 newLdap = Ldap
@@ -184,22 +186,33 @@ dispatch
   -> TQueue (Type.LdapMessage Request)
   -> IO a
 dispatch Ldap { client } inq outq =
-  flip fix (Map.empty, Map.empty, 1) $ \loop (!got, !results, !counter) ->
+  flip fix (Map.empty, 1) $ \loop (!req, !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.SearchResultEntry {} ->
-               return (Map.insertWith (++) mid [op] got, results, counter)
-             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)
-             _ -> do
-               traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
-               return (Map.delete mid got, Map.delete mid results, counter)
+           return (Map.insert (Type.Id counter) ([], var) req, counter + 1)
+      , do Type.LdapMessage mid op _
+               <- readTQueue inq
+           res <- case op of
+             Type.BindResponse {}          -> done mid op req
+             Type.SearchResultEntry {}     -> saveUp mid op req
+             Type.SearchResultReference {} -> return req
+             Type.SearchResultDone {}      -> done mid op req
+             Type.ModifyResponse {}        -> done mid op req
+             Type.AddResponse {}           -> done mid op req
+             Type.DeleteResponse {}        -> done mid op req
+             Type.ModifyDnResponse {}      -> done mid op req
+             Type.CompareResponse {}       -> done mid op req
+             Type.ExtendedResponse {}      -> done mid op req
+             Type.IntermediateResponse {}  -> saveUp mid op req
+           return (res, counter)
       ])
+ where
+  saveUp mid op res =
+    return (Map.adjust (\(stack, var) -> (op : stack, var)) mid res)
+  done mid op req =
+    case Map.lookup mid req of
+      Nothing -> return req
+      Just (stack, var) -> do
+        putTMVar var (op :| stack)
+        return (Map.delete mid req)