diff --git a/README.markdown b/README.markdown index 84b2394..7722db4 100644 --- a/README.markdown +++ b/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 | - | ✔ diff --git a/src/Ldap/Asn1/FromAsn1.hs b/src/Ldap/Asn1/FromAsn1.hs index 956bddf..3c2c154 100644 --- a/src/Ldap/Asn1/FromAsn1.hs +++ b/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 diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs index 3622b0f..944b10f 100644 --- a/src/Ldap/Asn1/ToAsn1.hs +++ b/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) diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs index e41eae5..a18aa59 100644 --- a/src/Ldap/Asn1/Type.hs +++ b/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 diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs index 2b70537..dfc0b65 100644 --- a/src/Ldap/Client.hs +++ b/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)