summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Omni/Jr/Web.hs83
-rw-r--r--Omni/Jr/Web/Style.hs60
2 files changed, 132 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)
diff --git a/Omni/Jr/Web/Style.hs b/Omni/Jr/Web/Style.hs
index 73b2c02..6fb793d 100644
--- a/Omni/Jr/Web/Style.hs
+++ b/Omni/Jr/Web/Style.hs
@@ -166,6 +166,7 @@ navigationStyles = do
display flex
Stylesheet.key "gap" ("2px" :: Text)
flexWrap Flexbox.wrap
+ alignItems center
".navbar-link" ? do
display inlineBlock
padding (px 4) (px 10) (px 4) (px 10)
@@ -178,6 +179,43 @@ navigationStyles = do
".navbar-link" # hover ? do
backgroundColor "#f3f4f6"
textDecoration none
+ ".navbar-dropdown" ? do
+ position relative
+ display inlineBlock
+ ".navbar-dropdown-btn" ? do
+ display inlineBlock
+ padding (px 4) (px 10) (px 4) (px 10)
+ color "#374151"
+ backgroundColor transparent
+ border (px 0) none transparent
+ borderRadius (px 2) (px 2) (px 2) (px 2)
+ fontSize (px 13)
+ fontWeight (weight 500)
+ cursor pointer
+ transition "background-color" (ms 150) ease (sec 0)
+ ".navbar-dropdown-btn" # hover ? backgroundColor "#f3f4f6"
+ ".navbar-dropdown-content" ? do
+ display none
+ position absolute
+ left (px 0)
+ top (pct 100)
+ backgroundColor white
+ minWidth (px 120)
+ Stylesheet.key "box-shadow" ("0 2px 8px rgba(0,0,0,0.15)" :: Text)
+ borderRadius (px 2) (px 2) (px 2) (px 2)
+ zIndex 100
+ Stylesheet.key "overflow" ("hidden" :: Text)
+ ".navbar-dropdown" # hover |> ".navbar-dropdown-content" ? display block
+ ".navbar-dropdown-item" ? do
+ display block
+ padding (px 8) (px 12) (px 8) (px 12)
+ color "#374151"
+ textDecoration none
+ fontSize (px 13)
+ transition "background-color" (ms 150) ease (sec 0)
+ ".navbar-dropdown-item" # hover ? do
+ backgroundColor "#f3f4f6"
+ textDecoration none
header ? do
backgroundColor white
padding (px 6) (px 12) (px 6) (px 12)
@@ -274,6 +312,15 @@ cardStyles = do
".empty-msg" ? do
color "#6b7280"
fontStyle italic
+ ".info-msg" ? do
+ color "#6b7280"
+ marginBottom (px 12)
+ ".kb-preview" ? do
+ color "#6b7280"
+ fontSize (px 12)
+ marginTop (px 4)
+ overflow hidden
+ Stylesheet.key "text-overflow" ("ellipsis" :: Text)
".ready-link" ? do
fontSize (px 13)
color "#0066cc"
@@ -800,6 +847,12 @@ responsiveStyles = do
".navbar-link" ? do
padding (px 4) (px 6) (px 4) (px 6)
fontSize (px 11)
+ ".navbar-dropdown-btn" ? do
+ padding (px 4) (px 6) (px 4) (px 6)
+ fontSize (px 11)
+ ".navbar-dropdown-item" ? do
+ padding (px 6) (px 10) (px 6) (px 10)
+ fontSize (px 11)
".nav-content" ? do
flexDirection column
alignItems flexStart
@@ -848,6 +901,13 @@ darkModeStyles =
".navbar-brand" ? color "#60a5fa"
".navbar-link" ? color "#d1d5db"
".navbar-link" # hover ? backgroundColor "#374151"
+ ".navbar-dropdown-btn" ? color "#d1d5db"
+ ".navbar-dropdown-btn" # hover ? backgroundColor "#374151"
+ ".navbar-dropdown-content" ? do
+ backgroundColor "#1f2937"
+ Stylesheet.key "box-shadow" ("0 2px 8px rgba(0,0,0,0.3)" :: Text)
+ ".navbar-dropdown-item" ? color "#d1d5db"
+ ".navbar-dropdown-item" # hover ? backgroundColor "#374151"
".nav-brand" ? color "#f3f4f6"
"h2" <> "h3" ? color "#d1d5db"
a ? color "#60a5fa"
generated by cgit v1.2.3 (git 2.25.1) at 2025-12-16 16:59:57 +0000