{-# LANGUAGE StrictData #-}
{-# LANGUAGE NoFieldSelectors #-}

module Job
   ( -- * Queue
    Queue (..)
   , push
   , prune

    -- * Work
   , Work (..)
   , retry
   , finish

    -- * Meta
   , Meta (..)

    -- * Id
   , Id
   , unsafeIdFromUUID7
   , idFromUUID7
   , newId

    -- * Nice
   , Nice (..)
   , nice0
   ) where

import Control.Monad
import Control.Monad.IO.Class
import Data.Acquire qualified as A
import Data.Hashable
import Data.Int
import Data.Time qualified as Time
import Data.UUID.V7 (UUID)
import Data.UUID.V7 qualified as UUID7
import Data.Word
import GHC.Records
import GHC.Stack

--------------------------------------------------------------------------------

-- | Nice value for a job.
--
-- * The __lower__ the value, the less “nice” a job is to other jobs.  Meaning
-- it will have priority over other jobs, and possibly be allocated more
-- resources.
--
-- * The __higher__ the value, the “nicer” a job is to other jobs. Meaning it
-- will have less priority over other jobs, and possibly allow competing jobs
-- to take more resources.
--
-- * Use 'nice0' (i.e,. @'Nice' 0@) as default 'Nice' value.
newtype Nice = Nice {Nice -> Int32
int32 :: Int32}
   deriving newtype (Nice -> Nice -> Bool
(Nice -> Nice -> Bool) -> (Nice -> Nice -> Bool) -> Eq Nice
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Nice -> Nice -> Bool
== :: Nice -> Nice -> Bool
$c/= :: Nice -> Nice -> Bool
/= :: Nice -> Nice -> Bool
Eq, Eq Nice
Eq Nice =>
(Nice -> Nice -> Ordering)
-> (Nice -> Nice -> Bool)
-> (Nice -> Nice -> Bool)
-> (Nice -> Nice -> Bool)
-> (Nice -> Nice -> Bool)
-> (Nice -> Nice -> Nice)
-> (Nice -> Nice -> Nice)
-> Ord Nice
Nice -> Nice -> Bool
Nice -> Nice -> Ordering
Nice -> Nice -> Nice
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Nice -> Nice -> Ordering
compare :: Nice -> Nice -> Ordering
$c< :: Nice -> Nice -> Bool
< :: Nice -> Nice -> Bool
$c<= :: Nice -> Nice -> Bool
<= :: Nice -> Nice -> Bool
$c> :: Nice -> Nice -> Bool
> :: Nice -> Nice -> Bool
$c>= :: Nice -> Nice -> Bool
>= :: Nice -> Nice -> Bool
$cmax :: Nice -> Nice -> Nice
max :: Nice -> Nice -> Nice
$cmin :: Nice -> Nice -> Nice
min :: Nice -> Nice -> Nice
Ord, Int -> Nice -> ShowS
[Nice] -> ShowS
Nice -> String
(Int -> Nice -> ShowS)
-> (Nice -> String) -> ([Nice] -> ShowS) -> Show Nice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Nice -> ShowS
showsPrec :: Int -> Nice -> ShowS
$cshow :: Nice -> String
show :: Nice -> String
$cshowList :: [Nice] -> ShowS
showList :: [Nice] -> ShowS
Show, Int -> Nice
Nice -> Int
Nice -> [Nice]
Nice -> Nice
Nice -> Nice -> [Nice]
Nice -> Nice -> Nice -> [Nice]
(Nice -> Nice)
-> (Nice -> Nice)
-> (Int -> Nice)
-> (Nice -> Int)
-> (Nice -> [Nice])
-> (Nice -> Nice -> [Nice])
-> (Nice -> Nice -> [Nice])
-> (Nice -> Nice -> Nice -> [Nice])
-> Enum Nice
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Nice -> Nice
succ :: Nice -> Nice
$cpred :: Nice -> Nice
pred :: Nice -> Nice
$ctoEnum :: Int -> Nice
toEnum :: Int -> Nice
$cfromEnum :: Nice -> Int
fromEnum :: Nice -> Int
$cenumFrom :: Nice -> [Nice]
enumFrom :: Nice -> [Nice]
$cenumFromThen :: Nice -> Nice -> [Nice]
enumFromThen :: Nice -> Nice -> [Nice]
$cenumFromTo :: Nice -> Nice -> [Nice]
enumFromTo :: Nice -> Nice -> [Nice]
$cenumFromThenTo :: Nice -> Nice -> Nice -> [Nice]
enumFromThenTo :: Nice -> Nice -> Nice -> [Nice]
Enum, Nice
Nice -> Nice -> Bounded Nice
forall a. a -> a -> Bounded a
$cminBound :: Nice
minBound :: Nice
$cmaxBound :: Nice
maxBound :: Nice
Bounded)

-- | @'nice0' = 'Nice' 0@
nice0 :: Nice
nice0 :: Nice
nice0 = Int32 -> Nice
Nice Int32
0

--------------------------------------------------------------------------------

-- | Unique identifier for the scheduled @job@ (and re-scheduled @job@, see
-- 'pull' and 'retry').
newtype Id
   = -- | Unsafe because there's no guarantee that the UUID is V7,
     -- which this library expects. Use 'idFromUUID7' if possible.
     UnsafeId UUID
   deriving newtype (Id -> Id -> Bool
(Id -> Id -> Bool) -> (Id -> Id -> Bool) -> Eq Id
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Id -> Id -> Bool
== :: Id -> Id -> Bool
$c/= :: Id -> Id -> Bool
/= :: Id -> Id -> Bool
Eq, Eq Id
Eq Id =>
(Id -> Id -> Ordering)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Bool)
-> (Id -> Id -> Id)
-> (Id -> Id -> Id)
-> Ord Id
Id -> Id -> Bool
Id -> Id -> Ordering
Id -> Id -> Id
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Id -> Id -> Ordering
compare :: Id -> Id -> Ordering
$c< :: Id -> Id -> Bool
< :: Id -> Id -> Bool
$c<= :: Id -> Id -> Bool
<= :: Id -> Id -> Bool
$c> :: Id -> Id -> Bool
> :: Id -> Id -> Bool
$c>= :: Id -> Id -> Bool
>= :: Id -> Id -> Bool
$cmax :: Id -> Id -> Id
max :: Id -> Id -> Id
$cmin :: Id -> Id -> Id
min :: Id -> Id -> Id
Ord, Int -> Id -> ShowS
[Id] -> ShowS
Id -> String
(Int -> Id -> ShowS)
-> (Id -> String) -> ([Id] -> ShowS) -> Show Id
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Id -> ShowS
showsPrec :: Int -> Id -> ShowS
$cshow :: Id -> String
show :: Id -> String
$cshowList :: [Id] -> ShowS
showList :: [Id] -> ShowS
Show, Eq Id
Eq Id => (Int -> Id -> Int) -> (Id -> Int) -> Hashable Id
Int -> Id -> Int
Id -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Id -> Int
hashWithSalt :: Int -> Id -> Int
$chash :: Id -> Int
hash :: Id -> Int
Hashable)

instance HasField "uuid7" Id UUID where
   getField :: Id -> UUID
getField (UnsafeId UUID
u) = UUID
u

unsafeIdFromUUID7 :: (HasCallStack) => UUID -> Id
unsafeIdFromUUID7 :: HasCallStack => UUID -> Id
unsafeIdFromUUID7 = Id -> (Id -> Id) -> Maybe Id -> Id
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Id
forall a. HasCallStack => String -> a
error String
"unsafeIdFromUUID7") Id -> Id
forall a. a -> a
id (Maybe Id -> Id) -> (UUID -> Maybe Id) -> UUID -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Maybe Id
idFromUUID7

