--------------------------------------------------------------------------------
-- |
-- Module : Database.EventStore.Internal.Subscription.Command
-- Copyright : (C) 2016 Yorick Laupa
-- License : (see the file LICENSE)
--
-- Maintainer : Yorick Laupa <yo.eight@gmail.com>
-- Stability : provisional
-- Portability : non-portable
--
--------------------------------------------------------------------------------
module Database.EventStore.Internal.Subscription.Command where

--------------------------------------------------------------------------------
import Data.ProtocolBuffers
import Data.Serialize

--------------------------------------------------------------------------------
import Database.EventStore.Internal.Command
import Database.EventStore.Internal.Prelude
import Database.EventStore.Internal.Subscription.Message
import Database.EventStore.Internal.Subscription.Types
import Database.EventStore.Internal.Types

--------------------------------------------------------------------------------
data ServerMessage
    = LiveMsg !LiveMsg
    | ConfirmationMsg !ConfirmationMsg
    | ErrorMsg !ErrorMsg

--------------------------------------------------------------------------------
data LiveMsg
    = EventAppearedMsg !ResolvedEvent
    | PersistentEventAppearedMsg !ResolvedEvent
    | DroppedMsg !SubDropReason

--------------------------------------------------------------------------------
data ConfirmationMsg
    = RegularConfirmationMsg !Int64 !(Maybe Int64)
    | PersistentConfirmationMsg !Text !Int64 !(Maybe Int64)

--------------------------------------------------------------------------------
confirmationCommitPos :: ConfirmationMsg -> Int64
confirmationCommitPos :: ConfirmationMsg -> Int64
confirmationCommitPos (RegularConfirmationMsg Int64
pos Maybe Int64
_)       = Int64
pos
confirmationCommitPos  (PersistentConfirmationMsg Text
_ Int64
pos Maybe Int64
_) = Int64
pos

--------------------------------------------------------------------------------
confirmationLastEventNum :: ConfirmationMsg -> Maybe Int64
confirmationLastEventNum :: ConfirmationMsg -> Maybe Int64
confirmationLastEventNum (RegularConfirmationMsg Int64
_ Maybe Int64
num)      = Maybe Int64
num
confirmationLastEventNum (PersistentConfirmationMsg Text
_ Int64
_ Maybe Int64
num) = Maybe Int64
num

--------------------------------------------------------------------------------
confirmationPersistentSubId :: ConfirmationMsg -> Maybe Text
confirmationPersistentSubId :: ConfirmationMsg -> Maybe Text
confirmationPersistentSubId (PersistentConfirmationMsg Text
ident Int64
_ Maybe Int64
_) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ident
confirmationPersistentSubId ConfirmationMsg
_                                     = Maybe Text
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
data ErrorMsg
    = BadRequestMsg !(Maybe Text)
    | NotHandledMsg !NotHandledReason !(Maybe MasterInfo)
    | NotAuthenticatedMsg !(Maybe Text)
    | UnknownMsg !(Maybe Command)

--------------------------------------------------------------------------------
decodeServerMessage :: Package -> ServerMessage
decodeServerMessage :: Package -> ServerMessage
decodeServerMessage Package
pkg = ServerMessage -> Maybe ServerMessage -> ServerMessage
forall a. a -> Maybe a -> a
fromMaybe ServerMessage
err Maybe ServerMessage
go
  where
    err :: ServerMessage
err = ErrorMsg -> ServerMessage
ErrorMsg (ErrorMsg -> ServerMessage) -> ErrorMsg -> ServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe Command -> ErrorMsg
UnknownMsg (Maybe Command -> ErrorMsg) -> Maybe Command -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Command -> Maybe Command
forall a. a -> Maybe a
Just (Command -> Maybe Command) -> Command -> Maybe Command
forall a b. (a -> b) -> a -> b
$ Package -> Command
packageCmd Package
pkg
    go :: Maybe ServerMessage
go =
        case Package -> Command
packageCmd Package
pkg of
            Command
cmd | Command
cmd Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
== Command
streamEventAppearedCmd -> do
                StreamEventAppeared
