{-# 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 :: Mailbox -> Package -> m ()
mailboxSendPkg (Mailbox Chan (Either OperationError Package)
chan) Package
pkg = Chan (Either OperationError Package)
-> Either OperationError Package -> m ()
forall (m :: * -> *) a. MonadBase IO m => Chan a -> a -> m ()
writeChan Chan (Either OperationError Package)
chan (Package -> Either OperationError Package
forall a b. b -> Either a b
Right Package
pkg)

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

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

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

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

       Package -> m Package
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 :: Package -> Either OperationError msg
decodePkg Package
pkg
  = case Get msg -> ByteString -> Either String msg
forall a. Get a -> ByteString -> Either String a
runGet Get msg
forall a. Decode a => Get a
decodeMessage (Package -> ByteString
packageData Package
pkg) of
      Left String
e -> OperationError -> Either OperationError msg
forall a b. a -> Either a b
Left (OperationError -> Either OperationError msg)
-> OperationError -> Either OperationError msg
forall a b. (a -> b) -> a -> b
$ String -> OperationError
ProtobufDecodingError String
e
      Right msg
resp -> msg -> Either OperationError msg
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
(OpResult -> OpResult -> Bool)
-> (OpResult -> OpResult -> Bool) -> Eq OpResult
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]
(OpResult -> OpResult)
-> (OpResult -> OpResult)
-> (Int -> OpResult)
-> (OpResult -> Int)
-> (OpResult -> [OpResult])
-> (OpResult -> OpResult -> [OpResult])
-> (OpResult -> OpResult -> [OpResult])
-> (OpResult -> OpResult -> OpResult -> [OpResult])
-> Enum 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
(Int -> OpResult -> ShowS)
-> (OpResult -> String) -> ([OpResult] -> ShowS) -> Show OpResult
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 :: 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 -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

--------------------------------------------------------------------------------
keepLoopingS :: Monad m => s -> (s -> m (LoopS s a)) -> m a
keepLoopingS :: 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
               -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a