idFromUUID7 :: UUID -> Maybe Id
idFromUUID7 :: UUID -> Maybe Id
idFromUUID7 UUID
u = UUID -> Id
UnsafeId UUID
u Id -> Maybe () -> Maybe Id
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (UUID -> Bool
UUID7.validate UUID
u)

newId :: (MonadIO m) => m Id
newId :: forall (m :: * -> *). MonadIO m => m Id
newId = UUID -> Id
UnsafeId (UUID -> Id) -> m UUID -> m Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m UUID
forall (m :: * -> *). MonadIO m => m UUID
UUID7.genUUID

--------------------------------------------------------------------------------

-- | A @job@ together with its 'Queue' execution context details.
--
-- As soon as you get your hands on a 'Work', which you do through 'pull',
-- start working on it right away.
data Work job = Work
   { forall job. Work job -> Id
id :: Id
   -- ^ Unique identifier for the scheduled @job@ (and re-scheduled @job@, see
   -- 'pull' and 'retry').
   , forall job. Work job -> job
job :: job
   -- ^ The actual @job@ to be carried out.
   , forall job. Work job -> Meta
meta :: Meta
   -- ^ 'Meta'data accompanying the @job@ being performed.
   , forall job. Work job -> Nice -> UTCTime -> IO ()
retry :: Nice -> Time.UTCTime -> IO ()
   -- ^ Once this 'Work' is released, reschedule to be executed at the
   -- specified 'Time.UTCTime' at the earliest.
   --
   -- See the documentation for 'Queue'\'s 'pull'.
   --
   -- @
   -- 'retry' _ _ '>>' 'retry' n t  ==  'retry' n t
   -- 'finish'    '>>' 'retry' n t  ==  'retry' n t
   -- 'retry' n t '>>' 'finish'     ==  'finish'
   -- @
   , forall job. Work job -> IO ()
finish :: IO ()
   -- ^ Once this 'Work' is released, remove it from the execution queue.
   --
   -- See the documentation for 'Queue'\'s 'pull'.
   --
   -- @
   -- 'finish'    '>>' 'retry' n t  ==  'retry' n t
   -- 'retry' n t '>>' 'finish'     ==  'finish'
   -- 'finish'    '>>' 'finish'     ==  'finish'
   -- @
   }
   deriving stock ((forall a b. (a -> b) -> Work a -> Work b)
-> (forall a b. a -> Work b -> Work a) -> Functor Work
forall a b. a -> Work b -> Work a
forall a b. (a -> b) -> Work a -> Work 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) -> Work a -> Work b
fmap :: forall a b. (a -> b) -> Work a -> Work b
$c<$ :: forall a b. a -> Work b -> Work a
<$ :: forall a b. a -> Work b -> Work a
Functor)

