module MessageDb.Handlers
  ( HandleError (..)
  , Handler (..)
  , runHandler
  , getMessage
  , getParsedMessage
  , Handlers
  , emptyHandlers
  , listToHandlers
  , addHandler
  , removeHandler
  , handle
  , ProjectionHandler
  , projectionHandler
  , ProjectionHandlers
  , addProjectionHandler
  , projectionHandle
  , SubscriptionHandler
  , subscriptionHandler
  , SubscriptionHandlers
  , addSubscriptionHandler
  , subscriptionHandle
  )
where

import Control.Exception (Exception)
import Control.Monad.Except (Except, MonadError (throwError), runExcept)
import Control.Monad.Reader (MonadReader (ask), ReaderT (..))
import qualified Data.Aeson as Aeson
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Semigroup
import GHC.Generics (Generic)
import MessageDb.Message (Message)
import qualified MessageDb.Message as Message


-- | An error that may occur from handling a message.
data HandleError
  = HandlerParseFailure Message.ParseMessageFailure
  | HandlerNotFound
  deriving (Int -> HandleError -> ShowS
[HandleError] -> ShowS
HandleError -> String
(Int -> HandleError -> ShowS)
-> (HandleError -> String)
-> ([HandleError] -> ShowS)
-> Show HandleError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HandleError] -> ShowS
$cshowList :: [HandleError] -> ShowS
show :: HandleError -> String
$cshow :: HandleError -> String
showsPrec :: Int -> HandleError -> ShowS
$cshowsPrec :: Int -> HandleError -> ShowS
Show, HandleError -> HandleError -> Bool
(HandleError -> HandleError -> Bool)
-> (HandleError -> HandleError -> Bool) -> Eq HandleError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HandleError -> HandleError -> Bool
$c/= :: HandleError -> HandleError -> Bool
== :: HandleError -> HandleError -> Bool
$c== :: HandleError -> HandleError -> Bool
Eq, (forall x. HandleError -> Rep HandleError x)
-> (forall x. Rep HandleError x -> HandleError)
-> Generic HandleError
forall x. Rep HandleError x -> HandleError
forall x. HandleError -> Rep HandleError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HandleError x -> HandleError
$cfrom :: forall x. HandleError -> Rep HandleError x
Generic)


instance Exception HandleError
instance Aeson.ToJSON HandleError
instance Aeson.FromJSON HandleError


newtype Handler output = Handler
  { Handler output -> ReaderT Message (Except HandleError) output
fromHandler :: ReaderT Message (Except HandleError) output
  }
  deriving
    ( a -> Handler b -> Handler a
(a -> b) -> Handler a -> Handler b
(forall a b. (a -> b) -> Handler a -> Handler b)
-> (forall a b. a -> Handler b -> Handler a) -> Functor Handler
forall a b. a -> Handler b -> Handler a
forall a b. (a -> b) -> Handler a -> Handler b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Handler b -> Handler a
$c<$ :: forall a b. a -> Handler b -> Handler a
fmap :: (a -> b) -> Handler a -> Handler b
$cfmap :: forall a b. (a -> b) -> Handler a -> Handler b
Functor
    , Functor Handler
a -> Handler a
Functor Handler
-> (forall a. a -> Handler a)
-> (forall a b. Handler (a -> b) -> Handler a -> Handler b)
-> (forall a b c.
    (a -> b -> c) -> Handler a -> Handler b -> Handler c)
-> (forall a b. Handler a -> Handler b -> Handler b)
-> (forall a b. Handler a -> Handler b -> Handler a)
-> Applicative Handler
Handler a -> Handler b -> Handler b
Handler a -> Handler b -> Handler a
Handler (a -> b) -> Handler a -> Handler b
(a -> b -> c) -> Handler a -> Handler b -> Handler c
forall a. a -> Handler a
forall a b. Handler a -> Handler b -> Handler a
forall a b. Handler a -> Handler b -> Handler b
forall a b. Handler (a -> b) -> Handler a -> Handler b
forall a b c. (a -> b -> c) -> Handler a -> Handler b -> Handler c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Handler a -> Handler b -> Handler a
$c<* :: forall a b. Handler a -> Handler b -> Handler a
*> :: Handler a -> Handler b -> Handler b
$c*> :: forall a b. Handler a -> Handler b -> Handler b
liftA2 :: (a -> b -> c) -> Handler a -> Handler b -> Handler c
$cliftA2 :: forall a b c. (a -> b -> c) -> Handler a -> Handler b -> Handler c
<*> :: Handler (a -> b) -> Handler a -> Handler b
$c<*> :: forall a b. Handler (a -> b) -> Handler a -> Handler b
pure :: a -> Handler a
$cpure :: forall a. a -> Handler a
$cp1Applicative :: Functor Handler
Applicative
    , Applicative Handler
a -> Handler a
Applicative Handler
-> (forall a b. Handler a -> (a -> Handler b) -> Handler b)
-> (forall a b. Handler a -> Handler b -> Handler b)
-> (forall a. a -> Handler a)
-> Monad Handler
Handler a -> (a -> Handler b) -> Handler b
Handler a -> Handler b -> Handler b
forall a. a -> Handler a
forall a b. Handler a -> Handler b -> Handler b
forall a b. Handler a -> (a -> Handler b) -> Handler b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Handler a
$creturn :: forall a. a -> Handler a
>> :: Handler a -> Handler b -> Handler b
$c>> :: forall a b. Handler a -> Handler b -> Handler b
>>= :: Handler a -> (a -> Handler b) -> Handler b
$c>>= :: forall a b. Handler a -> (a -> Handler b) -> Handler b
$cp1Monad :: Applicative Handler
Monad
    , MonadReader Message
    , MonadError HandleError
    )


