haskell/ldap-client
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Support Modify

Browse Source
This commit is contained in:
Matvey Aksenov 2015-04-03 13:38:30 +00:00
parent cfaabed84e
commit 51f61cea6c
11 changed files with 266 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
README.markdown
View File

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

63
src/Ldap/Asn1/FromAsn1.hs
View File

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

32
src/Ldap/Asn1/ToAsn1.hs
View File

@ -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 :)

11
src/Ldap/Asn1/Type.hs
View File

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

22
src/Ldap/Client.hs
View File

@ -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)

2
src/Ldap/Client/Bind.hs
View File

@ -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 =

66
src/Ldap/Client/Modify.hs Normal file
View File

@ -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)

6
src/Ldap/Client/Search.hs
View File

@ -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)

6
test/Ldap/Client/BindSpec.hs
View File

@ -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 _ : []

62
test/Ldap/Client/ModifySpec.hs Normal file
View File

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

52
test/ldap.js
View File

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