{-# 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|Not Started|] JobStatusRunning -> [hsx|Running|] JobStatusFailed -> [hsx|Failed|] JobStatusSucceeded -> [hsx|Succeeded|] JobStatusRetry -> [hsx|Retry|] JobStatusTimedOut -> [hsx|Timed Out|] -- BASE JOB VIEW HELPERS -------------------------------- renderBaseJobTable :: Text -> [BaseJob] -> Html renderBaseJobTable table rows = let headers :: [Text] = ["ID", "Updated At", "Status", "", ""] humanTitle = table |> columnNameToFieldLabel in [hsx|

{humanTitle}

{renderNewBaseJobLink table}
{forEach headers renderHeader} {forEach rows renderBaseJobTableRow}
See all {humanTitle}
|] where renderHeader field = [hsx|{field}|] renderBaseJobTablePaginated :: Text -> [BaseJob] -> Pagination -> Html renderBaseJobTablePaginated table jobs pagination = let headers :: [Text] = ["ID", "Updated At", "Status", "", ""] lastJobIndex = (List.length jobs) - 1 in [hsx|

{table |> columnNameToFieldLabel}

{renderNewBaseJobLink table}
{forEach headers renderHeader} {forEach jobs renderBaseJobTableRow}
{renderPagination pagination} |] where renderHeader field = [hsx|{field}|] renderBaseJobTableRow :: BaseJob -> Html renderBaseJobTableRow job = [hsx| {job.id} {job.updatedAt |> timeAgo} {renderStatus job} Show
|] -- | Link included in table to create a new job. renderNewBaseJobLink :: Text -> Html renderNewBaseJobLink table = let link = "/jobs/CreateJob?tableName=" <> table in [hsx|
|] renderNewBaseJobForm :: Text -> Html renderNewBaseJobForm table = [hsx|
New Job: {table}

|] renderBaseJobDetailView :: BaseJob -> Html renderBaseJobDetailView job = let table = job.table in [hsx|
Viewing Job {job.id} in {table |> columnNameToFieldLabel}

Updated At {job.updatedAt |> timeAgo} ({job.updatedAt})
Created At {job.createdAt |> timeAgo} ({job.createdAt})
Status {renderStatus job}
Last Error {fromMaybe "No error" (job.lastError)}
|] ------------------------------------------------------------------ -- 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|

{title}

{link}
{forEach headers renderHeader} {forEach rows renderRow}
See all {title}
|] where renderHeader field = [hsx|{field}|] 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|

{title}

{newLink}
{forEach headers renderHeader} {forEach jobs renderTableRow}
|] where renderHeader field = [hsx|{field}|] renderDest = let table = modelTableName @a in [hsx|
  • {page}
  • |] renderPrev | page == 1 = [hsx||] | otherwise = let table = modelTableName @a in [hsx|
  • Previous
  • |] renderNext | page == totalPages || totalPages == 0 = [hsx||] | otherwise = let table = modelTableName @a in [hsx|
  • Next
  • |] ------------------------------------------------------------ retryButtonStyle :: Text retryButtonStyle = "outline: none !important; padding: 0; border: 0; vertical-align: baseline;"