Initial commit
Only Bind and Search operations are (partially) implemented. More tests and documentation are needed.
This commit is contained in:
Matvey Aksenov
commit
7aa2703319
3
.gitignore
vendored
Normal file
3
.gitignore
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
dist/
|
||||
.cabal-sandbox/
|
||||
cabal.sandbox.config
|
||||
27
.vim.custom
Normal file
27
.vim.custom
Normal file
@ -0,0 +1,27 @@
|
||||
function s:hdevtools_options(rgs)
|
||||
return join(map(a:rgs, "'-g ' . v:val"))
|
||||
endfunction
|
||||
|
||||
function s:discover_cabal_sandbox(glob)
|
||||
let l:sandboxes = split(glob(a:glob, "."), "\n")
|
||||
if len(l:sandboxes) > 0
|
||||
return ['-no-user-package-db', '-package-db=' . l:sandboxes[-1]]
|
||||
else
|
||||
return []
|
||||
endif
|
||||
endfunction
|
||||
|
||||
let g:syntastic_haskell_hdevtools_args = s:hdevtools_options
|
||||
\ (
|
||||
\ [ '-isrc'
|
||||
\ , '-ibin'
|
||||
\ , '-itest'
|
||||
\ , '-idist/build/autogen'
|
||||
\ , '-DTEST'
|
||||
\ , '-O0'
|
||||
\ , '-fdefer-type-errors'
|
||||
\ , '-Wall'
|
||||
\ , '-fno-warn-unused-do-bind'
|
||||
\ , '-fno-warn-type-defaults'
|
||||
\ ] + s:discover_cabal_sandbox(".cabal-sandbox/*.conf.d")
|
||||
\ )
|
||||
26
LICENSE
Normal file
26
LICENSE
Normal file
@ -0,0 +1,26 @@
|
||||
Copyright (c) 2015, Matvey Aksenov
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are
|
||||
met:
|
||||
|
||||
1. Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
2. Redistributions in binary form must reproduce the above copyright
|
||||
notice, this list of conditions and the following disclaimer in the
|
||||
documentation and/or other materials provided with the
|
||||
distribution.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
28
README.markdown
Normal file
28
README.markdown
Normal file
@ -0,0 +1,28 @@
|
||||
ldap-client
|
||||
-----------
|
||||
|
||||
This library implements (the parts of) [RFC 4511][rfc4511]
|
||||
|
||||
Feature | RFC Section | Support
|
||||
:--------------------------- |:-----------:|:-----------:
|
||||
Bind Operation | 4.2 | ✔
|
||||
Unbind Operation | 4.3 | ✔
|
||||
Notice of Disconnection | 4.4.1 | ✘
|
||||
Search Operation | 4.5 | ✔ (partial)
|
||||
Modify Operation | 4.6 | ✘
|
||||
Add Operation | 4.7 | ✘
|
||||
Delete Operation | 4.8 | ✘
|
||||
Modify DN Operation | 4.9 | ✘
|
||||
Compare Operation | 4.10 | ✘
|
||||
Abandon Operation | 4.11 | ✘
|
||||
Extended Operation | 4.12 | ✘
|
||||
IntermediateResponse Message | 4.13 | ✘
|
||||
StartTLS Operation | 4.14 | ✘
|
||||
LDAP over TLS | - | ✔
|
||||
|
||||
```
|
||||
% git grep '\bString\b' | wc -l
|
||||
2
|
||||
```
|
||||
|
||||
[rfc4511]: https://tools.ietf.org/html/rfc4511
|
||||
102
example/login.hs
Normal file
102
example/login.hs
Normal file
@ -0,0 +1,102 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- | An example of how to do LDAP logins with ldap-client.
|
||||
--
|
||||
-- First, the assumptions this example makes. It defaults to LDAP over TLS,
|
||||
-- so if you only have a plaintext server, please replace `Secure` with `Plain`.
|
||||
-- It also assumes the accounts you may want to log in as all have
|
||||
-- `objectClass` "Person".
|
||||
--
|
||||
-- To run the example you have to provide a bunch of environment variables:
|
||||
--
|
||||
-- - `HOST` is the LDAP host to connect to (without "ldap://", "ldaps://", etc).
|
||||
-- - `POST` is the port LDAP server listens on.
|
||||
-- - `MANAGER_DN` is the DN of the account the first bind is made with.
|
||||
-- - `MANAGER_PASSWORD` is its password.
|
||||
-- - `BASE_OBJECT` is the search root
|
||||
module Main (main) where
|
||||
|
||||
import Control.Exception (bracket_) -- base
|
||||
import Control.Monad (when) -- base
|
||||
import Data.Function (fix) -- base
|
||||
import Data.Text (Text) -- text
|
||||
import qualified Data.Text.Encoding as Text -- text
|
||||
import qualified Data.Text.IO as Text -- text
|
||||
import Env -- envparse
|
||||
import qualified Ldap.Client as Ldap -- ldap-client
|
||||
import Ldap.Client -- ldap-client
|
||||
( LdapError
|
||||
, Scope(..)
|
||||
, Filter(..)
|
||||
, Attr(..)
|
||||
)
|
||||
import System.Exit (die) -- base
|
||||
import qualified System.IO as IO -- base
|
||||
|
||||
|
||||
data Conf = Conf
|
||||
{ host :: String
|
||||
, port :: Ldap.PortNumber
|
||||
, dn :: Ldap.Dn
|
||||
, password :: Ldap.Password
|
||||
, base :: Ldap.Dn
|
||||
} deriving (Show, Eq)
|
||||
|
||||
getConf :: IO Conf
|
||||
getConf = Env.parse (header "LDAP login example") $ Conf
|
||||
<$> var str "HOST" (help "LDAP hostname")
|
||||
<*> var (fmap fromIntegral . auto) "PORT" (help "LDAP port")
|
||||
<*> var (fmap Ldap.Dn . str) "MANAGER_DN" (help "Manager login DN")
|
||||
<*> var (fmap Ldap.Password . str) "MANAGER_PASSWORD" (help "Manager password")
|
||||
<*> var (fmap Ldap.Dn . str) "BASE_OBJECT" (help "Search root")
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
conf <- getConf
|
||||
res <- login conf
|
||||
case res of
|
||||
Left e -> die (show e)
|
||||
Right _ -> return ()
|
||||
|
||||
login :: Conf -> IO (Either LdapError ())
|
||||
login conf =
|
||||
Ldap.with (Ldap.Secure (host conf)) (port conf) $ \l -> do
|
||||
Ldap.bind l (dn conf) (password conf)
|
||||
fix $ \loop -> do
|
||||
uid <- prompt "Username: "
|
||||
us <- Ldap.search l (base conf)
|
||||
(Ldap.scope WholeSubtree <> Ldap.typesOnly True)
|
||||
(And [ Attr "objectClass" := "Person"
|
||||
, Attr "uid" := Text.encodeUtf8 uid
|
||||
])
|
||||
[]
|
||||
case us of
|
||||
Ldap.SearchEntry udn _ : _ ->
|
||||
fix $ \loop' -> do
|
||||
pwd <- bracket_ hideOutput
|
||||
showOutput
|
||||
(do pwd <- prompt ("Password for ‘" <> uid <> "’: ")
|
||||
Text.putStr "\n"
|
||||
return pwd)
|
||||
res <- Ldap.bindEither l udn (Ldap.Password (Text.encodeUtf8 pwd))
|
||||
case res of
|
||||
Left _ -> do again <- question "Invalid password. Try again? [y/n] "
|
||||
when again loop'
|
||||
Right _ -> Text.putStrLn "OK"
|
||||
[] -> do again <- question "Invalid username. Try again? [y/n] "
|
||||
when again loop
|
||||
|
||||
prompt :: Text -> IO Text
|
||||
prompt msg = do Text.putStr msg; IO.hFlush IO.stdout; Text.getLine
|
||||
|
||||
question :: Text -> IO Bool
|
||||
question msg = fix $ \loop -> do
|
||||
res <- prompt msg
|
||||
case res of
|
||||
"y" -> return True
|
||||
"n" -> return False
|
||||
_ -> do Text.putStrLn "Please, answer either ‘y’ or ‘n’."; loop
|
||||
|
||||
hideOutput, showOutput :: IO ()
|
||||
hideOutput = IO.hSetEcho IO.stdout False
|
||||
showOutput = IO.hSetEcho IO.stdout True
|
||||
43
ldap-client.cabal
Normal file
43
ldap-client.cabal
Normal file
@ -0,0 +1,43 @@
|
||||
name: ldap-client
|
||||
version: 0.1.0
|
||||
synopsis: Pure Haskell LDAP Client Library
|
||||
description:
|
||||
Pure Haskell LDAP client library implementing (the parts of) RFC 4511.
|
||||
homepage: https://supki.github.io/ldap-client
|
||||
license: BSD2
|
||||
license-file: LICENSE
|
||||
author: Matvey Aksenov
|
||||
maintainer: matvey.aksenov@gmail.com
|
||||
copyright: 2015 Matvey Aksenov
|
||||
category: Network
|
||||
build-type: Simple
|
||||
cabal-version: >= 1.10
|
||||
extra-source-files:
|
||||
README.markdown
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: git@github.com:supki/ldap-client
|
||||
|
||||
library
|
||||
default-language:
|
||||
Haskell2010
|
||||
hs-source-dirs:
|
||||
src
|
||||
exposed-modules:
|
||||
Ldap.Asn1.FromAsn1
|
||||
Ldap.Asn1.ToAsn1
|
||||
Ldap.Asn1.Type
|
||||
Ldap.Client
|
||||
build-depends:
|
||||
asn1-encoding >= 0.9
|
||||
, asn1-types >= 0.3
|
||||
, async
|
||||
, base >= 4.7 && < 5
|
||||
, bytestring
|
||||
, connection >= 0.2
|
||||
, containers
|
||||
, network >= 2.6
|
||||
, semigroups >= 0.16
|
||||
, stm
|
||||
, text
|
||||
303
src/Ldap/Asn1/FromAsn1.hs
Normal file
303
src/Ldap/Asn1/FromAsn1.hs
Normal file
@ -0,0 +1,303 @@
|
||||
module Ldap.Asn1.FromAsn1
|
||||
( FromAsn1(..)
|
||||
, Parser
|
||||
, parseAsn1
|
||||
, parse
|
||||
, next
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative(..), optional)
|
||||
import Control.Monad ((>=>), MonadPlus(..))
|
||||
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
|
||||
|
||||
|
||||
class FromAsn1 a where
|
||||
fromAsn1 :: Parser [ASN1] a
|
||||
|
||||
{- |
|
||||
LDAPMessage ::= SEQUENCE {
|
||||
messageID MessageID,
|
||||
protocolOp CHOICE {
|
||||
bindRequest BindRequest,
|
||||
bindResponse BindResponse,
|
||||
unbindRequest UnbindRequest,
|
||||
searchRequest SearchRequest,
|
||||
searchResEntry SearchResultEntry,
|
||||
searchResDone SearchResultDone,
|
||||
searchResRef SearchResultReference,
|
||||
... },
|
||||
controls [0] Controls OPTIONAL }
|
||||
-}
|
||||
instance FromAsn1 op => FromAsn1 (LdapMessage op) where
|
||||
fromAsn1 = do
|
||||
Asn1.Start Asn1.Sequence <- next
|
||||
i <- fromAsn1
|
||||
op <- fromAsn1
|
||||
Asn1.End Asn1.Sequence <- next
|
||||
return (LdapMessage i op Nothing)
|
||||
|
||||
{- |
|
||||
MessageID ::= INTEGER (0 .. maxInt)
|
||||
-}
|
||||
instance FromAsn1 Id where
|
||||
fromAsn1 = do
|
||||
Asn1.IntVal i <- next
|
||||
return (Id (fromIntegral i))
|
||||
|
||||
{- |
|
||||
LDAPString ::= OCTET STRING -- UTF-8 encoded,
|
||||
-}
|
||||
instance FromAsn1 LdapString where
|
||||
fromAsn1 = do
|
||||
Asn1.OctetString s <- next
|
||||
case Text.decodeUtf8' s of
|
||||
Right t -> return (LdapString t)
|
||||
Left _ -> empty
|
||||
|
||||
{- |
|
||||
LDAPDN ::= LDAPString
|
||||
-}
|
||||
instance FromAsn1 LdapDn where
|
||||
fromAsn1 = fmap LdapDn fromAsn1
|
||||
|
||||
{- |
|
||||
AttributeDescription ::= LDAPString
|
||||
-}
|
||||
instance FromAsn1 AttributeDescription where
|
||||
fromAsn1 = fmap AttributeDescription fromAsn1
|
||||
|
||||
{- |
|
||||
AttributeValue ::= OCTET STRING
|
||||
-}
|
||||
instance FromAsn1 AttributeValue where
|
||||
fromAsn1 = do
|
||||
Asn1.OctetString s <- next
|
||||
return (AttributeValue s)
|
||||
|
||||
{- |
|
||||
PartialAttribute ::= SEQUENCE {
|
||||
type AttributeDescription,
|
||||
vals SET OF value AttributeValue }
|
||||
-}
|
||||
instance FromAsn1 PartialAttribute where
|
||||
fromAsn1 = do
|
||||
Asn1.Start Asn1.Sequence <- next
|
||||
d <- fromAsn1
|
||||
Asn1.Start Asn1.Set <- next
|
||||
vs <- many fromAsn1
|
||||
Asn1.End Asn1.Set <- next
|
||||
Asn1.End Asn1.Sequence <- next
|
||||
return (PartialAttribute d (Set.fromList vs))
|
||||
|
||||
{- |
|
||||
LDAPResult ::= SEQUENCE {
|
||||
resultCode ENUMERATED {
|
||||
success (0),
|
||||
operationsError (1),
|
||||
protocolError (2),
|
||||
timeLimitExceeded (3),
|
||||
sizeLimitExceeded (4),
|
||||
compareFalse (5),
|
||||
compareTrue (6),
|
||||
authMethodNotSupported (7),
|
||||
strongerAuthRequired (8),
|
||||
-- 9 reserved --
|
||||
referral (10),
|
||||
adminLimitExceeded (11),
|
||||
unavailableCriticalExtension (12),
|
||||
confidentialityRequired (13),
|
||||
saslBindInProgress (14),
|
||||
noSuchAttribute (16),
|
||||
undefinedAttributeType (17),
|
||||
inappropriateMatching (18),
|
||||
constraintViolation (19),
|
||||
attributeOrValueExists (20),
|
||||
invalidAttributeSyntax (21),
|
||||
-- 22-31 unused --
|
||||
noSuchObject (32),
|
||||
aliasProblem (33),
|
||||
invalidDNSyntax (34),
|
||||
-- 35 reserved for undefined isLeaf --
|
||||
aliasDereferencingProblem (36),
|
||||
-- 37-47 unused --
|
||||
inappropriateAuthentication (48),
|
||||
invalidCredentials (49),
|
||||
insufficientAccessRights (50),
|
||||
busy (51),
|
||||
unavailable (52),
|
||||
unwillingToPerform (53),
|
||||
loopDetect (54),
|
||||
-- 55-63 unused --
|
||||
namingViolation (64),
|
||||
objectClassViolation (65),
|
||||
notAllowedOnNonLeaf (66),
|
||||
notAllowedOnRDN (67),
|
||||
entryAlreadyExists (68),
|
||||
objectClassModsProhibited (69),
|
||||
-- 70 reserved for CLDAP --
|
||||
affectsMultipleDSAs (71),
|
||||
-- 72-79 unused --
|
||||
other (80),
|
||||
... },
|
||||
matchedDN LDAPDN,
|
||||
diagnosticMessage LDAPString,
|
||||
referral [3] Referral OPTIONAL }
|
||||
-}
|
||||
instance FromAsn1 LdapResult where
|
||||
fromAsn1 = do
|
||||
resultCode <- do
|
||||
Asn1.Enumerated x <- next
|
||||
case x of
|
||||
0 -> pure Success
|
||||
1 -> pure OperationError
|
||||
2 -> pure ProtocolError
|
||||
3 -> pure TimeLimitExceeded
|
||||
4 -> pure SizeLimitExceeded
|
||||
5 -> pure CompareFalse
|
||||
6 -> pure CompareTrue
|
||||
7 -> pure AuthMethodNotSupported
|
||||
8 -> pure StrongerAuthRequired
|
||||
10 -> pure Referral
|
||||
11 -> pure AdminLimitExceeded
|
||||
12 -> pure UnavailableCriticalExtension
|
||||
13 -> pure ConfidentialityRequired
|
||||
14 -> pure SaslBindInProgress
|
||||
16 -> pure NoSuchAttribute
|
||||
17 -> pure UndefinedAttributeType
|
||||
18 -> pure InappropriateMatching
|
||||
19 -> pure ConstraintViolation
|
||||
20 -> pure AttributeOrValueExists
|
||||
21 -> pure InvalidAttributeSyntax
|
||||
32 -> pure NoSuchObject
|
||||
33 -> pure AliasProblem
|
||||
34 -> pure InvalidDNSyntax
|
||||
36 -> pure AliasDereferencingProblem
|
||||
48 -> pure InappropriateAuthentication
|
||||
49 -> pure InvalidCredentials
|
||||
50 -> pure InsufficientAccessRights
|
||||
51 -> pure Busy
|
||||
52 -> pure Unavailable
|
||||
53 -> pure UnwillingToPerform
|
||||
54 -> pure LoopDetect
|
||||
64 -> pure NamingViolation
|
||||
65 -> pure ObjectClassViolation
|
||||
66 -> pure NotAllowedOnNonLeaf
|
||||
67 -> pure NotAllowedOnRDN
|
||||
68 -> pure EntryAlreadyExists
|
||||
69 -> pure ObjectClassModsProhibited
|
||||
71 -> pure AffectsMultipleDSAs
|
||||
80 -> pure Other
|
||||
_ -> empty
|
||||
matchedDn <- fromAsn1
|
||||
diagnosticMessage
|
||||
<- fromAsn1
|
||||
referral <- optional $ do
|
||||
Asn1.Start (Asn1.Container Asn1.Context 0) <- next
|
||||
x <- fromAsn1
|
||||
Asn1.End (Asn1.Container Asn1.Context 0) <- next
|
||||
return x
|
||||
return (LdapResult resultCode matchedDn diagnosticMessage referral)
|
||||
|
||||
{- |
|
||||
Referral ::= SEQUENCE SIZE (1..MAX) OF uri URI
|
||||
-}
|
||||
instance FromAsn1 ReferralUris where
|
||||
fromAsn1 = do
|
||||
Asn1.Start Asn1.Sequence <- next
|
||||
xs <- some1 fromAsn1
|
||||
Asn1.End Asn1.Sequence <- next
|
||||
return (ReferralUris xs)
|
||||
|
||||
{- |
|
||||
URI ::= LDAPString
|
||||
-}
|
||||
instance FromAsn1 Uri where
|
||||
fromAsn1 = fmap Uri fromAsn1
|
||||
|
||||
{- |
|
||||
BindResponse ::= [APPLICATION 1] SEQUENCE {
|
||||
COMPONENTS OF LDAPResult,
|
||||
serverSaslCreds [7] OCTET STRING OPTIONAL }
|
||||
|
||||
SearchResultEntry ::= [APPLICATION 4] SEQUENCE {
|
||||
objectName LDAPDN,
|
||||
attributes PartialAttributeList }
|
||||
|
||||
SearchResultDone ::= [APPLICATION 5] 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)
|
||||
]
|
||||
|
||||
{- |
|
||||
PartialAttributeList ::= SEQUENCE OF partialAttribute PartialAttribute
|
||||
-}
|
||||
instance FromAsn1 PartialAttributeList where
|
||||
fromAsn1 = do
|
||||
Asn1.Start Asn1.Sequence <- next
|
||||
xs <- many fromAsn1
|
||||
Asn1.End Asn1.Sequence <- next
|
||||
return (PartialAttributeList xs)
|
||||
|
||||
|
||||
newtype Parser s a = Parser { unParser :: s -> Maybe (s, a) }
|
||||
|
||||
instance Functor (Parser s) where
|
||||
fmap f (Parser g) = Parser (fmap (fmap f) . g)
|
||||
|
||||
instance Applicative (Parser s) where
|
||||
pure x = Parser (\s -> pure (s, x))
|
||||
Parser mf <*> Parser mx = Parser $ \s -> do
|
||||
(s', f) <- mf s
|
||||
(s'', x) <- mx s'
|
||||
pure (s'', f x)
|
||||
|
||||
instance Alternative (Parser s) where
|
||||
empty = Parser (\_ -> empty)
|
||||
Parser ma <|> Parser mb =
|
||||
Parser (\s -> ma s <|> mb s)
|
||||
|
||||
instance Monad (Parser s) where
|
||||
return x = Parser (\s -> return (s, x))
|
||||
Parser mx >>= k =
|
||||
Parser (mx >=> \(s', x) -> unParser (k x) s')
|
||||
fail _ = empty
|
||||
|
||||
instance MonadPlus (Parser s) where
|
||||
mzero = Parser (\_ -> mzero)
|
||||
Parser ma `mplus` Parser mb =
|
||||
Parser (\s -> ma s `mplus` mb s)
|
||||
|
||||
parseAsn1 :: FromAsn1 a => [ASN1] -> Maybe ([ASN1], a)
|
||||
parseAsn1 = parse fromAsn1
|
||||
|
||||
parse :: Parser s a -> s -> Maybe (s, a)
|
||||
parse = unParser
|
||||
|
||||
next :: Parser [s] s
|
||||
next = Parser (\s -> case s of [] -> Nothing; x : xs -> Just (xs, x))
|
||||
258
src/Ldap/Asn1/ToAsn1.hs
Normal file
258
src/Ldap/Asn1/ToAsn1.hs
Normal file
@ -0,0 +1,258 @@
|
||||
module Ldap.Asn1.ToAsn1
|
||||
( ToAsn1(..)
|
||||
) where
|
||||
|
||||
import Data.ASN1.Types (ASN1, ASN1Class, ASN1Tag, ASN1ConstructionType)
|
||||
import qualified Data.ASN1.Types as Asn1
|
||||
import Data.ByteString (ByteString)
|
||||
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 Ldap.Asn1.Type
|
||||
|
||||
|
||||
class ToAsn1 a where
|
||||
toAsn1 :: a -> Endo [ASN1]
|
||||
|
||||
{- |
|
||||
LDAPMessage ::= SEQUENCE {
|
||||
messageID MessageID,
|
||||
protocolOp CHOICE {
|
||||
bindRequest BindRequest,
|
||||
bindResponse BindResponse,
|
||||
unbindRequest UnbindRequest,
|
||||
searchRequest SearchRequest,
|
||||
searchResEntry SearchResultEntry,
|
||||
searchResDone SearchResultDone,
|
||||
searchResRef SearchResultReference,
|
||||
... },
|
||||
controls [0] Controls OPTIONAL }
|
||||
-}
|
||||
instance ToAsn1 op => ToAsn1 (LdapMessage op) where
|
||||
toAsn1 (LdapMessage i op mc) =
|
||||
sequence (toAsn1 i <> toAsn1 op <> context 0 (optional mc))
|
||||
|
||||
{- |
|
||||
MessageID ::= INTEGER (0 .. maxInt)
|
||||
-}
|
||||
instance ToAsn1 Id where
|
||||
toAsn1 (Id i) = single (Asn1.IntVal (fromIntegral i))
|
||||
|
||||
{- |
|
||||
LDAPString ::= OCTET STRING -- UTF-8 encoded
|
||||
-}
|
||||
instance ToAsn1 LdapString where
|
||||
toAsn1 (LdapString s) = single (Asn1.OctetString (Text.encodeUtf8 s))
|
||||
|
||||
{- |
|
||||
LDAPOID ::= OCTET STRING -- Constrained to <numericoid>
|
||||
-}
|
||||
instance ToAsn1 LdapOid where
|
||||
toAsn1 (LdapOid s) = single (Asn1.OctetString s)
|
||||
|
||||
{- |
|
||||
LDAPDN ::= LDAPString -- Constrained to <distinguishedName>
|
||||
-}
|
||||
instance ToAsn1 LdapDn where
|
||||
toAsn1 (LdapDn s) = toAsn1 s
|
||||
|
||||
{- |
|
||||
AttributeDescription ::= LDAPString
|
||||
-}
|
||||
instance ToAsn1 AttributeDescription where
|
||||
toAsn1 (AttributeDescription s) = toAsn1 s
|
||||
|
||||
{- |
|
||||
AttributeValue ::= OCTET STRING
|
||||
-}
|
||||
instance ToAsn1 AttributeValue where
|
||||
toAsn1 (AttributeValue s) = single (Asn1.OctetString s)
|
||||
|
||||
{- |
|
||||
AttributeValueAssertion ::= SEQUENCE {
|
||||
attributeDesc AttributeDescription,
|
||||
assertionValue AssertionValue }
|
||||
-}
|
||||
instance ToAsn1 AttributeValueAssertion where
|
||||
toAsn1 (AttributeValueAssertion d v) = toAsn1 d <> toAsn1 v
|
||||
|
||||
{- |
|
||||
AssertionValue ::= OCTET STRING
|
||||
-}
|
||||
instance ToAsn1 AssertionValue where
|
||||
toAsn1 (AssertionValue s) = single (Asn1.OctetString s)
|
||||
|
||||
{- |
|
||||
MatchingRuleId ::= LDAPString
|
||||
-}
|
||||
instance ToAsn1 MatchingRuleId where
|
||||
toAsn1 (MatchingRuleId s) = toAsn1 s
|
||||
|
||||
{- |
|
||||
Controls ::= SEQUENCE OF control Control
|
||||
-}
|
||||
instance ToAsn1 Controls where
|
||||
toAsn1 (Controls cs) = sequence (foldMap toAsn1 cs)
|
||||
|
||||
{- |
|
||||
Control ::= SEQUENCE {
|
||||
controlType LDAPOID,
|
||||
criticality BOOLEAN DEFAULT FALSE,
|
||||
controlValue OCTET STRING OPTIONAL }
|
||||
-}
|
||||
instance ToAsn1 Control where
|
||||
toAsn1 (Control t c v) =
|
||||
sequence (fold
|
||||
[ toAsn1 t
|
||||
, single (Asn1.Boolean c)
|
||||
, maybe mempty (single . Asn1.OctetString) v
|
||||
])
|
||||
|
||||
{- |
|
||||
BindRequest ::= [APPLICATION 0] SEQUENCE {
|
||||
version INTEGER (1 .. 127),
|
||||
name LDAPDN,
|
||||
authentication AuthenticationChoice }
|
||||
|
||||
UnbindRequest ::= [APPLICATION 2] NULL
|
||||
|
||||
SearchRequest ::= [APPLICATION 3] SEQUENCE {
|
||||
baseObject LDAPDN,
|
||||
scope ENUMERATED {
|
||||
baseObject (0),
|
||||
singleLevel (1),
|
||||
wholeSubtree (2),
|
||||
... },
|
||||
derefAliases ENUMERATED {
|
||||
neverDerefAliases (0),
|
||||
derefInSearching (1),
|
||||
derefFindingBaseObj (2),
|
||||
derefAlways (3) },
|
||||
sizeLimit INTEGER (0 .. maxInt),
|
||||
timeLimit INTEGER (0 .. maxInt),
|
||||
typesOnly BOOLEAN,
|
||||
filter Filter,
|
||||
attributes AttributeSelection }
|
||||
-}
|
||||
instance ToAsn1 ProtocolClientOp where
|
||||
toAsn1 (BindRequest v n a) =
|
||||
application 0 (single (Asn1.IntVal (fromIntegral v)) <> toAsn1 n <> toAsn1 a)
|
||||
toAsn1 UnbindRequest =
|
||||
other Asn1.Application 2 mempty
|
||||
toAsn1 (SearchRequest bo s da sl tl to f a) =
|
||||
application 3 (fold
|
||||
[ toAsn1 bo
|
||||
, single (Asn1.Enumerated s')
|
||||
, single (Asn1.Enumerated da')
|
||||
, single (Asn1.IntVal (fromIntegral sl))
|
||||
, single (Asn1.IntVal (fromIntegral tl))
|
||||
, single (Asn1.Boolean to)
|
||||
, toAsn1 f
|
||||
, toAsn1 a
|
||||
])
|
||||
where
|
||||
s' = case s of
|
||||
BaseObject -> 0
|
||||
SingleLevel -> 1
|
||||
WholeSubtree -> 2
|
||||
da' = case da of
|
||||
NeverDerefAliases -> 0
|
||||
DerefInSearching -> 1
|
||||
DerefFindingBaseObject -> 2
|
||||
DerefAlways -> 3
|
||||
|
||||
{- |
|
||||
AuthenticationChoice ::= CHOICE {
|
||||
simple [0] OCTET STRING,
|
||||
... }
|
||||
-}
|
||||
instance ToAsn1 AuthenticationChoice where
|
||||
toAsn1 (Simple s) = other Asn1.Context 0 s
|
||||
|
||||
{- |
|
||||
AttributeSelection ::= SEQUENCE OF selector LDAPString
|
||||
-}
|
||||
instance ToAsn1 AttributeSelection where
|
||||
toAsn1 (AttributeSelection as) = sequence (foldMap toAsn1 as)
|
||||
|
||||
{- |
|
||||
Filter ::= CHOICE {
|
||||
and [0] SET SIZE (1..MAX) OF filter Filter,
|
||||
or [1] SET SIZE (1..MAX) OF filter Filter,
|
||||
not [2] Filter,
|
||||
equalityMatch [3] AttributeValueAssertion,
|
||||
substrings [4] SubstringFilter,
|
||||
greaterOrEqual [5] AttributeValueAssertion,
|
||||
lessOrEqual [6] AttributeValueAssertion,
|
||||
present [7] AttributeDescription,
|
||||
approxMatch [8] AttributeValueAssertion,
|
||||
extensibleMatch [9] MatchingRuleAssertion,
|
||||
... }
|
||||
-}
|
||||
instance ToAsn1 Filter where
|
||||
toAsn1 f = case f of
|
||||
And xs -> context 0 (foldMap toAsn1 xs)
|
||||
Or xs -> context 1 (foldMap toAsn1 xs)
|
||||
Not x -> context 2 (toAsn1 x)
|
||||
EqualityMatch x -> context 3 (toAsn1 x)
|
||||
Substrings x -> context 4 (toAsn1 x)
|
||||
GreaterOrEqual x -> context 5 (toAsn1 x)
|
||||
LessOrEqual x -> context 6 (toAsn1 x)
|
||||
Present x -> context 7 (toAsn1 x)
|
||||
ApproxMatch x -> context 8 (toAsn1 x)
|
||||
ExtensibleMatch x -> context 9 (toAsn1 x)
|
||||
|
||||
{- |
|
||||
SubstringFilter ::= SEQUENCE {
|
||||
type AttributeDescription,
|
||||
substrings SEQUENCE SIZE (1..MAX) OF substring CHOICE {
|
||||
initial [0] AssertionValue, -- can occur at most once
|
||||
any [1] AssertionValue,
|
||||
final [2] AssertionValue } -- can occur at most once
|
||||
}
|
||||
-}
|
||||
instance ToAsn1 SubstringFilter where
|
||||
toAsn1 (SubstringFilter ad ss) =
|
||||
toAsn1 ad <> sequence (foldMap (\s -> case s of
|
||||
Initial (AssertionValue v) -> other Asn1.Context 0 v
|
||||
Any (AssertionValue v) -> other Asn1.Context 1 v
|
||||
Final (AssertionValue v) -> other Asn1.Context 2 v) ss)
|
||||
|
||||
{- |
|
||||
MatchingRuleAssertion ::= SEQUENCE {
|
||||
matchingRule [1] MatchingRuleId OPTIONAL,
|
||||
type [2] AttributeDescription OPTIONAL,
|
||||
matchValue [3] AssertionValue,
|
||||
dnAttributes [4] BOOLEAN DEFAULT FALSE }
|
||||
-}
|
||||
instance ToAsn1 MatchingRuleAssertion where
|
||||
toAsn1 (MatchingRuleAssertion mmr mad av b) = sequence (fold
|
||||
[ context 1 (optional mmr)
|
||||
, context 2 (optional mad)
|
||||
, context 3 (toAsn1 av)
|
||||
, context 4 (single (Asn1.Boolean b))
|
||||
])
|
||||
|
||||
sequence :: Endo [ASN1] -> Endo [ASN1]
|
||||
sequence = construction Asn1.Sequence
|
||||
|
||||
application :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]
|
||||
application = construction . Asn1.Container Asn1.Application
|
||||
|
||||
context :: ASN1Tag -> Endo [ASN1] -> Endo [ASN1]
|
||||
context = construction . Asn1.Container Asn1.Context
|
||||
|
||||
construction :: ASN1ConstructionType -> Endo [ASN1] -> Endo [ASN1]
|
||||
construction t x = single (Asn1.Start t) <> x <> single (Asn1.End t)
|
||||
|
||||
other :: ASN1Class -> ASN1Tag -> ByteString -> Endo [ASN1]
|
||||
other c t = single . Asn1.Other c t
|
||||
|
||||
optional :: ToAsn1 a => Maybe a -> Endo [ASN1]
|
||||
optional = maybe mempty toAsn1
|
||||
|
||||
single :: a -> Endo [a]
|
||||
single x = Endo (x :)
|
||||
165
src/Ldap/Asn1/Type.hs
Normal file
165
src/Ldap/Asn1/Type.hs
Normal file
@ -0,0 +1,165 @@
|
||||
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)
|
||||
|
||||
|
||||
data LdapMessage op = LdapMessage
|
||||
{ ldapMessageId :: !Id
|
||||
, ldapMessageOp :: !op
|
||||
, ldapMessageControls :: !(Maybe Controls)
|
||||
} deriving (Show, Eq, Ord)
|
||||
|
||||
newtype Id = Id { unId :: Int32 }
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data ProtocolClientOp =
|
||||
BindRequest Int8 LdapDn AuthenticationChoice
|
||||
| UnbindRequest
|
||||
| SearchRequest LdapDn Scope DerefAliases Int32 Int32 Bool Filter AttributeSelection
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data ProtocolServerOp =
|
||||
BindResponse LdapResult (Maybe ByteString)
|
||||
| SearchResultEntry LdapDn PartialAttributeList
|
||||
| SearchResultReference (NonEmpty Uri)
|
||||
| SearchResultDone (LdapResult)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data AuthenticationChoice = Simple ByteString
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Scope =
|
||||
BaseObject
|
||||
| SingleLevel
|
||||
| WholeSubtree
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data DerefAliases =
|
||||
NeverDerefAliases
|
||||
| DerefInSearching
|
||||
| DerefFindingBaseObject
|
||||
| DerefAlways
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Filter =
|
||||
And (NonEmpty Filter)
|
||||
| Or (NonEmpty Filter)
|
||||
| Not Filter
|
||||
| EqualityMatch AttributeValueAssertion
|
||||
| Substrings SubstringFilter
|
||||
| GreaterOrEqual AttributeValueAssertion
|
||||
| LessOrEqual AttributeValueAssertion
|
||||
| Present AttributeDescription
|
||||
| ApproxMatch AttributeValueAssertion
|
||||
| ExtensibleMatch MatchingRuleAssertion
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data SubstringFilter = SubstringFilter AttributeDescription (NonEmpty Substring)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Substring =
|
||||
Initial AssertionValue
|
||||
| Any AssertionValue
|
||||
| Final AssertionValue
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data MatchingRuleAssertion = MatchingRuleAssertion (Maybe MatchingRuleId) (Maybe AttributeDescription) AssertionValue Bool
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype MatchingRuleId = MatchingRuleId LdapString
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype AttributeSelection = AttributeSelection [LdapString]
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype PartialAttributeList = PartialAttributeList [PartialAttribute]
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype Controls = Controls [Control]
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Control = Control LdapOid Bool (Maybe ByteString)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data LdapResult = LdapResult ResultCode LdapDn LdapString (Maybe ReferralUris)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data ResultCode =
|
||||
Success
|
||||
| OperationError
|
||||
| ProtocolError
|
||||
| TimeLimitExceeded
|
||||
| SizeLimitExceeded
|
||||
| CompareFalse
|
||||
| CompareTrue
|
||||
| AuthMethodNotSupported
|
||||
| StrongerAuthRequired
|
||||
| Referral
|
||||
| AdminLimitExceeded
|
||||
| UnavailableCriticalExtension
|
||||
| ConfidentialityRequired
|
||||
| SaslBindInProgress
|
||||
| NoSuchAttribute
|
||||
| UndefinedAttributeType
|
||||
| InappropriateMatching
|
||||
| ConstraintViolation
|
||||
| AttributeOrValueExists
|
||||
| InvalidAttributeSyntax
|
||||
| NoSuchObject
|
||||
| AliasProblem
|
||||
| InvalidDNSyntax
|
||||
| AliasDereferencingProblem
|
||||
| InappropriateAuthentication
|
||||
| InvalidCredentials
|
||||
| InsufficientAccessRights
|
||||
| Busy
|
||||
| Unavailable
|
||||
| UnwillingToPerform
|
||||
| LoopDetect
|
||||
| NamingViolation
|
||||
| ObjectClassViolation
|
||||
| NotAllowedOnNonLeaf
|
||||
| NotAllowedOnRDN
|
||||
| EntryAlreadyExists
|
||||
| ObjectClassModsProhibited
|
||||
| AffectsMultipleDSAs
|
||||
| Other
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype AttributeDescription = AttributeDescription LdapString
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype AttributeValue = AttributeValue ByteString
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data AttributeValueAssertion = AttributeValueAssertion AttributeDescription AssertionValue
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype AssertionValue = AssertionValue ByteString
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data PartialAttribute = PartialAttribute AttributeDescription (Set AttributeValue)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype LdapDn = LdapDn LdapString
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype ReferralUris = ReferralUris (NonEmpty Uri)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype Uri = Uri LdapString
|
||||
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
|
||||
-- following the UTF-8 [RFC3629] algorithm.
|
||||
newtype LdapString = LdapString Text
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
newtype LdapOid = LdapOid ByteString
|
||||
deriving (Show, Eq, Ord)
|
||||
446
src/Ldap/Client.hs
Normal file
446
src/Ldap/Client.hs
Normal file
@ -0,0 +1,446 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module Ldap.Client
|
||||
( Host(..)
|
||||
, PortNumber
|
||||
, Ldap
|
||||
, LdapError(..)
|
||||
, Async
|
||||
, with
|
||||
-- * Bind Request
|
||||
, Dn(..)
|
||||
, Password(..)
|
||||
, bind
|
||||
, bindEither
|
||||
, bindAsync
|
||||
, bindAsyncSTM
|
||||
-- * Search Request
|
||||
, Type.Scope(..)
|
||||
, Attr(..)
|
||||
, SearchEntry(..)
|
||||
, search
|
||||
, searchEither
|
||||
, searchAsync
|
||||
, searchAsyncSTM
|
||||
, Search
|
||||
, defaultSearch
|
||||
, scope
|
||||
, size
|
||||
, time
|
||||
, typesOnly
|
||||
, derefAliases
|
||||
, Filter(..)
|
||||
-- * Unbind Request
|
||||
, unbindAsync
|
||||
, unbindAsyncSTM
|
||||
-- * Waiting for Request Completion
|
||||
, wait
|
||||
, waitSTM
|
||||
) where
|
||||
|
||||
import qualified Control.Concurrent.Async as Async
|
||||
import Control.Concurrent.STM (STM, atomically)
|
||||
import Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, putTMVar, readTMVar)
|
||||
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO, writeTQueue, readTQueue)
|
||||
import Control.Exception (Exception, Handler(..), bracket, throwIO, catches)
|
||||
import Control.Monad (forever, void)
|
||||
import qualified Data.ASN1.BinaryEncoding as Asn1
|
||||
import qualified Data.ASN1.Encoding as Asn1
|
||||
import qualified Data.ASN1.Error as Asn1
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as ByteString
|
||||
import qualified Data.ByteString.Lazy as ByteString.Lazy
|
||||
import Data.Foldable (traverse_, asum)
|
||||
import Data.Function (fix)
|
||||
import Data.Int (Int32)
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Monoid (Endo(appEndo))
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
import Data.Typeable (Typeable)
|
||||
import Network.Connection (Connection)
|
||||
import qualified Network.Connection as Conn
|
||||
import Network (PortNumber)
|
||||
import qualified System.IO.Error as IO
|
||||
|
||||
import Ldap.Asn1.ToAsn1 (ToAsn1(toAsn1))
|
||||
import Ldap.Asn1.FromAsn1 (FromAsn1, parseAsn1)
|
||||
import qualified Ldap.Asn1.Type as Type
|
||||
|
||||
|
||||
data Host =
|
||||
Plain String
|
||||
| Secure String
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Ldap = Ldap
|
||||
{ client :: TQueue ClientMessage
|
||||
} deriving (Eq)
|
||||
|
||||
data ClientMessage = New Request (TMVar (NonEmpty Type.ProtocolServerOp))
|
||||
type Request = Type.ProtocolClientOp
|
||||
type InMessage = Type.ProtocolServerOp
|
||||
type Response = NonEmpty InMessage
|
||||
|
||||
newLdap :: IO Ldap
|
||||
newLdap = Ldap
|
||||
<$> newTQueueIO
|
||||
|
||||
data LdapError =
|
||||
IOError IOError
|
||||
| ParseError Asn1.ASN1Error
|
||||
| BindError BindError
|
||||
| SearchError SearchError
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | The entrypoint into LDAP.
|
||||
with :: Host -> PortNumber -> (Ldap -> IO a) -> IO (Either LdapError a)
|
||||
with host port f = do
|
||||
context <- Conn.initConnectionContext
|
||||
bracket (Conn.connectTo context params) Conn.connectionClose (\conn ->
|
||||
bracket newLdap unbindAsync (\l -> do
|
||||
inq <- newTQueueIO
|
||||
outq <- newTQueueIO
|
||||
Async.withAsync (input inq conn) $ \i ->
|
||||
Async.withAsync (output outq conn) $ \o ->
|
||||
Async.withAsync (dispatch l inq outq) $ \d ->
|
||||
Async.withAsync (f l) $ \u ->
|
||||
fmap (Right . snd) (Async.waitAnyCancel [i, o, d, u])))
|
||||
`catches`
|
||||
[ Handler (return . Left . IOError)
|
||||
, Handler (return . Left . ParseError)
|
||||
, Handler (return . Left . BindError)
|
||||
, Handler (return . Left . SearchError)
|
||||
]
|
||||
where
|
||||
params = Conn.ConnectionParams
|
||||
{ Conn.connectionHostname =
|
||||
case host of
|
||||
Plain h -> h
|
||||
Secure h -> h
|
||||
, Conn.connectionPort = port
|
||||
, Conn.connectionUseSecure =
|
||||
case host of
|
||||
Plain _ -> Nothing
|
||||
Secure _ -> Just Conn.TLSSettingsSimple
|
||||
{ Conn.settingDisableCertificateValidation = False
|
||||
, Conn.settingDisableSession = False
|
||||
, Conn.settingUseServerName = False
|
||||
}
|
||||
, Conn.connectionUseSocks = Nothing
|
||||
}
|
||||
|
||||
input :: FromAsn1 a => TQueue a -> Connection -> IO b
|
||||
input inq conn = flip fix [] $ \loop chunks -> do
|
||||
chunk <- Conn.connectionGet conn 8192
|
||||
case ByteString.length chunk of
|
||||
0 -> throwIO (IO.mkIOError IO.eofErrorType "Ldap.Client.input" Nothing Nothing)
|
||||
_ -> do
|
||||
let chunks' = chunk : chunks
|
||||
case Asn1.decodeASN1 Asn1.DER (ByteString.Lazy.fromChunks (reverse chunks')) of
|
||||
Left Asn1.ParsingPartial
|
||||
-> loop chunks'
|
||||
Left e -> throwIO e
|
||||
Right asn1 -> do
|
||||
flip fix asn1 $ \loop' asn1' ->
|
||||
case parseAsn1 asn1' of
|
||||
Nothing -> return ()
|
||||
Just (asn1'', a) -> do
|
||||
atomically (writeTQueue inq a)
|
||||
loop' asn1''
|
||||
loop []
|
||||
|
||||
output :: ToAsn1 a => TQueue a -> Connection -> IO b
|
||||
output out conn = forever $
|
||||
Conn.connectionPut conn . encode . toAsn1 =<< atomically (readTQueue out)
|
||||
where
|
||||
encode x = Asn1.encodeASN1' Asn1.DER (appEndo x [])
|
||||
|
||||
dispatch :: Ldap -> TQueue (Type.LdapMessage InMessage) -> TQueue (Type.LdapMessage Request) -> IO a
|
||||
dispatch Ldap { client } inq outq =
|
||||
flip fix (Map.empty, Map.empty, 1) $ \loop (!got, !results, !counter) -> do
|
||||
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
|
||||
return (Map.insertWith (++) mid [op] got, results, counter)
|
||||
Type.SearchResultReference {} -> do
|
||||
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)
|
||||
])
|
||||
|
||||
|
||||
data Async e a = Async (STM (Either e a))
|
||||
|
||||
instance Functor (Async e) where
|
||||
fmap f (Async stm) = Async (fmap (fmap f) stm)
|
||||
|
||||
|
||||
newtype Dn = Dn Text
|
||||
deriving (Show, Eq)
|
||||
newtype Password = Password ByteString
|
||||
deriving (Show, Eq)
|
||||
|
||||
data BindError =
|
||||
BindInvalidResponse Response
|
||||
| BindErrorCode Type.ResultCode
|
||||
deriving (Show, Eq, Typeable)
|
||||
|
||||
instance Exception BindError
|
||||
|
||||
-- | Throws 'BindError' on failure. Don't worry, the nearest 'with'
|
||||
-- will catch it, so it won't destroy your program.
|
||||
bind :: Ldap -> Dn -> Password -> IO ()
|
||||
bind l username password =
|
||||
raise =<< bindEither l username password
|
||||
|
||||
bindEither :: Ldap -> Dn -> Password -> IO (Either BindError ())
|
||||
bindEither l username password =
|
||||
wait =<< bindAsync l username password
|
||||
|
||||
bindAsync :: Ldap -> Dn -> Password -> IO (Async BindError ())
|
||||
bindAsync l username password =
|
||||
atomically (bindAsyncSTM l username password)
|
||||
|
||||
bindAsyncSTM :: Ldap -> Dn -> Password -> STM (Async BindError ())
|
||||
bindAsyncSTM l username password =
|
||||
sendRequest l bindResult (bindRequest username password)
|
||||
|
||||
bindRequest :: Dn -> Password -> Request
|
||||
bindRequest (Dn username) (Password password) =
|
||||
Type.BindRequest ldapVersion
|
||||
(Type.LdapDn (Type.LdapString username))
|
||||
(Type.Simple password)
|
||||
where
|
||||
ldapVersion = 3
|
||||
|
||||
bindResult :: Response -> Either BindError ()
|
||||
bindResult (Type.BindResponse (Type.LdapResult code _ _ _) _ :| [])
|
||||
| Type.Success <- code = Right ()
|
||||
| otherwise = Left (BindErrorCode code)
|
||||
bindResult res = Left (BindInvalidResponse res)
|
||||
|
||||
|
||||
data SearchError =
|
||||
SearchInvalidResponse Response
|
||||
| SearchErrorCode Type.ResultCode
|
||||
deriving (Show, Eq, Typeable)
|
||||
|
||||
instance Exception SearchError
|
||||
|
||||
search
|
||||
:: Ldap
|
||||
-> Dn
|
||||
-> Mod Search
|
||||
-> Filter
|
||||
-> [Attr]
|
||||
-> IO [SearchEntry]
|
||||
search l base opts flt attributes =
|
||||
raise =<< searchEither l base opts flt attributes
|
||||
|
||||
searchEither
|
||||
:: Ldap
|
||||
-> Dn
|
||||
-> Mod Search
|
||||
-> Filter
|
||||
-> [Attr]
|
||||
-> IO (Either SearchError [SearchEntry])
|
||||
searchEither l base opts flt attributes =
|
||||
wait =<< searchAsync l base opts flt attributes
|
||||
|
||||
searchAsync
|
||||
:: Ldap
|
||||
-> Dn
|
||||
-> Mod Search
|
||||
-> Filter
|
||||
-> [Attr]
|
||||
-> IO (Async SearchError [SearchEntry])
|
||||
searchAsync l base opts flt attributes =
|
||||
atomically (searchAsyncSTM l base opts flt attributes)
|
||||
|
||||
searchAsyncSTM
|
||||
:: Ldap
|
||||
-> Dn
|
||||
-> Mod Search
|
||||
-> Filter
|
||||
-> [Attr]
|
||||
-> STM (Async SearchError [SearchEntry])
|
||||
searchAsyncSTM l base opts flt attributes =
|
||||
sendRequest l searchResult (searchRequest base opts flt attributes)
|
||||
|
||||
searchResult :: Response -> Either SearchError [SearchEntry]
|
||||
searchResult (Type.SearchResultDone (Type.LdapResult code _ _ _) :| xs)
|
||||
| Type.Success <- code = Right (mapMaybe g xs)
|
||||
| otherwise = Left (SearchErrorCode code)
|
||||
where
|
||||
g (Type.SearchResultEntry (Type.LdapDn (Type.LdapString dn))
|
||||
(Type.PartialAttributeList ys)) =
|
||||
Just (SearchEntry (Dn dn) (map h ys))
|
||||
g _ = Nothing
|
||||
h (Type.PartialAttribute (Type.AttributeDescription (Type.LdapString x))
|
||||
y) = (Attr x, Set.map j y)
|
||||
j (Type.AttributeValue x) = x
|
||||
searchResult res = Left (SearchInvalidResponse res)
|
||||
|
||||
searchRequest :: Dn -> Mod Search -> Filter -> [Attr] -> Request
|
||||
searchRequest (Dn base) (Mod m) flt attributes =
|
||||
Type.SearchRequest (Type.LdapDn (Type.LdapString base))
|
||||
_scope
|
||||
_derefAliases
|
||||
_size
|
||||
_time
|
||||
_typesOnly
|
||||
(fromFilter flt)
|
||||
(Type.AttributeSelection (map (Type.LdapString . unAttr) attributes))
|
||||
where
|
||||
Search { _scope, _derefAliases, _size, _time, _typesOnly } =
|
||||
m defaultSearch
|
||||
fromFilter (Not x) = Type.Not (fromFilter x)
|
||||
fromFilter (And xs) = Type.And (fmap fromFilter xs)
|
||||
fromFilter (Or xs) = Type.Or (fmap fromFilter xs)
|
||||
fromFilter (Present (Attr x)) =
|
||||
Type.Present (Type.AttributeDescription (Type.LdapString x))
|
||||
fromFilter (Attr x := y) =
|
||||
Type.EqualityMatch
|
||||
(Type.AttributeValueAssertion (Type.AttributeDescription (Type.LdapString x))
|
||||
(Type.AssertionValue y))
|
||||
fromFilter (Attr x :>= y) =
|
||||
Type.GreaterOrEqual
|
||||
(Type.AttributeValueAssertion (Type.AttributeDescription (Type.LdapString x))
|
||||
(Type.AssertionValue y))
|
||||
fromFilter (Attr x :<= y) =
|
||||
Type.LessOrEqual
|
||||
(Type.AttributeValueAssertion (Type.AttributeDescription (Type.LdapString x))
|
||||
(Type.AssertionValue y))
|
||||
fromFilter (Attr x :~= y) =
|
||||
Type.ApproxMatch
|
||||
(Type.AttributeValueAssertion (Type.AttributeDescription (Type.LdapString x))
|
||||
(Type.AssertionValue y))
|
||||
fromFilter (Attr x :=* (mi, xs, mf)) =
|
||||
Type.Substrings
|
||||
(Type.SubstringFilter (Type.AttributeDescription (Type.LdapString x))
|
||||
(NonEmpty.fromList (concat
|
||||
[ maybe [] (\i -> [Type.Initial (Type.AssertionValue i)]) mi
|
||||
, fmap (Type.Any . Type.AssertionValue) xs
|
||||
, maybe [] (\f -> [Type.Final (Type.AssertionValue f)]) mf
|
||||
])))
|
||||
fromFilter ((mx, mr, b) ::= y) =
|
||||
Type.ExtensibleMatch
|
||||
(Type.MatchingRuleAssertion (fmap (\(Attr r) -> Type.MatchingRuleId (Type.LdapString r)) mr)
|
||||
(fmap (\(Attr x) -> Type.AttributeDescription (Type.LdapString x)) mx)
|
||||
(Type.AssertionValue y)
|
||||
b)
|
||||
|
||||
data Search = Search
|
||||
{ _scope :: Type.Scope
|
||||
, _derefAliases :: Type.DerefAliases
|
||||
, _size :: Int32
|
||||
, _time :: Int32
|
||||
, _typesOnly :: Bool
|
||||
} deriving (Show, Eq)
|
||||
|
||||
defaultSearch :: Search
|
||||
defaultSearch = Search
|
||||
{ _scope = Type.BaseObject
|
||||
, _size = 0
|
||||
, _time = 0
|
||||
, _typesOnly = False
|
||||
, _derefAliases = Type.NeverDerefAliases
|
||||
}
|
||||
|
||||
scope :: Type.Scope -> Mod Search
|
||||
scope x = Mod (\y -> y { _scope = x })
|
||||
|
||||
size :: Int32 -> Mod Search
|
||||
size x = Mod (\y -> y { _size = x })
|
||||
|
||||
time :: Int32 -> Mod Search
|
||||
time x = Mod (\y -> y { _time = x })
|
||||
|
||||
typesOnly :: Bool -> Mod Search
|
||||
typesOnly x = Mod (\y -> y { _typesOnly = x })
|
||||
|
||||
derefAliases :: Type.DerefAliases -> Mod Search
|
||||
derefAliases x = Mod (\y -> y { _derefAliases = x })
|
||||
|
||||
newtype Mod a = Mod (a -> a)
|
||||
|
||||
instance Monoid (Mod a) where
|
||||
mempty = Mod id
|
||||
Mod f `mappend` Mod g = Mod (g . f)
|
||||
|
||||
data Filter =
|
||||
Not Filter
|
||||
| And (NonEmpty Filter)
|
||||
| Or (NonEmpty Filter)
|
||||
| Present Attr
|
||||
| Attr := ByteString
|
||||
| Attr :>= ByteString
|
||||
| Attr :<= ByteString
|
||||
| Attr :~= ByteString
|
||||
| Attr :=* (Maybe ByteString, [ByteString], Maybe ByteString)
|
||||
| (Maybe Attr, Maybe Attr, Bool) ::= ByteString
|
||||
|
||||
newtype Attr = Attr Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- 'Attr' unwrapper. This is a separate function not to turn 'Attr''s
|
||||
-- 'Show' instance into complete and utter shit.
|
||||
unAttr :: Attr -> Text
|
||||
unAttr (Attr a) = a
|
||||
|
||||
data SearchEntry = SearchEntry Dn [(Attr, Set ByteString)]
|
||||
deriving (Show, Eq)
|
||||
|
||||
|
||||
-- | Note that 'unbindAsync' does not return an 'Async',
|
||||
-- because LDAP server never responds to @UnbindRequest@s, hence
|
||||
-- a call to 'wait' on a hypothetical 'Async' would have resulted
|
||||
-- in an exception anyway.
|
||||
unbindAsync :: Ldap -> IO ()
|
||||
unbindAsync =
|
||||
atomically . unbindAsyncSTM
|
||||
|
||||
-- | Note that 'unbindAsyncSTM' does not return an 'Async',
|
||||
-- because LDAP server never responds to @UnbindRequest@s, hence
|
||||
-- a call to 'wait' on a hypothetical 'Async' would have resulted
|
||||
-- in an exception anyway.
|
||||
unbindAsyncSTM :: Ldap -> STM ()
|
||||
unbindAsyncSTM l =
|
||||
void (sendRequest l die Type.UnbindRequest)
|
||||
where
|
||||
die = error "Ldap.Client: do not wait for the response to UnbindRequest"
|
||||
|
||||
|
||||
wait :: Async e a -> IO (Either e a)
|
||||
wait = atomically . waitSTM
|
||||
|
||||
waitSTM :: Async e a -> STM (Either e a)
|
||||
waitSTM (Async stm) = stm
|
||||
|
||||
|
||||
sendRequest :: Ldap -> (Response -> Either e a) -> Request -> STM (Async e a)
|
||||
sendRequest l p msg =
|
||||
do var <- newEmptyTMVar
|
||||
writeRequest l var msg
|
||||
return (Async (fmap p (readTMVar var)))
|
||||
|
||||
writeRequest :: Ldap -> TMVar Response -> Request -> STM ()
|
||||
writeRequest Ldap { client } var msg = writeTQueue client (New msg var)
|
||||
|
||||
raise :: Exception e => Either e a -> IO a
|
||||
raise = either throwIO return
|
||||
Loading…
Reference in New Issue
Block a user