ihp-job-dashboard (empty) → 1.5.0
raw patch · 8 files changed
+1016/−0 lines, 8 filesdep +basedep +blaze-htmldep +blaze-markup
Dependencies added: base, blaze-html, blaze-markup, hasql, hasql-dynamic-statements, hasql-implicits, hasql-pool, http-types, ihp, ihp-hsx, mtl, text, wai, wai-request-params
Files
- IHP/Job/Dashboard.hs +426/−0
- IHP/Job/Dashboard/Auth.hs +52/−0
- IHP/Job/Dashboard/Types.hs +106/−0
- IHP/Job/Dashboard/Utils.hs +29/−0
- IHP/Job/Dashboard/View.hs +305/−0
- LICENSE +21/−0
- changelog.md +10/−0
- ihp-job-dashboard.cabal +67/−0
+ IHP/Job/Dashboard.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{-|+Module: IHP.Job.Dashboard+Description: Auto-generate a dashboard for job types++This module allows IHP applications to generate a dashboard for interacting with job types.+To start, first define a type for the dashboard:++> type MyDashboard = JobsDashboardController NoAuth '[]++And include the following in the 'controllers' list of a FrontController:++> parseRoute @MyDashboard++This generates a dashboard with listings for all tables which have names ending with "_jobs".++All views are fully customizable. For more info, see the documentation for 'DisplayableJob'.+If you implement custom behavior for a job type, add it to the list in the Dashboard type:++> type MyDashboard = JobsDashboardController NoAuth '[EmailUserJob, UpdateRecordJob]+-}+module IHP.Job.Dashboard (+ module IHP.Job.Dashboard.View,+ module IHP.Job.Dashboard.Auth,+ module IHP.Job.Dashboard.Types,++ JobsDashboard(..),+ DisplayableJob(..),+ JobsDashboardController(..),+ getTableName,+) where++import IHP.Prelude+import IHP.ModelSupport+import IHP.ControllerPrelude+import Unsafe.Coerce+import IHP.Job.Queue ()+import IHP.Pagination.Types+import Network.Wai (requestMethod)+import Network.HTTP.Types.Method (methodPost)++import IHP.Job.Dashboard.Types+import IHP.Job.Dashboard.View+import IHP.Job.Dashboard.Auth+import IHP.Hasql.FromRow (FromRowHasql)+import IHP.Job.Dashboard.Utils+import qualified Hasql.Implicits.Encoders+import qualified Hasql.Decoders as Decoders+import qualified Hasql.DynamicStatements.Snippet as Snippet++-- | The crazy list of type constraints for this class defines everything needed for a generic "Job".+-- All jobs created through the IHP dev IDE will automatically satisfy these constraints and thus be able to+-- be used as a 'DisplayableJob'.+-- To customize the dashboard behavior for each job, you should provide a custom implementation of 'DisplayableJob'+-- for your job type. Your custom implementations will then be used instead of the defaults.+class ( job ~ GetModelByTableName (GetTableName job)+ , FilterPrimaryKey (GetTableName job)+ , FromRowHasql job+ , Show (PrimaryKey (GetTableName job))+ , KnownSymbol (GetTableName job)+ , HasField "id" job (Id job)+ , HasField "status" job JobStatus+ , HasField "updatedAt" job UTCTime+ , HasField "createdAt" job UTCTime+ , HasField "lastError" job (Maybe Text)+ , CanUpdate job+ , CanCreate job+ , Record job+ , Show job+ , Eq job+ , Table job+ , Typeable job+ , Hasql.Implicits.Encoders.DefaultParamEncoder (Id' (GetTableName job))+ ) => DisplayableJob job where++ -- | How this job's section should be displayed in the dashboard. By default it's displayed as a table,+ -- but this can be any arbitrary view! Make some cool graphs :)+ makeDashboardSection :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO SomeView++ makePageView :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Int -> Int -> IO SomeView++ -- | The content of the page that will be displayed for a detail view of this job.+ -- By default, the ID, Status, Created/Updated at times, and last error are displayed.+ -- Can be defined as any arbitrary view.+ makeDetailView :: (?context :: ControllerContext, ?modelContext :: ModelContext) => job -> IO SomeView+ makeDetailView job = do+ pure $ SomeView $ HtmlView $ renderBaseJobDetailView (buildBaseJob job)++ -- | The content of the page that will be displayed for the "new job" form of this job.+ -- By default, only the submit button is rendered. For additonal form data, define your own implementation.+ -- Can be defined as any arbitrary view, but it should be a form.+ makeNewJobView :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO SomeView+ makeNewJobView = pure $ SomeView $ HtmlView $ renderNewBaseJobForm $ tableName @job++ -- | The action run to create and insert a new value of this job into the database.+ -- By default, create an empty record and insert it.+ -- To add more data, define your own implementation.+ createNewJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO ()+ createNewJob = do+ newRecord @job |> create+ pure ()+++++-- | Defines implementations for actions for acting on a dashboard made of some list of types.+-- This is included to allow these actions to recurse on the types, isn't possible in an IHP Controller+-- action implementation.+--+-- Later functions and typeclasses introduce constraints on the types in this list,+-- so you'll get a compile error if you try and include a type that is not a job.+class JobsDashboard (jobs :: [Type]) where+ -- | Creates the entire dashboard by recursing on the type list and calling 'makeDashboardSection' on each type.+ makeDashboard :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Request) => IO SomeView++ includedJobTables :: [Text]++ -- | Renders the index page, which is the view returned from 'makeDashboard'.+ indexPage :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()++ listJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ()+ listJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ()++ -- | Renders the detail view page. Rescurses on the type list to find a type with the+ -- same table name as the "tableName" query parameter.+ viewJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ()+ viewJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ()++ -- | If performed in a POST request, creates a new job depending on the "tableName" query parameter.+ -- If performed in a GET request, renders the new job from depending on said parameter.+ newJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ()+ newJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ()++ -- | Deletes a job from the database.+ deleteJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ()+ deleteJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ()++ retryJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ()+ retryJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()++-- If no types are passed, try to get all tables dynamically and render them as BaseJobs+instance JobsDashboard '[] where++ -- | Invoked at the end of recursion+ makeDashboard = pure $ SomeView $ HtmlView [hsx|+ <script>+ function initPopover() {+ $('[data-bs-toggle="popover"]').popover({ trigger: 'hover click' })+ }+ $(document).on('ready turbolinks:load', initPopover);+ $(initPopover);+ </script>+ <style>+ .popover-body {+ background-color: #01313f;+ color: rgb(147, 161, 161);+ font-family: Monaco, Menlo, "Ubuntu Mono", Consolas, source-code-pro, monospace;+ font-size: 11px;+ }+ </style>+ |]++ includedJobTables = []++ indexPage = do+ tableNames <- getAllTableNames+ tables <- mapM buildBaseJobTable tableNames+ render $ SomeView tables+ where+ getAllTableNames = sqlQueryHasql getHasqlPool+ (Snippet.sql "SELECT table_name::text FROM information_schema.tables WHERE table_name LIKE '%_jobs'")+ (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text)))++ listJob = error "listJob: Requested job type not in JobsDashboard Type"+ listJob' _ = do+ let table = param "tableName"+ options = defaultPaginationOptions+ page = paramOrDefault 1 "page"+ pageSize = paramOrDefault (maxItems options) "maxItems"+ totalItems <- totalRecordsForTable table+ jobs <- queryBaseJobsFromTablePaginated table (page - 1) pageSize+ let pagination = Pagination { currentPage = page, totalItems, pageSize, window = windowSize options }+ render $ HtmlView $ renderBaseJobTablePaginated table jobs pagination++ viewJob = error "viewJob: Requested job type not in JobsDashboard Type"+ viewJob' _ = do+ baseJob <- queryBaseJob (param "tableName") (param "id")+ render $ HtmlView $ renderBaseJobDetailView baseJob++ newJob = error "newJob: Requested job type not in JobsDashboard Type"+ newJob' _ = do+ if requestMethod request == methodPost+ then do+ insertJob+ setSuccessMessage (columnNameToFieldLabel (param "tableName") <> " job started.")+ redirectTo ListJobsAction+ else render $ HtmlView $ renderNewBaseJobForm (param "tableName")+ where+ insertJob = do+ let tableName = param "tableName"+ sqlExecHasql getHasqlPool (Snippet.sql "INSERT INTO " <> sqlIdentifier tableName <> Snippet.sql " DEFAULT VALUES")++ deleteJob = error "deleteJob: Requested job type not in JobsDashboard Type"+ deleteJob' _ = do+ let id :: UUID = param "id"+ table :: Text = param "tableName"+ delete id table+ setSuccessMessage (columnNameToFieldLabel table <> " record deleted.")+ redirectTo ListJobsAction++ where+ delete id table = sqlExecHasql getHasqlPool+ (Snippet.sql "DELETE FROM " <> sqlIdentifier table <> Snippet.sql " WHERE id = " <> Snippet.param id)++ retryJob = error "retryJob: Requested job type not in JobsDashboard Type"+ retryJob' = do+ let id :: UUID = param "id"+ table :: Text = param "tableName"+ retryJobById table id+ setSuccessMessage (columnNameToFieldLabel table <> " record marked as 'retry'.")+ redirectTo ListJobsAction++ where+ retryJobById table id = sqlExecHasql getHasqlPool+ (Snippet.sql "UPDATE " <> sqlIdentifier table <> Snippet.sql " SET status = 'job_status_retry' WHERE id = " <> Snippet.param id)+++-- | Defines the default implementation for a dashboard of a list of job types.+-- We know the current job is a 'DisplayableJob', and we can recurse on the rest of the list to build the rest of the dashboard.+-- You probably don't want to provide custom implementations for these. Read the documentation for each of the functions if+-- you'd like to know how to customize the behavior. They mostly rely on the functions from 'DisplayableJob'.+instance {-# OVERLAPPABLE #-} (DisplayableJob job, JobsDashboard rest) => JobsDashboard (job:rest) where++ -- | Recusively create a list of views that are concatenated together as 'SomeView's to build the dashboard.+ -- To customize, override 'makeDashboardSection' for each job.+ makeDashboard = do+ section <- makeDashboardSection @job+ restSections <- SomeView <$> makeDashboard @rest+ pure $ SomeView (section : [restSections])++ -- | Recursively build list of included table names+ includedJobTables = tableName @job : includedJobTables @rest++ -- | Build the dashboard and render it.+ indexPage = do+ dashboardIncluded <- makeDashboard @(job:rest)+ notIncluded <- getNotIncludedTableNames (includedJobTables @(job:rest))+ baseJobTables <- mapM buildBaseJobTable notIncluded+ render $ dashboardIncluded : baseJobTables++ listJob table = do+ let page = fromMaybe 1 $ param "page"+ page <- makePageView @job page 25+ render page++ listJob' isFirstTime = do+ let table = param "tableName"++ when isFirstTime $ do+ notIncluded <- getNotIncludedTableNames (includedJobTables @(job:rest))+ when (table `elem` notIncluded) (listJob' @'[] False)++ if tableName @job == table+ then listJob @(job:rest) table+ else listJob' @rest False++ -- | View the detail page for the job with a given uuid.+ viewJob _ uuid = do+ let id :: Id job = unsafeCoerce uuid+ j <- fetch id+ view <- makeDetailView @job j+ render view++ -- | For a given "tableName" parameter, try and recurse over the list of types+ -- in order to find a type with the some table name as the parameter.+ -- If one is found, attempt to construct an ID from the "id" parameter,+ -- and render a page using the type's implementation of 'makeDetailView'.+ -- If you want to customize the page, override that function instead.+ viewJob' isFirstTime = do+ let table = param "tableName"++ when isFirstTime $ do+ notIncluded <- getNotIncludedTableNames (includedJobTables @(job:rest))+ when (table `elem` notIncluded) (viewJob' @'[] False)++ if tableName @job == table+ then viewJob @(job:rest) table (param "id")+ else viewJob' @rest False++ -- For POST, create a new job using the job's implementation of 'createNewJob'.+ -- To include other request data and parameters, override that function, not this one.+ -- If it's a GET request, render a new job form with the job's implementation of 'makeNewJobView'.+ -- For customizing this form, override 'makeNewJobView'.+ newJob tableName = do+ if requestMethod request == methodPost+ then do+ createNewJob @job+ setSuccessMessage (columnNameToFieldLabel tableName <> " job started.")+ redirectTo ListJobsAction+ else do+ view <- makeNewJobView @job+ render view++ -- | For a given "tableName" parameter, try and recurse over the list of types+ -- in order to find a type with the some table name as the parameter.+ -- If such a type is found, call newJob.+ newJob' isFirstTime = do+ let table = param "tableName"++ when isFirstTime $ do+ notIncluded <- getNotIncludedTableNames (includedJobTables @(job:rest))+ when (table `elem` notIncluded) (newJob' @'[] False)++ if tableName @job == table+ then newJob @(job:rest) table+ else newJob' @rest False++ -- | Delete job in 'table' with ID 'uuid'.+ deleteJob table uuid = do+ let id :: Id job = unsafeCoerce uuid+ deleteRecordById @job id+ setSuccessMessage (columnNameToFieldLabel table <> " record deleted.")+ redirectTo ListJobsAction++ -- | For a given "tableName" parameter, try and recurse over the list of types+ -- in order to find a type with the some table name as the parameter.+ -- If one is found, delete the record with the given id.+ deleteJob' isFirstTime = do+ let table = param "tableName"++ when isFirstTime $ do+ notIncluded <- getNotIncludedTableNames (includedJobTables @(job:rest))+ when (table `elem` notIncluded) (deleteJob' @'[] False)++ if tableName @job == table+ then deleteJob @(job:rest) table (param "id")+ else deleteJob' @rest False++ retryJob table uuid = do+ let id :: UUID = param "id"+ table :: Text = param "tableName"+ sqlExecHasql getHasqlPool+ (Snippet.sql "UPDATE " <> sqlIdentifier table <> Snippet.sql " SET status = 'job_status_retry' WHERE id = " <> Snippet.param id)+ setSuccessMessage (columnNameToFieldLabel table <> " record marked as 'retry'.")+ redirectTo ListJobsAction+ retryJob' = do+ let table = param "tableName"++ if tableName @job == table+ then retryJob @(job:rest) table (param "id")+ else retryJob' @rest++jobStatusDecoder :: Decoders.Value JobStatus+jobStatusDecoder = Decoders.enum (Just "public") "job_status" \case+ "job_status_not_started" -> Just JobStatusNotStarted+ "job_status_running" -> Just JobStatusRunning+ "job_status_failed" -> Just JobStatusFailed+ "job_status_timed_out" -> Just JobStatusTimedOut+ "job_status_succeeded" -> Just JobStatusSucceeded+ "job_status_retry" -> Just JobStatusRetry+ _ -> Nothing++baseJobDecoder :: Decoders.Row BaseJob+baseJobDecoder = BaseJob+ <$> Decoders.column (Decoders.nonNullable Decoders.text) -- table+ <*> Decoders.column (Decoders.nonNullable Decoders.uuid) -- id+ <*> Decoders.column (Decoders.nonNullable jobStatusDecoder) -- status+ <*> Decoders.column (Decoders.nonNullable Decoders.timestamptz) -- updatedAt+ <*> Decoders.column (Decoders.nonNullable Decoders.timestamptz) -- createdAt+ <*> Decoders.column (Decoders.nullable Decoders.text) -- lastError++getNotIncludedTableNames :: (?modelContext :: ModelContext) => [Text] -> IO [Text]+getNotIncludedTableNames includedNames = sqlQueryHasql getHasqlPool+ (Snippet.sql "SELECT table_name::text FROM information_schema.tables WHERE table_name LIKE '%_jobs' AND NOT (table_name = ANY(" <> Snippet.param includedNames <> Snippet.sql "))")+ (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text)))++buildBaseJobTable :: (?modelContext :: ModelContext, ?context :: ControllerContext, ?request :: Request) => Text -> IO SomeView+buildBaseJobTable tableName = do+ baseJobs <- sqlQueryHasql getHasqlPool+ (Snippet.sql "SELECT " <> Snippet.param tableName <> Snippet.sql ", id, status, updated_at, created_at, last_error FROM "+ <> sqlIdentifier tableName <> Snippet.sql " ORDER BY created_at DESC LIMIT 10")+ (Decoders.rowList baseJobDecoder)+ baseJobs+ |> renderBaseJobTable tableName+ |> HtmlView+ |> SomeView+ |> pure++buildBaseJob :: forall job. (DisplayableJob job) => job -> BaseJob+buildBaseJob job = BaseJob+ (tableName @job)+ (unsafeCoerce $ job.id) -- model Id type -> UUID. Pls don't use integer IDs for your jobs :)+ (job.status)+ (job.updatedAt)+ (job.createdAt)+ (job.lastError)+++-- | We can't always access the type of our job in order to use type application syntax for 'tableName'.+-- This is just a convinence function for those cases.+getTableName :: forall job. (DisplayableJob job) => job -> Text+getTableName _ = tableName @job++-- | Get the job with in the given table with the given ID as a 'BaseJob'.+queryBaseJob :: (?modelContext :: ModelContext) => Text -> UUID -> IO BaseJob+queryBaseJob table id = sqlQueryHasql getHasqlPool+ (Snippet.sql "SELECT " <> Snippet.param table <> Snippet.sql ", id, status, updated_at, created_at, last_error FROM "+ <> sqlIdentifier table <> Snippet.sql " WHERE id = " <> Snippet.param id)+ (Decoders.singleRow baseJobDecoder)++queryBaseJobsFromTablePaginated :: (?modelContext :: ModelContext) => Text -> Int -> Int -> IO [BaseJob]+queryBaseJobsFromTablePaginated table page pageSize = sqlQueryHasql getHasqlPool+ (Snippet.sql "SELECT " <> Snippet.param table <> Snippet.sql ", id, status, updated_at, created_at, last_error FROM "+ <> sqlIdentifier table <> Snippet.sql " OFFSET " <> Snippet.param (page * pageSize) <> Snippet.sql " LIMIT " <> Snippet.param pageSize)+ (Decoders.rowList baseJobDecoder)++instance (JobsDashboard jobs, AuthenticationMethod authType) => Controller (JobsDashboardController authType jobs) where+ beforeAction = authenticate @authType+ action ListJobsAction = autoRefresh $ indexPage @jobs+ action ListJobAction' = autoRefresh $ listJob' @jobs True+ action ViewJobAction' = autoRefresh $ viewJob' @jobs True+ action CreateJobAction' = newJob' @jobs True+ action DeleteJobAction' = deleteJob' @jobs True+ action RetryJobAction' = retryJob' @jobs+ action _ = error "Cannot call this action directly. Call the backtick function with no parameters instead."
+ IHP/Job/Dashboard/Auth.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{-|+Module: IHP.Job.Dashboard.Auth+Description: Authentication for Job dashboard+-}+module IHP.Job.Dashboard.Auth (+ AuthenticationMethod(..),+ NoAuth(..),+ BasicAuth(..),+ BasicAuthStatic(..),+) where++import IHP.Prelude+import IHP.ControllerPrelude+import qualified IHP.EnvVar as EnvVar++-- | Defines one method, 'authenticate', called before every action. Use to authenticate user.+--+-- Three implementations are provided:+-- - 'NoAuth' : No authentication+-- - 'BasicAuth' : HTTP Basic Auth using environment variables+-- - 'BasicAuthStatic' : HTTP Basic Auth using static values+--+-- Define your own implementation to use custom authentication for production.+class AuthenticationMethod a where+ authenticate :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Request) => IO ()++-- | Don't use any authentication for jobs.+data NoAuth++-- | Authenticate using HTTP Basic Authentication by looking up username/password values+-- in environment variables given as type-level strings.+data BasicAuth (userEnv :: Symbol) (passEnv :: Symbol)++-- | Authenticate using HTTP Basic Authentication using username/password given as type level strings.+-- Meant for development only!+data BasicAuthStatic (user :: Symbol) (pass :: Symbol)++instance AuthenticationMethod NoAuth where+ authenticate = pure ()++instance (KnownSymbol userEnv, KnownSymbol passEnv) => AuthenticationMethod (BasicAuth userEnv passEnv) where+ authenticate = do+ creds <- (,) <$> EnvVar.envOrNothing (symbolToByteString @userEnv) <*> EnvVar.envOrNothing (symbolToByteString @passEnv)+ case creds of+ (Just user, Just pass) -> basicAuth user pass "jobs"+ _ -> error "Did not find HTTP Basic Auth credentials for Jobs Dashboard."++instance (KnownSymbol user, KnownSymbol pass) => AuthenticationMethod (BasicAuthStatic user pass) where+ authenticate = basicAuth (cs $ symbolVal $ Proxy @user) (cs $ symbolVal $ Proxy @pass) "jobs"+
+ IHP/Job/Dashboard/Types.hs view
@@ -0,0 +1,106 @@+{-|+Module: IHP.Job.Dashboard.Types+Description: Types for Job dashboard+-}+{-# LANGUAGE AllowAmbiguousTypes #-}+module IHP.Job.Dashboard.Types (+ BaseJob(..),+ JobsDashboardController(..),+ TableViewable(..),+ IncludeWrapper(..),+) where++import IHP.Prelude+import IHP.ControllerPrelude+import IHP.ViewPrelude (Html)+import IHP.RouterPrelude hiding (get, tshow, error, map, putStrLn, elem)+data BaseJob = BaseJob {+ table :: Text+ , id :: UUID+ , status :: JobStatus+ , updatedAt :: UTCTime+ , createdAt :: UTCTime+ , lastError :: Maybe Text+} deriving (Show)++class TableViewable a where+ -- | Human readable title displayed on the table+ tableTitle :: Text++ -- | Database table backing the view+ modelTableName :: Text++ tableHeaders :: [Text]+ renderTableRow :: a -> Html++ -- | Link used in the table to send user to new job form+ newJobLink :: Html++ -- | Gets records for displaying in the dashboard index page+ getIndex :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO [a]++ -- | Gets paginated records for displaying in the list page+ getPage :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Int -> Int -> IO [a]+++-- | Often, jobs are related to some model type. These relations are modeled through the type system.+-- For example, the type 'Include "userId" UpdateUserJob' models an 'UpdateUserJob' type that can access+-- the 'User' it belongs to through the 'userId' field.+-- For some reason, GHC doesn't allow us to create implementations of type family applications, so the following doesn't work:+--+-- > instance DisplayableJob (Include "userId" UpdateUserJob) where+--+-- However, if we wrap this in a concrete type, it works fine. That's what this wrapper is for.+-- To get the same behavior as above, just define+--+-- > instance DisplayableJob (IncludeWrapper "userId" UpdateUserJob) where+--+-- and wrap the values as so:+--+-- > jobsWithUsers <- query @UpdateUserJob+-- > |> fetch+-- > >>= mapM (fetchRelated #userId)+-- > >>= pure . map (IncludeWrapper @"userId" @UpdateUserJob)+newtype IncludeWrapper (id :: Symbol) job = IncludeWrapper (Include id job)++-- | Defines controller actions for acting on a dashboard made of some list of types.+-- Later functions and typeclasses introduce constraints on the types in this list,+-- so you'll get a compile error if you try and include a type that is not a job.+data JobsDashboardController authType (jobs :: [Type])+ = ListJobsAction+ | ListJobAction { jobTableName :: Text, page :: Int }+ -- These actions are used for 'pathTo'. Need to pass the parameters explicity to know how to build the path+ | ViewJobAction { jobTableName :: Text, jobId :: UUID }+ | CreateJobAction { jobTableName :: Text }+ | DeleteJobAction { jobTableName :: Text, jobId :: UUID }+ | RetryJobAction { jobTableName :: Text, jobId :: UUID }++ -- These actions are used for interal routing. Parameters are extracted dynamically in the action based on types+ | ListJobAction'+ | ViewJobAction'+ | CreateJobAction'+ | DeleteJobAction'+ | RetryJobAction'+ deriving (Show, Eq, Data)+++instance HasPath (JobsDashboardController authType jobs) where+ pathTo ListJobsAction = "/jobs/ListJobs"+ pathTo ListJobAction { .. } = "/jobs/ListJob?tableName=" <> jobTableName <> "&page=" <> tshow page+ pathTo ViewJobAction { .. } = "/jobs/ViewJob?tableName=" <> jobTableName <> "&id=" <> tshow jobId+ pathTo CreateJobAction { .. } = "/jobs/CreateJob?tableName=" <> jobTableName+ pathTo DeleteJobAction { .. } = "/jobs/DeleteJob?tableName=" <> jobTableName <> "&id=" <> tshow jobId+ pathTo RetryJobAction { .. } = "/jobs/RetryJob?tableName=" <> jobTableName <> "&id=" <> tshow jobId+ pathTo _ = error "pathTo for internal JobsDashboard functions not supported. Use non-backtick action and pass necessary parameters to use pathTo."++instance CanRoute (JobsDashboardController authType jobs) where+ parseRoute' = do+ (string "/jobs" <* endOfInput >> pure ListJobsAction)+ <|> (string "/jobs/" <* endOfInput >> pure ListJobsAction)+ <|> (string "/jobs/ListJobs" <* endOfInput >> pure ListJobsAction)+ <|> (string "/jobs/ListJob" <* endOfInput >> pure ListJobAction')+ <|> (string "/jobs/ViewJob" <* endOfInput >> pure ViewJobAction')+ <|> (string "/jobs/CreateJob" <* endOfInput >> pure CreateJobAction')+ <|> (string "/jobs/DeleteJob" <* endOfInput >> pure DeleteJobAction')+ <|> (string "/jobs/RetryJob" <* endOfInput >> pure RetryJobAction')+
+ IHP/Job/Dashboard/Utils.hs view
@@ -0,0 +1,29 @@+module IHP.Job.Dashboard.Utils where++import IHP.Prelude+import IHP.ModelSupport+import qualified Hasql.Decoders as Decoders+import qualified Hasql.DynamicStatements.Snippet as Snippet+import qualified Hasql.Pool as HasqlPool+import qualified Data.Text as Text++-- | Safely quote a SQL identifier (table name) by escaping double quotes.+sqlIdentifier :: Text -> Snippet.Snippet+sqlIdentifier name = Snippet.sql ("\"" <> Text.replace "\"" "\"\"" name <> "\"")++-- | Get the hasql pool from the model context.+getHasqlPool :: (?modelContext :: ModelContext) => HasqlPool.Pool+getHasqlPool = ?modelContext.hasqlPool++numberOfPagesForTable :: (?modelContext::ModelContext) => Text -> Int -> IO Int+numberOfPagesForTable table pageSize = do+ totalRecords <- totalRecordsForTable table+ pure $ case totalRecords `quotRem` pageSize of+ (pages, 0) -> pages+ (pages, _) -> pages + 1++totalRecordsForTable :: (?modelContext :: ModelContext) => Text -> IO Int+totalRecordsForTable table =+ fromIntegral <$> sqlQueryHasql getHasqlPool+ (Snippet.sql "SELECT COUNT(*) FROM " <> sqlIdentifier table)+ (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)))
+ IHP/Job/Dashboard/View.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GADTs #-}++{-|+Module: IHP.Job.Dashboard.View+Description: Views for Job dashboard+-}+module IHP.Job.Dashboard.View where++import IHP.Prelude+import IHP.ViewPrelude (JobStatus(..), ControllerContext, Html, View, hsx, html, timeAgo)+import qualified Data.List as List+import IHP.Job.Dashboard.Types+import IHP.Job.Dashboard.Utils+import IHP.Pagination.Types+import IHP.Pagination.ViewFunctions++-- | Provides a type-erased view. This allows us to specify a view as a return type without needed+-- to know exactly what type the view will be, which in turn allows for custom implmentations of+-- almost all the view functions in this module. Go GADTs!+data SomeView where+ SomeView :: forall a. (View a) => a -> SomeView++-- | Since the only constructor for 'SomeView' requires that it is passed a 'View', we can use+-- that to implement a 'View' instance for 'SomeView'+instance View SomeView where+ html (SomeView a) = let ?view = a in IHP.ViewPrelude.html a++-- | Define how to render a list of views as a view. Just concatenate them together!+instance (View a) => View [a] where+ html [] = [hsx||]+ html (x:xs) =+ -- need to nest let's here in order to satisfy the implicit ?view parameter for 'html'.+ -- ?view needs to be the type of the view being rendered, so set it before each render+ -- here we render single view+ let ?view = x in+ let current = IHP.ViewPrelude.html x in+ -- now rendering a list view+ let ?view = xs in+ let rest = IHP.ViewPrelude.html xs in+ [hsx|{current}{rest}|]++-- | A view containing no data. Used occasionally as a default implementation for some functions.+data EmptyView = EmptyView+instance View EmptyView where+ html _ = [hsx||]++-- | A view constructed from some HTML.+newtype HtmlView = HtmlView Html+instance View HtmlView where+ html (HtmlView html) = [hsx|{html}|]++renderStatus job = case job.status of+ JobStatusNotStarted -> [hsx|<span class="badge text-bg-secondary">Not Started</span>|]+ JobStatusRunning -> [hsx|<span class="badge text-bg-primary">Running</span>|]+ JobStatusFailed -> [hsx|<span class="badge text-bg-danger" title="Last Error" data-bs-container="body" data-bs-toggle="popover" data-bs-placement="left" data-bs-content={fromMaybe "" (job.lastError)}>Failed</span>|]+ JobStatusSucceeded -> [hsx|<span class="badge text-bg-success">Succeeded</span>|]+ JobStatusRetry -> [hsx|<span class="badge text-bg-warning" title="Last Error" data-bs-container="body" data-bs-toggle="popover" data-bs-placement="left" data-bs-content={fromMaybe "" (job.lastError)}>Retry</span>|]+ JobStatusTimedOut -> [hsx|<span class="badge text-bg-danger" >Timed Out</span>|]++-- BASE JOB VIEW HELPERS --------------------------------++renderBaseJobTable :: Text -> [BaseJob] -> Html+renderBaseJobTable table rows =+ let+ headers :: [Text] = ["ID", "Updated At", "Status", "", ""]+ humanTitle = table |> columnNameToFieldLabel+ in [hsx|+ <div>+ <div class="d-flex justify-content-between align-items-center">+ <h3>{humanTitle}</h3>+ {renderNewBaseJobLink table}+ </div>+ <table class="table table-sm table-hover">+ <thead>+ <tr>+ {forEach headers renderHeader}+ </tr>+ </thead>++ <tbody>+ {forEach rows renderBaseJobTableRow}+ </tbody>+ </table>+ <a href={ListJobAction table 1} class="link-primary">See all {humanTitle}</a>+ <hr />+ </div>+|]+ where renderHeader field = [hsx|<th>{field}</th>|]++renderBaseJobTablePaginated :: Text -> [BaseJob] -> Pagination -> Html+renderBaseJobTablePaginated table jobs pagination =+ let+ headers :: [Text] = ["ID", "Updated At", "Status", "", ""]+ lastJobIndex = (List.length jobs) - 1+ in+ [hsx|+ <div>+ <div class="d-flex justify-content-between align-items-center">+ <h3>{table |> columnNameToFieldLabel}</h3>+ {renderNewBaseJobLink table}+ </div>+ <table class="table table-sm table-hover">+ <thead>+ <tr>+ {forEach headers renderHeader}+ </tr>+ </thead>++ <tbody>+ {forEach jobs renderBaseJobTableRow}+ </tbody>+ </table>+ </div>+ {renderPagination pagination}+ |]+ where+ renderHeader field = [hsx|<th>{field}</th>|]++renderBaseJobTableRow :: BaseJob -> Html+renderBaseJobTableRow job = [hsx|+ <tr>+ <td>{job.id}</td>+ <td>{job.updatedAt |> timeAgo}</td>+ <td>{renderStatus job}</td>+ <td><a href={ViewJobAction (job.table) (job.id)} class="text-primary">Show</a></td>+ <td>+ <form action={RetryJobAction (job.table) (job.id)} method="POST">+ <button type="submit" style={retryButtonStyle} class="btn btn-link text-secondary">Retry</button>+ </form>+ </td>+ </tr>+ |]++-- | Link included in table to create a new job.+renderNewBaseJobLink :: Text -> Html+renderNewBaseJobLink table =+ let+ link = "/jobs/CreateJob?tableName=" <> table+ in [hsx|+ <form action={link}>+ <button type="submit" class="btn btn-primary btn-sm">+ New Job</button>+ </form>+ |]++renderNewBaseJobForm :: Text -> Html+renderNewBaseJobForm table = [hsx|+ <br>+ <h5>New Job: {table}</h5>+ <br>+ <form action="/jobs/CreateJob" method="POST">+ <input type="hidden" id="tableName" name="tableName" value={table}>+ <button type="submit" class="btn btn-primary">New Job</button>+ </form>+|]++renderBaseJobDetailView :: BaseJob -> Html+renderBaseJobDetailView job = let table = job.table in [hsx|+ <br>+ <h5>Viewing Job {job.id} in {table |> columnNameToFieldLabel}</h5>+ <br>+ <table class="table">+ <tbody>+ <tr>+ <th>Updated At</th>+ <td>{job.updatedAt |> timeAgo} ({job.updatedAt})</td>+ </tr>+ <tr>+ <th>Created At</th>+ <td>{job.createdAt |> timeAgo} ({job.createdAt})</td>+ </tr>+ <tr>+ <th>Status</th>+ <td>{renderStatus job}</td>+ </tr>+ <tr>+ <th>Last Error</th>+ <td>{fromMaybe "No error" (job.lastError)}</td>+ </tr>+ </tbody>+ </table>++ <div class="d-flex flex-row">+ <form class="me-2" action="/jobs/DeleteJob" method="POST">+ <input type="hidden" id="tableName" name="tableName" value={table}>+ <input type="hidden" id="id" name="id" value={tshow $ job.id}>+ <button type="submit" class="btn btn-danger">Delete</button>+ </form>+ <form action="/jobs/RetryJob" method="POST">+ <input type="hidden" id="tableName" name="tableName" value={table}>+ <input type="hidden" id="id" name="id" value={tshow $ job.id}>+ <button type="submit" class="btn btn-primary">Run again</button>+ </form>+ </div>+|]+------------------------------------------------------------------++-- TABLE VIEWABLE view helpers -----------------------------------+makeDashboardSectionFromTableViewable :: forall a. (TableViewable a+ , ?context :: ControllerContext+ , ?modelContext :: ModelContext) => IO SomeView+makeDashboardSectionFromTableViewable = do+ indexRows <- getIndex @a+ pure $ SomeView $ HtmlView $ renderTableViewableTable indexRows++renderTableViewableTable :: forall a. TableViewable a => [a] -> Html+renderTableViewableTable rows = let+ headers = tableHeaders @a+ title = tableTitle @a+ link = newJobLink @a+ renderRow = renderTableRow @a+ table = modelTableName @a+ in [hsx|+ <div>+ <div class="d-flex justify-content-between align-items-center">+ <h3>{title}</h3>+ {link}+ </div>+ <table class="table table-sm table-hover">+ <thead>+ <tr>+ {forEach headers renderHeader}+ </tr>+ </thead>++ <tbody>+ {forEach rows renderRow}+ </tbody>+ </table>+ <a href={ListJobAction table 1} class="link-primary">See all {title}</a>+ <hr />+ </div>+|]+ where renderHeader field = [hsx|<th>{field}</th>|]++++makeListPageFromTableViewable :: forall a. (TableViewable a, ?context :: ControllerContext, ?modelContext :: ModelContext) => Int -> Int -> IO SomeView+makeListPageFromTableViewable page pageSize = do+ pageData <- getPage @a (page - 1) pageSize+ numPages <- numberOfPagesForTable (modelTableName @a) pageSize+ pure $ SomeView $ HtmlView $ renderTableViewableTablePaginated pageData page numPages++renderTableViewableTablePaginated :: forall a. TableViewable a => [a] -> Int -> Int -> Html+renderTableViewableTablePaginated jobs page totalPages =+ let+ title = tableTitle @a+ table = modelTableName @a+ headers = tableHeaders @a+ lastJobIndex = (List.length jobs) - 1+ newLink = newJobLink @a+ in+ [hsx|+ <div>+ <div class="d-flex justify-content-between align-items-center">+ <h3>{title}</h3>+ {newLink}+ </div>+ <table class="table table-sm table-hover">+ <thead>+ <tr>+ {forEach headers renderHeader}+ </tr>+ </thead>++ <tbody>+ {forEach jobs renderTableRow}+ </tbody>+ </table>+ </div>+ <nav aria-label="Page navigation example">+ <ul class="pagination justify-content-end">+ {renderPrev}+ {when (totalPages /= 1) renderDest}+ {renderNext}+ </ul>+ </nav>+ |]+ where+ renderHeader field = [hsx|<th>{field}</th>|]+ renderDest = let table = modelTableName @a in [hsx|<li class="page-item active"><a class="page-link" href={ListJobAction table page}>{page}</a></li>|]+ renderPrev+ | page == 1 = [hsx||]+ | otherwise = let table = modelTableName @a in [hsx|+ <li class="page-item">+ <a class="page-link" href={ListJobAction table (page - 1)} aria-label="Previous">+ <span aria-hidden="true">«</span>+ <span class="visually-hidden">Previous</span>+ </a>+ </li>+ |]+ renderNext+ | page == totalPages || totalPages == 0 = [hsx||]+ | otherwise = let table = modelTableName @a in [hsx|+ <li class="page-item">+ <a class="page-link" href={ListJobAction table (page + 1)} aria-label="Next">+ <span aria-hidden="true">»</span>+ <span class="visually-hidden">Next</span>+ </a>+ </li>+ |]+------------------------------------------------------------++retryButtonStyle :: Text+retryButtonStyle = "outline: none !important; padding: 0; border: 0; vertical-align: baseline;"
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2020 digitally induced GmbH++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ changelog.md view
@@ -0,0 +1,10 @@+# Changelog for `ihp-job-dashboard`++## v1.5.0++- Migrate from postgresql-simple to hasql+- Migrate Bootstrap 4 to Bootstrap 5 (CSS classes and data attributes)++## v1.4.0++- Initial release as a standalone package, extracted from ihp
+ ihp-job-dashboard.cabal view
@@ -0,0 +1,67 @@+cabal-version: 2.2+name: ihp-job-dashboard+version: 1.5.0+synopsis: Dashboard for IHP job runners+description: Web-based dashboard for monitoring IHP background job runners+license: MIT+license-file: LICENSE+author: digitally induced GmbH+maintainer: hello@digitallyinduced.com+homepage: https://ihp.digitallyinduced.com/+bug-reports: https://github.com/digitallyinduced/ihp/issues+copyright: (c) digitally induced GmbH+category: Web, IHP+stability: Stable+tested-with: GHC == 9.8.4+build-type: Simple+extra-source-files: changelog.md++library+ default-language: GHC2021+ ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields+ build-depends:+ base >= 4.17.0 && < 4.22+ , wai+ , mtl+ , blaze-html+ , blaze-markup+ , ihp+ , ihp-hsx+ , http-types+ , wai-request-params+ , hasql-implicits+ , hasql+ , hasql-dynamic-statements+ , hasql-pool+ , text+ default-extensions:+ OverloadedStrings+ , NoImplicitPrelude+ , ImplicitParams+ , DisambiguateRecordFields+ , DuplicateRecordFields+ , OverloadedLabels+ , DataKinds+ , QuasiQuotes+ , TypeFamilies+ , PackageImports+ , RecordWildCards+ , DefaultSignatures+ , FunctionalDependencies+ , PartialTypeSignatures+ , BlockArguments+ , LambdaCase+ , TemplateHaskell+ , OverloadedRecordDot+ , DeepSubsumption+ hs-source-dirs: .+ exposed-modules:+ IHP.Job.Dashboard+ , IHP.Job.Dashboard.Types+ , IHP.Job.Dashboard.Auth+ , IHP.Job.Dashboard.View+ , IHP.Job.Dashboard.Utils++source-repository head+ type: git+ location: https://github.com/digitallyinduced/ihp