diff options
Diffstat (limited to 'Omni/Jr/Web.hs')
| -rw-r--r-- | Omni/Jr/Web.hs | 169 |
1 files changed, 112 insertions, 57 deletions
diff --git a/Omni/Jr/Web.hs b/Omni/Jr/Web.hs index 17849f4..3c24d71 100644 --- a/Omni/Jr/Web.hs +++ b/Omni/Jr/Web.hs @@ -58,13 +58,19 @@ type API = :> QueryParam "namespace" Text :> Get '[Lucid.HTML] TaskListPage :<|> "tasks" :> Capture "id" Text :> Get '[Lucid.HTML] TaskDetailPage - :<|> "tasks" :> Capture "id" Text :> "status" :> ReqBody '[FormUrlEncoded] StatusForm :> PostRedirect + :<|> "tasks" :> Capture "id" Text :> "status" :> ReqBody '[FormUrlEncoded] StatusForm :> Post '[Lucid.HTML] StatusBadgePartial :<|> "tasks" :> Capture "id" Text :> "description" :> ReqBody '[FormUrlEncoded] DescriptionForm :> PostRedirect :<|> "tasks" :> Capture "id" Text :> "review" :> Get '[Lucid.HTML] TaskReviewPage :<|> "tasks" :> Capture "id" Text :> "accept" :> PostRedirect :<|> "tasks" :> Capture "id" Text :> "reject" :> ReqBody '[FormUrlEncoded] RejectForm :> PostRedirect :<|> "partials" :> "recent-activity" :> Get '[Lucid.HTML] RecentActivityPartial :<|> "partials" :> "ready-count" :> Get '[Lucid.HTML] ReadyCountPartial + :<|> "partials" + :> "task-list" + :> QueryParam "status" Text + :> QueryParam "priority" Text + :> QueryParam "namespace" Text + :> Get '[Lucid.HTML] TaskListPartial data CSS @@ -103,6 +109,10 @@ newtype RecentActivityPartial = RecentActivityPartial [TaskCore.Task] newtype ReadyCountPartial = ReadyCountPartial Int +data StatusBadgePartial = StatusBadgePartial TaskCore.Status Text + +newtype TaskListPartial = TaskListPartial [TaskCore.Task] + newtype RejectForm = RejectForm (Maybe Text) instance FromForm RejectForm where @@ -163,6 +173,29 @@ statusBadge status = TaskCore.Done -> ("badge badge-done", "Done") in Lucid.span_ [Lucid.class_ cls] label +statusBadgeWithForm :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m () +statusBadgeWithForm status tid = + Lucid.div_ [Lucid.id_ "status-badge-container", Lucid.class_ "status-badge-container"] <| do + statusBadge status + Lucid.select_ + [ Lucid.name_ "status", + Lucid.class_ "status-select-inline", + Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/status"), + Lucid.makeAttribute "hx-target" "#status-badge-container", + Lucid.makeAttribute "hx-swap" "outerHTML" + ] + <| do + statusOptionHtmx TaskCore.Open status + statusOptionHtmx TaskCore.InProgress status + statusOptionHtmx TaskCore.Review status + statusOptionHtmx TaskCore.Approved status + statusOptionHtmx TaskCore.Done status + where + statusOptionHtmx :: (Monad m2) => TaskCore.Status -> TaskCore.Status -> Lucid.HtmlT m2 () + statusOptionHtmx opt current = + let attrs = [Lucid.value_ (tshow opt)] <> [Lucid.selected_ "selected" | opt == current] + in Lucid.option_ attrs (Lucid.toHtml (tshow opt)) + renderTaskCard :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m () renderTaskCard t = Lucid.a_ @@ -287,45 +320,61 @@ instance Lucid.ToHtml TaskListPage where Lucid.h1_ <| Lucid.toHtml ("Tasks (" <> tshow (length tasks) <> ")") Lucid.div_ [Lucid.class_ "filter-form"] <| do - Lucid.form_ [Lucid.method_ "GET", Lucid.action_ "/tasks"] <| do - Lucid.div_ [Lucid.class_ "filter-row"] <| do - Lucid.div_ [Lucid.class_ "filter-group"] <| do - Lucid.label_ [Lucid.for_ "status"] "Status:" - Lucid.select_ [Lucid.name_ "status", Lucid.id_ "status", Lucid.class_ "filter-select"] <| do - Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterStatus filters)) "All" - statusFilterOption TaskCore.Open (filterStatus filters) - statusFilterOption TaskCore.InProgress (filterStatus filters) - statusFilterOption TaskCore.Review (filterStatus filters) - statusFilterOption TaskCore.Approved (filterStatus filters) - statusFilterOption TaskCore.Done (filterStatus filters) - - Lucid.div_ [Lucid.class_ "filter-group"] <| do - Lucid.label_ [Lucid.for_ "priority"] "Priority:" - Lucid.select_ [Lucid.name_ "priority", Lucid.id_ "priority", Lucid.class_ "filter-select"] <| do - Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterPriority filters)) "All" - priorityFilterOption TaskCore.P0 (filterPriority filters) - priorityFilterOption TaskCore.P1 (filterPriority filters) - priorityFilterOption TaskCore.P2 (filterPriority filters) - priorityFilterOption TaskCore.P3 (filterPriority filters) - priorityFilterOption TaskCore.P4 (filterPriority filters) - - Lucid.div_ [Lucid.class_ "filter-group"] <| do - Lucid.label_ [Lucid.for_ "namespace"] "Namespace:" - Lucid.input_ - [ Lucid.type_ "text", - Lucid.name_ "namespace", - Lucid.id_ "namespace", - Lucid.class_ "filter-input", - Lucid.placeholder_ "e.g. Omni/Jr", - Lucid.value_ (fromMaybe "" (filterNamespace filters)) - ] + Lucid.form_ + [ Lucid.method_ "GET", + Lucid.action_ "/tasks", + Lucid.makeAttribute "hx-get" "/partials/task-list", + Lucid.makeAttribute "hx-target" "#task-list", + Lucid.makeAttribute "hx-push-url" "/tasks", + Lucid.makeAttribute "hx-trigger" "submit, change from:select" + ] + <| do + Lucid.div_ [Lucid.class_ "filter-row"] <| do + Lucid.div_ [Lucid.class_ "filter-group"] <| do + Lucid.label_ [Lucid.for_ "status"] "Status:" + Lucid.select_ [Lucid.name_ "status", Lucid.id_ "status", Lucid.class_ "filter-select"] <| do + Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterStatus filters)) "All" + statusFilterOption TaskCore.Open (filterStatus filters) + statusFilterOption TaskCore.InProgress (filterStatus filters) + statusFilterOption TaskCore.Review (filterStatus filters) + statusFilterOption TaskCore.Approved (filterStatus filters) + statusFilterOption TaskCore.Done (filterStatus filters) + + Lucid.div_ [Lucid.class_ "filter-group"] <| do + Lucid.label_ [Lucid.for_ "priority"] "Priority:" + Lucid.select_ [Lucid.name_ "priority", Lucid.id_ "priority", Lucid.class_ "filter-select"] <| do + Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterPriority filters)) "All" + priorityFilterOption TaskCore.P0 (filterPriority filters) + priorityFilterOption TaskCore.P1 (filterPriority filters) + priorityFilterOption TaskCore.P2 (filterPriority filters) + priorityFilterOption TaskCore.P3 (filterPriority filters) + priorityFilterOption TaskCore.P4 (filterPriority filters) + + Lucid.div_ [Lucid.class_ "filter-group"] <| do + Lucid.label_ [Lucid.for_ "namespace"] "Namespace:" + Lucid.input_ + [ Lucid.type_ "text", + Lucid.name_ "namespace", + Lucid.id_ "namespace", + Lucid.class_ "filter-input", + Lucid.placeholder_ "e.g. Omni/Jr", + Lucid.value_ (fromMaybe "" (filterNamespace filters)) + ] - Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter" - Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "clear-btn"] "Clear" + Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter" + Lucid.a_ + [ Lucid.href_ "/tasks", + Lucid.class_ "clear-btn", + Lucid.makeAttribute "hx-get" "/partials/task-list", + Lucid.makeAttribute "hx-target" "#task-list", + Lucid.makeAttribute "hx-push-url" "/tasks" + ] + "Clear" - if null tasks - then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters." - else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks + Lucid.div_ [Lucid.id_ "task-list"] <| do + if null tasks + then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters." + else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks where maybeSelected :: (Eq a) => Maybe a -> Maybe a -> [Lucid.Attribute] maybeSelected opt current = [Lucid.selected_ "selected" | opt == current] @@ -372,7 +421,7 @@ instance Lucid.ToHtml TaskDetailPage where Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "Status:" - Lucid.span_ [Lucid.class_ "detail-value"] <| statusBadge (TaskCore.taskStatus task) + Lucid.span_ [Lucid.class_ "detail-value"] <| statusBadgeWithForm (TaskCore.taskStatus task) (TaskCore.taskId task) Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "Priority:" @@ -456,17 +505,6 @@ instance Lucid.ToHtml TaskDetailPage where Lucid.class_ "review-link-btn" ] "Review This Task" - - Lucid.div_ [Lucid.class_ "status-form"] <| do - Lucid.h3_ "Update Status" - Lucid.form_ [Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/status")] <| do - Lucid.select_ [Lucid.name_ "status", Lucid.class_ "status-select"] <| do - statusOption TaskCore.Open (TaskCore.taskStatus task) - statusOption TaskCore.InProgress (TaskCore.taskStatus task) - statusOption TaskCore.Review (TaskCore.taskStatus task) - statusOption TaskCore.Approved (TaskCore.taskStatus task) - statusOption TaskCore.Done (TaskCore.taskStatus task) - Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "submit-btn"] "Submit" where priorityDesc :: TaskCore.Priority -> Text priorityDesc p = case p of @@ -476,11 +514,6 @@ instance Lucid.ToHtml TaskDetailPage where TaskCore.P3 -> " (Low)" TaskCore.P4 -> " (Backlog)" - statusOption :: (Monad m) => TaskCore.Status -> TaskCore.Status -> Lucid.HtmlT m () - statusOption opt current = - let attrs = [Lucid.value_ (tshow opt)] <> [Lucid.selected_ "selected" | opt == current] - in Lucid.option_ attrs (Lucid.toHtml (tshow opt)) - renderDependency :: (Monad m) => TaskCore.Dependency -> Lucid.HtmlT m () renderDependency dep = Lucid.li_ <| do @@ -727,6 +760,18 @@ instance Lucid.ToHtml ReadyCountPartial where Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "ready-link"] <| Lucid.toHtml ("(" <> tshow count <> " tasks)") +instance Lucid.ToHtml StatusBadgePartial where + toHtmlRaw = Lucid.toHtml + toHtml (StatusBadgePartial status tid) = + statusBadgeWithForm status tid + +instance Lucid.ToHtml TaskListPartial where + toHtmlRaw = Lucid.toHtml + toHtml (TaskListPartial tasks) = + if null tasks + then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters." + else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks + -- | Simple markdown renderer for epic descriptions -- Supports: headers (#, ##, ###), lists (- or *), code blocks (```), inline code (`) renderMarkdown :: (Monad m) => Text -> Lucid.HtmlT m () @@ -858,6 +903,7 @@ server = :<|> taskRejectHandler :<|> recentActivityHandler :<|> readyCountHandler + :<|> taskListPartialHandler where styleHandler :: Servant.Handler LazyText.Text styleHandler = pure Style.css @@ -944,10 +990,10 @@ server = activities <- liftIO (TaskCore.getActivitiesForTask tid) pure (TaskDetailFound task tasks activities) - taskStatusHandler :: Text -> StatusForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent) + taskStatusHandler :: Text -> StatusForm -> Servant.Handler StatusBadgePartial taskStatusHandler tid (StatusForm newStatus) = do liftIO <| TaskCore.updateTaskStatus tid newStatus [] - pure <| addHeader ("/tasks/" <> tid) NoContent + pure (StatusBadgePartial newStatus tid) taskDescriptionHandler :: Text -> DescriptionForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent) taskDescriptionHandler tid (DescriptionForm desc) = do @@ -1001,6 +1047,15 @@ server = readyTasks <- liftIO TaskCore.getReadyTasks pure (ReadyCountPartial (length readyTasks)) + taskListPartialHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPartial + taskListPartialHandler maybeStatusText maybePriorityText maybeNamespace = do + allTasks <- liftIO TaskCore.loadTasks + let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText + maybePriority = parsePriority =<< emptyToNothing maybePriorityText + filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) + filteredTasks = applyFilters filters allTasks + pure (TaskListPartial filteredTasks) + getReviewInfo :: Text -> IO ReviewInfo getReviewInfo tid = do maybeCommit <- findCommitForTask tid |