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

newtype BatchId = BatchId Text
  deriving stock (Int -> BatchId -> ShowS
[BatchId] -> ShowS
BatchId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BatchId] -> ShowS
$cshowList :: [BatchId] -> ShowS
show :: BatchId -> String
$cshow :: BatchId -> String
showsPrec :: Int -> BatchId -> ShowS
$cshowsPrec :: Int -> BatchId -> ShowS
Show, BatchId -> BatchId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BatchId -> BatchId -> Bool
$c/= :: BatchId -> BatchId -> Bool
== :: BatchId -> BatchId -> Bool
$c== :: BatchId -> BatchId -> Bool
Eq)
  deriving newtype (Value -> Parser [BatchId]
Value -> Parser BatchId
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BatchId]
$cparseJSONList :: Value -> Parser [BatchId]
parseJSON :: Value -> Parser BatchId
$cparseJSON :: Value -> Parser BatchId
FromJSON, [BatchId] -> Encoding
[BatchId] -> Value
BatchId -> Encoding
BatchId -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BatchId] -> Encoding
$ctoEncodingList :: [BatchId] -> Encoding
toJSONList :: [BatchId] -> Value
$ctoJSONList :: [BatchId] -> Value
toEncoding :: BatchId -> Encoding
$ctoEncoding :: BatchId -> Encoding
toJSON :: BatchId -> Value
$ctoJSON :: BatchId -> Value
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 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
$cto :: forall arg x. Rep (BatchOptions arg) x -> BatchOptions arg
$cfrom :: forall arg x. BatchOptions arg -> Rep (BatchOptions arg) x
Generic
  deriving (NonEmpty (BatchOptions arg) -> BatchOptions arg
BatchOptions arg -> BatchOptions arg -> 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
stimes :: forall b. Integral b => b -> BatchOptions arg -> BatchOptions arg
$cstimes :: forall arg b.
Integral b =>
b -> BatchOptions arg -> BatchOptions arg
sconcat :: NonEmpty (BatchOptions arg) -> BatchOptions arg
$csconcat :: forall arg. NonEmpty (BatchOptions arg) -> BatchOptions arg
<> :: BatchOptions arg -> BatchOptions arg -> BatchOptions arg
$c<> :: forall arg.
BatchOptions arg -> BatchOptions arg -> BatchOptions arg
Semigroup, 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
mconcat :: [BatchOptions arg] -> BatchOptions arg
$cmconcat :: forall arg. [BatchOptions arg] -> BatchOptions arg
mappend :: BatchOptions arg -> BatchOptions arg -> BatchOptions arg
$cmappend :: forall arg.
BatchOptions arg -> BatchOptions arg -> BatchOptions arg
mempty :: BatchOptions arg
$cmempty :: forall arg. BatchOptions arg
Monoid) via GenericSemigroupMonoid (BatchOptions arg)

instance ToJSON arg => ToJSON (BatchOptions arg) where
  toJSON :: BatchOptions arg -> Value
toJSON = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON forall a b. (a -> b) -> a -> b
$ ShowS -> Options
aesonPrefix ShowS
snakeCase
  toEncoding :: BatchOptions arg -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding 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 = forall a. Monoid a => a
mempty { boDescription :: Maybe (Last Text)
boDescription = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Last a
Last Text
d }

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

success :: Job arg -> BatchOptions arg
success :: forall arg. Job arg -> BatchOptions arg
success Job arg
job = forall a. Monoid a => a
mempty { boSuccess :: Maybe (Last (Job arg))
boSuccess = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Last a
Last Job arg
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 <- forall arg.
ToJSON arg =>
Producer -> BatchOptions arg -> IO BatchId
newBatch Producer
producer BatchOptions arg
options
  a
result <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT BatchId IO a
f BatchId
bid
  a
result 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. 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
$cto :: forall x. Rep CustomBatchId x -> CustomBatchId
$cfrom :: forall x. CustomBatchId -> Rep CustomBatchId x
Generic
  deriving anyclass [CustomBatchId] -> Encoding
[CustomBatchId] -> Value
CustomBatchId -> Encoding
CustomBatchId -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CustomBatchId] -> Encoding
$ctoEncodingList :: [CustomBatchId] -> Encoding
toJSONList :: [CustomBatchId] -> Value
$ctoJSONList :: [CustomBatchId] -> Value
toEncoding :: CustomBatchId -> Encoding
$ctoEncoding :: CustomBatchId -> Encoding
toJSON :: CustomBatchId -> Value
$ctoJSON :: CustomBatchId -> Value
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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall a. ReaderT BatchId IO a -> Batch a
Batch forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall arg.
(HasCallStack, ToJSON arg) =>
JobOptions -> Producer -> arg -> IO String
perform (JobOptions
options forall a. Semigroup a => a -> a -> a
<> 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"
    [forall a. ToJSON a => a -> ByteString
encode BatchOptions arg
options]
  case Either String (Maybe ByteString)
result of
    Left String
err -> forall {m :: * -> *} {a}. MonadThrow m => String -> m a
batchNewError String
err
    Right Maybe ByteString
Nothing -> forall {m :: * -> *} {a}. MonadThrow m => String -> m a
batchNewError String
"No BatchId returned"
    Right (Just ByteString
bs) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> BatchId
BatchId forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
bs
  where batchNewError :: String -> m a
batchNewError String
err = forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString forall a b. (a -> b) -> a -> b
$ String
"BATCH NEW error: " 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 forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
bid]