instance Semigroup output => Semigroup (Handler output) where
  Handler output
left <> :: Handler output -> Handler output -> Handler output
<> Handler output
right = do
    output
leftOutput <- Handler output
left
    output
rightOutput <- Handler output
right
    output -> Handler output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (output -> Handler output) -> output -> Handler output
forall a b. (a -> b) -> a -> b
$ output
leftOutput output -> output -> output
forall a. Semigroup a => a -> a -> a
<> output
rightOutput


instance Monoid output => Monoid (Handler output) where
  mempty :: Handler output
mempty = output -> Handler output
forall (f :: * -> *) a. Applicative f => a -> f a
pure output
forall a. Monoid a => a
mempty


runHandler :: Handler output -> Message -> Either HandleError output
runHandler :: Handler output -> Message -> Either HandleError output
runHandler Handler output
handler Message
message =
  Except HandleError output -> Either HandleError output
forall e a. Except e a -> Either e a
runExcept (Except HandleError output -> Either HandleError output)
-> Except HandleError output -> Either HandleError output
forall a b. (a -> b) -> a -> b
$ ReaderT Message (Except HandleError) output
-> Message -> Except HandleError output
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Handler output -> ReaderT Message (Except HandleError) output
forall output.
Handler output -> ReaderT Message (Except HandleError) output
fromHandler Handler output
handler) Message
message


getMessage :: Handler Message
getMessage :: Handler Message
getMessage =
  Handler Message
forall r (m :: * -> *). MonadReader r m => m r
ask


getParsedMessage ::
  (Aeson.FromJSON payload, Aeson.FromJSON metadata) =>
  Handler (Message.ParsedMessage payload metadata)
getParsedMessage :: Handler (ParsedMessage payload metadata)
getParsedMessage = do
  Message
message <- Handler Message
forall r (m :: * -> *). MonadReader r m => m r
ask

  case Message
-> Either ParseMessageFailure (ParsedMessage payload metadata)
forall payload metadata.
(FromJSON payload, FromJSON metadata) =>
Message
-> Either ParseMessageFailure (ParsedMessage payload metadata)
Message.parseMessage Message
message of
    Left ParseMessageFailure
err ->
      HandleError -> Handler (ParsedMessage payload metadata)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HandleError -> Handler (ParsedMessage payload metadata))
-> HandleError -> Handler (ParsedMessage payload metadata)
forall a b. (a -> b) -> a -> b
$ ParseMessageFailure -> HandleError
HandlerParseFailure ParseMessageFailure
err
    Right ParsedMessage payload metadata
msg ->
      ParsedMessage payload metadata
-> Handler (ParsedMessage payload metadata)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedMessage payload metadata
msg


type Handlers output =
  Map Message.MessageType (Handler output)


emptyHandlers :: Handlers output
emptyHandlers :: Handlers output
emptyHandlers =
  Handlers output