-- | Like the 'retry' field in 'Work', except with a bit more
-- polymorphic type and intended to be used as a top-level function.
retry
   :: forall job m
    . (MonadIO m)
   => Work job
   -> Nice
   -> Time.UTCTime
   -> m ()
retry :: forall job (m :: * -> *).
MonadIO m =>
Work job -> Nice -> UTCTime -> m ()
retry Work{$sel:retry:Work :: forall job. Work job -> Nice -> UTCTime -> IO ()
retry = Nice -> UTCTime -> IO ()
f} Nice
n UTCTime
t = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Nice -> UTCTime -> IO ()
f Nice
n UTCTime
t

-- | Like the 'finish' field in 'Work', except with a bit more
-- polymorphic type and intended to be used as a top-level function.
finish
   :: forall job m
    . (MonadIO m)
   => Work job
   -> m ()
finish :: forall job (m :: * -> *). MonadIO m => Work job -> m ()
finish Work{$sel:finish:Work :: forall job. Work job -> IO ()
finish = IO ()
m} = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
m

-- | A @job@ 'Queue'.
--
-- * @job@s can be 'push'ed to the 'Queue' for eventual execution, 'pull'ed
-- from the 'Queue' for immediate execution, and the 'Queue' itself can be
-- pruned.
--
-- * @"Job.Memory".'Job.Memory.queue'@ is an in-memory implementation that can
-- serve as reference.
--
-- * Other backends are expected to provide a 'Queue' implementation.
data Queue job = Queue
   { forall job. Queue job -> Nice -> UTCTime -> job -> IO Id
push :: Nice -> Time.UTCTime -> job -> IO Id
   -- ^ Push new @job@ to the queue so to be executed after the specified
   -- 'Time.UTCTime', which may be in the past. Throws if the 'Queue' has
   -- already been released.
   , forall job. Queue job -> Acquire (Maybe (Work job))
pull :: A.Acquire (Maybe (Work job))
   -- ^ Pull some 'Work' from the queue
   --
   -- * If the 'Queue' itself has been released, then returns 'Nothing'
   -- right away.
   --
   -- * Otherwise, blocks until 'Work' is available.
   --
   -- * On 'A.ReleaseExceptionWith', the @job@ is automatically rescheduled
   -- for re-execution after a few seconds. This behavior can be overriden
   -- by using 'Work'\'s 'retry' or 'finish'.
   --
   -- * On 'A.ReleaseNormal' or 'A.ReleaseEarly', the @job@ is automatically
   -- removed from the 'Queue'. This behavior can be overriden
   -- by using 'Work'\'s 'retry' or 'finish'.
   , forall job.
Queue job
-> forall a. Monoid a => (Id -> Meta -> job -> (Bool, a)) -> IO a
prune :: forall a. (Monoid a) => (Id -> Meta -> job -> (Bool, a)) -> IO a
   -- ^ Prune @job@s from the 'Queue', keeping only those for which the given
   -- function returns 'True' (like 'List.filter'). Allows collecting some
   -- additional 'Monoid'al output.  The given @job@s are in no particular
   -- order. Throws if the 'Queue' has already been released.
   -- __IMPORTANT:__ If you remove a @job@ that is currently active,
   -- it might be 'push'ed back to the 'Queue' later if required by 'retry'
   -- or a 'Work' exception.
   }

