jobs-ui (empty) → 0.1.0.0
raw patch · 12 files changed
+1031/−0 lines, 12 filesdep +Spockdep +Spock-digestivedep +Spock-lucid
Dependencies added: Spock, Spock-digestive, Spock-lucid, base, bytestring, containers, deepseq, digestive-functors, digestive-functors-lucid, file-embed, http-types, hvect, lucid, mtl, pretty-relative-time, stm, text, time, transformers
Files
- LICENSE +191/−0
- Makefile +19/−0
- README.md +33/−0
- jobs-ui.cabal +67/−0
- src/Web/JobsUi.hs +8/−0
- src/Web/JobsUi/Actions.hs +109/−0
- src/Web/JobsUi/Forms.hs +111/−0
- src/Web/JobsUi/Html.hs +152/−0
- src/Web/JobsUi/Internal/Types.hs +82/−0
- src/Web/JobsUi/Run.hs +205/−0
- src/Web/JobsUi/Types.hs +50/−0
- src/Web/JobsUi/Utils.hs +4/−0
+ LICENSE view
@@ -0,0 +1,191 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ Copyright 2019 Gil Mizrahi++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+
+ Makefile view
@@ -0,0 +1,19 @@+.PHONY: setup++setup:+ stack setup++.PHONY: build++build:+ stack build++.PHONY: dev++dev:+ stack build --fast --file-watch++.PHONY: clean_all++clean:+ stack clean
+ README.md view
@@ -0,0 +1,33 @@+Jobs UI is a UI system for queuing and running custom IO Jobs.++> License: Apache License 2.0++++## Deps++This package uses hpack and stack.++## Usage++[See the example project](https://gitlab.com/gilmi/jobs-ui/tree/master/example/Main.hs).++Define your own custom jobs using the `JobInfo` type:++```hs+data JobInfo a+ = JobInfo+ { jiType :: T.Text -- ^ The name of the job type.+ , jiInputs :: [Param] -- ^ Definition of user parameters.+ , jiParams :: a -> [T.Text]+ -- ^ Conversion from the job payload structure to presentable parameters.+ , jiConstructor :: [(T.Text, T.Text)] -> IO a+ -- ^ Construct a payload type from user entered parameters.+ , jiExec :: a -> IO T.Text+ -- ^ How to execute a job. Returns a presentable Html when the job succeeds.+ , jiNotify :: a -> (Result T.Text T.Text) -> IO ()+ -- ^ Will be run when job ends.+ }+```++Wrap it in the `JobType` constructor, and pass it to the `run :: [JobType] -> IO ()`.
+ jobs-ui.cabal view
@@ -0,0 +1,67 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: cc1d4563ac0034c1a87c5a01bb68a81add04e8d100bc310c416a33984f217884++name: jobs-ui+version: 0.1.0.0+synopsis: A library for creating a jobs management website running custom jobs.+description: A library for creating a jobs management website running custom jobs by defining jobs in Haskell.+category: Web+author: Gil Mizrahi+maintainer: gilmi@posteo.net+copyright: 2019 Gil Mizrahi+license: Apache-2.0+license-file: LICENSE+build-type: Simple+extra-source-files:+ Makefile+extra-doc-files:+ README.md+ LICENSE+data-dir: static++source-repository head+ type: git+ location: https://gitlab.com/gilmi/jobs-ui++library+ exposed-modules:+ Web.JobsUi+ Web.JobsUi.Actions+ Web.JobsUi.Forms+ Web.JobsUi.Html+ Web.JobsUi.Internal.Types+ Web.JobsUi.Run+ Web.JobsUi.Types+ Web.JobsUi.Utils+ other-modules:+ Paths_jobs_ui+ hs-source-dirs:+ src+ default-extensions: TypeApplications OverloadedStrings ConstraintKinds DataKinds DeriveFunctor DeriveFoldable DeriveTraversable EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf PatternGuards PatternSynonyms RankNTypes RecordWildCards NamedFieldPuns ScopedTypeVariables TupleSections ViewPatterns BangPatterns+ ghc-options: -Wall+ build-depends:+ Spock+ , Spock-digestive+ , Spock-lucid+ , base >=4.7 && <5+ , bytestring+ , containers+ , deepseq+ , digestive-functors+ , digestive-functors-lucid+ , file-embed+ , http-types+ , hvect+ , lucid+ , mtl+ , pretty-relative-time+ , stm+ , text+ , time+ , transformers+ default-language: Haskell2010
+ src/Web/JobsUi.hs view
@@ -0,0 +1,8 @@+module Web.JobsUi+ ( module Export+ )+where++import Web.JobsUi.Run as Export (run)+import Web.JobsUi.Types as Export+import Web.JobsUi.Utils as Export
+ src/Web/JobsUi/Actions.hs view
@@ -0,0 +1,109 @@+{-# 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++-------------+-- Actions --+-------------++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+ -- | Display the form to the user+ formView mErr view = do+ form <- secureForm (jiType jobinfo) (editJobFormView jobinfo) view+ formViewer "create" form mErr++ -- Run the form+ form <- runForm "" (editJobForm $ Left jobinfo)+ -- validate the form.+ -- Nothing means failure. will display the form view back to the user when validation fails.+ 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)++-- | Display the form to the user+formViewer :: T.Text -> Html -> Maybe Html -> Action v ()+formViewer actionName form mErr = do+ lucid $ do+ template+ actionName+ $ do+ maybe (pure ()) id mErr+ form
+ src/Web/JobsUi/Forms.hs view
@@ -0,0 +1,111 @@+{- | Defines the forms used in the app+-}++{-# LANGUAGE ExistentialQuantification #-}++module Web.JobsUi.Forms where++import Web.Spock+import Control.Monad.Trans++import Web.JobsUi.Internal.Types++import Data.Foldable+import Text.Digestive ((.:))+import Data.Traversable+import qualified Text.Digestive as D+import qualified Text.Digestive.Lucid.Html5 as D+import qualified Lucid as H+import qualified Data.Text as T+++-----------+-- Utils --+-----------++-- | A form with hidden csrf token+secureForm :: T.Text -> (D.View Html -> Html) -> D.View Html -> Action v Html+secureForm route formHtml view = do+ csrfToken <- getCsrfToken+ pure $ D.form view route $ do+ H.input_ [ H.type_ "hidden", H.name_ "__csrf_token", H.value_ csrfToken ]+ formHtml view++-----------+-- Forms --+-----------++-- | Definition of an edit job data type+data EditJob+ = forall info. EditJob+ { ejJobInfo :: JobInfo info+ , ejPayload :: [(T.Text, T.Text)]+ }++-- | Definition of a form and it's validation+editJobForm :: Either (JobInfo info) EditJob -> D.Form Html (Action' ()) EditJob+editJobForm = \case+ Left info ->+ EditJob info <$> createPayload info+ Right edit -> -- not handling this correctly yet+ pure edit++createPayload :: JobInfo info -> D.Form Html (Action' ()) [(T.Text, T.Text)]+createPayload info = D.monadic $ do+ fmap sequenceA $ for (jiInputs info) $ \Param{..} ->+ case paramInputType of+ TextInput ->+ pure $ (.:)+ paramDesc+ ( D.validateM+ ( fmap (fmap (paramDesc,))+ . fmap (D.resultMapError H.toHtml)+ . liftIO . paramValidation+ . trim+ )+ (D.text Nothing)+ )++ TextOptions opts -> do+ opts' <- liftIO opts+ pure $ (.:)+ paramDesc+ ( D.choice+ ( map (\x -> ((paramDesc, x), H.toHtml x)) opts'+ )+ Nothing+ )++-- | Defining the view for the edit event form+editJobFormView :: JobInfo info -> D.View Html -> Html+editJobFormView info view = H.div_ $ do+ H.table_ $ do+ H.tr_ $ do+ H.th_ [ H.scope_ "col" ] ""+ H.th_ [ H.scope_ "col" ] ""+ for_ (jiInputs info) $ \Param{..} ->+ case paramInputType of+ TextInput -> H.tr_ $ do+ H.td_ $ D.label paramDesc view (H.toHtml paramDesc)+ H.td_ $ do+ D.inputText paramDesc view+ D.errorList paramDesc view++ TextOptions _ -> H.tr_ $ do+ H.td_ $ D.label paramDesc view (H.toHtml paramDesc)+ H.td_ $ do+ D.inputSelect paramDesc view+ D.errorList paramDesc view++ D.inputSubmit "Create"+++jobToEditJob :: Job -> EditJob+jobToEditJob job@Job{..} =+ EditJob jobInfo (zip (paramDesc <$> jiInputs jobInfo) (getJobParams job))+++-- | trim spaces from both sides+trim :: T.Text -> T.Text+trim = T.filter (/='\r') . T.reverse . T.dropWhile (==' ') . T.reverse . T.dropWhile (==' ')+
+ src/Web/JobsUi/Html.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}++module Web.JobsUi.Html where++import Web.JobsUi.Internal.Types++import Data.Time+import Data.Foldable+import Control.Monad+import qualified Data.Text as T++import qualified Lucid as H+import Lucid.Html5 hiding (for_)+import Text.Time.Pretty++----------+-- Html --+----------++++displayJobsList :: Jobs -> Html+displayJobsList Jobs{..} = do+ div_ [ class_ "jobs three columns" ] $ do+ h3_ "Jobs"+ ul_ [ class_ "jobs-list" ] $ do+ for_ waiting $ \job ->+ displayJobInList Waiting job+ for_ running $ \job ->+ displayJobInList Running job+ for_ done $ \job ->+ displayJobInList Done job++displayJobInList :: JobStatus -> Job -> Html+displayJobInList status job@Job{..} =+ li_ [ class_ $ ppJobStatus job status ] $+ a_ [ href_ $ T.pack $ "/job/" <> show jobId, class_ $ ppJobStatus job status ] $+ H.toHtml $ "Job #" <> show jobId++ppJobStatus :: Job -> JobStatus -> T.Text+ppJobStatus Job{..} = \case+ Waiting -> "waiting-job"+ Running -> "running-job"+ Done -> case jobFinished of+ Nothing -> "done-job"+ Just Error{} -> "failed-job"+ Just Success{} -> "success-job"++displayJob :: JobStatus -> Job -> Html+displayJob status job@Job{..} = do+ div_ [ class_ "job nine columns" ] $ do+ when (status /= Done) $+ form_ [ action_ $ T.pack $ "/job/" <> show (getJobId jobId) <> "/cancel" ] $+ input_ [ class_ "cancel-btn", type_ "submit", value_ "Cancel Job" ]+ h3_ $ H.toHtml $ "Job #" <> show jobId+ table_ [ class_ "jobinfo" ] $ do+ tr_ $ do+ th_ [ scope_ "col" ] ""+ th_ [ scope_ "col" ] ""+ tr_ $ do+ td_ $ "Type"+ td_ $ H.toHtml $ getJobType job+ tr_ $ do+ td_ "Status"+ td_ [class_ $ ppJobStatus job status] $ H.toHtml $ show status+ tr_ $ do+ td_ "Queued Time"+ td_ $ H.toHtml $ myFormatTime jobTimeQueued+ case (jobTimeStarted, jobTimeEnded) of+ (Nothing, Nothing) -> pure ()+ (Just ts, Nothing) ->+ tr_ $ do+ td_ "Start Time"+ td_ $ H.toHtml $ myFormatTime ts+ (Nothing, Just te) ->+ tr_ $ do+ td_ "End Time"+ td_ $ H.toHtml $ myFormatTime te+ (Just ts, Just te) -> do+ tr_ $ do+ td_ "Start Time"+ td_ $ H.toHtml $ myFormatTime ts+ tr_ $ do+ td_ "End Time"+ td_ $ H.toHtml $ myFormatTime te+ tr_ $ do+ td_ "Finished"+ td_ $ H.toHtml $+ prettyTimeAuto (zonedTimeToUTC ts) (zonedTimeToUTC te)++ table_ [ class_ "params" ] $ do+ th_ [ scope_ "col" ] ""+ th_ [ scope_ "col" ] ""+ for_ (zip (jiInputs jobInfo) (getJobParams job)) displayParam++ case jobFinished of+ Nothing -> pure ()+ Just (Success str) -> do+ div_ [ class_ "result" ] $ do+ h5_ [ class_ $ ppJobStatus job status ] "Succeeded:"+ pre_ $ H.toHtml str+ Just (Error str) -> do+ div_ [ class_ "result" ] $ do+ h5_ [ class_ $ ppJobStatus job status ] "Failed:"+ pre_ $ H.toHtml str++myFormatTime :: ZonedTime -> Html+myFormatTime = H.toHtml . formatTime defaultTimeLocale "%Y-%m-%d %T %Z"++displayParam :: (Param, T.Text) -> Html+displayParam (Param{..}, val) =+ tr_ $ do+ td_ $ label_ $ H.toHtml paramDesc+ td_ $ case paramInputType of+ TextInput ->+ input_ [ disabled_ "", value_ val ]+ TextOptions _ ->+ select_ [ disabled_ "", value_ val ] $+ option_ [ value_ val, selected_ "" ] $ H.toHtml val++-- Template --+++-- | A page template+template :: T.Text -> Html -> Html+template subtitle body =+ doctypehtml_ $ do+ head_ $ do+ meta_ [ charset_ "utf-8" ]++ title_ $ H.toHtml $ T.intercalate " - " [title, subtitle]++ meta_ [ name_ "viewport", content_ "width=device-width, initial-scale=1" ]++ link_ [ rel_ "stylesheet", type_ "text/css", href_ "/css/normalize.css" ]+ link_ [ rel_ "stylesheet", type_ "text/css", href_ "/css/skeleton.css" ]+ link_ [ rel_ "stylesheet", type_ "text/css", href_ "/css/jobs-ui.css" ]++ body_ $ do+ div_ [class_ "container"] $ do+ div_ [ class_ "top row" ] $ do+ header_ [ class_ "seven columns" ] $ do+ h1_ $ a_ [ href_ "/" ] $ H.toHtml title+ ul_ [ class_ "navigation" ] $+ li_ $+ form_ [ action_ "/job/create" ] $+ input_ [ type_ "submit", value_ "Create New Job" ]++ div_ [id_ "main", class_ "row" ] body++title :: T.Text+title = "Jobs UI"
+ src/Web/JobsUi/Internal/Types.hs view
@@ -0,0 +1,82 @@+{- | Defines types used throughout the app+-}+++{-# LANGUAGE ExistentialQuantification #-}++module Web.JobsUi.Internal.Types+ ( module Web.JobsUi.Internal.Types+ , module Export+ )+where++import Web.Spock+import Data.Time+import Control.Concurrent+import Control.Concurrent.STM+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import qualified Lucid as H++import Text.Digestive.Types as Export (Result(..))+import Web.JobsUi.Types as Export++++type Html = H.Html ()+++data ServerState+ = ServerState+ { myjobsVar :: TVar Jobs+ , counterVar :: TVar Int+ }++type Action ctx a = SpockActionCtx ctx () () ServerState a+type Action' ctx = SpockActionCtx ctx () () ServerState++type Jobs = JobsDS Job++data JobsDS a+ = Jobs+ { waiting :: Seq.Seq a+ , running :: Maybe a+ , done :: [a]+ }+ deriving (Functor, Foldable, Traversable)++noJobs :: Jobs+noJobs = Jobs mempty Nothing mempty++data Job+ = forall info. Job+ { jobId :: JobId+ , jobTimeQueued :: ZonedTime+ , jobTimeStarted :: Maybe ZonedTime+ , jobTimeEnded :: Maybe ZonedTime+ , jobFinished :: Maybe (Result T.Text T.Text)+ , jobThread :: Maybe ThreadId+ , jobPayload :: info+ , jobInfo :: JobInfo info+ }++getJobType :: Job -> T.Text+getJobType Job{..} = jiType jobInfo++getJobParams :: Job -> [T.Text]+getJobParams Job{..} = jiParams jobInfo $ jobPayload++newtype JobId+ = JobId+ { getJobId :: Int+ }+ deriving (Eq, Ord)++instance Show JobId where+ show (JobId i) = show i++data JobStatus+ = Done+ | Running+ | Waiting+ deriving (Eq, Show)
+ src/Web/JobsUi/Run.hs view
@@ -0,0 +1,205 @@+{- |++This module contains the @@run@@ function that can be used to launch the website.+It also contains the router and the background runner running the tasks.++-}+++{-# LANGUAGE OverloadedStrings, DeriveAnyClass, TemplateHaskell #-}++module Web.JobsUi.Run (run) where++import Web.JobsUi.Actions+import Web.JobsUi.Internal.Types++import Data.Time+import Data.Maybe+import Data.Foldable+import Control.Monad+import Control.Monad.Trans+import Web.Spock+import Web.Spock.Config+import Control.Concurrent.STM+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import qualified Data.ByteString as BS+import qualified Data.Map as M+import Control.Exception+import Control.Concurrent+import Network.HTTP.Types.Status+import Data.FileEmbed++import System.IO.Unsafe+import Control.DeepSeq+++-- | This function launches the website.+-- It get's a Map of named job types which are used+-- to define different kinds of jobs a user can select to run.+run+ :: [JobType] -- ^ The jiType should be unique+ -> IO ()+run jobtypeList = do+ let+ jobtypes = M.fromList $+ map (\job@JobType{..} -> (jiType getJobInfo, job)) jobtypeList+ defaultJobs = noJobs+ initial <- ServerState+ <$> newTVarIO defaultJobs+ <*> newTVarIO (length defaultJobs + 1)+ spockCfg <- defaultSpockCfg () PCNoDatabase initial+ _ <- forkIO $ runner initial+ runSpock 1337 (spock spockCfg{spc_errorHandler=myError} $ app jobtypes)++------------+-- Router --+------------++-- | We use file-embed to embed the css and other static files into the executable,+-- so we can easily ship an executable only.+myStaticDir :: M.Map T.Text BS.ByteString+myStaticDir = M.mapKeys T.pack $ M.fromList $ $(embedDir "static")++-- | Defines the app an routing. Is called from @@run@@.+app :: M.Map T.Text JobType -> SpockM () () ServerState ()+app jobtypes = do+ get root $+ showHistory++ get ("job" <//> var) $ \i ->+ showJob $ JobId i++ -- will either move a waiting job to the done list or+ -- throw an exeception to the executing thread if the job is currently running,+ -- to be taken care in the @@runner@@ when cancelled.+ -- Has no effect on done jobs.+ get ("job" <//> var <//> "cancel") $ \(JobId -> i) -> do+ jobsvar <- myjobsVar <$> getState+ toCancel <- liftIO $ atomically $ do+ jobs@Jobs{..} <- readTVar jobsvar+ if fmap jobId running == Just i+ then do+ pure $ jobThread =<< running+ else do+ case find ((==) i . jobId) $ toList waiting of+ Nothing ->+ pure Nothing+ Just job -> do+ writeTVar jobsvar $ jobs+ { waiting = flip Seq.deleteAt waiting+ (fromJust $ Seq.findIndexL ((==) i . jobId) waiting)+ , done = job : done+ }+ pure Nothing+ liftIO $ maybe (pure ()) (flip throwTo Job_Cancelled) toCancel+ redirect "/"++ getpost ("job" <//> "create") $ do+ jobsMenu (M.keysSet jobtypes)++ getpost ("job" <//> "create" <//> var) $ \jobtype ->+ case M.lookup jobtype jobtypes of+ Nothing -> do+ setStatus status404+ myError $ Status 404 "No such job type available."+ Just JobType{ .. } ->+ createJob getJobInfo++ -- lookup static things in our embeded @@myStaticDir@@+ get wildcard $ \route -> do+ case M.lookup route myStaticDir of+ Just fileContent ->+ bytes fileContent+ Nothing -> do+ setStatus status404+ myError $ Status 404 "could not find route to url"+++-- | May be thrown from @@app@@ to forked @@runner@@ thread executing a job+data MyException+ = Job_Cancelled+ deriving (Show, Exception)++-- | Handles running tasks. The only function that moves tasks to running status and from it+runner :: ServerState -> IO ()+runner ServerState{myjobsVar} = forever $ do+ -- move a running job to the done list (if there is one)+ endTime <- getZonedTime+ endedJob <- atomically $ do+ jobs <- readTVar myjobsVar+ writeTVar myjobsVar $+ case running jobs of+ Nothing -> jobs+ Just job ->+ jobs+ { running = Nothing+ , done = job{jobTimeEnded = Just endTime}+ : done jobs+ }+ pure $ running jobs++ -- notify result+ forM_ endedJob $ \Job{..} ->+ case jobFinished of+ Nothing -> pure ()+ Just result -> void $ forkIO $+ jiNotify jobInfo jobPayload result++ -- move a waiting job to the running job+ Job{..} <- atomically $ do+ jobs <- readTVar myjobsVar+ case Seq.viewr $ waiting jobs of+ Seq.EmptyR ->+ retry+ rest Seq.:> job -> do+ startTime <- pure $! unsafePerformIO getZonedTime+ writeTVar myjobsVar $ jobs+ { waiting = rest+ , running = Just $ job { jobTimeStarted = Just startTime }+ }+ pure job+ -- execute the new running job+ mvar <- newEmptyMVar+ tid <- forkOS $ do+ catch+ ( flip finally (putMVar mvar ()) $ do+ result <- jiExec jobInfo jobPayload+ -- success+ deepseq result $ atomically $ modifyTVar myjobsVar $ \jobs ->+ jobs+ { running = fmap+ ( \job -> job+ { jobFinished = Just $ Success result+ , jobThread = Nothing+ }+ )+ (running jobs)+ }+ )+ -- failure cleanup+ ( \e -> do+ atomically $ modifyTVar myjobsVar $ \jobs ->+ jobs+ { running = fmap+ (\job -> job+ { jobFinished = Just (Error $ T.pack $ displayException (e :: SomeException))+ , jobThread = Nothing+ }+ )+ (running jobs)+ }+ )+ -- we may use the job thread to cancel a job+ atomically $ modifyTVar myjobsVar $ \jobs ->+ jobs+ { running = fmap+ (\job -> job+ { jobThread = Just tid+ }+ )+ (running jobs)+ }+ takeMVar mvar++ putStrLn $ "Done: #" <> show (getJobId jobId)
+ src/Web/JobsUi/Types.hs view
@@ -0,0 +1,50 @@+{- | Define a job type: a description of a task a user can run.++-}++{-# LANGUAGE ExistentialQuantification #-}++module Web.JobsUi.Types+ ( module Web.JobsUi.Types+ , module Export+ )+where++import qualified Data.Text as T+import Text.Digestive.Types as Export (Result(..))++-- | JobInfo is a description a job a user can run+-- @@a@@ is the structure built from the parameters.+data JobInfo a+ = JobInfo+ { jiType :: T.Text -- ^ The name of the job type.+ , jiInputs :: [Param] -- ^ Definition of user parameters.+ , jiParams :: a -> [T.Text]+ -- ^ Conversion from the job payload structure to presentable parameters.+ , jiConstructor :: [(T.Text, T.Text)] -> IO a+ -- ^ Construct a payload type from user entered parameters.+ , jiExec :: a -> IO T.Text+ -- ^ How to execute a job. Returns a presentable Html when the job succeeds.+ , jiNotify :: a -> (Result T.Text T.Text) -> IO ()+ -- ^ Will be run when job ends.+ }++-- | Defines a parameter for the user+data Param+ = Param+ { paramDesc :: T.Text+ , paramInputType :: ParamInputType+ , paramValidation :: T.Text -> IO (Result T.Text T.Text)+ }++-- | Input type+data ParamInputType+ = TextInput+ | TextOptions (IO [T.Text])++-- | Existential type for job. Let's us ignore the job payload internally.+data JobType+ = forall a. JobType+ { getJobInfo :: JobInfo a+ }+
+ src/Web/JobsUi/Utils.hs view
@@ -0,0 +1,4 @@+module Web.JobsUi.Utils where++lookupIO :: Show a => Eq a => a -> [(a, b)] -> IO b+lookupIO key = maybe (error $ "Missing value for key: " <> show key) pure . lookup key