forall k a. Map k a
Map.empty


listToHandlers :: [(Message.MessageType, Handler output)] -> Handlers output
listToHandlers :: [(MessageType, Handler output)] -> Handlers output
listToHandlers =
  [(MessageType, Handler output)] -> Handlers output
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList


addHandler :: Message.MessageType -> Handler output -> Handlers output -> Handlers output
addHandler :: MessageType -> Handler output -> Handlers output -> Handlers output
addHandler =
  MessageType -> Handler output -> Handlers output -> Handlers output
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert


removeHandler :: Message.MessageType -> Handlers output -> Handlers output
removeHandler :: MessageType -> Handlers output -> Handlers output
removeHandler =
  MessageType -> Handlers output -> Handlers output
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete


handle :: Handlers output -> Message -> Either HandleError output
handle :: Handlers output -> Message -> Either HandleError output
handle Handlers output
handlers Message
message =
  case MessageType -> Handlers output -> Maybe (Handler output)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Message -> MessageType
Message.messageType Message
message) Handlers output
handlers of
    Maybe (Handler output)
Nothing ->
      HandleError -> Either HandleError output
forall a b. a -> Either a b
Left HandleError
HandlerNotFound
    Just Handler output
handler ->
      Handler output -> Message -> Either HandleError output
forall output.
Handler output -> Message -> Either HandleError output
runHandler Handler output
handler Message
message


type ProjectionHandler state =
  Handler (Endo state)


projectionHandler ::
  forall payload metadata state.
  (Aeson.FromJSON payload, Aeson.FromJSON metadata) =>
  (Message -> payload -> metadata -> state -> state) ->
  ProjectionHandler state
projectionHandler :: (Message -> payload -> metadata -> state -> state)
-> ProjectionHandler state
projectionHandler Message -> payload -> metadata -> state -> state
original = do
  Message
message <- Handler Message
getMessage
  Message.ParsedMessage{payload
metadata
parsedMetadata :: forall payload metadata. ParsedMessage payload metadata -> metadata
parsedPayload :: forall payload metadata. ParsedMessage payload metadata -> payload
parsedMetadata :: metadata
parsedPayload :: payload
..} <- (FromJSON payload, FromJSON metadata) =>
Handler (ParsedMessage payload metadata)
forall payload metadata.
(FromJSON payload, FromJSON metadata) =>
Handler (ParsedMessage payload metadata)
getParsedMessage @payload @metadata
  Endo state -> ProjectionHandler state
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Endo state -> ProjectionHandler state)
-> ((state -> state) -> Endo state)
-> (state -> state)
-> ProjectionHandler state
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (state -> state) -> Endo state
forall a. (a -> a) -> Endo a
Endo ((state -> state) -> ProjectionHandler state)
-> (state -> state) -> ProjectionHandler state
forall a b. (a -> b) -> a -> b
$ \state
state -> Message -> payload -> metadata -> state -> state
original Message
message payload
parsedPayload metadata
parsedMetadata state
state


type ProjectionHandlers state =
  Handlers (Endo state)


addProjectionHandler ::
  forall payload metadata state.
  (Aeson.FromJSON payload, Aeson.FromJSON metadata) =>
  Message.MessageType ->
  (Message -> payload -> metadata -> state -> state) ->
  ProjectionHandlers state ->
  ProjectionHandlers state
addProjectionHandler :: MessageType
-> (Message -> payload -> metadata -> state -> state)
-> ProjectionHandlers state
-> ProjectionHandlers state
addProjectionHandler MessageType
messageType Message -> payload -> metadata -> state -> state
original =
  MessageType
-> Handler (Endo state)
-> ProjectionHandlers state
-> ProjectionHandlers state
forall output.
MessageType -> Handler output -> Handlers output -> Handlers output
addHandler MessageType
messageType ((Message -> payload -> metadata -> state -> state)
-> Handler (Endo state)
forall payload metadata state.
(FromJSON payload, FromJSON metadata) =>
(Message -> payload -> metadata -> state -> state)
-> ProjectionHandler state
projectionHandler Message -> payload -> metadata -> state -> state
original)


projectionHandle :: ProjectionHandlers state -> Message -> state -> Either HandleError state
projectionHandle :: ProjectionHandlers state
-> Message -> state -> Either HandleError state
projectionHandle ProjectionHandlers state
handlers Message
message state
state =
  let result :: Either HandleError (Endo state)