msg <- ByteString -> Maybe StreamEventAppeared
forall a. Decode a => ByteString -> Maybe a
maybeDecodeMessage (ByteString -> Maybe StreamEventAppeared)
-> ByteString -> Maybe StreamEventAppeared
forall a b. (a -> b) -> a -> b
$ Package -> ByteString
packageData Package
pkg
                let evt :: ResolvedEvent
evt = ResolvedEventBuf -> ResolvedEvent
newResolvedEventFromBuf (ResolvedEventBuf -> ResolvedEvent)
-> ResolvedEventBuf -> ResolvedEvent
forall a b. (a -> b) -> a -> b
$ Field 1 (RequiredField (Always (Message ResolvedEventBuf)))
-> FieldType
     (Field 1 (RequiredField (Always (Message ResolvedEventBuf))))
forall a. HasField a => a -> FieldType a
getField
                                                  (Field 1 (RequiredField (Always (Message ResolvedEventBuf)))
 -> FieldType
      (Field 1 (RequiredField (Always (Message ResolvedEventBuf)))))
-> Field 1 (RequiredField (Always (Message ResolvedEventBuf)))
-> FieldType
     (Field 1 (RequiredField (Always (Message ResolvedEventBuf))))
forall a b. (a -> b) -> a -> b
$ StreamEventAppeared -> Required 1 (Message ResolvedEventBuf)
streamResolvedEvent StreamEventAppeared
msg
                ServerMessage -> Maybe ServerMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerMessage -> Maybe ServerMessage)
-> ServerMessage -> Maybe ServerMessage
forall a b. (a -> b) -> a -> b
$ LiveMsg -> ServerMessage
LiveMsg (LiveMsg -> ServerMessage) -> LiveMsg -> ServerMessage
forall a b. (a -> b) -> a -> b
$ ResolvedEvent -> LiveMsg
EventAppearedMsg ResolvedEvent
evt
                | Command
cmd Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
== Command
persistentSubscriptionStreamEventAppearedCmd -> do
                PersistentSubscriptionStreamEventAppeared
msg <- ByteString -> Maybe PersistentSubscriptionStreamEventAppeared
forall a. Decode a => ByteString -> Maybe a
maybeDecodeMessage (ByteString -> Maybe PersistentSubscriptionStreamEventAppeared)
-> ByteString -> Maybe PersistentSubscriptionStreamEventAppeared
forall a b. (a -> b) -> a -> b
$ Package -> ByteString
packageData Package
pkg
                let evt :: ResolvedEvent
evt = ResolvedIndexedEvent -> ResolvedEvent
newResolvedEvent (ResolvedIndexedEvent -> ResolvedEvent)
-> ResolvedIndexedEvent -> ResolvedEvent
forall a b. (a -> b) -> a -> b
$ Field 1 (RequiredField (Always (Message ResolvedIndexedEvent)))
-> FieldType
     (Field 1 (RequiredField (Always (Message ResolvedIndexedEvent))))
forall a. HasField a => a -> FieldType a
getField (Field 1 (RequiredField (Always (Message ResolvedIndexedEvent)))
 -> FieldType
      (Field 1 (RequiredField (Always (Message ResolvedIndexedEvent)))))
-> Field 1 (RequiredField (Always (Message ResolvedIndexedEvent)))
-> FieldType
     (Field 1 (RequiredField (Always (Message ResolvedIndexedEvent))))
forall a b. (a -> b) -> a -> b
$ PersistentSubscriptionStreamEventAppeared
-> Required 1 (Message ResolvedIndexedEvent)
psseaEvt PersistentSubscriptionStreamEventAppeared
msg
                ServerMessage -> Maybe ServerMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerMessage -> Maybe ServerMessage)
-> ServerMessage -> Maybe ServerMessage
forall a b. (a -> b) -> a -> b
$ LiveMsg -> ServerMessage
LiveMsg (LiveMsg -> ServerMessage) -> LiveMsg -> ServerMessage
forall a b. (a -> b) -> a -> b
$ ResolvedEvent -> LiveMsg
PersistentEventAppearedMsg ResolvedEvent
evt
                | Command
cmd Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
== Command
subscriptionConfirmationCmd -> do
                SubscriptionConfirmation
