{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-} -- : dep warp -- : dep servant-server -- : dep lucid -- : dep servant-lucid -- : dep http-api-data -- : dep process module Omni.Jr.Web ( run, defaultPort, ) where import Alpha import qualified Data.List as List import qualified Data.Text as Text import qualified Lucid import qualified Network.Wai.Handler.Warp as Warp import qualified Omni.Task.Core as TaskCore import Servant import qualified Servant.HTML.Lucid as Lucid import qualified System.Exit as Exit import qualified System.Process as Process import Web.FormUrlEncoded (FromForm (..), lookupUnique, parseUnique) type PostRedirect = Verb 'POST 303 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent) defaultPort :: Warp.Port defaultPort = 8080 data TaskFilters = TaskFilters { filterStatus :: Maybe TaskCore.Status, filterPriority :: Maybe TaskCore.Priority, filterNamespace :: Maybe Text } deriving (Show, Eq) type API = Get '[Lucid.HTML] HomePage :<|> "ready" :> Get '[Lucid.HTML] ReadyQueuePage :<|> "tasks" :> QueryParam "status" TaskCore.Status :> QueryParam "priority" TaskCore.Priority :> 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 :> "review" :> Get '[Lucid.HTML] TaskReviewPage :<|> "tasks" :> Capture "id" Text :> "accept" :> PostRedirect :<|> "tasks" :> Capture "id" Text :> "reject" :> ReqBody '[FormUrlEncoded] RejectForm :> PostRedirect data HomePage = HomePage TaskCore.TaskStats [TaskCore.Task] [TaskCore.Task] newtype ReadyQueuePage = ReadyQueuePage [TaskCore.Task] data TaskListPage = TaskListPage [TaskCore.Task] TaskFilters data TaskDetailPage = TaskDetailFound TaskCore.Task [TaskCore.Task] | TaskDetailNotFound Text data TaskReviewPage = ReviewPageFound TaskCore.Task ReviewInfo | ReviewPageNotFound Text data ReviewInfo = ReviewNoCommit | ReviewMergeConflict Text [Text] | ReviewReady Text Text newtype RejectForm = RejectForm (Maybe Text) instance FromForm RejectForm where fromForm form = Right (RejectForm (either (const Nothing) Just (lookupUnique "notes" form))) newtype StatusForm = StatusForm TaskCore.Status instance FromForm StatusForm where fromForm form = do statusText <- parseUnique "status" form case readMaybe (Text.unpack statusText) of Just s -> Right (StatusForm s) Nothing -> Left "Invalid status" instance Lucid.ToHtml HomePage where toHtmlRaw = Lucid.toHtml toHtml (HomePage stats readyTasks recentTasks) = Lucid.doctypehtml_ <| do Lucid.head_ <| do Lucid.title_ "Jr Dashboard" Lucid.meta_ [Lucid.charset_ "utf-8"] Lucid.meta_ [ Lucid.name_ "viewport", Lucid.content_ "width=device-width, initial-scale=1" ] Lucid.style_ homeStyles Lucid.body_ <| do Lucid.h1_ "Jr Dashboard" Lucid.div_ [Lucid.class_ "actions"] <| do Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "action-btn"] "View All Tasks" Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "action-btn action-btn-primary"] "View Ready Queue" Lucid.h2_ "Task Status" Lucid.div_ [Lucid.class_ "stats-grid"] <| do statCard "Open" (TaskCore.openTasks stats) "badge-open" statCard "In Progress" (TaskCore.inProgressTasks stats) "badge-inprogress" statCard "Review" (TaskCore.reviewTasks stats) "badge-review" statCard "Approved" (TaskCore.approvedTasks stats) "badge-approved" statCard "Done" (TaskCore.doneTasks stats) "badge-done" Lucid.h2_ <| do "Ready Queue " Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "ready-link"] <| Lucid.toHtml ("(" <> tshow (length readyTasks) <> " tasks)") if null readyTasks then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks ready for work." else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (take 5 readyTasks) Lucid.h2_ "Recent Activity" if null recentTasks then Lucid.p_ [Lucid.class_ "empty-msg"] "No recent tasks." else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard recentTasks where statCard :: (Monad m) => Text -> Int -> Text -> Lucid.HtmlT m () statCard label count badgeClass = Lucid.div_ [Lucid.class_ ("stat-card " <> badgeClass)] <| do Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml (tshow count)) Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label) renderTaskCard :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m () renderTaskCard t = Lucid.div_ [Lucid.class_ "task-card"] <| do Lucid.div_ [Lucid.class_ "task-header"] <| do Lucid.a_ [ Lucid.class_ "task-id", Lucid.href_ ("/tasks/" <> TaskCore.taskId t) ] (Lucid.toHtml (TaskCore.taskId t)) statusBadge (TaskCore.taskStatus t) Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t)) statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m () statusBadge status = let (cls, label) = case status of TaskCore.Open -> ("badge badge-open", "Open") TaskCore.InProgress -> ("badge badge-inprogress", "In Progress") TaskCore.Review -> ("badge badge-review", "Review") TaskCore.Approved -> ("badge badge-approved", "Approved") TaskCore.Done -> ("badge badge-done", "Done") in Lucid.span_ [Lucid.class_ cls] label homeStyles :: Text homeStyles = "* { box-sizing: border-box; } \ \body { font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif; \ \ margin: 0; padding: 16px; background: #f5f5f5; max-width: 900px; } \ \h1 { margin: 0 0 16px 0; } \ \h2 { margin: 24px 0 12px 0; color: #374151; font-size: 18px; } \ \.actions { display: flex; flex-wrap: wrap; gap: 8px; margin-bottom: 16px; } \ \.action-btn { display: inline-block; padding: 10px 16px; background: white; \ \ border: 1px solid #d1d5db; border-radius: 6px; color: #374151; \ \ text-decoration: none; font-size: 14px; font-weight: 500; } \ \.action-btn:hover { background: #f9fafb; } \ \.action-btn-primary { background: #0066cc; color: white; border-color: #0066cc; } \ \.action-btn-primary:hover { background: #0052a3; } \ \.stats-grid { display: grid; grid-template-columns: repeat(auto-fit, minmax(100px, 1fr)); gap: 12px; } \ \.stat-card { background: white; border-radius: 8px; padding: 16px; text-align: center; \ \ box-shadow: 0 1px 3px rgba(0,0,0,0.1); } \ \.stat-count { font-size: 28px; font-weight: 700; } \ \.stat-label { font-size: 12px; color: #6b7280; margin-top: 4px; } \ \.stat-card.badge-open { border-left: 4px solid #f59e0b; } \ \.stat-card.badge-open .stat-count { color: #92400e; } \ \.stat-card.badge-inprogress { border-left: 4px solid #3b82f6; } \ \.stat-card.badge-inprogress .stat-count { color: #1e40af; } \ \.stat-card.badge-review { border-left: 4px solid #8b5cf6; } \ \.stat-card.badge-review .stat-count { color: #6b21a8; } \ \.stat-card.badge-approved { border-left: 4px solid #10b981; } \ \.stat-card.badge-approved .stat-count { color: #065f46; } \ \.stat-card.badge-done { border-left: 4px solid #10b981; } \ \.stat-card.badge-done .stat-count { color: #065f46; } \ \.ready-link { font-size: 14px; color: #0066cc; text-decoration: none; } \ \.ready-link:hover { text-decoration: underline; } \ \.empty-msg { color: #6b7280; font-style: italic; } \ \.task-list { display: flex; flex-direction: column; gap: 8px; } \ \.task-card { background: white; border-radius: 8px; padding: 16px; \ \ box-shadow: 0 1px 3px rgba(0,0,0,0.1); } \ \.task-header { display: flex; flex-wrap: wrap; align-items: center; gap: 8px; margin-bottom: 8px; } \ \.task-id { font-family: monospace; color: #0066cc; text-decoration: none; \ \ font-size: 14px; padding: 4px 0; } \ \.task-id:hover { text-decoration: underline; } \ \.badge { display: inline-block; padding: 4px 8px; border-radius: 4px; \ \ font-size: 12px; font-weight: 500; } \ \.badge-open { background: #fef3c7; color: #92400e; } \ \.badge-inprogress { background: #dbeafe; color: #1e40af; } \ \.badge-review { background: #ede9fe; color: #6b21a8; } \ \.badge-approved { background: #d1fae5; color: #065f46; } \ \.badge-done { background: #d1fae5; color: #065f46; } \ \.priority { font-size: 12px; color: #6b7280; } \ \.task-title { font-size: 16px; margin: 0; }" instance Lucid.ToHtml ReadyQueuePage where toHtmlRaw = Lucid.toHtml toHtml (ReadyQueuePage tasks) = Lucid.doctypehtml_ <| do Lucid.head_ <| do Lucid.title_ "Ready Queue - Jr Web UI" Lucid.meta_ [Lucid.charset_ "utf-8"] Lucid.meta_ [ Lucid.name_ "viewport", Lucid.content_ "width=device-width, initial-scale=1" ] Lucid.style_ readyStyles Lucid.body_ <| do Lucid.p_ <| Lucid.a_ [Lucid.href_ "/"] "← Back to Dashboard" Lucid.h1_ <| Lucid.toHtml ("Ready Queue (" <> tshow (length tasks) <> " tasks)") if null tasks then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks are ready for work." else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTask tasks where readyStyles :: Text readyStyles = "* { box-sizing: border-box; } \ \body { font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif; \ \ margin: 0; padding: 16px; background: #f5f5f5; max-width: 900px; } \ \h1 { margin: 16px 0; } \ \.count-badge { background: #0066cc; color: white; padding: 4px 10px; \ \ border-radius: 12px; font-size: 14px; vertical-align: middle; } \ \.empty-msg { color: #6b7280; font-style: italic; } \ \.task-list { display: flex; flex-direction: column; gap: 8px; } \ \.task-card { background: white; border-radius: 8px; padding: 16px; \ \ box-shadow: 0 1px 3px rgba(0,0,0,0.1); } \ \.task-header { display: flex; flex-wrap: wrap; align-items: center; gap: 8px; margin-bottom: 8px; } \ \.task-id { font-family: monospace; color: #0066cc; text-decoration: none; \ \ font-size: 14px; padding: 4px 0; } \ \.task-id:hover { text-decoration: underline; } \ \.badge { display: inline-block; padding: 4px 8px; border-radius: 4px; \ \ font-size: 12px; font-weight: 500; } \ \.badge-open { background: #fef3c7; color: #92400e; } \ \.badge-inprogress { background: #dbeafe; color: #1e40af; } \ \.badge-review { background: #ede9fe; color: #6b21a8; } \ \.badge-approved { background: #d1fae5; color: #065f46; } \ \.badge-done { background: #d1fae5; color: #065f46; } \ \.priority { font-size: 12px; color: #6b7280; } \ \.task-title { font-size: 16px; margin: 0; }" renderTask :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m () renderTask t = Lucid.div_ [Lucid.class_ "task-card"] <| do Lucid.div_ [Lucid.class_ "task-header"] <| do Lucid.a_ [ Lucid.class_ "task-id", Lucid.href_ ("/tasks/" <> TaskCore.taskId t) ] (Lucid.toHtml (TaskCore.taskId t)) statusBadge (TaskCore.taskStatus t) Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t)) statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m () statusBadge status = let (cls, label) = case status of TaskCore.Open -> ("badge badge-open", "Open") TaskCore.InProgress -> ("badge badge-inprogress", "In Progress") TaskCore.Review -> ("badge badge-review", "Review") TaskCore.Approved -> ("badge badge-approved", "Approved") TaskCore.Done -> ("badge badge-done", "Done") in Lucid.span_ [Lucid.class_ cls] label instance Lucid.ToHtml TaskListPage where toHtmlRaw = Lucid.toHtml toHtml (TaskListPage tasks filters) = Lucid.doctypehtml_ <| do Lucid.head_ <| do Lucid.title_ "Tasks - Jr Web UI" Lucid.meta_ [Lucid.charset_ "utf-8"] Lucid.meta_ [ Lucid.name_ "viewport", Lucid.content_ "width=device-width, initial-scale=1" ] Lucid.style_ styles Lucid.body_ <| do Lucid.p_ <| Lucid.a_ [Lucid.href_ "/"] "← Back to Dashboard" 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.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter" Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "clear-btn"] "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_ renderTask tasks where maybeSelected :: (Eq a) => Maybe a -> Maybe a -> [Lucid.Attribute] maybeSelected opt current = [Lucid.selected_ "selected" | opt == current] statusFilterOption :: (Monad m) => TaskCore.Status -> Maybe TaskCore.Status -> Lucid.HtmlT m () statusFilterOption s current = let attrs = [Lucid.value_ (tshow s)] <> [Lucid.selected_ "selected" | Just s == current] in Lucid.option_ attrs (Lucid.toHtml (tshow s)) priorityFilterOption :: (Monad m) => TaskCore.Priority -> Maybe TaskCore.Priority -> Lucid.HtmlT m () priorityFilterOption p current = let attrs = [Lucid.value_ (tshow p)] <> [Lucid.selected_ "selected" | Just p == current] in Lucid.option_ attrs (Lucid.toHtml (tshow p)) styles :: Text styles = "* { box-sizing: border-box; } \ \body { font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif; \ \ margin: 0; padding: 16px; background: #f5f5f5; max-width: 900px; } \ \h1 { margin: 16px 0; } \ \.filter-form { background: white; border-radius: 8px; padding: 16px; \ \ box-shadow: 0 1px 3px rgba(0,0,0,0.1); margin-bottom: 16px; } \ \.filter-row { display: flex; flex-wrap: wrap; gap: 12px; align-items: flex-end; } \ \.filter-group { display: flex; flex-direction: column; gap: 4px; } \ \.filter-group label { font-size: 12px; color: #6b7280; font-weight: 500; } \ \.filter-select, .filter-input { padding: 8px 12px; border: 1px solid #d1d5db; border-radius: 4px; \ \ font-size: 14px; min-width: 120px; } \ \.filter-input { min-width: 150px; } \ \.filter-btn { padding: 8px 16px; background: #0066cc; color: white; border: none; \ \ border-radius: 4px; font-size: 14px; cursor: pointer; } \ \.filter-btn:hover { background: #0052a3; } \ \.clear-btn { padding: 8px 16px; background: #6b7280; color: white; border: none; \ \ border-radius: 4px; font-size: 14px; cursor: pointer; text-decoration: none; } \ \.clear-btn:hover { background: #4b5563; } \ \.empty-msg { color: #6b7280; font-style: italic; } \ \.task-list { display: flex; flex-direction: column; gap: 8px; } \ \.task-card { background: white; border-radius: 8px; padding: 16px; \ \ box-shadow: 0 1px 3px rgba(0,0,0,0.1); } \ \.task-header { display: flex; flex-wrap: wrap; align-items: center; gap: 8px; margin-bottom: 8px; } \ \.task-id { font-family: monospace; color: #0066cc; text-decoration: none; \ \ font-size: 14px; padding: 4px 0; } \ \.task-id:hover { text-decoration: underline; } \ \.badge { display: inline-block; padding: 4px 8px; border-radius: 4px; \ \ font-size: 12px; font-weight: 500; } \ \.badge-open { background: #fef3c7; color: #92400e; } \ \.badge-inprogress { background: #dbeafe; color: #1e40af; } \ \.badge-review { background: #ede9fe; color: #6b21a8; } \ \.badge-approved { background: #d1fae5; color: #065f46; } \ \.badge-done { background: #d1fae5; color: #065f46; } \ \.priority { font-size: 12px; color: #6b7280; } \ \.task-title { font-size: 16px; margin: 0; }" renderTask :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m () renderTask t = Lucid.div_ [Lucid.class_ "task-card"] <| do Lucid.div_ [Lucid.class_ "task-header"] <| do Lucid.a_ [ Lucid.class_ "task-id", Lucid.href_ ("/tasks/" <> TaskCore.taskId t) ] (Lucid.toHtml (TaskCore.taskId t)) statusBadge (TaskCore.taskStatus t) Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t)) statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m () statusBadge status = let (cls, label) = case status of TaskCore.Open -> ("badge badge-open", "Open") TaskCore.InProgress -> ("badge badge-inprogress", "In Progress") TaskCore.Review -> ("badge badge-review", "Review") TaskCore.Approved -> ("badge badge-approved", "Approved") TaskCore.Done -> ("badge badge-done", "Done") in Lucid.span_ [Lucid.class_ cls] label instance Lucid.ToHtml TaskDetailPage where toHtmlRaw = Lucid.toHtml toHtml (TaskDetailNotFound tid) = Lucid.doctypehtml_ <| do Lucid.head_ <| do Lucid.title_ "Task Not Found - Jr Web UI" Lucid.meta_ [Lucid.charset_ "utf-8"] Lucid.meta_ [ Lucid.name_ "viewport", Lucid.content_ "width=device-width, initial-scale=1" ] Lucid.style_ detailStyles Lucid.body_ <| do Lucid.h1_ "Task Not Found" Lucid.p_ <| do "The task " Lucid.code_ (Lucid.toHtml tid) " could not be found." Lucid.p_ <| Lucid.a_ [Lucid.href_ "/tasks"] "← Back to Tasks" toHtml (TaskDetailFound task allTasks) = Lucid.doctypehtml_ <| do Lucid.head_ <| do Lucid.title_ <| Lucid.toHtml (TaskCore.taskId task <> " - Jr Web UI") Lucid.meta_ [Lucid.charset_ "utf-8"] Lucid.meta_ [ Lucid.name_ "viewport", Lucid.content_ "width=device-width, initial-scale=1" ] Lucid.style_ detailStyles Lucid.body_ <| do Lucid.p_ <| Lucid.a_ [Lucid.href_ "/tasks"] "← Back to Tasks" Lucid.h1_ <| Lucid.toHtml (TaskCore.taskTitle task) Lucid.div_ [Lucid.class_ "task-detail"] <| do Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "ID:" Lucid.code_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskId task)) Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "Type:" Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.taskType task))) 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.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "Priority:" Lucid.span_ [Lucid.class_ "detail-value"] <| do Lucid.toHtml (tshow (TaskCore.taskPriority task)) Lucid.span_ [Lucid.class_ "priority-desc"] (Lucid.toHtml (priorityDesc (TaskCore.taskPriority task))) case TaskCore.taskNamespace task of Nothing -> pure () Just ns -> Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "Namespace:" Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml ns) case TaskCore.taskParent task of Nothing -> pure () Just pid -> Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "Parent:" Lucid.a_ [Lucid.href_ ("/tasks/" <> pid), Lucid.class_ "detail-value task-link"] (Lucid.toHtml pid) Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "Created:" Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.taskCreatedAt task))) Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "Updated:" Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.taskUpdatedAt task))) let deps = TaskCore.taskDependencies task unless (null deps) <| do Lucid.div_ [Lucid.class_ "detail-section"] <| do Lucid.h3_ "Dependencies" Lucid.ul_ [Lucid.class_ "dep-list"] <| do traverse_ renderDependency deps case TaskCore.taskDescription task of Nothing -> pure () Just desc -> Lucid.div_ [Lucid.class_ "detail-section"] <| do Lucid.h3_ "Description" Lucid.pre_ [Lucid.class_ "description"] (Lucid.toHtml desc) let children = filter (maybe False (TaskCore.matchesId (TaskCore.taskId task)) <. TaskCore.taskParent) allTasks unless (null children) <| do Lucid.div_ [Lucid.class_ "detail-section"] <| do Lucid.h3_ "Child Tasks" Lucid.ul_ [Lucid.class_ "child-list"] <| do traverse_ renderChild children when (TaskCore.taskStatus task == TaskCore.Review) <| do Lucid.div_ [Lucid.class_ "review-link-section"] <| do Lucid.a_ [ Lucid.href_ ("/tasks/" <> TaskCore.taskId task <> "/review"), 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 TaskCore.P0 -> " (Critical)" TaskCore.P1 -> " (High)" TaskCore.P2 -> " (Medium)" TaskCore.P3 -> " (Low)" TaskCore.P4 -> " (Backlog)" statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m () statusBadge status = let (cls, label) = case status of TaskCore.Open -> ("badge badge-open", "Open") TaskCore.InProgress -> ("badge badge-inprogress", "In Progress") TaskCore.Review -> ("badge badge-review", "Review") TaskCore.Approved -> ("badge badge-approved", "Approved") TaskCore.Done -> ("badge badge-done", "Done") in Lucid.span_ [Lucid.class_ cls] label statusOption :: (Monad m) => TaskCore.Status -> TaskCore.Status -> Lucid.HtmlT m () statusOption opt current = let attrs = if opt == current then [Lucid.value_ (tshow opt), Lucid.selected_ "selected"] else [Lucid.value_ (tshow opt)] in Lucid.option_ attrs (Lucid.toHtml (tshow opt)) renderDependency :: (Monad m) => TaskCore.Dependency -> Lucid.HtmlT m () renderDependency dep = Lucid.li_ <| do Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.depId dep), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.depId dep)) Lucid.span_ [Lucid.class_ "dep-type"] <| Lucid.toHtml (" [" <> tshow (TaskCore.depType dep) <> "]") renderChild :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m () renderChild child = Lucid.li_ <| do Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.taskId child), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.taskId child)) Lucid.span_ [Lucid.class_ "child-title"] <| Lucid.toHtml (" - " <> TaskCore.taskTitle child) Lucid.span_ [Lucid.class_ "child-status"] <| Lucid.toHtml (" [" <> tshow (TaskCore.taskStatus child) <> "]") detailStyles :: Text detailStyles = "* { box-sizing: border-box; } \ \body { font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif; \ \ margin: 0; padding: 16px; background: #f5f5f5; max-width: 800px; } \ \h1 { margin: 16px 0; } \ \h3 { margin: 16px 0 8px 0; color: #374151; } \ \.task-detail { background: white; border-radius: 8px; padding: 16px; \ \ box-shadow: 0 1px 3px rgba(0,0,0,0.1); } \ \.detail-row { display: flex; padding: 8px 0; border-bottom: 1px solid #e5e7eb; } \ \.detail-row:last-child { border-bottom: none; } \ \.detail-label { font-weight: 600; width: 120px; color: #6b7280; } \ \.detail-value { flex: 1; } \ \.detail-section { margin-top: 16px; padding-top: 16px; border-top: 1px solid #e5e7eb; } \ \.task-link { color: #0066cc; text-decoration: none; font-family: monospace; } \ \.task-link:hover { text-decoration: underline; } \ \.dep-list, .child-list { margin: 8px 0; padding-left: 20px; } \ \.dep-list li, .child-list li { margin: 4px 0; } \ \.dep-type { color: #6b7280; font-size: 14px; } \ \.child-title { color: #374151; } \ \.child-status { color: #6b7280; font-size: 14px; } \ \.description { background: #f9fafb; padding: 12px; border-radius: 4px; \ \ font-family: monospace; font-size: 14px; white-space: pre-wrap; margin: 0; } \ \.priority-desc { color: #6b7280; margin-left: 4px; } \ \.badge { display: inline-block; padding: 4px 8px; border-radius: 4px; \ \ font-size: 12px; font-weight: 500; } \ \.badge-open { background: #fef3c7; color: #92400e; } \ \.badge-inprogress { background: #dbeafe; color: #1e40af; } \ \.badge-review { background: #ede9fe; color: #6b21a8; } \ \.badge-approved { background: #d1fae5; color: #065f46; } \ \.badge-done { background: #d1fae5; color: #065f46; } \ \.status-form { margin-top: 24px; background: white; border-radius: 8px; padding: 16px; \ \ box-shadow: 0 1px 3px rgba(0,0,0,0.1); } \ \.status-select { padding: 8px 12px; border: 1px solid #d1d5db; border-radius: 4px; \ \ font-size: 14px; margin-right: 8px; } \ \.submit-btn { padding: 8px 16px; background: #0066cc; color: white; border: none; \ \ border-radius: 4px; font-size: 14px; cursor: pointer; } \ \.submit-btn:hover { background: #0052a3; } \ \.review-link-section { margin: 16px 0; } \ \.review-link-btn { display: inline-block; padding: 12px 24px; background: #8b5cf6; \ \ color: white; text-decoration: none; border-radius: 6px; \ \ font-size: 16px; font-weight: 500; } \ \.review-link-btn:hover { background: #7c3aed; }" instance Lucid.ToHtml TaskReviewPage where toHtmlRaw = Lucid.toHtml toHtml (ReviewPageNotFound tid) = Lucid.doctypehtml_ <| do Lucid.head_ <| do Lucid.title_ "Task Not Found - Jr Review" Lucid.meta_ [Lucid.charset_ "utf-8"] Lucid.meta_ [ Lucid.name_ "viewport", Lucid.content_ "width=device-width, initial-scale=1" ] Lucid.style_ reviewStyles Lucid.body_ <| do Lucid.h1_ "Task Not Found" Lucid.p_ <| do "The task " Lucid.code_ (Lucid.toHtml tid) " could not be found." Lucid.p_ <| Lucid.a_ [Lucid.href_ "/tasks"] "<- Back to Tasks" toHtml (ReviewPageFound task reviewInfo) = Lucid.doctypehtml_ <| do Lucid.head_ <| do Lucid.title_ <| Lucid.toHtml ("Review: " <> TaskCore.taskId task <> " - Jr") Lucid.meta_ [Lucid.charset_ "utf-8"] Lucid.meta_ [ Lucid.name_ "viewport", Lucid.content_ "width=device-width, initial-scale=1" ] Lucid.style_ reviewStyles Lucid.body_ <| do Lucid.p_ <| Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.taskId task)] "<- Back to Task" Lucid.h1_ "Review Task" Lucid.div_ [Lucid.class_ "task-summary"] <| do Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "ID:" Lucid.code_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskId task)) Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "Title:" Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskTitle task)) Lucid.div_ [Lucid.class_ "detail-row"] <| do Lucid.span_ [Lucid.class_ "detail-label"] "Status:" Lucid.span_ [Lucid.class_ "detail-value"] <| statusBadge (TaskCore.taskStatus task) case reviewInfo of ReviewNoCommit -> do Lucid.div_ [Lucid.class_ "no-commit-msg"] <| do Lucid.h3_ "No Commit Found" Lucid.p_ "No commit with this task ID was found in the git history." Lucid.p_ "The worker may not have completed yet, or the commit message doesn't include the task ID." ReviewMergeConflict commitSha conflictFiles -> do Lucid.div_ [Lucid.class_ "conflict-warning"] <| do Lucid.h3_ "Merge Conflict Detected" Lucid.p_ <| do "Commit " Lucid.code_ (Lucid.toHtml (Text.take 8 commitSha)) " cannot be cleanly merged." Lucid.p_ "Conflicting files:" Lucid.ul_ <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflictFiles ReviewReady commitSha diffText -> do Lucid.div_ [Lucid.class_ "diff-section"] <| do Lucid.h3_ <| do "Commit: " Lucid.code_ (Lucid.toHtml (Text.take 8 commitSha)) Lucid.pre_ [Lucid.class_ "diff-block"] (Lucid.toHtml diffText) Lucid.div_ [Lucid.class_ "review-actions"] <| do Lucid.form_ [ Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/accept"), Lucid.class_ "inline-form" ] <| do Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "accept-btn"] "Accept" Lucid.form_ [ Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/reject"), Lucid.class_ "reject-form" ] <| do Lucid.textarea_ [ Lucid.name_ "notes", Lucid.class_ "reject-notes", Lucid.placeholder_ "Rejection notes (optional)" ] "" Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reject-btn"] "Reject" where statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m () statusBadge status = let (cls, label) = case status of TaskCore.Open -> ("badge badge-open", "Open") TaskCore.InProgress -> ("badge badge-inprogress", "In Progress") TaskCore.Review -> ("badge badge-review", "Review") TaskCore.Approved -> ("badge badge-approved", "Approved") TaskCore.Done -> ("badge badge-done", "Done") in Lucid.span_ [Lucid.class_ cls] label reviewStyles :: Text reviewStyles = "* { box-sizing: border-box; } \ \body { font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif; \ \ margin: 0; padding: 16px; background: #f5f5f5; max-width: 1000px; } \ \h1 { margin: 16px 0; } \ \h3 { margin: 16px 0 8px 0; color: #374151; } \ \.task-summary { background: white; border-radius: 8px; padding: 16px; \ \ box-shadow: 0 1px 3px rgba(0,0,0,0.1); margin-bottom: 16px; } \ \.detail-row { display: flex; padding: 8px 0; border-bottom: 1px solid #e5e7eb; } \ \.detail-row:last-child { border-bottom: none; } \ \.detail-label { font-weight: 600; width: 100px; color: #6b7280; } \ \.detail-value { flex: 1; } \ \.badge { display: inline-block; padding: 4px 8px; border-radius: 4px; \ \ font-size: 12px; font-weight: 500; } \ \.badge-open { background: #fef3c7; color: #92400e; } \ \.badge-inprogress { background: #dbeafe; color: #1e40af; } \ \.badge-review { background: #ede9fe; color: #6b21a8; } \ \.badge-approved { background: #d1fae5; color: #065f46; } \ \.badge-done { background: #d1fae5; color: #065f46; } \ \.no-commit-msg { background: #fff3cd; border: 1px solid #ffc107; border-radius: 8px; \ \ padding: 16px; margin: 16px 0; } \ \.conflict-warning { background: #f8d7da; border: 1px solid #dc3545; border-radius: 8px; \ \ padding: 16px; margin: 16px 0; } \ \.diff-section { background: white; border-radius: 8px; padding: 16px; \ \ box-shadow: 0 1px 3px rgba(0,0,0,0.1); margin: 16px 0; } \ \.diff-block { background: #1e1e1e; color: #d4d4d4; padding: 16px; border-radius: 4px; \ \ font-family: 'SF Mono', Monaco, 'Courier New', monospace; font-size: 13px; \ \ overflow-x: auto; white-space: pre; margin: 0; max-height: 600px; overflow-y: auto; } \ \.review-actions { background: white; border-radius: 8px; padding: 16px; \ \ box-shadow: 0 1px 3px rgba(0,0,0,0.1); display: flex; gap: 16px; \ \ align-items: flex-start; flex-wrap: wrap; } \ \.inline-form { display: inline-block; } \ \.reject-form { display: flex; gap: 8px; flex: 1; min-width: 300px; } \ \.reject-notes { flex: 1; padding: 8px; border: 1px solid #d1d5db; border-radius: 4px; \ \ font-size: 14px; resize: vertical; min-height: 38px; } \ \.accept-btn { padding: 10px 24px; background: #10b981; color: white; border: none; \ \ border-radius: 4px; font-size: 14px; font-weight: 500; cursor: pointer; } \ \.accept-btn:hover { background: #059669; } \ \.reject-btn { padding: 10px 24px; background: #ef4444; color: white; border: none; \ \ border-radius: 4px; font-size: 14px; font-weight: 500; cursor: pointer; } \ \.reject-btn:hover { background: #dc2626; }" api :: Proxy API api = Proxy server :: Server API server = homeHandler :<|> readyQueueHandler :<|> taskListHandler :<|> taskDetailHandler :<|> taskStatusHandler :<|> taskReviewHandler :<|> taskAcceptHandler :<|> taskRejectHandler where homeHandler :: Servant.Handler HomePage homeHandler = do stats <- liftIO <| TaskCore.getTaskStats Nothing readyTasks <- liftIO TaskCore.getReadyTasks allTasks <- liftIO TaskCore.loadTasks let recentTasks = take 5 <| List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks pure (HomePage stats readyTasks recentTasks) readyQueueHandler :: Servant.Handler ReadyQueuePage readyQueueHandler = do readyTasks <- liftIO TaskCore.getReadyTasks let sortedTasks = List.sortBy (compare `on` TaskCore.taskPriority) readyTasks pure (ReadyQueuePage sortedTasks) taskListHandler :: Maybe TaskCore.Status -> Maybe TaskCore.Priority -> Maybe Text -> Servant.Handler TaskListPage taskListHandler maybeStatus maybePriority maybeNamespace = do allTasks <- liftIO TaskCore.loadTasks let filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) filteredTasks = applyFilters filters allTasks pure (TaskListPage filteredTasks filters) emptyToNothing :: Maybe Text -> Maybe Text emptyToNothing (Just t) | Text.null (Text.strip t) = Nothing emptyToNothing x = x applyFilters :: TaskFilters -> [TaskCore.Task] -> [TaskCore.Task] applyFilters filters = filter matchesAllFilters where matchesAllFilters task = matchesStatus task && matchesPriority task && matchesNamespace task matchesStatus task = case filterStatus filters of Nothing -> True Just s -> TaskCore.taskStatus task == s matchesPriority task = case filterPriority filters of Nothing -> True Just p -> TaskCore.taskPriority task == p matchesNamespace task = case filterNamespace filters of Nothing -> True Just ns -> case TaskCore.taskNamespace task of Nothing -> False Just taskNs -> ns `Text.isPrefixOf` taskNs taskDetailHandler :: Text -> Servant.Handler TaskDetailPage taskDetailHandler tid = do tasks <- liftIO TaskCore.loadTasks case TaskCore.findTask tid tasks of Nothing -> pure (TaskDetailNotFound tid) Just task -> pure (TaskDetailFound task tasks) taskStatusHandler :: Text -> StatusForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent) taskStatusHandler tid (StatusForm newStatus) = do liftIO <| TaskCore.updateTaskStatus tid newStatus [] pure <| addHeader ("/tasks/" <> tid) NoContent taskReviewHandler :: Text -> Servant.Handler TaskReviewPage taskReviewHandler tid = do tasks <- liftIO TaskCore.loadTasks case TaskCore.findTask tid tasks of Nothing -> pure (ReviewPageNotFound tid) Just task -> do reviewInfo <- liftIO <| getReviewInfo tid pure (ReviewPageFound task reviewInfo) taskAcceptHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent) taskAcceptHandler tid = do liftIO <| do TaskCore.clearRetryContext tid TaskCore.updateTaskStatus tid TaskCore.Done [] pure <| addHeader ("/tasks/" <> tid) NoContent taskRejectHandler :: Text -> RejectForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent) taskRejectHandler tid (RejectForm maybeNotes) = do liftIO <| do maybeCommit <- findCommitForTask tid let commitSha = fromMaybe "" maybeCommit maybeCtx <- TaskCore.getRetryContext tid let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx let reason = "rejected: " <> fromMaybe "(no notes)" maybeNotes TaskCore.setRetryContext TaskCore.RetryContext { TaskCore.retryTaskId = tid, TaskCore.retryOriginalCommit = commitSha, TaskCore.retryConflictFiles = [], TaskCore.retryAttempt = attempt, TaskCore.retryReason = reason } TaskCore.updateTaskStatus tid TaskCore.Open [] pure <| addHeader ("/tasks/" <> tid) NoContent getReviewInfo :: Text -> IO ReviewInfo getReviewInfo tid = do maybeCommit <- findCommitForTask tid case maybeCommit of Nothing -> pure ReviewNoCommit Just commitSha -> do conflictResult <- checkMergeConflict (Text.unpack commitSha) case conflictResult of Just conflictFiles -> pure (ReviewMergeConflict commitSha conflictFiles) Nothing -> do (_, diffOut, _) <- Process.readProcessWithExitCode "git" ["show", Text.unpack commitSha] "" pure (ReviewReady commitSha (Text.pack diffOut)) findCommitForTask :: Text -> IO (Maybe Text) findCommitForTask tid = do let grepArg = "--grep=" <> Text.unpack tid (code, shaOut, _) <- Process.readProcessWithExitCode "git" ["log", "--pretty=format:%H", "-n", "1", grepArg] "" if code /= Exit.ExitSuccess || null shaOut then pure Nothing else case List.lines shaOut of (x : _) -> pure (Just (Text.pack x)) [] -> pure Nothing checkMergeConflict :: String -> IO (Maybe [Text]) checkMergeConflict commitSha = do (_, origHead, _) <- Process.readProcessWithExitCode "git" ["rev-parse", "HEAD"] "" (cpCode, _, cpErr) <- Process.readProcessWithExitCode "git" ["cherry-pick", "--no-commit", commitSha] "" _ <- Process.readProcessWithExitCode "git" ["cherry-pick", "--abort"] "" _ <- Process.readProcessWithExitCode "git" ["reset", "--hard", List.head (List.lines origHead)] "" case cpCode of Exit.ExitSuccess -> pure Nothing Exit.ExitFailure _ -> do let errLines = Text.lines (Text.pack cpErr) conflictLines = filter (Text.isPrefixOf "CONFLICT") errLines files = mapMaybe extractConflictFile conflictLines pure (Just (if null files then ["(unknown files)"] else files)) extractConflictFile :: Text -> Maybe Text extractConflictFile line = case Text.breakOn "Merge conflict in " line of (_, rest) | not (Text.null rest) -> Just (Text.strip (Text.drop 18 rest)) _ -> case Text.breakOn "in " line of (_, rest) | not (Text.null rest) -> Just (Text.strip (Text.drop 3 rest)) _ -> Nothing app :: Application app = serve api server run :: Warp.Port -> IO () run port = do putText <| "Starting Jr web server on port " <> tshow port Warp.run port app