{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module Ldap.Client.Internal
( Host(..)
, PortNumber
, Ldap(..)
, ClientMessage(..)
, Type.ResultCode(..)
, Async
, AttrList
, wait
, waitSTM
, Response
, ResponseError(..)
, Request
, raise
, sendRequest
, Dn(..)
, Attr(..)
, AttrValue
, unAttr
, unbindAsync
, unbindAsyncSTM
) where
import Control.Concurrent.STM (STM, atomically)
import Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVar, readTMVar)
import Control.Concurrent.STM.TQueue (TQueue, writeTQueue)
import Control.Exception (Exception, throwIO)
import Control.Monad (void)
import Data.ByteString (ByteString)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Network.Connection (TLSSettings)
import Network.Socket (PortNumber)
import qualified Ldap.Asn1.Type as Type
data Host =
Plain String
| Tls String TLSSettings
deriving (Int -> Host -> ShowS
[Host] -> ShowS
Host -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Host] -> ShowS
$cshowList :: [Host] -> ShowS
show :: Host -> String
$cshow :: Host -> String
showsPrec :: Int -> Host -> ShowS
$cshowsPrec :: Int -> Host -> ShowS
Show)
newtype Ldap = Ldap
{ Ldap -> TQueue ClientMessage
client :: TQueue ClientMessage
} deriving (Ldap -> Ldap -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ldap -> Ldap -> Bool
$c/= :: Ldap -> Ldap -> Bool
== :: Ldap -> Ldap -> Bool
$c== :: Ldap -> Ldap -> Bool
Eq)
data ClientMessage = New !Request !(TMVar (NonEmpty Type.ProtocolServerOp))
type Request = Type.ProtocolClientOp
type InMessage = Type.ProtocolServerOp
type Response = NonEmpty InMessage
newtype Async a = Async (STM (Either ResponseError a))
instance Functor Async where
fmap :: forall a b. (a -> b) -> Async a -> Async b
fmap a -> b
f (Async STM (Either ResponseError a)
stm) = forall a. STM (Either ResponseError a) -> Async a
Async (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) STM (Either ResponseError a)
stm)
newtype Dn = Dn Text
deriving (Int -> Dn -> ShowS
[Dn] -> ShowS
Dn -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dn] -> ShowS
$cshowList :: [Dn] -> ShowS
show :: Dn -> String
$cshow :: Dn -> String
showsPrec :: Int -> Dn -> ShowS
$cshowsPrec :: Int -> Dn -> ShowS
Show, Dn -> Dn -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dn -> Dn -> Bool
$c/= :: Dn -> Dn -> Bool
== :: Dn -> Dn -> Bool
$c== :: Dn -> Dn -> Bool
Eq)
data ResponseError =
ResponseInvalid !Request !Response
| ResponseErrorCode !Request !Type.ResultCode !Dn !Text
deriving (Int -> ResponseError -> ShowS
[ResponseError] -> ShowS
ResponseError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResponseError] -> ShowS
$cshowList :: [ResponseError] -> ShowS
show :: ResponseError -> String
$cshow :: ResponseError -> String
showsPrec :: Int -> ResponseError -> ShowS
$cshowsPrec :: Int -> ResponseError -> ShowS
Show, ResponseError -> ResponseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResponseError -> ResponseError -> Bool
$c/= :: ResponseError -> ResponseError -> Bool
== :: ResponseError -> ResponseError -> Bool
$c== :: ResponseError -> ResponseError -> Bool
Eq, Typeable)
instance Exception ResponseError
newtype Attr = Attr Text
deriving (Int -> Attr -> ShowS
[Attr] -> ShowS
Attr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attr] -> ShowS
$cshowList :: [Attr] -> ShowS
show :: Attr -> String
$cshow :: Attr -> String
showsPrec :: Int -> Attr -> ShowS
$cshowsPrec :: Int -> Attr -> ShowS
Show, Attr -> Attr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attr -> Attr -> Bool
$c/= :: Attr -> Attr -> Bool
== :: Attr -> Attr -> Bool
$c== :: Attr -> Attr -> Bool
Eq)
type AttrValue = ByteString
type AttrList f = [(Attr, f AttrValue)]
unAttr :: Attr -> Text
unAttr :: Attr -> Text
unAttr (Attr Text
a) = Text
a
wait :: Async a -> IO (Either ResponseError a)
wait :: forall a. Async a -> IO (Either ResponseError a)
wait = forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Async a -> STM (Either ResponseError a)
waitSTM
waitSTM :: Async a -> STM (Either ResponseError a)
waitSTM :: forall a. Async a -> STM (Either ResponseError a)
waitSTM (Async STM (Either ResponseError a)
stm) = STM (Either ResponseError a)
stm
sendRequest :: Ldap -> (Response -> Either ResponseError a) -> Request -> STM (Async a)
sendRequest :: forall a.
Ldap
-> (Response -> Either ResponseError a) -> Request -> STM (Async a)
sendRequest Ldap
l Response -> Either ResponseError a
p Request
msg =
do TMVar Response
var <- forall a. STM (TMVar a)
newEmptyTMVar
Ldap -> TMVar Response -> Request -> STM ()
writeRequest Ldap
l TMVar Response
var Request
msg
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. STM (Either ResponseError a) -> Async a
Async (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response -> Either ResponseError a
p (forall a. TMVar a -> STM a
readTMVar TMVar Response
var)))
writeRequest :: Ldap -> TMVar Response -> Request -> STM ()
writeRequest :: Ldap -> TMVar Response -> Request -> STM ()
writeRequest Ldap { TQueue ClientMessage
client :: TQueue ClientMessage
client :: Ldap -> TQueue ClientMessage
client } TMVar Response
var Request
msg = forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ClientMessage
client (Request -> TMVar Response -> ClientMessage
New Request
msg TMVar Response
var)
raise :: Exception e => Either e a -> IO a
raise :: forall e a. Exception e => Either e a -> IO a
raise = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return
unbindAsync :: Ldap -> IO ()
unbindAsync :: Ldap -> IO ()
unbindAsync =
forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ldap -> STM ()
unbindAsyncSTM
unbindAsyncSTM :: Ldap -> STM ()
unbindAsyncSTM :: Ldap -> STM ()
unbindAsyncSTM Ldap
l =
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a.
Ldap
-> (Response -> Either ResponseError a) -> Request -> STM (Async a)
sendRequest Ldap
l forall {a}. a
die Request
Type.UnbindRequest)
where
die :: a
die = forall a. HasCallStack => String -> a
error String
"Ldap.Client: do not wait for the response to UnbindRequest"