msg <- ByteString -> Maybe SubscriptionConfirmation
forall a. Decode a => ByteString -> Maybe a
maybeDecodeMessage (ByteString -> Maybe SubscriptionConfirmation)
-> ByteString -> Maybe SubscriptionConfirmation
forall a b. (a -> b) -> a -> b
$ Package -> ByteString
packageData Package
pkg
                let lcp :: FieldType (Field 1 (RequiredField (Always (Value Int64))))
lcp = Field 1 (RequiredField (Always (Value Int64)))
-> FieldType (Field 1 (RequiredField (Always (Value Int64))))
forall a. HasField a => a -> FieldType a
getField (Field 1 (RequiredField (Always (Value Int64)))
 -> FieldType (Field 1 (RequiredField (Always (Value Int64)))))
-> Field 1 (RequiredField (Always (Value Int64)))
-> FieldType (Field 1 (RequiredField (Always (Value Int64))))
forall a b. (a -> b) -> a -> b
$ SubscriptionConfirmation -> Required 1 (Value Int64)
subscribeLastCommitPos SubscriptionConfirmation
msg
                    len :: FieldType (Field 2 (OptionalField (Last (Value Int64))))
len = Field 2 (OptionalField (Last (Value Int64)))
-> FieldType (Field 2 (OptionalField (Last (Value Int64))))
forall a. HasField a => a -> FieldType a
getField (Field 2 (OptionalField (Last (Value Int64)))
 -> FieldType (Field 2 (OptionalField (Last (Value Int64)))))
-> Field 2 (OptionalField (Last (Value Int64)))
-> FieldType (Field 2 (OptionalField (Last (Value Int64))))
forall a b. (a -> b) -> a -> b
$ SubscriptionConfirmation -> Optional 2 (Value Int64)
subscribeLastEventNumber SubscriptionConfirmation
msg
                ServerMessage -> Maybe ServerMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerMessage -> Maybe ServerMessage)
-> ServerMessage -> Maybe ServerMessage
forall a b. (a -> b) -> a -> b
$ ConfirmationMsg -> ServerMessage
ConfirmationMsg (ConfirmationMsg -> ServerMessage)
-> ConfirmationMsg -> ServerMessage
forall a b. (a -> b) -> a -> b
$ Int64 -> Maybe Int64 -> ConfirmationMsg
RegularConfirmationMsg Int64
FieldType (Field 1 (RequiredField (Always (Value Int64))))
lcp Maybe Int64
FieldType (Field 2 (OptionalField (Last (Value Int64))))
len
                | Command
cmd Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
== Command
persistentSubscriptionConfirmationCmd -> do
                PersistentSubscriptionConfirmation
msg <- ByteString -> Maybe PersistentSubscriptionConfirmation
forall a. Decode a => ByteString -> Maybe a
maybeDecodeMessage (ByteString -> Maybe PersistentSubscriptionConfirmation)
-> ByteString -> Maybe PersistentSubscriptionConfirmation
forall a b. (a -> b) -> a -> b
$ Package -> ByteString
packageData Package
pkg
                let lcp :: FieldType (Field 1 (RequiredField (Always (Value Int64))))
lcp = Field 1 (RequiredField (Always (Value Int64)))
-> FieldType (Field 1 (RequiredField (Always (Value Int64))))
forall a. HasField a => a -> FieldType a
getField (Field 1 (RequiredField (Always (Value Int64)))
 -> FieldType (Field 1 (RequiredField (Always (Value Int64)))))
-> Field 1 (RequiredField (Always (Value Int64)))
-> FieldType (Field 1 (RequiredField (Always (Value Int64))))
forall a b. (a -> b) -> a -> b
$ PersistentSubscriptionConfirmation -> Required 1 (Value Int64)
pscLastCommitPos PersistentSubscriptionConfirmation
msg
                    sid :: FieldType (Field 2 (RequiredField (Always (Value Text))))
sid = Field 2 (RequiredField (Always (Value Text)))
-> FieldType (Field 2 (RequiredField (Always (Value Text))))
forall a. HasField a => a -> FieldType a
getField (Field 2 (RequiredField (Always (Value Text)))
 -> FieldType (Field 2 (RequiredField (Always (Value Text)))))
-> Field 2 (RequiredField (Always (Value Text)))
-> FieldType (Field 2 (RequiredField (Always (Value Text))))
forall a b. (a -> b) -> a -> b
$ PersistentSubscriptionConfirmation -> Required 2 (Value Text)
pscId PersistentSubscriptionConfirmation
msg
                    len :: FieldType (Field 3 (OptionalField (Last (Value Int64))))
