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

Support ModifyDN

Browse Source
This commit is contained in:
Matvey Aksenov 2015-04-03 22:27:35 +00:00
parent ebccd8628f
commit dd1a89d426
15 changed files with 128 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
README.markdown
View File

@ -15,7 +15,7 @@ Search Operation | 4.5 | ✔\*
Modify Operation | 4.6 | ✔
Add Operation | 4.7 | ✔
Delete Operation | 4.8 | ✔
Modify DN Operation | 4.9 | ✘
Modify DN Operation | 4.9 | ✔
Compare Operation | 4.10 | ✔
Abandon Operation | 4.11 | ✘
Extended Operation | 4.12 | ✔

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

@ -21,6 +21,9 @@ import qualified Data.Text.Encoding as Text
import Ldap.Asn1.Type
{-# ANN module "HLint: ignore Use const" #-}
{-# ANN module "HLint: ignore Avoid lambda" #-}
class FromAsn1 a where
fromAsn1 :: Parser [ASN1] a
@ -262,6 +265,7 @@ instance FromAsn1 ProtocolServerOp where
, fmap ModifyResponse (app 7)
, fmap AddResponse (app 9)
, fmap DeleteResponse (app 11)
, fmap ModifyDnResponse (app 13)
, fmap CompareResponse (app 15)
, do
Asn1.Start (Asn1.Container Asn1.Application 24) <- next

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

@ -61,6 +61,12 @@ LDAPDN ::= LDAPString -- Constrained to <distinguishedName>
instance ToAsn1 LdapDn where
toAsn1 (LdapDn s) = toAsn1 s
{- |
RelativeLDAPDN ::= LDAPString -- Constrained to <name-component>
-}
instance ToAsn1 RelativeLdapDn where
toAsn1 (RelativeLdapDn s) = toAsn1 s
{- |
AttributeDescription ::= LDAPString
-}
@ -172,6 +178,12 @@ AddRequest ::= [APPLICATION 8] SEQUENCE {
DelRequest ::= [APPLICATION 10] LDAPDN
ModifyDNRequest ::= [APPLICATION 12] SEQUENCE {
entry LDAPDN,
newrdn RelativeLDAPDN,
deleteoldrdn BOOLEAN,
newSuperior [0] LDAPDN OPTIONAL }
CompareRequest ::= [APPLICATION 14] SEQUENCE {
entry LDAPDN,
ava AttributeValueAssertion }
@ -219,6 +231,15 @@ instance ToAsn1 ProtocolClientOp where
application 8 (toAsn1 dn <> toAsn1 as)
toAsn1 (DeleteRequest (LdapDn (LdapString dn))) =
other Asn1.Application 10 (Text.encodeUtf8 dn)
toAsn1 (ModifyDnRequest dn rdn del new) =
application 12 (fold
[ toAsn1 dn
, toAsn1 rdn
, single (Asn1.Boolean del)
, maybe mempty
(\(LdapDn (LdapString dn')) -> other Asn1.Context 0 (Text.encodeUtf8 dn'))
new
])
toAsn1 (CompareRequest dn av) =
application 14 (toAsn1 dn <> sequence (toAsn1 av))
toAsn1 (ExtendedRequest (LdapOid oid) mv) =

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

@ -19,10 +19,11 @@ data ProtocolClientOp =
BindRequest Int8 LdapDn AuthenticationChoice
| UnbindRequest
| SearchRequest LdapDn Scope DerefAliases Int32 Int32 Bool Filter AttributeSelection
| ModifyRequest LdapDn [(Operation, PartialAttribute)]
| AddRequest LdapDn AttributeList
| DeleteRequest LdapDn
| ModifyDnRequest LdapDn RelativeLdapDn Bool (Maybe LdapDn)
| CompareRequest LdapDn AttributeValueAssertion
| ModifyRequest LdapDn [(Operation, PartialAttribute)]
| ExtendedRequest LdapOid (Maybe ByteString)
deriving (Show, Eq, Ord)
@ -34,6 +35,7 @@ data ProtocolServerOp =
| ModifyResponse LdapResult
| AddResponse LdapResult
| DeleteResponse LdapResult
| ModifyDnResponse LdapResult
| CompareResponse LdapResult
| ExtendedResponse LdapResult (Maybe LdapOid) (Maybe ByteString)
deriving (Show, Eq, Ord)
@ -163,6 +165,9 @@ data PartialAttribute = PartialAttribute AttributeDescription [AttributeValue]
newtype LdapDn = LdapDn LdapString
deriving (Show, Eq, Ord)
newtype RelativeLdapDn = RelativeLdapDn LdapString
deriving (Show, Eq, Ord)
newtype ReferralUris = ReferralUris (NonEmpty Uri)
deriving (Show, Eq, Ord)

29
src/Ldap/Client.hs
View File

@ -1,6 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module Ldap.Client
( Host(..)
@ -35,6 +34,9 @@ module Ldap.Client
, add
-- * Delete Operation
, delete
-- * ModifyDn Operation
, RelativeDn(..)
, modifyDn
-- * Compare Operation
, compare
-- * Extended Operation
@ -85,7 +87,7 @@ import Ldap.Client.Search
, Filter(..)
, SearchEntry(..)
)
import Ldap.Client.Modify (Operation(..), modify)
import Ldap.Client.Modify (Operation(..), modify, modifyDn)
import Ldap.Client.Add (add)
import Ldap.Client.Delete (delete)
import Ldap.Client.Compare (compare)
@ -177,37 +179,22 @@ dispatch
-> TQueue (Type.LdapMessage Request)
-> IO a
dispatch Ldap { client } inq outq =
flip fix (Map.empty, Map.empty, 1) $ \loop (!got, !results, !counter) -> do
flip fix (Map.empty, Map.empty, 1) $ \loop (!got, !results, !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.BindResponse {} -> do
traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
return (Map.delete mid got, Map.delete mid results, counter)
Type.SearchResultEntry {} -> do
Type.SearchResultEntry {} ->
return (Map.insertWith (++) mid [op] got, results, counter)
Type.SearchResultReference {} -> do
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)
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)
Type.DeleteResponse {} -> do
traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
return (Map.delete mid got, Map.delete mid results, counter)
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
_ -> do
traverse_ (\var -> putTMVar var (op :| [])) (Map.lookup mid results)
return (Map.delete mid got, Map.delete mid results, counter)
])

4
src/Ldap/Client/Extended.hs
View File

@ -36,8 +36,8 @@ 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
extendedRequest (Oid oid) =
Type.ExtendedRequest (Type.LdapOid oid)
extendedResult :: Request -> Response -> Either ResponseError ()
extendedResult req (Type.ExtendedResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn))

