{-# 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
(Int -> Host -> ShowS)
-> (Host -> String) -> ([Host] -> ShowS) -> Show Host
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Host -> ShowS
showsPrec :: Int -> Host -> ShowS
$cshow :: Host -> String
show :: Host -> String
$cshowList :: [Host] -> ShowS
showList :: [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
(Ldap -> Ldap -> Bool) -> (Ldap -> Ldap -> Bool) -> Eq Ldap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Ldap -> Ldap -> Bool
== :: Ldap -> Ldap -> Bool
$c/= :: Ldap -> Ldap -> Bool
/= :: 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) = STM (Either ResponseError b) -> Async b
forall a. STM (Either ResponseError a) -> Async a
Async ((Either ResponseError a -> Either ResponseError b)
-> STM (Either ResponseError a) -> STM (Either ResponseError b)
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Either ResponseError a -> Either ResponseError b
forall a b.
(a -> b) -> Either ResponseError a -> Either ResponseError b
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
(Int -> Dn -> ShowS)
-> (Dn -> String) -> ([Dn] -> ShowS) -> Show Dn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dn -> ShowS
showsPrec :: Int -> Dn -> ShowS
$cshow :: Dn -> String
show :: Dn -> String
$cshowList :: [Dn] -> ShowS
showList :: [Dn] -> ShowS
Show, Dn -> Dn -> Bool
(Dn -> Dn -> Bool) -> (Dn -> Dn -> Bool) -> Eq Dn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Dn -> Dn -> Bool
== :: Dn -> Dn -> Bool
$c/= :: Dn -> Dn -> Bool
/= :: 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
(Int -> ResponseError -> ShowS)
-> (ResponseError -> String)
-> ([ResponseError] -> ShowS)
-> Show ResponseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResponseError -> ShowS
showsPrec :: Int -> ResponseError -> ShowS
$cshow :: ResponseError -> String
show :: ResponseError -> String
$cshowList :: [ResponseError] -> ShowS
showList :: [ResponseError] -> ShowS
Show, ResponseError -> ResponseError -> Bool
(ResponseError -> ResponseError -> Bool)
-> (ResponseError -> ResponseError -> Bool) -> Eq ResponseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResponseError -> ResponseError -> Bool
== :: ResponseError -> ResponseError -> Bool
$c/= :: ResponseError -> ResponseError -> Bool
/= :: ResponseError -> ResponseError -> Bool
Eq, Typeable)

instance Exception ResponseError

-- | Attribute name.
newtype Attr = Attr Text
    deriving (Int -> Attr -> ShowS
[Attr] -> ShowS
Attr -> String
(Int -> Attr -> ShowS)
-> (Attr -> String) -> ([Attr] -> ShowS) -> Show Attr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Attr -> ShowS
showsPrec :: Int -> Attr -> ShowS
$cshow :: Attr -> String
show :: Attr -> String
$cshowList :: [Attr] -> ShowS
showList :: [Attr] -> ShowS
Show, Attr -> Attr -> Bool
(Attr -> Attr -> Bool) -> (Attr -> Attr -> Bool) -> Eq Attr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Attr -> Attr -> Bool
== :: Attr -> Attr -> Bool
$c/= :: Attr -> Attr -> Bool
/= :: 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 = STM (Either ResponseError a) -> IO (Either ResponseError a)
forall a. STM a -> IO a
atomically (STM (Either ResponseError a) -> IO (Either ResponseError a))
-> (Async a -> STM (Either ResponseError a))
-> Async a
-> IO (Either ResponseError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async a -> STM (Either ResponseError a)
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 <- STM (TMVar Response)
forall a. STM (TMVar a)
newEmptyTMVar
     Ldap -> TMVar Response -> Request -> STM ()
writeRequest Ldap
l TMVar Response
var Request
msg
     Async a -> STM (Async a)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (STM (Either ResponseError a) -> Async a
forall a. STM (Either ResponseError a) -> Async a
Async ((Response -> Either ResponseError a)
-> STM Response -> STM (Either ResponseError a)
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response -> Either ResponseError a
p (TMVar Response -> STM Response
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 :: Ldap -> TQueue ClientMessage
client :: TQueue ClientMessage
client } TMVar Response
var Request
msg = TQueue ClientMessage -> ClientMessage -> STM ()
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 = (e -> IO a) -> (a -> IO a) -> Either e a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure


-- | 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 =
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Ldap -> STM ()) -> Ldap -> IO ()
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 =
  STM (Async Any) -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ldap
-> (Response -> Either ResponseError Any)
-> Request
-> STM (Async Any)
forall a.
Ldap
-> (Response -> Either ResponseError a) -> Request -> STM (Async a)
sendRequest Ldap
l Response -> Either ResponseError Any
forall {a}. a
die Request
Type.UnbindRequest)
 where
  die :: a
die = String -> a
forall a. HasCallStack => String -> a
error String
"Ldap.Client: do not wait for the response to UnbindRequest"