{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StandaloneDeriving #-}
--------------------------------------------------------------------------------
-- |
-- Module    :  Database.EventStore.Internal.Operation
-- Copyright :  (C) 2020 Yorick Laupa
-- License   :  (see the file LICENSE)
-- Maintainer:  Yorick Laupa <yo.eight@gmail.com>
-- Stability :  experimental
-- Portability: non-portable
--
--------------------------------------------------------------------------------
module Database.EventStore.Internal.Operation where

--------------------------------------------------------------------------------
import Prelude (String)
import Data.ProtocolBuffers
import Data.Serialize (runPut, runGet)

--------------------------------------------------------------------------------
import Database.EventStore.Internal.Command
import Database.EventStore.Internal.Control
import Database.EventStore.Internal.Prelude hiding ((.), id)
import Database.EventStore.Internal.Stream
import Database.EventStore.Internal.Types

--------------------------------------------------------------------------------
newtype Mailbox = Mailbox (Chan (Either OperationError Package))

--------------------------------------------------------------------------------
mailboxSendPkg :: MonadBase IO m => Mailbox -> Package -> m ()
mailboxSendPkg :: forall (m :: * -> *). MonadBase IO m => Mailbox -> Package -> m ()
mailboxSendPkg (Mailbox Chan (Either OperationError Package)
chan) Package
pkg = forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan Chan (Either OperationError Package)
chan (forall a b. b -> Either a b
Right Package
pkg)

--------------------------------------------------------------------------------
mailboxFail :: MonadBase IO m => Mailbox -> OperationError -> m ()
mailboxFail :: forall (m :: * -> *).
MonadBase IO m =>
Mailbox -> OperationError -> m ()
mailboxFail (Mailbox Chan (Either OperationError Package)
chan) OperationError
e = forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan Chan (Either OperationError Package)
chan (forall a b. a -> Either a b
Left OperationError
e)

--------------------------------------------------------------------------------
mailboxRead :: MonadBase IO m => Mailbox -> m (Either OperationError Package)
mailboxRead :: forall (m :: * -> *).
MonadBase IO m =>
Mailbox -> m (Either OperationError Package)
mailboxRead (Mailbox Chan (Either OperationError Package)
chan) = forall (m :: * -> *) a. MonadBase IO m => Chan a -> m a
readChan Chan (Either OperationError Package)
chan

--------------------------------------------------------------------------------
mailboxReadDecoded
  :: (MonadBase IO m, Decode resp)
  => Mailbox
  -> m (Either OperationError resp)
mailboxReadDecoded :: forall (m :: * -> *) resp.
(MonadBase IO m, Decode resp) =>
Mailbox -> m (Either OperationError resp)
mailboxReadDecoded (Mailbox Chan (Either OperationError Package)
chan)
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall msg. Decode msg => Package -> Either OperationError msg
decodePkg forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadBase IO m => Chan a -> m a
readChan Chan (Either OperationError Package)
chan

--------------------------------------------------------------------------------
mailboxNew :: MonadBase IO m => m Mailbox
mailboxNew :: forall (m :: * -> *). MonadBase IO m => m Mailbox
mailboxNew = Chan (Either OperationError Package) -> Mailbox
Mailbox forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadBase IO m => m (Chan a)
newChan

--------------------------------------------------------------------------------
createPkg
  :: (Encode msg, MonadIO m)
  => Command
  -> Maybe Credentials
  -> msg
  -> m Package
createPkg :: forall msg (m :: * -> *).
(Encode msg, MonadIO m) =>
Command -> Maybe Credentials -> msg -> m Package
createPkg Command
cmd Maybe Credentials
creds msg
msg
  = do UUID
pkgId <- forall (m :: * -> *). MonadIO m => m UUID
freshUUID
       let dat :: ByteString
dat = Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ forall a. Encode a => a -> Put
encodeMessage msg
msg
           pkg :: Package
pkg
             = Package
               { packageCmd :: Command
packageCmd = Command
cmd
               , packageCorrelation :: UUID
packageCorrelation = UUID
pkgId
               , packageData :: ByteString
packageData = ByteString
dat
               , packageCred :: Maybe Credentials
packageCred = Maybe Credentials
creds
               }

       forall (f :: * -> *) a. Applicative f => a -> f a
pure Package
pkg

--------------------------------------------------------------------------------
-- FIXME We could use Bifunctor but can't I am not sure it covers all the GHC
-- we support at that time.
decodePkg :: Decode msg => Package -> Either OperationError msg
decodePkg :: forall msg. Decode msg => Package -> Either OperationError msg
decodePkg Package
pkg
  = case forall a. Get a -> ByteString -> Either String a
runGet forall a. Decode a => Get a
decodeMessage (Package -> ByteString
packageData Package
pkg) of
      Left String
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> OperationError
ProtobufDecodingError String
e
      Right msg
resp -> forall a b. b -> Either a b
Right msg
resp

--------------------------------------------------------------------------------
-- | Operation exception that can occurs on an operation response.
data OperationError
  = WrongExpectedVersion !Text !ExpectedVersion -- ^ Stream and Expected Version
  | StreamDeleted !StreamName                        -- ^ Stream
  | InvalidTransaction
  | forall t. AccessDenied !(StreamId t)                   -- ^ Stream
  | InvalidServerResponse !Command !Command     -- ^ Expected, Found
  | ProtobufDecodingError !String
  | ServerError !(Maybe Text)                  -- ^ Reason
  | InvalidOperation !Text
  | StreamNotFound !StreamName
  | NotAuthenticatedOp
    -- ^ Invalid operation state. If happens, it's a driver bug.
  | Aborted
    -- ^ Occurs when the user asked to close the connection or if the
    --   connection can't reconnect anymore.
  | ConnectionHasDropped
  deriving Typeable

--------------------------------------------------------------------------------
deriving instance Show OperationError

--------------------------------------------------------------------------------
instance Exception OperationError

--------------------------------------------------------------------------------
-- | Operation result sent by the server.
data OpResult
    = OP_SUCCESS
    | OP_PREPARE_TIMEOUT
    | OP_COMMIT_TIMEOUT
    | OP_FORWARD_TIMEOUT
    | OP_WRONG_EXPECTED_VERSION
    | OP_STREAM_DELETED
    | OP_INVALID_TRANSACTION
    | OP_ACCESS_DENIED
    deriving (OpResult -> OpResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OpResult -> OpResult -> Bool
$c/= :: OpResult -> OpResult -> Bool
== :: OpResult -> OpResult -> Bool
$c== :: OpResult -> OpResult -> Bool
Eq, Int -> OpResult
OpResult -> Int
OpResult -> [OpResult]
OpResult -> OpResult
OpResult -> OpResult -> [OpResult]
OpResult -> OpResult -> OpResult -> [OpResult]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: OpResult -> OpResult -> OpResult -> [OpResult]
$cenumFromThenTo :: OpResult -> OpResult -> OpResult -> [OpResult]
enumFromTo :: OpResult -> OpResult -> [OpResult]
$cenumFromTo :: OpResult -> OpResult -> [OpResult]
enumFromThen :: OpResult -> OpResult -> [OpResult]
$cenumFromThen :: OpResult -> OpResult -> [OpResult]
enumFrom :: OpResult -> [OpResult]
$cenumFrom :: OpResult -> [OpResult]
fromEnum :: OpResult -> Int
$cfromEnum :: OpResult -> Int
toEnum :: Int -> OpResult
$ctoEnum :: Int -> OpResult
pred :: OpResult -> OpResult
$cpred :: OpResult -> OpResult
succ :: OpResult -> OpResult
$csucc :: OpResult -> OpResult
Enum, Int -> OpResult -> ShowS
[OpResult] -> ShowS
OpResult -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OpResult] -> ShowS
$cshowList :: [OpResult] -> ShowS
show :: OpResult -> String
$cshow :: OpResult -> String
showsPrec :: Int -> OpResult -> ShowS
$cshowsPrec :: Int -> OpResult -> ShowS
Show)

