-- | Strategies for dealing with message handle failures.
module MessageDb.Subscription.FailureStrategy
  ( FailureReason (..),
    FailureStrategy (..),
    ignoreFailures,
    writeToCategory,
    writeUnknownFailuresToCategory,
    writeAllToCategory,
  )
where

import Control.Exception (Exception, SomeException)
import Control.Exception.Safe (finally)
import Control.Monad (void, when)
import qualified Data.Text as Text
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID.V4
import qualified MessageDb.Functions as Functions
import MessageDb.Handlers
import MessageDb.Message (Message)
import qualified MessageDb.Message as Message
import qualified MessageDb.StreamName as StreamName
import MessageDb.Subscription.FailedMessage (FailedMessage (FailedMessage))
import qualified MessageDb.Subscription.FailedMessage as FailedMessage


-- | Reason why the message handle failed.
data FailureReason
  = HandleFailure HandleError
  | UnknownFailure SomeException
  deriving (Int -> FailureReason -> ShowS
[FailureReason] -> ShowS
FailureReason -> String
(Int -> FailureReason -> ShowS)
-> (FailureReason -> String)
-> ([FailureReason] -> ShowS)
-> Show FailureReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureReason] -> ShowS
$cshowList :: [FailureReason] -> ShowS
show :: FailureReason -> String
$cshow :: FailureReason -> String
showsPrec :: Int -> FailureReason -> ShowS
$cshowsPrec :: Int -> FailureReason -> ShowS
Show)


instance Exception FailureReason


-- | Strategy for logging failures.
newtype FailureStrategy = FailureStrategy
  { FailureStrategy -> Message -> FailureReason -> IO ()
logFailure :: Message -> FailureReason -> IO ()
  }


-- | Do nothing, ignore all failures.
ignoreFailures :: FailureStrategy
ignoreFailures :: FailureStrategy
ignoreFailures = (Message -> FailureReason -> IO ()) -> FailureStrategy
FailureStrategy ((Message -> FailureReason -> IO ()) -> FailureStrategy)
-> (Message -> FailureReason -> IO ()) -> FailureStrategy
forall a b. (a -> b) -> a -> b
$ \Message
_ FailureReason
_ ->
  () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Combine a strategy with another so that they both run for a failure.
combine :: FailureStrategy -> FailureStrategy -> FailureStrategy
combine :: FailureStrategy -> FailureStrategy -> FailureStrategy
combine FailureStrategy
first FailureStrategy
second = (Message -> FailureReason -> IO ()) -> FailureStrategy
FailureStrategy ((Message -> FailureReason -> IO ()) -> FailureStrategy)
-> (Message -> FailureReason -> IO ()) -> FailureStrategy
forall a b. (a -> b) -> a -> b
$ \Message
message FailureReason
reason ->
  FailureStrategy -> Message -> FailureReason -> IO ()