result = ProjectionHandlers state
-> Message -> Either HandleError (Endo state)
forall output.
Handlers output -> Message -> Either HandleError output
handle ProjectionHandlers state
handlers Message
message
   in (Endo state -> state)
-> Either HandleError (Endo state) -> Either HandleError state
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((state -> state) -> state -> state
forall a b. (a -> b) -> a -> b
$ state
state) ((state -> state) -> state)
-> (Endo state -> state -> state) -> Endo state -> state
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Endo state -> state -> state
forall a. Endo a -> a -> a
appEndo) Either HandleError (Endo state)
result


type SubscriptionHandler =
  Handler (IO ())


subscriptionHandler ::
  forall payload metadata.
  (Aeson.FromJSON payload, Aeson.FromJSON metadata) =>
  (Message -> payload -> metadata -> IO ()) ->
  SubscriptionHandler
subscriptionHandler :: (Message -> payload -> metadata -> IO ()) -> SubscriptionHandler
subscriptionHandler Message -> payload -> metadata -> IO ()
original = do
  Message
message <- Handler Message
forall r (m :: * -> *). MonadReader r m => m r
ask
  Message.ParsedMessage{payload
metadata
parsedMetadata :: metadata
parsedPayload :: payload
parsedMetadata :: forall payload metadata. ParsedMessage payload metadata -> metadata
parsedPayload :: forall payload metadata. ParsedMessage payload metadata -> payload
..} <- (FromJSON payload, FromJSON metadata) =>
Handler (ParsedMessage payload metadata)
forall payload metadata.
(FromJSON payload, FromJSON metadata) =>
Handler (ParsedMessage payload metadata)
getParsedMessage @payload @metadata
  IO () -> SubscriptionHandler
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> SubscriptionHandler) -> IO () -> SubscriptionHandler
forall a b. (a -> b) -> a -> b
$ Message -> payload -> metadata -> IO ()
original Message
message payload
parsedPayload metadata
parsedMetadata


type SubscriptionHandlers =
  Handlers (IO ())


addSubscriptionHandler ::
  forall payload metadata.
  (Aeson.FromJSON payload, Aeson.FromJSON metadata) =>
  Message.MessageType ->
  (Message -> payload -> metadata -> IO ()) ->
  SubscriptionHandlers ->
  SubscriptionHandlers
addSubscriptionHandler :: MessageType
-> (Message -> payload -> metadata -> IO ())
-> SubscriptionHandlers
-> SubscriptionHandlers
addSubscriptionHandler MessageType
messageType Message -> payload -> metadata -> IO ()
original =
  MessageType
-> SubscriptionHandler
-> SubscriptionHandlers
-> SubscriptionHandlers
forall output.
MessageType -> Handler output -> Handlers output -> Handlers output
addHandler MessageType
messageType ((Message -> payload -> metadata -> IO ()) -> SubscriptionHandler
forall payload metadata.
(FromJSON payload, FromJSON metadata) =>
(Message -> payload -> metadata -> IO ()) -> SubscriptionHandler
subscriptionHandler Message -> payload -> metadata -> IO ()
original)


subscriptionHandle :: SubscriptionHandlers -> Message -> IO (Either HandleError ())
subscriptionHandle :: SubscriptionHandlers -> Message -> IO (Either HandleError ())
subscriptionHandle SubscriptionHandlers
handlers Message
message =
  let result :: Either HandleError (IO ())
result = SubscriptionHandlers -> Message -> Either HandleError (IO ())
forall output.
Handlers output -> Message -> Either HandleError output
handle SubscriptionHandlers
handlers Message
message
   in (HandleError -> IO (Either HandleError ()))
-> (IO () -> IO (Either HandleError ()))
-> Either HandleError (IO ())
-> IO (Either HandleError ())
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either HandleError () -> IO (Either HandleError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HandleError () -> IO (Either HandleError ()))
-> (HandleError -> Either HandleError ())
-> HandleError
-> IO (Either HandleError ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandleError -> Either HandleError ()
forall a b. a -> Either a b
Left) ((() -> Either HandleError ())
-> IO () -> IO (Either HandleError ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Either HandleError ()
forall a b. b -> Either a b
Right) Either HandleError (IO ())
result