{-# LANGUAGE DerivingVia #-}

-- | Support for the @BATCH@ command (Enterprise only)
--
-- <https://github.com/contribsys/faktory/wiki/Ent-Batches>
--
-- Batches allow multiple Jobs to be enqueued as a group, with a description
-- (visible in the admin UI) and Jobs attached to run on completion of all Jobs
-- within the group (always, or only if all were successful).
--
-- Usage:
--
-- @
-- -- Build a Job to run at completion of the Batch. Arguments are the same as
-- -- you would pass to 'perform' the Job.
-- onComplete <- buildJob mempty producer myJob
--
-- 'runBatch' ('complete' onComplete <> 'description' "My Batch") producer $ do
--   -- Use 'batchPerform' instead of 'perform'
--   void $ 'batchPerform' mempty producer myBatchedJob1
--   void $ 'batchPerform' mempty producer myBatchedJob2
-- @
--
-- __/NOTE__: This module does not support batched Jobs dynamically adding more
-- Jobs to the Batch. PRs welcome.
module Faktory.Ent.Batch
  ( -- * Options
    BatchOptions
  , description
  , complete
  , success

    -- * Running
  , runBatch
  , Batch
  , batchPerform

    -- * Low-level
  , BatchId (..)
  , CustomBatchId (..)
  , newBatch
  , commitBatch
  ) where

import Faktory.Prelude

import Control.Monad.Reader
import Data.Aeson
import Data.Aeson.Casing
import Data.ByteString.Lazy as BSL
import Data.Semigroup (Last (..))
import Data.Semigroup.Generic
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Faktory.Client
import Faktory.Job
import Faktory.Producer
import GHC.Generics
import GHC.Stack

newtype Batch a = Batch (ReaderT BatchId IO a)
  deriving newtype ((forall a b. (a -> b) -> Batch a -> Batch b)
-> (forall a b. a -> Batch b -> Batch a) -> Functor Batch
forall a b. a -> Batch b -> Batch a
forall a b. (a -> b) -> Batch a -> Batch b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Batch a -> Batch b
fmap :: forall a b. (a -> b) -> Batch a -> Batch b
$c<$ :: forall a b. a -> Batch b -> Batch a
<$ :: forall a b. a -> Batch b -> Batch a
Functor, Functor Batch
Functor Batch =>
(forall a. a -> Batch a)
-> (forall a b. Batch (a -> b) -> Batch a -> Batch b)
-> (forall a b c. (a -> b -> c) -> Batch a -> Batch b -> Batch c)
-> (forall a b. Batch a -> Batch b -> Batch b)
-> (forall a b. Batch a -> Batch b -> Batch a)
-> Applicative Batch
forall a. a -> Batch a
forall a b. Batch a -> Batch b -> Batch a
forall a b. Batch a -> Batch b -> Batch b
forall a b. Batch (a -> b) -> Batch a -> Batch b
forall a b c. (a -> b -> c) -> Batch a -> Batch b -> Batch 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
$cpure :: forall a. a -> Batch a
pure :: forall a. a -> Batch a
$c<*> :: forall a b. Batch (a -> b) -> Batch a -> Batch b
<*> :: forall a b. Batch (a -> b) -> Batch a -> Batch b
$cliftA2 :: forall a b c. (a -> b -> c) -> Batch a -> Batch b -> Batch c
liftA2 :: forall a b c. (a -> b -> c) -> Batch a -> Batch b -> Batch c
$c*> :: forall a b. Batch a -> Batch b -> Batch b
*> :: forall a b. Batch a -> Batch b -> Batch b
$c<* :: forall a b. Batch a -> Batch b -> Batch a
<* :: forall a b. Batch a -> Batch b -> Batch a
Applicative, Applicative Batch
Applicative Batch =>
(forall a b. Batch a -> (a -> Batch b) -> Batch b)
-> (forall a b. Batch a -> Batch b -> Batch b)
-> (forall a. a -> Batch a)
-> Monad Batch
forall a. a -> Batch a
forall a b. Batch a -> Batch b -> Batch b
forall a b. Batch a -> (a -> Batch b) -> Batch 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
$c>>= :: forall a b. Batch a -> (a -> Batch b) -> Batch b
>>= :: forall a b. Batch a -> (a -> Batch b) -> Batch b
$c>> :: forall a b. Batch a -> Batch b -> Batch b
>> :: forall a b. Batch a -> Batch b -> Batch b
$creturn :: forall a. a -> Batch a
return :: forall a. a -> Batch a
Monad, Monad Batch
Monad Batch => (forall a. IO a -> Batch a) -> MonadIO Batch
forall a. IO a -> Batch a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Batch a
liftIO :: forall a. IO a -> Batch a
MonadIO, MonadReader BatchId)

newtype BatchId = BatchId Text
  deriving stock (Int -> BatchId -> ShowS
[BatchId] -> ShowS
BatchId -> String
(Int -> BatchId -> ShowS)
-> (BatchId -> String) -> ([BatchId] -> ShowS) -> Show BatchId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BatchId -> ShowS
showsPrec :: Int -> BatchId -> ShowS
$cshow :: BatchId -> String
show :: BatchId -> String
$cshowList :: [BatchId] -> ShowS
showList :: [BatchId] -> ShowS
Show, BatchId -> BatchId -> Bool
(BatchId -> BatchId -> Bool)
-> (BatchId -> BatchId -> Bool) -> Eq BatchId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BatchId -> BatchId -> Bool
== :: BatchId -> BatchId -> Bool
$c/= :: BatchId -> BatchId -> Bool
/= :: BatchId -> BatchId -> Bool
Eq)
  deriving newtype (Maybe BatchId
Value -> Parser [BatchId]
Value -> Parser BatchId
(Value -> Parser BatchId)
-> (Value -> Parser [BatchId]) -> Maybe BatchId -> FromJSON BatchId
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser BatchId
parseJSON :: Value -> Parser BatchId
$cparseJSONList :: Value -> Parser [BatchId]
parseJSONList :: Value -> Parser [BatchId]
$comittedField :: Maybe BatchId
omittedField :: Maybe BatchId
FromJSON, [BatchId] -> Value
[BatchId] -> Encoding
BatchId -> Bool
BatchId -> Value
BatchId -> Encoding
(BatchId -> Value)
-> (BatchId -> Encoding)
-> ([BatchId] -> Value)
-> ([BatchId] -> Encoding)
-> (BatchId -> Bool)
-> ToJSON BatchId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: BatchId -> Value
toJSON :: BatchId -> Value
$ctoEncoding :: BatchId -> Encoding
toEncoding :: BatchId -> Encoding
$ctoJSONList :: [BatchId] -> Value
toJSONList :: [BatchId] -> Value
$ctoEncodingList :: [BatchId] -> Encoding
toEncodingList :: [BatchId] -> Encoding
$comitField :: BatchId -> Bool
omitField :: BatchId -> Bool
ToJSON)

data BatchOptions arg = BatchOptions
  { forall arg. BatchOptions arg -> Maybe (Last Text)
boDescription :: Maybe (Last Text)
  , forall arg. BatchOptions arg -> Maybe (Last (Job arg))
boSuccess :: Maybe (Last (Job arg))
  , forall arg. BatchOptions arg -> Maybe (Last (Job arg))
boComplete :: Maybe (Last (Job arg))
  }
  deriving stock ((forall x. BatchOptions arg -> Rep (BatchOptions arg) x)
-> (forall x. Rep (BatchOptions arg) x -> BatchOptions arg)
-> Generic (BatchOptions arg)
forall x. Rep (BatchOptions arg) x -> BatchOptions arg
forall x. BatchOptions arg -> Rep (BatchOptions arg) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall arg x. Rep (BatchOptions arg) x -> BatchOptions arg
forall arg x. BatchOptions arg -> Rep (BatchOptions arg) x
$cfrom :: forall arg x. BatchOptions arg -> Rep (BatchOptions arg) x
from :: forall x. BatchOptions arg -> Rep (BatchOptions arg) x
$cto :: forall arg x. Rep (BatchOptions arg) x -> BatchOptions arg
to :: forall x. Rep (BatchOptions arg) x -> BatchOptions arg
Generic)
  deriving (NonEmpty (BatchOptions arg) -> BatchOptions arg
BatchOptions arg -> BatchOptions arg -> BatchOptions arg
(BatchOptions arg -> BatchOptions arg -> BatchOptions arg)
-> (NonEmpty (BatchOptions arg) -> BatchOptions arg)
-> (forall b.
    Integral b =>
    b -> BatchOptions arg -> BatchOptions arg)
-> Semigroup (BatchOptions arg)
forall b. Integral b => b -> BatchOptions arg -> BatchOptions arg
forall arg. NonEmpty (BatchOptions arg) -> BatchOptions arg
forall arg.
BatchOptions arg -> BatchOptions arg -> BatchOptions arg
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall arg b.
Integral b =>
b -> BatchOptions arg -> BatchOptions arg
$c<> :: forall arg.
BatchOptions arg -> BatchOptions arg -> BatchOptions arg
<> :: BatchOptions arg -> BatchOptions arg -> BatchOptions arg
$csconcat :: forall arg. NonEmpty (BatchOptions arg) -> BatchOptions arg
sconcat :: NonEmpty (BatchOptions arg) -> BatchOptions arg
$cstimes :: forall arg b.
Integral b =>
b -> BatchOptions arg -> BatchOptions arg
stimes :: forall b. Integral b => b -> BatchOptions arg -> BatchOptions arg
Semigroup, Semigroup (BatchOptions arg)
BatchOptions arg
Semigroup (BatchOptions arg) =>
BatchOptions arg
-> (BatchOptions arg -> BatchOptions arg -> BatchOptions arg)
-> ([BatchOptions arg] -> BatchOptions arg)
-> Monoid (BatchOptions arg)
[BatchOptions arg] -> BatchOptions arg
BatchOptions arg -> BatchOptions arg -> BatchOptions arg
forall arg. Semigroup (BatchOptions arg)
forall arg. BatchOptions arg
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall arg. [BatchOptions arg] -> BatchOptions arg
forall arg.
BatchOptions arg -> BatchOptions arg -> BatchOptions arg
$cmempty :: forall arg. BatchOptions arg
mempty :: BatchOptions arg
$cmappend :: forall arg.
BatchOptions arg -> BatchOptions arg -> BatchOptions arg
mappend :: BatchOptions arg -> BatchOptions arg -> BatchOptions arg
$cmconcat :: forall arg. [BatchOptions arg] -> BatchOptions arg
mconcat :: [BatchOptions arg] -> BatchOptions arg
Monoid) via GenericSemigroupMonoid (BatchOptions arg)

instance ToJSON arg => ToJSON (BatchOptions arg) where
  toJSON :: BatchOptions arg -> Value
toJSON = Options -> BatchOptions arg -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (Options -> BatchOptions arg -> Value)
-> Options -> BatchOptions arg -> Value
forall a b. (a -> b) -> a -> b
$ ShowS -> Options
aesonPrefix ShowS
snakeCase
  toEncoding :: BatchOptions arg -> Encoding
toEncoding = Options -> BatchOptions arg -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding (Options -> BatchOptions arg -> Encoding)
-> Options -> BatchOptions arg -> Encoding
forall a b. (a -> b) -> a -> b
$ ShowS -> Options
aesonPrefix ShowS
snakeCase

description :: Text -> BatchOptions arg
description :: forall arg. Text -> BatchOptions arg
description Text
d = BatchOptions arg
forall a. Monoid a => a
mempty {boDescription = Just $ Last d}

complete :: Job arg -> BatchOptions arg
complete :: forall arg. Job arg -> BatchOptions arg
complete Job arg
job = BatchOptions arg
forall a. Monoid a => a
mempty {boComplete = Just $ Last job}

success :: Job arg -> BatchOptions arg
success :: forall arg. Job arg -> BatchOptions arg
success Job arg
job = BatchOptions arg
forall a. Monoid a => a
mempty {boSuccess = Just $ Last job}

runBatch :: ToJSON arg => BatchOptions arg -> Producer -> Batch a -> IO a
runBatch :: forall arg a.
ToJSON arg =>
BatchOptions arg -> Producer -> Batch a -> IO a
runBatch BatchOptions arg
options Producer
producer (Batch ReaderT BatchId IO a
f) = do
  BatchId
bid <- Producer -> BatchOptions arg -> IO BatchId
forall arg.
ToJSON arg =>
Producer -> BatchOptions arg -> IO BatchId
newBatch Producer
producer BatchOptions arg
options
  a
result <- ReaderT BatchId IO a -> BatchId -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT BatchId IO a
f BatchId
bid
  a
result a -> IO () -> IO a
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Producer -> BatchId -> IO ()
commitBatch Producer
producer BatchId
bid

newtype CustomBatchId = CustomBatchId
  { CustomBatchId -> BatchId
bid :: BatchId
  }
  deriving stock ((forall x. CustomBatchId -> Rep CustomBatchId x)
-> (forall x. Rep CustomBatchId x -> CustomBatchId)
-> Generic CustomBatchId
forall x. Rep CustomBatchId x -> CustomBatchId
forall x. CustomBatchId -> Rep CustomBatchId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CustomBatchId -> Rep CustomBatchId x
from :: forall x. CustomBatchId -> Rep CustomBatchId x
$cto :: forall x. Rep CustomBatchId x -> CustomBatchId
to :: forall x. Rep CustomBatchId x -> CustomBatchId
Generic)
  deriving anyclass ([CustomBatchId] -> Value
[CustomBatchId] -> Encoding
CustomBatchId -> Bool
CustomBatchId -> Value
CustomBatchId -> Encoding
(CustomBatchId -> Value)
-> (CustomBatchId -> Encoding)
-> ([CustomBatchId] -> Value)
-> ([CustomBatchId] -> Encoding)
-> (CustomBatchId -> Bool)
-> ToJSON CustomBatchId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: CustomBatchId -> Value
toJSON :: CustomBatchId -> Value
$ctoEncoding :: CustomBatchId -> Encoding
toEncoding :: CustomBatchId -> Encoding
$ctoJSONList :: [CustomBatchId] -> Value
toJSONList :: [CustomBatchId] -> Value
$ctoEncodingList :: [CustomBatchId] -> Encoding
toEncodingList :: [CustomBatchId] -> Encoding
$comitField :: CustomBatchId -> Bool
omitField :: CustomBatchId -> Bool
ToJSON)

batchPerform
  :: (HasCallStack, ToJSON arg) => JobOptions -> Producer -> arg -> Batch JobId
batchPerform :: forall arg.
(HasCallStack, ToJSON arg) =>
JobOptions -> Producer -> arg -> Batch String
batchPerform JobOptions
options Producer
producer arg
arg = do
  BatchId
bid <- Batch BatchId
forall r (m :: * -> *). MonadReader r m => m r
ask
  ReaderT BatchId IO String -> Batch String
forall a. ReaderT BatchId IO a -> Batch a
Batch (ReaderT BatchId IO String -> Batch String)
-> ReaderT BatchId IO String -> Batch String
forall a b. (a -> b) -> a -> b
$ IO String -> ReaderT BatchId IO String
forall (m :: * -> *) a. Monad m => m a -> ReaderT BatchId m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO String -> ReaderT BatchId IO String)
-> IO String -> ReaderT BatchId IO String
forall a b. (a -> b) -> a -> b
$ JobOptions -> Producer -> arg -> IO String
forall arg.
(HasCallStack, ToJSON arg) =>
JobOptions -> Producer -> arg -> IO String
perform (JobOptions
options JobOptions -> JobOptions -> JobOptions
forall a. Semigroup a => a -> a -> a
<> CustomBatchId -> JobOptions
forall a. ToJSON a => a -> JobOptions
custom (BatchId -> CustomBatchId
CustomBatchId BatchId
bid)) Producer
producer arg
arg

