{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module Ldap.Client.Internal
  ( Host(..)
  , PortNumber
  , Ldap(..)
  , ClientMessage(..)
  , Type.ResultCode(..)
  , Async
  , AttrList
    -- * Waiting for Request Completion
  , wait
  , waitSTM
    -- * Misc
  , Response
  , ResponseError(..)
  , Request
  , raise
  , sendRequest
  , Dn(..)
  , Attr(..)
  , AttrValue
  , unAttr
    -- * Unbind operation
  , 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


-- | LDAP host.
data Host =
    Plain String           -- ^ Plain LDAP.
  | Tls String TLSSettings -- ^ LDAP over TLS.
    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)

-- | A token. All functions that interact with the Directory require one.
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

-- | Asynchronous LDAP operation. Use 'wait' or 'waitSTM' to wait for its completion.
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)

-- | Unique identifier of an LDAP entry.
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)

-- | Response indicates a failed operation.
data ResponseError =
    ResponseInvalid !Request !Response -- ^ LDAP server did not follow the protocol, so @ldap-client@ couldn't make sense of the response.
  | ResponseErrorCode !Request !Type.ResultCode !Dn !Text -- ^ The response contains a result code indicating failure and an error message.
    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

-- | Attribute name.
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)

-- | Attribute value.
type AttrValue = ByteString

-- | List of attributes and their values. @f@ is the structure these
-- values are in, e.g. 'NonEmpty'.
type AttrList f = [(Attr, f AttrValue)]

-- 'Attr' unwrapper. This is a separate function not to turn 'Attr''s
-- 'Show' instance into complete and utter shit.
unAttr :: Attr -> Text
unAttr :: Attr -> Text
unAttr (Attr Text
a) = Text
a

-- | Wait for operation completion.
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

-- | Wait for operation completion inside 'STM'.
--
-- Do not use this inside the same 'STM' transaction the operation was
-- requested in! To give LDAP the chance to respond to it that transaction
-- should commit. After that, applying 'waitSTM' to the corresponding 'Async'
-- starts to make sense.
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


-- | Terminate the connection to the Directory.
--
-- 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 :: Ldap -> IO ()
unbindAsync =
  forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ldap -> STM ()
unbindAsyncSTM

-- | Terminate the connection to the Directory.
--
-- 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 :: 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"