{-# LANGUAGE StrictData #-}
{-# LANGUAGE NoFieldSelectors #-}
module Job
(
Queue (..)
, push
, prune
, Work (..)
, retry
, finish
, Meta (..)
, Id
, unsafeIdFromUUID7
, idFromUUID7
, newId
, 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
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
nice0 :: Nice
nice0 = Int32 -> Nice
Nice Int32
0
newtype Id
=
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
data Work job = Work
{ forall job. Work job -> Id
id :: Id
, forall job. Work job -> job
job :: job
, forall job. Work job -> Meta
meta :: Meta
, forall job. Work job -> Nice -> UTCTime -> IO ()
retry :: Nice -> Time.UTCTime -> IO ()
, forall job. Work job -> IO ()
finish :: IO ()
}
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)
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
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
data Queue job = Queue
{ forall job. Queue job -> Nice -> UTCTime -> job -> IO Id
push :: Nice -> Time.UTCTime -> job -> IO Id
, forall job. Queue job -> Acquire (Maybe (Work job))
pull :: A.Acquire (Maybe (Work job))
, 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
}
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
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
data Meta = Meta
{ Meta -> Maybe UTCTime
alive :: Maybe Time.UTCTime
, Meta -> Nice
nice :: Nice
, Meta -> UTCTime
wait :: Time.UTCTime
, Meta -> Word32
try :: Word32
}
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
, 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
)