5
src/Ldap/Client/Internal.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module Ldap.Client.Internal
@ -20,6 +19,7 @@ module Ldap.Client.Internal
, raise
, sendRequest
, Dn(..)
, RelativeDn(..)
, Password(..)
, Attr(..)
, unAttr
@ -62,6 +62,9 @@ instance Functor Async where
newtype Dn = Dn Text
deriving (Show, Eq)
newtype RelativeDn = RelativeDn Text
deriving (Show, Eq)
newtype Oid = Oid ByteString
deriving (Show, Eq)

34
src/Ldap/Client/Modify.hs
View File

@ -4,6 +4,10 @@ module Ldap.Client.Modify
, modifyEither
, modifyAsync
, modifyAsyncSTM
, modifyDn
, modifyDnEither
, modifyDnAsync
, modifyDnAsyncSTM
) where
import Control.Monad.STM (STM, atomically)
@ -55,3 +59,33 @@ modifyResult req (Type.ModifyResponse (Type.LdapResult code (Type.LdapDn (Type.L
| Type.Success <- code = Right ()
| otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
modifyResult req res = Left (ResponseInvalid req res)
modifyDn :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO ()
modifyDn l dn rdn del new =
raise =<< modifyDnEither l dn rdn del new
modifyDnEither :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO (Either ResponseError ())
modifyDnEither l dn rdn del new =
wait =<< modifyDnAsync l dn rdn del new
modifyDnAsync :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> IO (Async ())
modifyDnAsync l dn rdn del new =
atomically (modifyDnAsyncSTM l dn rdn del new)
modifyDnAsyncSTM :: Ldap -> Dn -> RelativeDn -> Bool -> Maybe Dn -> STM (Async ())
modifyDnAsyncSTM l dn rdn del new =
let req = modifyDnRequest dn rdn del new in sendRequest l (modifyDnResult req) req
modifyDnRequest :: Dn -> RelativeDn -> Bool -> Maybe Dn -> Request
modifyDnRequest (Dn dn) (RelativeDn rdn) del new =
Type.ModifyDnRequest (Type.LdapDn (Type.LdapString dn))
(Type.RelativeLdapDn (Type.LdapString rdn))
del
(fmap (\(Dn dn') -> Type.LdapDn (Type.LdapString dn')) new)
modifyDnResult :: Request -> Response -> Either ResponseError ()
modifyDnResult req (Type.ModifyDnResponse (Type.LdapResult code (Type.LdapDn (Type.LdapString dn)) (Type.LdapString msg) _) :| [])
| Type.Success <- code = Right ()
| otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
modifyDnResult req res = Left (ResponseInvalid req res)

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

@ -21,9 +21,9 @@ spec = do
it "adds an entry" $ do
res <- locally $ \l -> do
Ldap.add l vulpix
[ (Attr "cn", (NonEmpty.fromList ["vulpix"]))
, (Attr "evolution", (NonEmpty.fromList ["0"]))
, (Attr "type", (NonEmpty.fromList ["fire"]))
[ (Attr "cn", NonEmpty.fromList ["vulpix"])
, (Attr "evolution", NonEmpty.fromList ["0"])
, (Attr "type", NonEmpty.fromList ["fire"])
]
res <- go l (Attr "cn" := "vulpix")
dns res `shouldBe` [vulpix]

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

@ -11,12 +11,12 @@ import SpecHelper (locally)
spec :: Spec
spec = do
it "binds as ‘admin’" $ do
res <- locally $ \l -> do
res <- locally $ \l ->
Ldap.bind l (Dn "cn=admin") (Password "secret")
res `shouldBe` Right ()
it "tries to bind as ‘admin’ with the wrong password, unsuccessfully" $ do
res <- locally $ \l -> do
res <- locally $ \l ->
Ldap.bind l (Dn "cn=admin") (Password "public")
res `shouldBe` Left
(Ldap.ResponseError
@ -31,7 +31,7 @@ spec = do
it "binds as ‘pikachu’" $ do
res <- locally $ \l -> do
Ldap.bind l (Dn "cn=admin") (Password "secret")
Ldap.SearchEntry udn _ : []
[Ldap.SearchEntry udn _]
<- Ldap.search l (Dn "o=localhost")
(scope WholeSubtree)
(Attr "cn" := "pikachu")

2
test/Ldap/Client/DeleteSpec.hs
View File

@ -26,7 +26,7 @@ spec = do
res `shouldBe` Right ()
it "tries to delete an non-existing entry, unsuccessfully" $ do
res <- locally $ \l -> do
res <- locally $ \l ->
Ldap.delete l oddish
res `shouldBe` Left
(Ldap.ResponseError

2
test/Ldap/Client/ExtendedSpec.hs
View File

@ -21,7 +21,7 @@ spec = do
(Dn "")
"0 not supported"))
it "sends a startTLS request" $ do
it "sends a StartTLS request" $ do
res <- locally $ \l ->
Ldap.startTls l
res `shouldBe` Left

26
test/Ldap/Client/ModifySpec.hs
View File

@ -7,7 +7,7 @@ import Test.Hspec
import qualified Ldap.Asn1.Type as Ldap.Type
import Ldap.Client as Ldap
import SpecHelper (locally, charizard, pikachu)
import SpecHelper (locally, charizard, pikachu, raichu)
spec :: Spec
@ -30,7 +30,7 @@ spec = do
res `shouldBe` Right ()
it "tries to remove ‘pikachu’'s password, unsuccessfully" $ do
res <- locally $ \l -> do
res <- locally $ \l ->
Ldap.modify l pikachu [Attr "password" `Delete` []]
res `shouldBe` Left
(ResponseError
@ -45,7 +45,7 @@ spec = do
(Dn "o=localhost")
"cannot delete password"))
context "add" $ do
context "add" $
it "can feed ‘charizard’" $ do
res <- locally $ \l -> do
[x] <- go l (Attr "cn" := "charizard")
@ -57,7 +57,7 @@ spec = do
lookupAttr (Attr "type") y `shouldBe` Just ["fire", "flying", "fed"]
res `shouldBe` Right ()
context "replace" $ do
context "replace" $
it "can put ‘charizard’ to sleep" $ do
res <- locally $ \l -> do
[x] <- go l (Attr "cn" := "charizard")
@ -69,5 +69,23 @@ spec = do
lookupAttr (Attr "type") y `shouldBe` Just ["sleeping"]
res `shouldBe` Right ()
context "modify dn" $
it "evolves ‘pikachu’ into ‘raichu’" $ do
res <- locally $ \l -> do
[] <- go l (Attr "cn" := "raichu")
Ldap.modifyDn l pikachu (RelativeDn "cn=raichu") False Nothing
Ldap.modify l raichu [Attr "evolution" `Replace` ["1"]]
[res] <- go l (Attr "cn" := "raichu")
res `shouldBe`
SearchEntry raichu
[ (Attr "cn", ["raichu"])
, (Attr "evolution", ["1"])
, (Attr "type", ["electric"])
, (Attr "password", ["i-choose-you"])
]
res `shouldBe` Right ()
lookupAttr :: Attr -> SearchEntry -> Maybe [ByteString]
lookupAttr a (SearchEntry _ as) = lookup a as

4
test/SpecHelper.hs
View File

@ -17,6 +17,7 @@ module SpecHelper
, metapod
, butterfree
, pikachu
, raichu
, vulpix
, oddish
) where
@ -90,6 +91,9 @@ butterfree = Dn "cn=butterfree,o=localhost"
pikachu :: Dn
pikachu = Dn "cn=pikachu,o=localhost"
raichu :: Dn
raichu = Dn "cn=raichu,o=localhost"
vulpix :: Dn
vulpix = Dn "cn=vulpix,o=localhost"

15
test/ldap.js
View File

@ -158,6 +158,19 @@ server.del('o=localhost', [], function(req, res, next) {
return next(new ldapjs.NoSuchObjectError(req.dn.toString()));
});
server.modifyDN('o=localhost', [], function(req, res, next) {
for (var i = 0; i < pokemon.length; i++) {
if (req.dn.toString() === pokemon[i].dn) {
req.dn.rdns[0] = req.newRdn.rdns[0];
pokemon[i].dn = req.dn.toString();
pokemon[i].attributes.cn = req.newRdn.rdns[0].cn;
}
}
res.end();
return next();
});
server.compare('o=localhost', [], function(req, res, next) {
for (var i = 0; i < pokemon.length; i++) {
if (req.dn.toString() === pokemon[i].dn) {
@ -183,6 +196,6 @@ server.compare('o=localhost', [], function(req, res, next) {
return next(new ldapjs.NoSuchObjectError(req.dn.toString()));
});
server.listen(port, '0.0.0.0', function() {
server.listen(port, function() {
console.log("ldaps://localhost:%d", port);
});