summaryrefslogtreecommitdiff
path: root/Omni/Jr/Web.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Omni/Jr/Web.hs')
-rw-r--r--Omni/Jr/Web.hs83
1 files changed, 72 insertions, 11 deletions
diff --git a/Omni/Jr/Web.hs b/Omni/Jr/Web.hs
index 46511a0..3327b26 100644
--- a/Omni/Jr/Web.hs
+++ b/Omni/Jr/Web.hs
@@ -42,7 +42,8 @@ defaultPort = 8080
data TaskFilters = TaskFilters
{ filterStatus :: Maybe TaskCore.Status,
filterPriority :: Maybe TaskCore.Priority,
- filterNamespace :: Maybe Text
+ filterNamespace :: Maybe Text,
+ filterType :: Maybe TaskCore.TaskType
}
deriving (Show, Eq)
@@ -57,7 +58,9 @@ type API =
:> QueryParam "status" Text
:> QueryParam "priority" Text
:> QueryParam "namespace" Text
+ :> QueryParam "type" Text
:> Get '[Lucid.HTML] TaskListPage
+ :<|> "kb" :> Get '[Lucid.HTML] KBPage
:<|> "tasks" :> Capture "id" Text :> Get '[Lucid.HTML] TaskDetailPage
:<|> "tasks" :> Capture "id" Text :> "status" :> ReqBody '[FormUrlEncoded] StatusForm :> Post '[Lucid.HTML] StatusBadgePartial
:<|> "tasks" :> Capture "id" Text :> "description" :> ReqBody '[FormUrlEncoded] DescriptionForm :> PostRedirect
@@ -74,6 +77,7 @@ type API =
:> QueryParam "status" Text
:> QueryParam "priority" Text
:> QueryParam "namespace" Text
+ :> QueryParam "type" Text
:> Get '[Lucid.HTML] TaskListPartial
:<|> "partials" :> "task" :> Capture "id" Text :> "metrics" :> Get '[Lucid.HTML] TaskMetricsPartial
@@ -124,6 +128,8 @@ data TaskDiffPage
data StatsPage = StatsPage TaskCore.TaskStats (Maybe Text)
+newtype KBPage = KBPage [TaskCore.Task]
+
newtype RecentActivityPartial = RecentActivityPartial [TaskCore.Task]
newtype ReadyCountPartial = ReadyCountPartial Int
@@ -185,10 +191,18 @@ navbar =
Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-brand"] "Jr"
Lucid.div_ [Lucid.class_ "navbar-links"] <| do
Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-link"] "Dashboard"
- Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "navbar-link"] "Tasks"
- Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "navbar-link"] "Ready"
- Lucid.a_ [Lucid.href_ "/blocked", Lucid.class_ "navbar-link"] "Blocked"
- Lucid.a_ [Lucid.href_ "/intervention", Lucid.class_ "navbar-link"] "Intervention"
+ Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do
+ Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Tasks ▾"
+ Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do
+ Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "navbar-dropdown-item"] "Ready"
+ Lucid.a_ [Lucid.href_ "/blocked", Lucid.class_ "navbar-dropdown-item"] "Blocked"
+ Lucid.a_ [Lucid.href_ "/intervention", Lucid.class_ "navbar-dropdown-item"] "Intervention"
+ Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "navbar-dropdown-item"] "All"
+ Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do
+ Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Plans ▾"
+ Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do
+ Lucid.a_ [Lucid.href_ "/tasks?type=Epic", Lucid.class_ "navbar-dropdown-item"] "Epics"
+ Lucid.a_ [Lucid.href_ "/kb", Lucid.class_ "navbar-dropdown-item"] "KB"
Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "navbar-link"] "Stats"
statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m ()
@@ -337,6 +351,36 @@ instance Lucid.ToHtml InterventionPage where
then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks need intervention."
else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks
+instance Lucid.ToHtml KBPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (KBPage tasks) =
+ Lucid.doctypehtml_ <| do
+ pageHead "Knowledge Base - Jr"
+ Lucid.body_ <| do
+ navbar
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.h1_ "Knowledge Base"
+ Lucid.p_ [Lucid.class_ "info-msg"] "Epic design documents and project knowledge."
+ if null tasks
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No epics with designs yet."
+ else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderEpicCard tasks
+ where
+ renderEpicCard :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
+ renderEpicCard t =
+ Lucid.a_
+ [ Lucid.class_ "task-card task-card-link",
+ Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
+ ]
+ <| do
+ Lucid.div_ [Lucid.class_ "task-header"] <| do
+ Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
+ statusBadge (TaskCore.taskStatus t)
+ Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
+ case TaskCore.taskDescription t of
+ Nothing -> pure ()
+ Just desc ->
+ Lucid.p_ [Lucid.class_ "kb-preview"] (Lucid.toHtml (Text.take 200 desc <> "..."))
+
instance Lucid.ToHtml TaskListPage where
toHtmlRaw = Lucid.toHtml
toHtml (TaskListPage tasks filters) =
@@ -1188,6 +1232,7 @@ server =
:<|> interventionHandler
:<|> statsHandler
:<|> taskListHandler
+ :<|> kbHandler
:<|> taskDetailHandler
:<|> taskStatusHandler
:<|> taskDescriptionHandler
@@ -1237,21 +1282,31 @@ server =
stats <- liftIO <| TaskCore.getTaskStats epicId
pure (StatsPage stats epicId)
- taskListHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPage
- taskListHandler maybeStatusText maybePriorityText maybeNamespace = do
+ taskListHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPage
+ taskListHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText = do
allTasks <- liftIO TaskCore.loadTasks
let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText
maybePriority = parsePriority =<< emptyToNothing maybePriorityText
- filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace)
+ maybeType = parseTaskType =<< emptyToNothing maybeTypeText
+ filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType
filteredTasks = applyFilters filters allTasks
pure (TaskListPage filteredTasks filters)
+ kbHandler :: Servant.Handler KBPage
+ kbHandler = do
+ allTasks <- liftIO TaskCore.loadTasks
+ let epicTasks = filter (\t -> TaskCore.taskType t == TaskCore.Epic) allTasks
+ pure (KBPage epicTasks)
+
parseStatus :: Text -> Maybe TaskCore.Status
parseStatus = readMaybe <. Text.unpack
parsePriority :: Text -> Maybe TaskCore.Priority
parsePriority = readMaybe <. Text.unpack
+ parseTaskType :: Text -> Maybe TaskCore.TaskType
+ parseTaskType = readMaybe <. Text.unpack
+
emptyToNothing :: Maybe Text -> Maybe Text
emptyToNothing (Just t) | Text.null (Text.strip t) = Nothing
emptyToNothing x = x
@@ -1263,6 +1318,7 @@ server =
matchesStatus task
&& matchesPriority task
&& matchesNamespace task
+ && matchesType task
matchesStatus task = case filterStatus filters of
Nothing -> True
@@ -1278,6 +1334,10 @@ server =
Nothing -> False
Just taskNs -> ns `Text.isPrefixOf` taskNs
+ matchesType task = case filterType filters of
+ Nothing -> True
+ Just t -> TaskCore.taskType task == t
+
taskDetailHandler :: Text -> Servant.Handler TaskDetailPage
taskDetailHandler tid = do
tasks <- liftIO TaskCore.loadTasks
@@ -1366,12 +1426,13 @@ server =
readyTasks <- liftIO TaskCore.getReadyTasks
pure (ReadyCountPartial (length readyTasks))
- taskListPartialHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPartial
- taskListPartialHandler maybeStatusText maybePriorityText maybeNamespace = do
+ taskListPartialHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPartial
+ taskListPartialHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText = do
allTasks <- liftIO TaskCore.loadTasks
let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText
maybePriority = parsePriority =<< emptyToNothing maybePriorityText
- filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace)
+ maybeType = parseTaskType =<< emptyToNothing maybeTypeText
+ filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType
filteredTasks = applyFilters filters allTasks
pure (TaskListPartial filteredTasks)
generated by cgit v1.2.3 (git 2.25.1) at 2025-12-16 13:08:27 +0000