len = Field 3 (OptionalField (Last (Value Int64)))
-> FieldType (Field 3 (OptionalField (Last (Value Int64))))
forall a. HasField a => a -> FieldType a
getField (Field 3 (OptionalField (Last (Value Int64)))
 -> FieldType (Field 3 (OptionalField (Last (Value Int64)))))
-> Field 3 (OptionalField (Last (Value Int64)))
-> FieldType (Field 3 (OptionalField (Last (Value Int64))))
forall a b. (a -> b) -> a -> b
$ PersistentSubscriptionConfirmation -> Optional 3 (Value Int64)
pscLastEvtNumber PersistentSubscriptionConfirmation
msg
                ServerMessage -> Maybe ServerMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerMessage -> Maybe ServerMessage)
-> ServerMessage -> Maybe ServerMessage
forall a b. (a -> b) -> a -> b
$ ConfirmationMsg -> ServerMessage
ConfirmationMsg (ConfirmationMsg -> ServerMessage)
-> ConfirmationMsg -> ServerMessage
forall a b. (a -> b) -> a -> b
$ Text -> Int64 -> Maybe Int64 -> ConfirmationMsg
PersistentConfirmationMsg Text
FieldType (Field 2 (RequiredField (Always (Value Text))))
sid Int64
FieldType (Field 1 (RequiredField (Always (Value Int64))))
lcp Maybe Int64
FieldType (Field 3 (OptionalField (Last (Value Int64))))
len
                | Command
cmd Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
== Command
subscriptionDroppedCmd -> do
                SubscriptionDropped
msg <- ByteString -> Maybe SubscriptionDropped
forall a. Decode a => ByteString -> Maybe a
maybeDecodeMessage (ByteString -> Maybe SubscriptionDropped)
-> ByteString -> Maybe SubscriptionDropped
forall a b. (a -> b) -> a -> b
$ Package -> ByteString
packageData Package
pkg
                let reason :: DropReason
reason = DropReason -> Maybe DropReason -> DropReason
forall a. a -> Maybe a -> a
fromMaybe DropReason
D_Unsubscribed (Maybe DropReason -> DropReason) -> Maybe DropReason -> DropReason
forall a b. (a -> b) -> a -> b
$ Field 1 (OptionalField (Last (Enumeration DropReason)))
-> FieldType
     (Field 1 (OptionalField (Last (Enumeration DropReason))))
forall a. HasField a => a -> FieldType a
getField
                                                      (Field 1 (OptionalField (Last (Enumeration DropReason)))
 -> FieldType
      (Field 1 (OptionalField (Last (Enumeration DropReason)))))
-> Field 1 (OptionalField (Last (Enumeration DropReason)))
-> FieldType
     (Field 1 (OptionalField (Last (Enumeration DropReason))))
forall a b. (a -> b) -> a -> b
$ SubscriptionDropped -> Optional 1 (Enumeration DropReason)
dropReason SubscriptionDropped
msg
                ServerMessage -> Maybe ServerMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerMessage -> Maybe ServerMessage)
-> ServerMessage -> Maybe ServerMessage
forall a b. (a -> b) -> a -> b
$ LiveMsg -> ServerMessage
LiveMsg (LiveMsg -> ServerMessage) -> LiveMsg -> ServerMessage
forall a b. (a -> b) -> a -> b
$ SubDropReason -> LiveMsg
DroppedMsg (SubDropReason -> LiveMsg) -> SubDropReason -> LiveMsg
forall a b. (a -> b) -> a -> b
$ DropReason -> SubDropReason
toSubDropReason DropReason
reason
                | Command
cmd Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
== Command
badRequestCmd ->
                ServerMessage -> Maybe ServerMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerMessage -> Maybe ServerMessage)
-> ServerMessage -> Maybe ServerMessage
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ServerMessage
ErrorMsg (ErrorMsg -> ServerMessage) -> ErrorMsg -> ServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe Text -> ErrorMsg
BadRequestMsg (Maybe Text -> ErrorMsg) -> Maybe Text -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Package -> Maybe Text
packageDataAsText Package
pkg
                | Command
