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