git.iko.soy/sc-build
on bc59dfb help sign in
sc-build/src/Control/Task/Scheduler/Query.hs
121 lines 3.3 kB history raw
1{-# LANGUAGE TypeApplications #-}
3module Control.Task.Scheduler.Query
4 ( scheduleTaskQuery,
5 completeTaskQuery,
6 rescheduleTaskQuery,
7 pickTasksQuery,
8 PickedTask (..),
9 )
10where
12import Colog
13import Control.Monad.IO.Unlift
14import Control.Squeal
15import Control.Task
16import Data.Aeson hiding (Result (..))
17import Data.Proxy
18import qualified Data.Text as T
19import Data.Time
20import Data.Word
21import GHC.Generics (Generic)
22import GHC.TypeLits
23import qualified Generics.SOP as SOP
24import Server.Schema
25import Squeal.PostgreSQL
27scheduleTaskQuery ::
28 forall m t s env.
29 (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
30 t ->
31 m ()
32scheduleTaskQuery task = do
33 logInfo . T.pack $ "schdeuling task: " <> show task
34 let query =
35 insertInto
36 #tasks
37 ( Values_ $
38 Set (param @1) `as` #task
39 :* Set (param @2) `as` #payload
40 :* Default `as` #creation_time
41 )
42 ( OnConflict
43 (OnConstraint #pk_task_payload)
44 (DoUpdate (Default `as` #creation_time) [])
45 )
46 (Returning_ Nil)
47 dbWrite (const $ return ()) $
48 manipulateParams_
49 query
50 (symbolVal @s Proxy, Jsonb $ toJSON task)
52completeTaskQuery ::
53 forall m t s env.
54 (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
55 t ->
56 m ()
57completeTaskQuery payload = do
58 let task = symbolVal @s Proxy
59 logInfo . T.pack $ "Completing task: " <> task <> " with payload " <> show payload
60 let query :: Manipulation_ Schema (String, Jsonb Value) ()
61 query =
62 deleteFrom_
63 #tasks
64 (param @1 .== #task .&& param @2 .== #payload)
65 dbWrite (const $ return ()) $
66 manipulateParams_
67 query
68 (symbolVal @s Proxy, Jsonb $ toJSON payload)
70rescheduleTaskQuery ::
71 forall s t m env.
72 (StaticPQ m, Task t s, WithLog env Message m, MonadUnliftIO m) =>
73 t ->
74 m ()
75rescheduleTaskQuery payload = do
76 let task = symbolVal @s Proxy
77 logInfo . T.pack $
78 "reschdeuling task: " <> task
79 <> " with payload "
80 <> show payload
81 let query :: Manipulation_ Schema (String, Jsonb Value) ()
82 query =
83 update_
84 #tasks
85 (Default `as` #creation_time)
86 (param @1 .== #task .&& param @2 .== #payload)
87 dbWrite (const $ return ()) $
88 manipulateParams_
89 query
90 (symbolVal @s Proxy, Jsonb $ toJSON payload)
92pickTasksQuery ::
93 forall m env.
94 (StaticPQ m, WithLog env Message m, MonadUnliftIO m) =>
95 [String] ->
96 Word64 ->
97 m [PickedTask]
98pickTasksQuery tasks limitCount = do
99 logDebug "reading tasks"
100 let query :: Query_ Schema () PickedTask
101 query =
102 select_
103 ( #task `as` #task
104 :* #payload `as` #payload
105 :* #creation_time `as` #creationTime
106 )
107 ( from (table #tasks)
108 & where_ (#task `in_` (literal <$> tasks))
109 & orderBy [#creation_time & Asc]
110 & limit limitCount
111 )
112 dbRead (const $ return []) $
113 runQuery query >>= getRows
115data PickedTask
116 = PickedTask
117 { task :: String,
118 payload :: Jsonb Value,
119 creationTime :: UTCTime
120 }
121 deriving (Eq, Show, Generic, SOP.Generic, SOP.HasDatatypeInfo)