logFailure FailureStrategy
first Message
message FailureReason
reason
    IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` FailureStrategy -> Message -> FailureReason -> IO ()
logFailure FailureStrategy
second Message
message FailureReason
reason


instance Semigroup FailureStrategy where
  <> :: FailureStrategy -> FailureStrategy -> FailureStrategy
(<>) = FailureStrategy -> FailureStrategy -> FailureStrategy
combine


instance Monoid FailureStrategy where
  mempty :: FailureStrategy
mempty = FailureStrategy
ignoreFailures


-- | Write a failure to a category. Use @shouldKeep@ to filter out message failures you don't want to log.
writeToCategory ::
  (FailureReason -> Bool) ->
  Functions.WithConnection ->
  StreamName.CategoryName ->
  FailureStrategy
writeToCategory :: (FailureReason -> Bool)
-> WithConnection -> CategoryName -> FailureStrategy
writeToCategory FailureReason -> Bool
shouldKeep WithConnection
withConnection CategoryName
categoryName =
  let logFailureToCategory :: Message -> FailureReason -> IO ()
logFailureToCategory Message
message FailureReason
reason =
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FailureReason -> Bool
shouldKeep FailureReason
reason) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          IdentityName
identity <-
            case StreamName -> Maybe IdentityName
StreamName.identityOfStream (Message -> StreamName
Message.messageStream Message
message) of
              Maybe IdentityName
Nothing -> (UUID -> IdentityName) -> IO UUID -> IO IdentityName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> IdentityName
StreamName.IdentityName (Text -> IdentityName) -> (UUID -> Text) -> UUID -> IdentityName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Text
UUID.toText) IO UUID
UUID.V4.nextRandom
              Just IdentityName
value -> IdentityName -> IO IdentityName
forall (f :: * -> *) a. Applicative f => a -> f a
pure IdentityName
value

          let streamName :: StreamName
streamName =
                CategoryName -> IdentityName -> StreamName
StreamName.addIdentityToCategory CategoryName
categoryName IdentityName
identity

              payload :: FailedMessage
payload =
                FailedMessage :: Message -> Text -> FailedMessage
FailedMessage
                  { message :: Message
message = Message
message
                  , reason :: Text
reason = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ FailureReason -> String
forall a. Show a => a -> String
show FailureReason
reason
                  }

              metadata :: Metadata
metadata = Message -> Metadata
Message.messageMetadata Message
message

          IO (MessageId, StreamPosition) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (MessageId, StreamPosition) -> IO ())
-> ((Connection -> IO (MessageId, StreamPosition))
    -> IO (MessageId, StreamPosition))
-> (Connection -> IO (MessageId, StreamPosition))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> IO (MessageId, StreamPosition))
-> IO (MessageId, StreamPosition)
WithConnection
withConnection ((Connection -> IO (MessageId, StreamPosition)) -> IO ())
-> (Connection -> IO (MessageId, StreamPosition)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
connection ->
            Connection
-> StreamName
-> MessageType
-> FailedMessage
-> Maybe Metadata
-> Maybe ExpectedVersion
-> IO (MessageId, StreamPosition)
forall payload metadata.
(ToJSON payload, ToJSON metadata) =>
Connection
-> StreamName
-> MessageType
-> payload
-> Maybe metadata
-> Maybe ExpectedVersion
-> IO (MessageId, StreamPosition)
Functions.writeMessage
              Connection
connection
              StreamName
streamName
              MessageType
FailedMessage.messageType
              FailedMessage
payload
              (Metadata -> Maybe Metadata
forall a. a -> Maybe a
Just Metadata
metadata)
              Maybe ExpectedVersion
forall a. Maybe a
Nothing
   in (Message -> FailureReason -> IO ()) -> FailureStrategy
FailureStrategy Message -> FailureReason -> IO ()
logFailureToCategory


-- | Only write 'UnknownFailure's to a category.
writeUnknownFailuresToCategory :: Functions.WithConnection -> StreamName.CategoryName -> FailureStrategy
writeUnknownFailuresToCategory :: WithConnection -> CategoryName -> FailureStrategy
writeUnknownFailuresToCategory =
  (FailureReason -> Bool)
-> WithConnection -> CategoryName -> FailureStrategy
writeToCategory ((FailureReason -> Bool)
 -> WithConnection -> CategoryName -> FailureStrategy)
-> (FailureReason -> Bool)
-> WithConnection
-> CategoryName
-> FailureStrategy
forall a b. (a -> b) -> a -> b
$ \case
    UnknownFailure SomeException
_ -> Bool
True
    FailureReason
_ -> Bool
False


-- | Write either 'UnknownFailure's or 'HandleFailure's to a category.
writeAllToCategory :: Functions.WithConnection -> StreamName.CategoryName -> FailureStrategy
writeAllToCategory :: WithConnection -> CategoryName -> FailureStrategy
writeAllToCategory =
  (FailureReason -> Bool)
-> WithConnection -> CategoryName -> FailureStrategy
writeToCategory ((FailureReason -> Bool)
 -> WithConnection -> CategoryName -> FailureStrategy)
-> (FailureReason -> Bool)
-> WithConnection
-> CategoryName
-> FailureStrategy
forall a b. (a -> b) -> a -> b
$ Bool -> FailureReason -> Bool
forall a b. a -> b -> a
const Bool
True