diff --git a/README.markdown b/README.markdown index dd15d59..4970e1a 100644 --- a/README.markdown +++ b/README.markdown @@ -10,8 +10,8 @@ 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 | ✔ (partial) -Modify Operation | 4.6 | ✘ +Search Operation | 4.5 | ✔† +Modify Operation | 4.6 | ✔ Add Operation | 4.7 | ✔ Delete Operation | 4.8 | ✔ Modify DN Operation | 4.9 | ✘ @@ -22,6 +22,8 @@ IntermediateResponse Message | 4.13 | ✘ StartTLS Operation | 4.14 | ✘ LDAP over TLS | - | ✔ +†: approximate and extensible matches are untested, so probably do not work + ``` % git grep '\bString\b' | wc -l 2 diff --git a/src/Ldap/Asn1/FromAsn1.hs b/src/Ldap/Asn1/FromAsn1.hs index 55dc42e..6dd33a1 100644 --- a/src/Ldap/Asn1/FromAsn1.hs +++ b/src/Ldap/Asn1/FromAsn1.hs @@ -6,13 +6,12 @@ module Ldap.Asn1.FromAsn1 , next ) where -import Control.Applicative (Alternative(..), optional) -import Control.Monad ((>=>), MonadPlus(..)) +import Control.Applicative (Alternative(..), liftA2, optional) +import Control.Monad (MonadPlus(..), (>=>), guard) import Data.ASN1.Types (ASN1) import qualified Data.ASN1.Types as Asn1 import Data.Foldable (asum) import Data.List.NonEmpty (some1) -import qualified Data.Set as Set import qualified Data.Text.Encoding as Text import Ldap.Asn1.Type @@ -96,7 +95,7 @@ instance FromAsn1 PartialAttribute where vs <- many fromAsn1 Asn1.End Asn1.Set <- next Asn1.End Asn1.Sequence <- next - return (PartialAttribute d (Set.fromList vs)) + return (PartialAttribute d vs) {- | LDAPResult ::= SEQUENCE { @@ -234,6 +233,8 @@ SearchResultEntry ::= [APPLICATION 4] SEQUENCE { SearchResultDone ::= [APPLICATION 5] LDAPResult +ModifyResponse ::= [APPLICATION 7] LDAPResult + AddResponse ::= [APPLICATION 9] LDAPResult DelResponse ::= [APPLICATION 11] LDAPResult @@ -242,43 +243,22 @@ CompareResponse ::= [APPLICATION 15] LDAPResult -} instance FromAsn1 ProtocolServerOp where fromAsn1 = asum - [ do - Asn1.Start (Asn1.Container Asn1.Application 1) <- next - result <- fromAsn1 - Asn1.End (Asn1.Container Asn1.Application 1) <- next - return (BindResponse result Nothing) - - , do - Asn1.Start (Asn1.Container Asn1.Application 4) <- next - ldapDn <- fromAsn1 - partialAttributeList <- fromAsn1 - Asn1.End (Asn1.Container Asn1.Application 4) <- next - return (SearchResultEntry ldapDn partialAttributeList) - - , do - Asn1.Start (Asn1.Container Asn1.Application 5) <- next - 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) - - , do - Asn1.Start (Asn1.Container Asn1.Application 11) <- next - result <- fromAsn1 - Asn1.End (Asn1.Container Asn1.Application 11) <- next - return (DeleteResponse result) - - , do - Asn1.Start (Asn1.Container Asn1.Application 15) <- next - result <- fromAsn1 - Asn1.End (Asn1.Container Asn1.Application 15) <- next - return (CompareResponse result) + [ fmap (\res -> BindResponse res Nothing) (app 1) + , fmap (uncurry SearchResultEntry) (app 4) + , fmap SearchResultDone (app 5) + , fmap ModifyResponse (app 7) + , fmap AddResponse (app 9) + , fmap DeleteResponse (app 11) + , fmap CompareResponse (app 15) ] + where + app l = do + Asn1.Start (Asn1.Container Asn1.Application x) <- next + guard (x == l) + res <- fromAsn1 + Asn1.End (Asn1.Container Asn1.Application y) <- next + guard (y == l) + return res {- | PartialAttributeList ::= SEQUENCE OF partialAttribute PartialAttribute @@ -290,6 +270,9 @@ instance FromAsn1 PartialAttributeList where Asn1.End Asn1.Sequence <- next return (PartialAttributeList xs) +instance (FromAsn1 a, FromAsn1 b) => FromAsn1 (a, b) where + fromAsn1 = liftA2 (,) fromAsn1 fromAsn1 + newtype Parser s a = Parser { unParser :: s -> Maybe (s, a) } diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs index c6c6760..12cc53b 100644 --- a/src/Ldap/Asn1/ToAsn1.hs +++ b/src/Ldap/Asn1/ToAsn1.hs @@ -9,7 +9,7 @@ import Data.Foldable (fold, foldMap) import Data.Maybe (Maybe, maybe) import Data.Monoid (Endo(Endo), (<>), mempty) import qualified Data.Text.Encoding as Text -import Prelude ((.), fromIntegral) +import Prelude (Integer, (.), fromIntegral) import Ldap.Asn1.Type @@ -87,11 +87,16 @@ AssertionValue ::= OCTET STRING instance ToAsn1 AssertionValue where toAsn1 (AssertionValue s) = single (Asn1.OctetString s) + {- | PartialAttribute ::= SEQUENCE { type AttributeDescription, vals SET OF value AttributeValue } +-} +instance ToAsn1 PartialAttribute where + toAsn1 (PartialAttribute d xs) = sequence (toAsn1 d <> set (foldMap toAsn1 xs)) +{- | Attribute ::= PartialAttribute(WITH COMPONENTS { ..., vals (SIZE(1..MAX))}) @@ -151,6 +156,16 @@ SearchRequest ::= [APPLICATION 3] SEQUENCE { filter Filter, attributes AttributeSelection } +ModifyRequest ::= [APPLICATION 6] SEQUENCE { + object LDAPDN, + changes SEQUENCE OF change SEQUENCE { + operation ENUMERATED { + add (0), + delete (1), + replace (2), + ... }, + modification PartialAttribute } } + AddRequest ::= [APPLICATION 8] SEQUENCE { entry LDAPDN, attributes AttributeList } @@ -169,8 +184,8 @@ instance ToAsn1 ProtocolClientOp where toAsn1 (SearchRequest bo s da sl tl to f a) = application 3 (fold [ toAsn1 bo - , single (Asn1.Enumerated s') - , single (Asn1.Enumerated da') + , enum s' + , enum da' , single (Asn1.IntVal (fromIntegral sl)) , single (Asn1.IntVal (fromIntegral tl)) , single (Asn1.Boolean to) @@ -187,6 +202,14 @@ instance ToAsn1 ProtocolClientOp where DerefInSearching -> 1 DerefFindingBaseObject -> 2 DerefAlways -> 3 + toAsn1 (ModifyRequest dn xs) = + application 6 (fold + [ toAsn1 dn + , sequence (foldMap (\(op, pa) -> sequence (enum (case op of + Add -> 0 + Delete -> 1 + Replace -> 2) <> toAsn1 pa)) xs) + ]) toAsn1 (AddRequest dn as) = application 8 (toAsn1 dn <> toAsn1 as) toAsn1 (DeleteRequest (LdapDn (LdapString dn))) = @@ -294,5 +317,8 @@ other c t = single . Asn1.Other c t optional :: ToAsn1 a => Maybe a -> Endo [ASN1] optional = maybe mempty toAsn1 +enum :: Integer -> Endo [ASN1] +enum = single . Asn1.Enumerated + single :: a -> Endo [a] single x = Endo (x :) diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs index c9cf289..6c065f8 100644 --- a/src/Ldap/Asn1/Type.hs +++ b/src/Ldap/Asn1/Type.hs @@ -3,7 +3,6 @@ module Ldap.Asn1.Type where import Data.ByteString (ByteString) import Data.Int (Int8, Int32) import Data.List.NonEmpty (NonEmpty) -import Data.Set (Set) import Data.Text (Text) @@ -23,6 +22,7 @@ data ProtocolClientOp = | AddRequest LdapDn AttributeList | DeleteRequest LdapDn | CompareRequest LdapDn AttributeValueAssertion + | ModifyRequest LdapDn [(Operation, PartialAttribute)] deriving (Show, Eq, Ord) data ProtocolServerOp = @@ -30,6 +30,7 @@ data ProtocolServerOp = | SearchResultEntry LdapDn PartialAttributeList | SearchResultReference (NonEmpty Uri) | SearchResultDone (LdapResult) + | ModifyResponse LdapResult | AddResponse LdapResult | DeleteResponse LdapResult | CompareResponse LdapResult @@ -154,7 +155,7 @@ newtype AssertionValue = AssertionValue ByteString data Attribute = Attribute AttributeDescription (NonEmpty AttributeValue) deriving (Show, Eq, Ord) -data PartialAttribute = PartialAttribute AttributeDescription (Set AttributeValue) +data PartialAttribute = PartialAttribute AttributeDescription [AttributeValue] deriving (Show, Eq, Ord) newtype LdapDn = LdapDn LdapString @@ -166,6 +167,12 @@ newtype ReferralUris = ReferralUris (NonEmpty Uri) newtype Uri = Uri LdapString deriving (Show, Eq, Ord) +data Operation = + Add + | Delete + | Replace + deriving (Show, Eq, Ord) + -- | The LDAPString is a notational convenience to indicate that, although -- strings of LDAPString type encode as ASN.1 OCTET STRING types, the -- [ISO10646] character set (a superset of [Unicode]) is used, encoded diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs index 015941b..cdc6cb4 100644 --- a/src/Ldap/Client.hs +++ b/src/Ldap/Client.hs @@ -9,12 +9,12 @@ module Ldap.Client , Type.ResultCode(..) , Async , with - -- * Bind Request + -- * Bind Operation , Dn(..) , Password(..) , BindError(..) , bind - -- * Search Request + -- * Search Operation , Attr(..) , SearchError(..) , search @@ -27,17 +27,21 @@ module Ldap.Client , derefAliases , Filter(..) , SearchEntry(..) - -- * Add Request + -- * Modify Operation + , ModifyError(..) + , Operation(..) + , modify + -- * Add Operation , AttrList , AddError(..) , add - -- * Delete Request + -- * Delete Operation , DeleteError(..) , delete - -- * Compare Request + -- * Compare Operation , CompareError(..) , compare - -- * Waiting for Request Completion + -- * Waiting for Operation Completion , wait , waitSTM ) where @@ -80,6 +84,7 @@ import Ldap.Client.Search , Filter(..) , SearchEntry(..) ) +import Ldap.Client.Modify (ModifyError(..), Operation(..), modify) import Ldap.Client.Compare (CompareError(..), compare) @@ -92,6 +97,7 @@ data LdapError = | ParseError Asn1.ASN1Error | BindError BindError | SearchError SearchError + | ModifyError ModifyError | AddError AddError | DeleteError DeleteError | CompareError CompareError @@ -115,6 +121,7 @@ with host port f = do , Handler (return . Left . ParseError) , Handler (return . Left . BindError) , Handler (return . Left . SearchError) + , Handler (return . Left . ModifyError) , Handler (return . Left . AddError) , Handler (return . Left . DeleteError) , Handler (return . Left . CompareError) @@ -194,6 +201,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.ModifyResponse {} -> do + traverse_ (\var -> putTMVar var (op :| [])) (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) diff --git a/src/Ldap/Client/Bind.hs b/src/Ldap/Client/Bind.hs index 38550a5..9409a01 100644 --- a/src/Ldap/Client/Bind.hs +++ b/src/Ldap/Client/Bind.hs @@ -14,8 +14,8 @@ import Control.Monad.STM (STM, atomically) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Typeable (Typeable) -import Ldap.Client.Internal import qualified Ldap.Asn1.Type as Type +import Ldap.Client.Internal data BindError = diff --git a/src/Ldap/Client/Modify.hs b/src/Ldap/Client/Modify.hs new file mode 100644 index 0000000..8d23f0c --- /dev/null +++ b/src/Ldap/Client/Modify.hs @@ -0,0 +1,66 @@ +module Ldap.Client.Modify + ( ModifyError(..) + , Operation(..) + , modify + , modifyEither + , modifyAsync + , modifyAsyncSTM + ) where + +import Control.Exception (Exception) +import Control.Monad.STM (STM, atomically) +import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Text (Text) +import Data.Typeable (Typeable) + +import qualified Ldap.Asn1.Type as Type +import Ldap.Client.Internal + + +data ModifyError = + ModifyInvalidResponse Response + | ModifyErrorCode Type.ResultCode Dn Text + deriving (Show, Eq, Typeable) + +data Operation = + Delete Attr [ByteString] + | Add Attr [ByteString] + | Replace Attr [ByteString] + deriving (Show, Eq) + + +instance Exception ModifyError + +modify :: Ldap -> Dn -> [Operation] -> IO () +modify l dn as = + raise =<< modifyEither l dn as + +modifyEither :: Ldap -> Dn -> [Operation] -> IO (Either ModifyError ()) +modifyEither l dn as = + wait =<< modifyAsync l dn as + +modifyAsync :: Ldap -> Dn -> [Operation] -> IO (Async ModifyError ()) +modifyAsync l dn as = + atomically (modifyAsyncSTM l dn as) + +modifyAsyncSTM :: Ldap -> Dn -> [Operation] -> STM (Async ModifyError ()) +modifyAsyncSTM l (Dn dn) xs = + sendRequest l modifyResult + (Type.ModifyRequest (Type.LdapDn (Type.LdapString dn)) (map f xs)) + where + f (Delete (Attr k) vs) = + (Type.Delete, Type.PartialAttribute (Type.AttributeDescription (Type.LdapString k)) + (map Type.AttributeValue vs)) + f (Add (Attr k) vs) = + (Type.Add, Type.PartialAttribute (Type.AttributeDescription (Type.LdapString k)) + (map Type.AttributeValue vs)) + f (Replace (Attr k) vs) = + (Type.Replace, Type.PartialAttribute (Type.AttributeDescription (Type.LdapString k)) + (map Type.AttributeValue vs)) + +modifyResult :: Response -> Either ModifyError () +modifyResult (Type.ModifyResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn)) (Type.LdapString msg) _) :| []) + | Type.Success <- code = Right () + | otherwise = Left (ModifyErrorCode code (Dn dn) msg) +modifyResult res = Left (ModifyInvalidResponse res) diff --git a/src/Ldap/Client/Search.hs b/src/Ldap/Client/Search.hs index cbfbe0f..f1104ac 100644 --- a/src/Ldap/Client/Search.hs +++ b/src/Ldap/Client/Search.hs @@ -23,8 +23,6 @@ import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (mapMaybe) -import Data.Set (Set) -import qualified Data.Set as Set import Data.Typeable (Typeable) import qualified Ldap.Asn1.Type as Type @@ -90,7 +88,7 @@ searchResult (Type.SearchResultDone (Type.LdapResult code _ _ _) :| xs) Just (SearchEntry (Dn dn) (map h ys)) g _ = Nothing h (Type.PartialAttribute (Type.AttributeDescription (Type.LdapString x)) - y) = (Attr x, Set.map j y) + y) = (Attr x, fmap j y) j (Type.AttributeValue x) = x searchResult res = Left (SearchInvalidResponse res) @@ -193,5 +191,5 @@ data Filter = | Attr :=* (Maybe ByteString, [ByteString], Maybe ByteString) | (Maybe Attr, Maybe Attr, Bool) ::= ByteString -data SearchEntry = SearchEntry Dn (AttrList Set) +data SearchEntry = SearchEntry Dn (AttrList []) deriving (Show, Eq) diff --git a/test/Ldap/Client/BindSpec.hs b/test/Ldap/Client/BindSpec.hs index 5e9eb84..09173f4 100644 --- a/test/Ldap/Client/BindSpec.hs +++ b/test/Ldap/Client/BindSpec.hs @@ -9,17 +9,17 @@ import SpecHelper (locally) spec :: Spec spec = do - it "binds as admin" $ do + it "binds as ‘admin’" $ do res <- locally $ \l -> do Ldap.bind l (Dn "cn=admin") (Password "secret") res `shouldBe` Right () - it "tries to bind as admin with the wrong password, unsuccessfully" $ do + it "tries to bind as ‘admin’ with the wrong password, unsuccessfully" $ do res <- locally $ \l -> do Ldap.bind l (Dn "cn=admin") (Password "public") res `shouldBe` Left (Ldap.BindError (Ldap.BindErrorCode Ldap.InvalidCredentials)) - it "binds as pikachu" $ do + it "binds as ‘pikachu’" $ do res <- locally $ \l -> do Ldap.bind l (Dn "cn=admin") (Password "secret") Ldap.SearchEntry udn _ : [] diff --git a/test/Ldap/Client/ModifySpec.hs b/test/Ldap/Client/ModifySpec.hs new file mode 100644 index 0000000..cc2b9b5 --- /dev/null +++ b/test/Ldap/Client/ModifySpec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +module Ldap.Client.ModifySpec (spec) where + +import Data.ByteString (ByteString) +import Data.Monoid ((<>)) +import Test.Hspec +import Ldap.Client as Ldap + +import SpecHelper (locally, charizard, pikachu) + + +spec :: Spec +spec = do + let go l f = Ldap.search l (Dn "o=localhost") + (Ldap.scope WholeSubtree <> Ldap.typesOnly True) + f + [] + + context "delete" $ do + it "can land ‘charizard’" $ do + res <- locally $ \l -> do + [x] <- go l (Attr "cn" := "charizard") + lookupAttr (Attr "type") x `shouldBe` Just ["fire", "flying"] + + Ldap.modify l charizard [Attr "type" `Delete` ["flying"]] + + [y] <- go l (Attr "cn" := "charizard") + lookupAttr (Attr "type") y `shouldBe` Just ["fire"] + res `shouldBe` Right () + + it "tries to remove ‘pikachu’'s password, unsuccessfully" $ do + res <- locally $ \l -> do + Ldap.modify l pikachu [Attr "password" `Delete` []] + res `shouldBe` Left + (ModifyError (ModifyErrorCode UnwillingToPerform (Dn "o=localhost") "cannot delete password")) + + context "add" $ do + it "can feed ‘charizard’" $ do + res <- locally $ \l -> do + [x] <- go l (Attr "cn" := "charizard") + lookupAttr (Attr "type") x `shouldBe` Just ["fire", "flying"] + + Ldap.modify l charizard [Attr "type" `Add` ["fed"]] + + [y] <- go l (Attr "cn" := "charizard") + lookupAttr (Attr "type") y `shouldBe` Just ["fire", "flying", "fed"] + res `shouldBe` Right () + + context "replace" $ do + it "can put ‘charizard’ to sleep" $ do + res <- locally $ \l -> do + [x] <- go l (Attr "cn" := "charizard") + lookupAttr (Attr "type") x `shouldBe` Just ["fire", "flying"] + + Ldap.modify l charizard [Attr "type" `Replace` ["sleeping"]] + + [y] <- go l (Attr "cn" := "charizard") + lookupAttr (Attr "type") y `shouldBe` Just ["sleeping"] + res `shouldBe` Right () + +lookupAttr :: Attr -> SearchEntry -> Maybe [ByteString] +lookupAttr a (SearchEntry _ as) = lookup a as diff --git a/test/ldap.js b/test/ldap.js index 787f1d6..f555737 100755 --- a/test/ldap.js +++ b/test/ldap.js @@ -47,7 +47,7 @@ var pokemon = [ attributes: { cn: 'butterfree', evolution: "2", type: ["bug", "flying"], } }, { dn: 'cn=pikachu,o=localhost', - attributes: { cn: 'pikachu', evolution: "0", type: ["electric"], password: "i-choose-you" } + attributes: { cn: 'pikachu', evolution: "0", type: ["electric"], password: ["i-choose-you"] } }, ]; @@ -133,6 +133,56 @@ server.compare('o=localhost', [], function(req, res, 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; }); +}; + +server.modify('o=localhost', [], function(req, res, next) { + var dn = req.dn.toString(); + + for (var i = 0; i < pokemon.length; i++) { + if (pokemon[i].dn === dn) { + for (var j = 0; j < req.changes.length; j++) { + var m = req.changes[j].modification; + + switch (req.changes[j].operation) { + case 'add': + pokemon[i].attributes[m.type] = pokemon[i].attributes[m.type].concat(m.vals); + break; + case 'delete': + if (m.type === "password") { + return next(new ldapjs.UnwillingToPerformError('cannot delete password')); + } else { + if (m.vals === 0) { + delete pokemon[i].attributes[m.type]; + } else { + pokemon[i].attributes[m.type] = pokemon[i].attributes[m.type].diff(m.vals); + if (pokemon[i].attributes[m.type].length === 0) { + delete pokemon[i].attributes[m.type]; + } + } + } + break; + case 'replace': + if (m.vals === 0) { + delete pokemon[i].attributes[m.type]; + } else { + pokemon[i].attributes[m.type] = m.vals; + } + break; + } + } + + res.end(); + return next(); + } + } + + res.end(); + return next(new ldapjs.NoSuchObjectError(dn)); +}); + server.listen(port, function() { console.log("ldaps://localhost:%d", port); });