newBatch :: ToJSON arg => Producer -> BatchOptions arg -> IO BatchId
newBatch :: forall arg.
ToJSON arg =>
Producer -> BatchOptions arg -> IO BatchId
newBatch Producer
producer BatchOptions arg
options = do
  Either String (Maybe ByteString)
result <-
    Client
-> ByteString
-> [ByteString]
-> IO (Either String (Maybe ByteString))
commandByteString
      (Producer -> Client
producerClient Producer
producer)
      ByteString
"BATCH NEW"
      [BatchOptions arg -> ByteString
forall a. ToJSON a => a -> ByteString
encode BatchOptions arg
options]
  case Either String (Maybe ByteString)
result of
    Left String
err -> String -> IO BatchId
forall {m :: * -> *} {a}. MonadThrow m => String -> m a
batchNewError String
err
    Right Maybe ByteString
Nothing -> String -> IO BatchId
forall {m :: * -> *} {a}. MonadThrow m => String -> m a
batchNewError String
"No BatchId returned"
    Right (Just ByteString
bs) -> BatchId -> IO BatchId
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BatchId -> IO BatchId) -> BatchId -> IO BatchId
forall a b. (a -> b) -> a -> b
$ Text -> BatchId
BatchId (Text -> BatchId) -> Text -> BatchId
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
bs
 where
  batchNewError :: String -> m a
batchNewError String
err = String -> m a
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"BATCH NEW error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err

commitBatch :: Producer -> BatchId -> IO ()
commitBatch :: Producer -> BatchId -> IO ()
commitBatch Producer
producer (BatchId Text
bid) =
  Client -> ByteString -> [ByteString] -> IO ()
command_
    (Producer -> Client
producerClient Producer
producer)
    ByteString
"BATCH COMMIT"
    [ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
bid]