{-# LANGUAGE OverloadedStrings #-}
module Web.JobsUi.Actions where
import Web.JobsUi.Internal.Types
import Web.JobsUi.Html
import Web.JobsUi.Forms
import Data.Foldable
import Control.Monad.Trans
import Web.Spock
import Web.Spock.Lucid
import Web.Spock.Digestive
import qualified Data.Text as T
import qualified Data.Set as S
import Control.Concurrent.STM
import Data.Time
import qualified Data.Sequence as Seq
import qualified Lucid as H
import Network.HTTP.Types.Status
myError :: MonadIO a => Status -> ActionCtxT () a ()
myError = \case
Status 404 msg ->
lucid $ template "404 - Not found." $ do
H.h3_ "Not Found"
H.toHtml msg
Status 500 msg ->
lucid $ template "500 - Internal error." $ do
H.h3_ "Internal Error"
H.toHtml msg
Status cod msg ->
lucid $ template (T.pack $ show cod) $ H.toHtml msg
showHistory :: Action () ()
showHistory = do
jobs <- getState >>= liftIO . readTVarIO . myjobsVar
lucid $ template "Welcome" $ do
displayJobsList jobs
for_ (running jobs) (displayJob Running)
showJob :: JobId -> Action () ()
showJob i = do
jobs <- getState >>= liftIO . readTVarIO . myjobsVar
lucid $ template (T.pack $ "Job #" <> show i) $ do
displayJobsList jobs
for_ (find ((==) i . jobId) $ waiting jobs) $ displayJob Waiting
for_ (find ((==) i . jobId) $ running jobs) $ displayJob Running
for_ (find ((==) i . jobId) $ done jobs) $ displayJob Done
jobsMenu :: S.Set T.Text -> Action () ()
jobsMenu jobtypes = do
lucid $ template "Jobs Menu" $
H.ul_ $ forM_ jobtypes $ \jobtype -> do
H.li_ $ H.a_ [ H.href_ $ "/job/create/" <> jobtype ] (H.toHtml jobtype)
createJob :: JobInfo info -> Action () ()
createJob jobinfo = do
let
formView mErr view = do
form <- secureForm (jiType jobinfo) (editJobFormView jobinfo) view
formViewer "create" form mErr
form <- runForm "" (editJobForm $ Left jobinfo)
case form of
(view, Nothing) ->
formView Nothing view
(_, Just EditJob{..}) -> do
ServerState{myjobsVar, counterVar} <- getState
time <- liftIO getZonedTime
dat <- liftIO $ jiConstructor ejJobInfo ejPayload
jid <- liftIO $ atomically $ do
counter <- readTVar counterVar
myjobs <- readTVar myjobsVar
writeTVar counterVar $ counter + 1
writeTVar myjobsVar $ myjobs
{ waiting = flip (Seq.<|) (waiting myjobs) $ Job
{ jobId = JobId counter
, jobTimeQueued = time
, jobTimeStarted = Nothing
, jobTimeEnded = Nothing
, jobPayload = dat
, jobInfo = ejJobInfo
, jobFinished = Nothing
, jobThread = Nothing
}
}
pure counter
redirect $ "/job/" <> T.pack (show jid)
formViewer :: T.Text -> Html -> Maybe Html -> Action v ()
formViewer actionName form mErr = do
lucid $ do
template
actionName
$ do
maybe (pure ()) id mErr
form