--------------------------------------------------------------------------------
data Lifetime
  = OneTime
  | KeepAlive !Command

--------------------------------------------------------------------------------
data Loop a
  = Loop
  | Break !a

--------------------------------------------------------------------------------
data LoopS s a
  = LoopS !s
  | BreakS !a

--------------------------------------------------------------------------------
keepLooping :: Monad m => m (Loop a) -> m a
keepLooping :: forall (m :: * -> *) a. Monad m => m (Loop a) -> m a
keepLooping m (Loop a)
action
  = m a
go
  where
    go :: m a
go = do Loop a
result <- m (Loop a)
action
            case Loop a
result of
              Loop a
Loop -> m a
go
              Break a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

--------------------------------------------------------------------------------
keepLoopingS :: Monad m => s -> (s -> m (LoopS s a)) -> m a
keepLoopingS :: forall (m :: * -> *) s a.
Monad m =>
s -> (s -> m (LoopS s a)) -> m a
keepLoopingS s
seed s -> m (LoopS s a)
action
  = s -> m a
go s
seed
  where
    go :: s -> m a
go s
cur
      = do LoopS s a
result <- s -> m (LoopS s a)
action s
cur
           case LoopS s a
result of
             LoopS s
next
               -> s -> m a
go s
next
             BreakS a
a
               -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a