@@ -1,8 +1,12 @@
1−{-# LANGUAGE TypeOperators, DeriveGeneric, NamedFieldPuns, DataKinds, StandaloneDeriving, FlexibleContexts, RecordWildCards #-}
1+{-# LANGUAGE TypeOperators, DeriveGeneric, NamedFieldPuns, DataKinds, StandaloneDeriving, FlexibleContexts, RecordWildCards, RankNTypes #-}
2+
3+
4+-- | TODO: Rename this to OddJobs.Servant
25
36module OddJobs.Endpoints where
47
5−import OddJobs.Web as Web
8+import OddJobs.Web as Web hiding (Routes(..))
9+import qualified OddJobs.Web as Web
610import OddJobs.Job as Job
711import OddJobs.Types
812import GHC.Generics
@@ -25,15 +29,12 @@ import Control.Monad.Reader
2529import Data.String.Conv (toS)
2630import Control.Monad.Except
2731import Data.Time as Time
28−import Data.Time.Format.Human (humanReadableTime')
2932import Data.Aeson as Aeson
3033import qualified Data.HashMap.Strict as HM
3134import GHC.Exts (toList)
3235import Data.Maybe (fromMaybe, mapMaybe)
33−import Data.Text.Conversions (fromText, toText)
3436import Control.Applicative ((<|>))
35−import Data.Time.Convenience (timeSince, Unit(..), Direction(..))
36−import qualified OddJobs.Links as Links
37+-- import qualified OddJobs.Links as Links
3738import Data.List ((\\))
3839import qualified System.Log.FastLogger as FLogger
3940import qualified System.Log.FastLogger.Date as FLogger
@@ -50,34 +51,34 @@ import qualified OddJobs.ConfigBuilder as Builder
5051-- stopApp :: IO ()
5152-- stopApp = undefined
5253
53−tname :: TableName
54−tname = "jobs_aqgrqtaowi"
55−
56−startApp :: IO ()
57−startApp = do
58− let connInfo = ConnectInfo
59− { connectHost = "localhost"
60− , connectPort = fromIntegral 5432
61− , connectUser = "jobs_test"
62− , connectPassword = "jobs_test"
63− , connectDatabase = "jobs_test"
64− }
65− dbPool <- createPool
66− (PGS.connect connInfo) -- cretea a new resource
67− (PGS.close) -- destroy resource
68− 1 -- stripes
69− (fromRational 10) -- number of seconds unused resources are kept around
70− 5 -- maximum open connections
54+data Routes route = Routes
55+ { rFilterResults :: route :- QueryParam "filters" Web.Filter :> Get '[HTML] (Html ())
56+ , rStaticAssets :: route :- "assets" :> Raw
57+ , rEnqueue :: route :- "enqueue" :> Capture "jobId" JobId :> Post '[HTML] NoContent
58+ , rRunNow :: route :- "run" :> Capture "jobId" JobId :> Post '[HTML] NoContent
59+ , rCancel :: route :- "cancel" :> Capture "jobId" JobId :> Post '[HTML] NoContent
60+ , rRefreshJobTypes :: route :- "refresh-job-types" :> Post '[HTML] NoContent
61+ , rRefreshJobRunners :: route :- "refresh-job-runners" :> Post '[HTML] NoContent
62+ } deriving (Generic)
63+
64+
65+data Env = Env
66+ { envRoutes :: Web.Routes
67+ , envJobTypesRef :: IORef [Text]
68+ , envJobRunnersRef :: IORef [JobRunnerName]
69+ }
7170
72− tcache <- FLogger.newTimeCache FLogger.simpleTimeFormat'
73− (tlogger, cleanup) <- FLogger.newTimedFastLogger tcache (FLogger.LogStdout FLogger.defaultBufSize)
74− let flogger = Builder.defaultTimedLogger tlogger (Builder.defaultLogStr (Builder.defaultJobToText Builder.defaultJobType))
75− jm = Builder.finalizeConfig $ Builder.defaultConfigBuilder flogger tname dbPool Job.UnlimitedConcurrentJobs (const $ pure ())
71+mkEnv :: (MonadIO m) => Config -> (Link -> Text) -> m Env
72+mkEnv cfg@Config{..} linksFn = do
73+ allJobTypes <- fetchAllJobTypes cfg
74+ allJobRunners <- fetchAllJobRunners cfg
75+ envJobTypesRef <- newIORef allJobTypes
76+ envJobRunnersRef <- newIORef allJobRunners
77+ let envRoutes = routes linksFn
7678
77− allJobTypes <- fetchAllJobTypes jm dbPool
78− allJobRunners <- fetchAllJobRunners jm dbPool
79− jobTypesRef <- newIORef allJobTypes
80− jobRunnerRef <- newIORef allJobRunners
79+ pure Env{..}
80+ -- TODO: remove hard-coded port
81+ -- run 8080 $ genericServe (server cfg Env{..})
8182
8283 -- let nt :: ReaderT Job.Config IO a -> Servant.Handler a
8384 -- nt action = (liftIO $ try $ runReaderT action jm) >>= \case
@@ -85,405 +86,104 @@ startApp = do
8586 -- Right a -> Servant.Handler $ ExceptT $ pure $ Right a
8687 -- appProxy = (Proxy :: Proxy (ToServant Routes AsApi))
8788
88− finally
89− (run 8080 $ genericServe (server jm dbPool jobTypesRef jobRunnerRef))
90− (cleanup >> (Pool.destroyAllResources dbPool))
89+ -- finally
90+ -- (run 8080 $ genericServe (server jm dbPool jobTypesRef jobRunnerRef))
91+ -- (cleanup >> (Pool.destroyAllResources dbPool))
9192
9293stopApp :: IO ()
9394stopApp = pure ()
9495
95−server :: Config
96− -> Pool Connection
97− -> IORef [Text]
98− -> IORef [JobRunnerName]
99− -> Routes AsServer
100−server config dbPool jobTypesRef jobRunnerRef = Routes
101− { rFilterResults = (\mFilter -> filterResults config dbPool jobTypesRef mFilter)
96+
97+server :: (MonadIO m)
98+ => Config
99+ -> Env
100+ -> (forall a . Handler a -> m a)
101+ -> Routes (AsServerT m)
102+server cfg env nt = Routes
103+ { rFilterResults = nt . (filterResults cfg env)
102104 , rStaticAssets = serveDirectoryFileServer "assets"
103− , rEnqueue = enqueueJob config dbPool
104− , rCancel = cancelJob config dbPool
105− , rRunNow = runJobNow config dbPool
106− , rRefreshJobTypes = refreshJobTypes config dbPool jobTypesRef
107− , rRefreshJobRunners = refreshJobRunners config dbPool jobRunnerRef
105+ , rEnqueue = nt . (enqueueJob cfg env)
106+ , rCancel = nt . (cancelJob cfg env)
107+ , rRunNow = nt . (runJobNow cfg env)
108+ , rRefreshJobTypes = nt $ refreshJobTypes cfg env
109+ , rRefreshJobRunners = nt $ refreshJobRunners cfg env
108110 }
109111
110112refreshJobRunners :: Config
111− -> Pool Connection
112− -> IORef [JobRunnerName]
113+ -> Env
113114 -> Handler NoContent
114−refreshJobRunners cfg dbPool jobRunnerRef = do
115− allJobRunners <- fetchAllJobRunners cfg dbPool
116− atomicModifyIORef' jobRunnerRef (\_ -> (allJobRunners, ()))
117− throwError $ err301{errHeaders=[("Location", toS $ Links.rFilterResults Nothing)]}
115+refreshJobRunners cfg@Config{..} Env{envRoutes=Web.Routes{..}, envJobRunnersRef} = do
116+ allJobRunners <- fetchAllJobRunners cfg
117+ atomicModifyIORef' envJobRunnersRef (\_ -> (allJobRunners, ()))
118+ throwError $ err301{errHeaders=[("Location", toS $ rFilterResults Nothing)]}
118119
119120refreshJobTypes :: Config
120− -> Pool Connection
121− -> IORef [Text]
121+ -> Env
122122 -> Handler NoContent
123−refreshJobTypes cfg dbPool jobTypesRef = do
124− allJobTypes <- fetchAllJobTypes cfg dbPool
125− atomicModifyIORef' jobTypesRef (\_ -> (allJobTypes, ()))
126− throwError $ err301{errHeaders=[("Location", toS $ Links.rFilterResults Nothing)]}
123+refreshJobTypes cfg Env{envRoutes=Web.Routes{..}, envJobTypesRef} = do
124+ allJobTypes <- fetchAllJobTypes cfg
125+ atomicModifyIORef' envJobTypesRef (\_ -> (allJobTypes, ()))
126+ throwError $ err301{errHeaders=[("Location", toS $ rFilterResults Nothing)]}
127127
128128cancelJob :: Config
129− -> Pool Connection
129+ -> Env
130130 -> JobId
131131 -> Handler NoContent
132−cancelJob cfg dbPool jid = do
133− updateHelper cfg dbPool (Failed, jid, In [Queued, Retry])
132+cancelJob Config{..} env jid = do
133+ liftIO $ withResource cfgDbPool $ \conn -> void $ cancelJobIO conn cfgTableName jid
134+ redirectToHome env
134135
135136runJobNow :: Config
136− -> Pool Connection
137+ -> Env
137138 -> JobId
138139 -> Handler NoContent
139−runJobNow cfg dbPool jid = do
140− updateHelper cfg dbPool (Queued, jid, In [Queued, Retry])
141−
140+runJobNow Config{..} env jid = do
141+ liftIO $ withResource cfgDbPool $ \conn -> void $ runJobNowIO conn cfgTableName jid
142+ redirectToHome env
142143
143144enqueueJob :: Config
144− -> Pool Connection
145+ -> Env
145146 -> JobId
146147 -> Handler NoContent
147−enqueueJob cfg dbPool jid = do
148− updateHelper cfg dbPool (Queued, jid, In [Locked, Failed])
148+enqueueJob Config{..} env jid = do
149+ liftIO $ withResource cfgDbPool $ \conn -> do
150+ void $ unlockJobIO conn cfgTableName jid
151+ void $ runJobNowIO conn cfgTableName jid
152+ redirectToHome env
149153
150−updateHelper :: Config
151− -> Pool Connection
152− -> (Status, JobId, In [Status])
153− -> Handler NoContent
154−updateHelper Config{cfgTableName} dbPool args = do
155− liftIO $ void $ withResource dbPool $ \conn -> do
156− PGS.execute conn (updateQuery tname) args
157− throwError $ err301{errHeaders=[("Location", toS $ Links.rFilterResults Nothing)]}
154+redirectToHome :: Env -> Handler NoContent
155+redirectToHome Env{envRoutes=Web.Routes{..}} = do
156+ throwError $ err301{errHeaders=[("Location", toS $ rFilterResults Nothing)]}
158157
159158
160−fetchAllJobTypes :: (MonadIO m)
161− => Config
162− -> Pool Connection
163− -> m [Text]
164−fetchAllJobTypes Config{cfgAllJobTypes} dbPool = liftIO $ do
165− case cfgAllJobTypes of
166− AJTFixed jts -> pure jts
167− AJTSql fn -> withResource dbPool fn
168− AJTCustom fn -> fn
169−
170−fetchAllJobRunners :: (MonadIO m)
171− => Config
172− -> Pool Connection
173− -> m [JobRunnerName]
174−fetchAllJobRunners Config{cfgTableName} dbPool = liftIO $ withResource dbPool $ \conn -> do
175− fmap (mapMaybe fromOnly) $ PGS.query_ conn $ "select distinct locked_by from " <> cfgTableName
176−
177−
178−updateQuery :: TableName -> PGS.Query
179−updateQuery tname = "update " <> tname <> " set locked_at=null, locked_by=null, attempts=0, status=?, run_at=now() where id=? and status in ?"
180−
181159filterResults :: Config
182− -> Pool Connection
183− -> IORef [Text]
160+ -> Env
184161 -> Maybe Filter
185162 -> Handler (Html ())
186−filterResults cfg@Config{cfgJobToHtml} dbPool jobTypesRef mFilter = do
163+filterResults cfg@Config{cfgJobToHtml, cfgDbPool} Env{..} mFilter = do
187164 let filters = fromMaybe mempty mFilter
188− (jobs, runningCount) <- liftIO $ Pool.withResource dbPool $ \conn -> (,)
165+ (jobs, runningCount) <- liftIO $ Pool.withResource cfgDbPool $ \conn -> (,)
189166 <$> (filterJobs cfg conn filters)
190167 <*> (countJobs cfg conn filters{ filterStatuses = [Job.Locked] })
191168 t <- liftIO getCurrentTime
192169 js <- liftIO $ fmap (DL.zip jobs) $ cfgJobToHtml jobs
193− allJobTypes <- readIORef jobTypesRef
194− let navHtml = sideNav allJobTypes [] t filters
195− bodyHtml = resultsPanel t filters js runningCount
196− pure $ pageLayout navHtml bodyHtml
197−
198−
199−pageNav :: Html ()
200−pageNav = do
201− div_ $ nav_ [ class_ "navbar navbar-default navigation-clean" ] $ div_ [ class_ "container-fluid" ] $ do
202− div_ [ class_ "navbar-header" ] $ do
203− a_ [ class_ "navbar-brand navbar-link", href_ "#", style_ "margin-left: 2px; padding: 0px;" ] $ img_ [ src_ "/assets/odd-jobs-color-logo.png", title_ "Odd Jobs Logo" ]
204− button_ [ class_ "navbar-toggle collapsed", data_ "toggle" "collapse", data_ "target" "#navcol-1" ] $ do
205− span_ [ class_ "sr-only" ] $ "Toggle navigation"
206− span_ [ class_ "icon-bar" ] $ ""
207− span_ [ class_ "icon-bar" ] $ ""
208− span_ [ class_ "icon-bar" ] $ ""
209− -- div_ [ class_ "collapse navbar-collapse", id_ "navcol-1" ] $ ul_ [ class_ "nav navbar-nav navbar-right" ] $ do
210− -- li_ [ class_ "active", role_ "presentation" ] $ a_ [ href_ "#" ] $ "First Item"
211− -- li_ [ role_ "presentation" ] $ a_ [ href_ "#" ] $ "Second Item"
212− -- li_ [ role_ "presentation" ] $ a_ [ href_ "#" ] $ "Third Item"
213− -- li_ [ class_ "dropdown" ] $ do
214− -- a_ [ class_ "dropdown-toggle", data_ "toggle" "dropdown", ariaExpanded_ "false", href_ "#" ] $ do
215− -- "Dropdown"
216− -- span_ [ class_ "caret" ] $ ""
217− -- ul_ [ class_ "dropdown-menu", role_ "menu" ] $ do
218− -- li_ [ role_ "presentation" ] $ a_ [ href_ "#" ] $ "First Item"
219− -- li_ [ role_ "presentation" ] $ a_ [ href_ "#" ] $ "Second Item"
220− -- li_ [ role_ "presentation" ] $ a_ [ href_ "#" ] $ "Third Item"
221−
222−pageLayout :: Html() -> Html () -> Html ()
223−pageLayout navHtml bodyHtml = do
224− doctype_
225− html_ $ do
226− head_ $ do
227− meta_ [ charset_ "utf-8" ]
228− meta_ [ name_ "viewport", content_ "width=device-width, initial-scale=1.0" ]
229− title_ "haskell-pg-queue"
230− link_ [ rel_ "stylesheet", href_ "assets/bootstrap/css/bootstrap.min.css" ]
231− link_ [ rel_ "stylesheet", href_ "https://fonts.googleapis.com/css?family=Lato:100i,300,300i,400,700,900" ]
232− -- link_ [ rel_ "stylesheet", href_ "assets/css/logo-slider.css" ]
233− -- link_ [ rel_ "stylesheet", href_ "assets/css/Navigation-Clean1.css" ]
234− link_ [ rel_ "stylesheet", href_ "assets/css/styles.css" ]
235− body_ $ do
236− pageNav
237− div_ $ div_ [ class_ "container-fluid", style_ "/*background-color:#f2f2f2;*/" ] $ div_ [ class_ "row" ] $ do
238− div_ [ class_ "d-none d-md-block col-md-2" ] navHtml
239− div_ [ class_ "col-12 col-md-10" ] bodyHtml
240− script_ [ src_ "assets/js/jquery.min.js" ] $ ("" :: Text)
241− script_ [ src_ "assets/bootstrap/js/bootstrap.min.js" ] $ ("" :: Text)
242− script_ [ src_ "assets/js/custom.js" ] $ ("" :: Text)
243− -- script_ [ src_ "https://cdnjs.cloudflare.com/ajax/libs/slick-carousel/1.6.0/slick.js" ] $ ("" :: Text)
244− -- script_ [ src_ "assets/js/logo-slider.js" ] $ ("" :: Text)
245−
246−sideNav :: [Text] -> [JobRunnerName] -> UTCTime -> Filter -> Html ()
247−sideNav jobTypes jobRunnerNames t filter@Filter{..} = do
248− div_ [ class_ "filters mt-3" ] $ do
249− jobStatusFilters
250− jobTypeFilters
251− jobRunnerFilters
252− where
253− jobStatusFilters = do
254− h6_ "Filter by job status"
255− div_ [ class_ "card" ] $ do
256− ul_ [ class_ "list-group list-group-flush" ] $ do
257− li_ [ class_ ("list-group-item " <> if filterStatuses == [] then "active-nav" else "") ] $ do
258− let lnk = (Links.rFilterResults $ Just filter{filterStatuses = [], filterPage = (Web.filterPage blankFilter)})
259− a_ [ href_ lnk ] $ do
260− "all"
261− span_ [ class_ "badge badge-pill badge-secondary float-right" ] "12"
262− forM_ ((\\) (enumFrom minBound) [Job.Success]) $ \st -> do
263− li_ [ class_ ("list-group-item " <> if (st `elem` filterStatuses) then "active-nav" else "") ] $ do
264− let lnk = (Links.rFilterResults $ Just filter{filterStatuses = [st], filterPage = Nothing})
265− a_ [ href_ lnk ] $ do
266− toHtml $ toText st
267− span_ [ class_ "badge badge-pill badge-secondary float-right" ] "12"
268−
269− jobRunnerFilters = do
270− h6_ [ class_ "mt-3" ] $ do
271− "Filter by job-runner"
272− form_ [ method_ "post", action_ Links.rRefreshJobRunners, class_ "d-inline"] $ do
273− button_ [ type_ "submit", class_ "btn btn-link m-0 p-0 ml-1 float-right"] $ do
274− small_ "refresh"
275−
276− div_ [ class_ "card" ] $ do
277− ul_ [ class_ "list-group list-group-flush" ] $ do
278− li_ [ class_ ("list-group-item " <> if filterJobRunner == [] then "active-nav" else "") ] $ do
279− let lnk = (Links.rFilterResults $ Just filter{filterJobRunner = [], filterPage = (Web.filterPage blankFilter)})
280− a_ [ href_ lnk ] "all"
281− forM_ jobRunnerNames $ \jr -> do
282− li_ [ class_ ("list-group-item" <> if (jr `elem` filterJobRunner) then " active-nav" else "")] $ do
283− a_ [ href_ "#" ] $ toHtml $ unJobRunnerName jr
284−
285− jobTypeFilters = do
286− h6_ [ class_ "mt-3" ] $ do
287− "Filter by job-type"
288− form_ [ method_ "post", action_ Links.rRefreshJobTypes, class_ "d-inline"] $ do
289− button_ [ type_ "submit", class_ "btn btn-link m-0 p-0 ml-1 float-right"] $ do
290− small_ "refresh"
291−
292− div_ [ class_ "card" ] $ do
293− ul_ [ class_ "list-group list-group-flush" ] $ do
294− li_ [ class_ ("list-group-item " <> if filterJobTypes == [] then "active-nav" else "") ] $ do
295− let lnk = (Links.rFilterResults $ Just filter{filterJobTypes = [], filterPage = (Web.filterPage blankFilter)})
296− a_ [ href_ lnk ] "all"
297− forM_ jobTypes $ \jt -> do
298− li_ [ class_ ("list-group-item" <> if (jt `elem` filterJobTypes) then " active-nav" else "")] $ do
299− a_ [ href_ (Links.rFilterResults $ Just filter{filterJobTypes=[jt]}) ] $ toHtml jt
300−
301−searchBar :: UTCTime -> Filter -> Html ()
302−searchBar t filter@Filter{filterStatuses, filterCreatedAfter, filterCreatedBefore, filterUpdatedAfter, filterUpdatedBefore, filterJobTypes, filterRunAfter} = do
303− form_ [ style_ "padding-top: 2em;" ] $ do
304− div_ [ class_ "form-group" ] $ do
305− div_ [ class_ "search-container" ] $ do
306− ul_ [ class_ "list-inline search-bar" ] $ do
307− forM_ filterStatuses $ \s -> renderFilter "Status" (toText s) (Links.rFilterResults $ Just filter{filterStatuses = filterStatuses \\ [s]})
308− maybe mempty (\x -> renderFilter "Created after" (showText x) (Links.rFilterResults $ Just filter{filterCreatedAfter = Nothing})) filterCreatedAfter
309− maybe mempty (\x -> renderFilter "Created before" (showText x) (Links.rFilterResults $ Just filter{filterCreatedBefore = Nothing})) filterCreatedBefore
310− maybe mempty (\x -> renderFilter "Updated after" (showText x) (Links.rFilterResults $ Just filter{filterUpdatedAfter = Nothing})) filterUpdatedAfter
311− maybe mempty (\x -> renderFilter "Updated before" (showText x) (Links.rFilterResults $ Just filter{filterUpdatedBefore = Nothing})) filterUpdatedBefore
312− maybe mempty (\x -> renderFilter "Run after" (showText x) (Links.rFilterResults $ Just filter{filterRunAfter = Nothing})) filterRunAfter
313− forM_ filterJobTypes $ \x -> renderFilter "Job type" x (Links.rFilterResults $ Just filter{filterJobTypes = filterJobTypes \\ [x]})
314−
315− button_ [ class_ "btn btn-default search-button", type_ "button" ] $ "Search"
316− -- ul_ [ class_ "list-inline" ] $ do
317− -- li_ $ span_ $ strong_ "Common searches:"
318− -- li_ $ a_ [ href_ (Links.rFilterResults $ Just mempty) ] $ "All jobs"
319− -- li_ $ a_ [ href_ (Links.rFilterResults $ Just $ filter{ filterStatuses = [Job.Locked] }) ] $ "Currently running"
320− -- li_ $ a_ [ href_ (Links.rFilterResults $ Just $ filter{ filterStatuses = [Job.Success] }) ] $ "Successful"
321− -- li_ $ a_ [ href_ (Links.rFilterResults $ Just $ filter{ filterStatuses = [Job.Failed] }) ] $ "Failed"
322− -- li_ $ a_ [ href_ (Links.rFilterResults $ Just $ filter{ filterRunAfter = Just t }) ] $ "Future"
323− -- -- li_ $ a_ [ href_ "#" ] $ "Retried"
324− -- li_ $ a_ [ href_ (Links.rFilterResults $ Just $ filter{ filterStatuses = [Job.Queued] }) ] $ "Queued"
325− -- li_ $ a_ [ href_ (Links.rFilterResults $ Just $ filter{ filterUpdatedAfter = Just $ timeSince t 10 Minutes Ago }) ] $ "Last 10 mins"
326− -- li_ $ a_ [ href_ (Links.rFilterResults $ Just $ filter{ filterCreatedAfter = Just $ timeSince t 10 Minutes Ago }) ] $ "Recently created"
327− where
328− renderFilter :: Text -> Text -> Text -> Html ()
329− renderFilter k v u = do
330− li_ [ class_ "search-filter" ] $ do
331− span_ [ class_ "filter-name" ] $ toHtml k
332− span_ [ class_ "filter-value" ] $ do
333− toHtml v
334− a_ [ href_ u, class_ "text-danger" ] $ i_ [ class_ "glyphicon glyphicon-remove" ] $ ""
335−
336−
337−timeDuration :: UTCTime -> UTCTime -> (Int, String)
338−timeDuration from to = (diff, str)
339− where
340− str = if diff <= 0
341− then "under 1s"
342− else (if d>0 then (show d) <> "d" else "") <>
343− (if m>0 then (show m) <> "m" else "") <>
344− (if s>0 then (show s) <> "s" else "")
345− diff = (abs $ round $ diffUTCTime from to)
346− (m', s) = diff `divMod` 60
347− (h', m) = m' `divMod` 60
348− (d, h) = h' `divMod` 24
349−
350−showText :: (Show a) => a -> Text
351−showText a = toS $ show a
352−
353−jobContent :: Value -> Value
354−jobContent v = case v of
355− Aeson.Object o -> case HM.lookup "contents" o of
356− Nothing -> v
357− Just c -> c
358− _ -> v
359−
360−jobRow :: UTCTime -> (Job, Html ()) -> Html ()
361−jobRow t (job@Job{..}, jobHtml) = do
362− tr_ $ do
363− td_ [ class_ "job-type" ] $ do
364− let statusFn = case jobStatus of
365− Job.Success -> statusSuccess
366− Job.Failed -> statusFailed
367− Job.Queued -> if jobRunAt > t
368− then statusFuture
369− else statusWaiting
370− Job.Retry -> statusRetry
371− Job.Locked -> statusLocked
372− statusFn t job
373−
374− td_ jobHtml
375− td_ $ do
376− let actionsFn = case jobStatus of
377− Job.Success -> (const mempty)
378− Job.Failed -> actionsFailed
379− Job.Queued -> if jobRunAt > t
380− then actionsFuture
381− else actionsWaiting
382− Job.Retry -> actionsRetry
383− Job.Locked -> (const mempty)
384− actionsFn job
385−
386−
387−actionsFailed :: Job -> Html ()
388−actionsFailed Job{..} = do
389− form_ [ action_ (Links.rEnqueue jobId), method_ "post" ] $ do
390− button_ [ class_ "btn btn-secondary", type_ "submit" ] $ "Enqueue again"
391−
392−actionsRetry :: Job -> Html ()
393−actionsRetry Job{..} = do
394− form_ [ action_ (Links.rRunNow jobId), method_ "post" ] $ do
395− button_ [ class_ "btn btn-secondary", type_ "submit" ] $ "Run now"
396−
397−actionsFuture :: Job -> Html ()
398−actionsFuture Job{..} = do
399− form_ [ action_ (Links.rRunNow jobId), method_ "post" ] $ do
400− button_ [ class_ "btn btn-secondary", type_ "submit" ] $ "Run now"
401−
402−actionsWaiting :: Job -> Html ()
403−actionsWaiting Job{..} = do
404− form_ [ action_ (Links.rCancel jobId), method_ "post" ] $ do
405− button_ [ class_ "btn btn-danger", type_ "submit" ] $ "Cancel"
406−
407−statusSuccess :: UTCTime -> Job -> Html ()
408−statusSuccess t Job{..} = do
409− span_ [ class_ "badge badge-success" ] $ "Success"
410− span_ [ class_ "job-run-time" ] $ do
411− let (d, s) = timeDuration jobCreatedAt jobUpdatedAt
412− abbr_ [ title_ (showText jobUpdatedAt) ] $ toHtml $ "Completed " <> humanReadableTime' t jobUpdatedAt <> ". "
413− abbr_ [ title_ (showText d <> " seconds")] $ toHtml $ "Took " <> s
414−
415−statusFailed :: UTCTime -> Job -> Html ()
416−statusFailed t Job{..} = do
417− span_ [ class_ "badge badge-danger" ] $ "Failed"
418− span_ [ class_ "job-run-time" ] $ do
419− abbr_ [ title_ (showText jobUpdatedAt) ] $ toHtml $ "Failed " <> humanReadableTime' t jobUpdatedAt <> " after " <> show jobAttempts <> " attempts"
420−
421−statusFuture :: UTCTime -> Job -> Html ()
422−statusFuture t Job{..} = do
423− span_ [ class_ "badge badge-secondary" ] $ "Future"
424− span_ [ class_ "job-run-time" ] $ do
425− abbr_ [ title_ (showText jobRunAt) ] $ toHtml $ humanReadableTime' t jobRunAt
426−
427−statusWaiting :: UTCTime -> Job -> Html ()
428−statusWaiting t Job{..} = do
429− span_ [ class_ "badge badge-warning" ] $ "Waiting"
430− -- span_ [ class_ "job-run-time" ] ("Waiting to be picked up" :: Text)
431−
432−statusRetry :: UTCTime -> Job -> Html ()
433−statusRetry t Job{..} = do
434− span_ [ class_ "badge badge-warning" ] $ toHtml $ "Retries (" <> show jobAttempts <> ")"
435− span_ [ class_ "job-run-time" ] $ do
436− abbr_ [ title_ (showText jobUpdatedAt) ] $ toHtml $ "Retried " <> humanReadableTime' t jobUpdatedAt <> ". "
437− abbr_ [ title_ (showText jobRunAt)] $ toHtml $ "Next retry in " <> humanReadableTime' t jobRunAt
438−
439−statusLocked :: UTCTime -> Job -> Html ()
440−statusLocked t Job{..} = do
441− span_ [ class_ "badge badge-info" ] $ toHtml ("Locked" :: Text)
442− -- span_ [ class_ "job-run-time" ] $ do
443− -- abbr_ [ title_ (showText jobUpdatedAt) ] $ toHtml $ "Retried " <> humanReadableTime' t jobUpdatedAt <> ". "
444− -- abbr_ [ title_ (showText jobRunAt)] $ toHtml $ "Next retry in " <> humanReadableTime' t jobRunAt
445−
446−resultsPanel :: UTCTime -> Filter -> [(Job, Html ())] -> Int -> Html ()
447−resultsPanel t filter@Filter{filterPage} js runningCount = do
448− div_ [ class_ "card mt-3" ] $ do
449− div_ [ class_ "card-header bg-secondary text-white" ] $ do
450− "Currently running "
451− span_ [ class_ "badge badge-primary badge-primary" ] $ toHtml (show runningCount)
452− div_ [ class_ "currently-running" ] $ div_ [ class_ "" ] $ table_ [ class_ "table table-striped table-hover" ] $ do
453− thead_ [ class_ "thead-dark"] $ do
454− tr_ $ do
455− th_ "Job status"
456− th_ "Job"
457− th_ [ style_ "min-width: 12em;" ] "Actions"
458− tbody_ $ do
459− forM_ js (jobRow t)
460− div_ [ class_ "card-footer" ] $ do
461− nav_ $ do
462− ul_ [ class_ "pagination" ] $ do
463− prevLink
464− nextLink
170+ allJobTypes <- readIORef envJobTypesRef
171+ let navHtml = Web.sideNav envRoutes allJobTypes [] t filters
172+ bodyHtml = Web.resultsPanel envRoutes t filters js runningCount
173+ pure $ Web.pageLayout navHtml bodyHtml
174+
175+routes :: (Link -> Text) -> Web.Routes
176+routes linkFn = Web.Routes
177+ { Web.rFilterResults = rFilterResults
178+ , Web.rStaticAssets = Prelude.id
179+ , Web.rEnqueue = rEnqueue
180+ , Web.rRunNow = rRunNow
181+ , Web.rCancel = rCancel
182+ , Web.rRefreshJobTypes = rRefreshJobTypes
183+ , Web.rRefreshJobRunners = rRefreshJobRunners
184+ }
465185 where
466− prevLink = do
467− let (extraClass, lnk) = case filterPage of
468− Nothing -> ("disabled", "")
469− Just (l, 0) -> ("disabled", "")
470− Just (l, o) -> ("", Links.rFilterResults $ Just $ filter {filterPage = Just (l, max 0 $ o - l)})
471− li_ [ class_ ("page-item previous " <> extraClass) ] $ do
472− a_ [ class_ "page-link", href_ lnk ] $ "Prev"
473−
474− nextLink = do
475− let (extraClass, lnk) = case filterPage of
476− Nothing ->
477− if (DL.length js) < 10
478− then ("disabled", "")
479− else ("", (Links.rFilterResults $ Just $ filter {filterPage = Just (10, 10)}))
480− Just (l, o) ->
481− if (DL.length js) < l
482− then ("disabled", "")
483− else ("", (Links.rFilterResults $ Just $ filter {filterPage = Just (l, o + l)}))
484− li_ [ class_ ("page-item next " <> extraClass) ] $ do
485− a_ [ class_ "page-link", href_ lnk ] $ "Next"
486−
487−ariaExpanded_ :: Text -> Attribute
488−ariaExpanded_ v = makeAttribute "aria-expanded" v
186+ OddJobs.Endpoints.Routes{..} = allFieldLinks' linkFn :: OddJobs.Endpoints.Routes (AsLink Text)
489187
188+-- absText :: Link -> Text
189+-- absText l = "/" <> (toS $ show $ linkURI l)