-- | Like the 'push' field in 'Queue', except with a bit more polymorphic type
-- and intended to be used as a top-level function.
push
   :: forall job m
    . (MonadIO m)
   => Queue job
   -> Nice
   -> Time.UTCTime
   -> job
   -> m Id
push :: forall job (m :: * -> *).
MonadIO m =>
Queue job -> Nice -> UTCTime -> job -> m Id
push Queue{$sel:push:Queue :: forall job. Queue job -> Nice -> UTCTime -> job -> IO Id
push = Nice -> UTCTime -> job -> IO Id
f} Nice
n UTCTime
t job
j = IO Id -> m Id
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Id -> m Id) -> IO Id -> m Id
forall a b. (a -> b) -> a -> b
$ Nice -> UTCTime -> job -> IO Id
f Nice
n UTCTime
t job
j

-- | Like the 'prune' field in 'Queue', except with a bit more polymorphic type
-- and intended to be used as a top-level function.
prune
   :: forall job a m
    . (Monoid a, MonadIO m)
   => Queue job
   -> (Id -> Meta -> job -> (Bool, a))
   -> m a
prune :: forall job a (m :: * -> *).
(Monoid a, MonadIO m) =>
Queue job -> (Id -> Meta -> job -> (Bool, a)) -> m a
prune Queue{$sel:prune:Queue :: forall job.
Queue job
-> forall a. Monoid a => (Id -> Meta -> job -> (Bool, a)) -> IO a
prune = forall a. Monoid a => (Id -> Meta -> job -> (Bool, a)) -> IO a
f} Id -> Meta -> job -> (Bool, a)
g = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ (Id -> Meta -> job -> (Bool, a)) -> IO a
forall a. Monoid a => (Id -> Meta -> job -> (Bool, a)) -> IO a
f Id -> Meta -> job -> (Bool, a)
g

-- | Wrapper for all the @job@-related data accessible through 'Queue'\'s
-- 'prune' function.
data Meta = Meta
   { Meta -> Maybe UTCTime
alive :: Maybe Time.UTCTime
   -- ^ If 'Just', the @job@ is currently being 'Work'ed on, allegedly. The
   -- last time the @job@ sent a heartbeat is attached.
   , Meta -> Nice
nice :: Nice
   -- ^ 'Nice' value used while scheduling the @job@.
   , Meta -> UTCTime
wait :: Time.UTCTime
   -- ^ Time until the 'Queue' is or was supposed to wait before considering
   -- working on the @job@.
   , Meta -> Word32
try :: Word32
   -- ^ How many tries have been attempted already (excluding the current
   -- one, in case 'alive' is 'Just').
   }
   deriving
      ( Meta -> Meta -> Bool
(Meta -> Meta -> Bool) -> (Meta -> Meta -> Bool) -> Eq Meta
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Meta -> Meta -> Bool
== :: Meta -> Meta -> Bool
$c/= :: Meta -> Meta -> Bool
/= :: Meta -> Meta -> Bool
Eq
      , Eq Meta
Eq Meta =>
(Meta -> Meta -> Ordering)
-> (Meta -> Meta -> Bool)
-> (Meta -> Meta -> Bool)
-> (Meta -> Meta -> Bool)
-> (Meta -> Meta -> Bool)
-> (Meta -> Meta -> Meta)
-> (Meta -> Meta -> Meta)
-> Ord Meta
Meta -> Meta -> Bool
Meta -> Meta -> Ordering
Meta -> Meta -> Meta
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Meta -> Meta -> Ordering
compare :: Meta -> Meta -> Ordering
$c< :: Meta -> Meta -> Bool
< :: Meta -> Meta -> Bool
$c<= :: Meta -> Meta -> Bool
<= :: Meta -> Meta -> Bool
$c> :: Meta -> Meta -> Bool
> :: Meta -> Meta -> Bool
$c>= :: Meta -> Meta -> Bool
>= :: Meta -> Meta -> Bool
$cmax :: Meta -> Meta -> Meta
max :: Meta -> Meta -> Meta
$cmin :: Meta -> Meta -> Meta
min :: Meta -> Meta -> Meta
Ord
        -- ^ Order compatible with the one in 'prune'.
      , Int -> Meta -> ShowS
[Meta] -> ShowS
Meta -> String
(Int -> Meta -> ShowS)
-> (Meta -> String) -> ([Meta] -> ShowS) -> Show Meta
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Meta -> ShowS
showsPrec :: Int -> Meta -> ShowS
$cshow :: Meta -> String
show :: Meta -> String
$cshowList :: [Meta] -> ShowS
showList :: [Meta] -> ShowS
Show
      )