git.iko.soy/sc-build
on bc59dfb help sign in
sc-build/src/Control/Task/Scheduler.hs
86 lines 2.2 kB history raw
1{-# LANGUAGE TypeApplications #-}
3module Control.Task.Scheduler
4 ( scheduleTask,
5 runTasks,
6 )
7where
9import Colog
10import Control.Monad
11import Control.Monad.IO.Unlift
12import Control.Task
13import Control.Task.Scheduler.Query
14import Data.Aeson hiding (Result (..))
15import qualified Data.Aeson as A
16import Data.Foldable
17import Data.Proxy
18import qualified Data.Text as T
19import Data.Word
20import GHC.TypeLits
21import Server.Schema
22import Squeal.PostgreSQL
24scheduleTask ::
25 (StaticPQ m, WithLog env Message m, Task t s, MonadUnliftIO m) =>
26 t ->
27 m ()
28scheduleTask = scheduleTaskQuery
30runTasks ::
31 forall tt m env.
32 (StaticPQ m, WithLog env Message m, RunTasks tt m, MonadUnliftIO m) =>
33 Word64 ->
34 m Int
35runTasks n = do
36 tasks <- pickTasksQuery (taskNames @tt @m) n
37 for_ tasks $ runTask @tt @m
38 return $ length tasks
40rescheduleTaskTime ::
41 forall t s m env.
42 (Task t s, StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
43 t ->
44 m ()
45rescheduleTaskTime = rescheduleTaskQuery
47class RunTasks (ts :: [*]) m where
49 runTask :: WithLog env Message m => PickedTask -> m ()
51 taskNames :: [String]
53instance
54 forall t ts tt m.
55 (Task t ts, TaskMonad t m, StaticPQ m, RunTasks tt m, MonadUnliftIO m) =>
56 RunTasks (t ': tt) m
57 where
59 runTask (PickedTask s (Jsonb v) initialStartTime) | symbolVal @ts Proxy == s =
60 case fromJSON @t v of
61 A.Error e ->
62 logError . T.pack $
63 "Coulndn't decode payload for task " <> s
64 <> " with payload "
65 <> show v
66 <> " with error "
67 <> e
68 A.Success t -> do
69 logInfo . T.pack $ "running task " <> task <> " with " <> show t <> " created at " <> show initialStartTime
70 r <- performTask @t @ts @m t
71 when (r == Failure) $ logWarning . T.pack $ "Task " <> task <> " failed"
72 case r of
73 Success -> completeTaskQuery t
74 Failure -> rescheduleTaskTime t
75 where
76 task = symbolVal @ts Proxy
77 runTask t = runTask @tt @m t
79 taskNames = symbolVal @ts Proxy : taskNames @tt @m
81instance RunTasks '[] m where
83 runTask (PickedTask s (Jsonb v) _) =
84 logError . T.pack $ "Unknown task " <> s <> " with payload " <> show v
86 taskNames = []