cmd Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
== Command
notAuthenticatedCmd ->
                ServerMessage -> Maybe ServerMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerMessage -> Maybe ServerMessage)
-> ServerMessage -> Maybe ServerMessage
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ServerMessage
ErrorMsg (ErrorMsg -> ServerMessage) -> ErrorMsg -> ServerMessage
forall a b. (a -> b) -> a -> b
$ Maybe Text -> ErrorMsg
NotAuthenticatedMsg (Maybe Text -> ErrorMsg) -> Maybe Text -> ErrorMsg
forall a b. (a -> b) -> a -> b
$ Package -> Maybe Text
packageDataAsText Package
pkg
                | Command
cmd Command -> Command -> Bool
forall a. Eq a => a -> a -> Bool
== Command
notHandledCmd -> do
                NotHandledBuf
msg <- ByteString -> Maybe NotHandledBuf
forall a. Decode a => ByteString -> Maybe a
maybeDecodeMessage (ByteString -> Maybe NotHandledBuf)
-> ByteString -> Maybe NotHandledBuf
forall a b. (a -> b) -> a -> b
$ Package -> ByteString
packageData Package
pkg
                let info :: Maybe MasterInfo
info = (MasterInfoBuf -> MasterInfo)
-> Maybe MasterInfoBuf -> Maybe MasterInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MasterInfoBuf -> MasterInfo
masterInfo (Maybe MasterInfoBuf -> Maybe MasterInfo)
-> Maybe MasterInfoBuf -> Maybe MasterInfo
forall a b. (a -> b) -> a -> b
$ Field 2 (OptionalField (Maybe (Message MasterInfoBuf)))
-> FieldType
     (Field 2 (OptionalField (Maybe (Message MasterInfoBuf))))
forall a. HasField a => a -> FieldType a
getField
                                           (Field 2 (OptionalField (Maybe (Message MasterInfoBuf)))
 -> FieldType
      (Field 2 (OptionalField (Maybe (Message MasterInfoBuf)))))
-> Field 2 (OptionalField (Maybe (Message MasterInfoBuf)))
-> FieldType
     (Field 2 (OptionalField (Maybe (Message MasterInfoBuf))))
forall a b. (a -> b) -> a -> b
$ NotHandledBuf -> Optional 2 (Message MasterInfoBuf)
notHandledAdditionalInfo NotHandledBuf
msg
                    reason :: FieldType
  (Field 1 (RequiredField (Always (Enumeration NotHandledReason))))
reason = Field 1 (RequiredField (Always (Enumeration NotHandledReason)))
-> FieldType
     (Field 1 (RequiredField (Always (Enumeration NotHandledReason))))
forall a. HasField a => a -> FieldType a
getField (Field 1 (RequiredField (Always (Enumeration NotHandledReason)))
 -> FieldType
      (Field 1 (RequiredField (Always (Enumeration NotHandledReason)))))
-> Field 1 (RequiredField (Always (Enumeration NotHandledReason)))
-> FieldType
     (Field 1 (RequiredField (Always (Enumeration NotHandledReason))))
forall a b. (a -> b) -> a -> b
$ NotHandledBuf -> Required 1 (Enumeration NotHandledReason)
notHandledReason NotHandledBuf
msg
                ServerMessage -> Maybe ServerMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerMessage -> Maybe ServerMessage)
-> ServerMessage -> Maybe ServerMessage
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> ServerMessage
ErrorMsg (ErrorMsg -> ServerMessage) -> ErrorMsg -> ServerMessage
forall a b. (a -> b) -> a -> b
$ NotHandledReason -> Maybe MasterInfo -> ErrorMsg
NotHandledMsg FieldType
  (Field 1 (RequiredField (Always (Enumeration NotHandledReason))))
NotHandledReason
reason Maybe MasterInfo
info
                | Bool
otherwise -> Maybe ServerMessage
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
maybeDecodeMessage :: Decode a => ByteString -> Maybe a
maybeDecodeMessage :: ByteString -> Maybe a
maybeDecodeMessage ByteString
bytes =
    case Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
runGet Get a
forall a. Decode a => Get a
decodeMessage ByteString
bytes of
        Right a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
        Either String a
_       -> Maybe a
forall a. Maybe a
Nothing