diff options
Diffstat (limited to 'Omni/Jr/Web.hs')
| -rw-r--r-- | Omni/Jr/Web.hs | 2864 |
1 files changed, 2864 insertions, 0 deletions
diff --git a/Omni/Jr/Web.hs b/Omni/Jr/Web.hs new file mode 100644 index 0000000..fe1711b --- /dev/null +++ b/Omni/Jr/Web.hs @@ -0,0 +1,2864 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- : dep warp +-- : dep servant-server +-- : dep lucid +-- : dep servant-lucid +-- : dep http-api-data +-- : dep process +-- : dep clay +module Omni.Jr.Web + ( run, + defaultPort, + ) +where + +import Alpha +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text.Lazy.Encoding as LazyText +import Data.Time (Day, NominalDiffTime, UTCTime (..), dayOfWeek, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime, toGregorian) +import Data.Time.Calendar (DayOfWeek (..)) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import qualified Lucid +import qualified Lucid.Base as Lucid +import qualified Network.Wai.Handler.Warp as Warp +import Numeric (showFFloat) +import qualified Omni.Fact as Fact +import qualified Omni.Jr.Web.Style as Style +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 + +formatRelativeTime :: UTCTime -> UTCTime -> Text +formatRelativeTime now timestamp = + let delta = diffUTCTime now timestamp + in relativeText delta + +relativeText :: NominalDiffTime -> Text +relativeText delta + | delta < 60 = "just now" + | delta < 3600 = tshow (round (delta / 60) :: Int) <> " minutes ago" + | delta < 7200 = "1 hour ago" + | delta < 86400 = tshow (round (delta / 3600) :: Int) <> " hours ago" + | delta < 172800 = "yesterday" + | delta < 604800 = tshow (round (delta / 86400) :: Int) <> " days ago" + | delta < 1209600 = "1 week ago" + | delta < 2592000 = tshow (round (delta / 604800) :: Int) <> " weeks ago" + | delta < 5184000 = "1 month ago" + | delta < 31536000 = tshow (round (delta / 2592000) :: Int) <> " months ago" + | otherwise = tshow (round (delta / 31536000) :: Int) <> " years ago" + +formatExactTimestamp :: UTCTime -> Text +formatExactTimestamp = Text.pack <. formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" + +renderRelativeTimestamp :: (Monad m) => UTCTime -> UTCTime -> Lucid.HtmlT m () +renderRelativeTimestamp now timestamp = + Lucid.span_ + [ Lucid.class_ "relative-time", + Lucid.title_ (formatExactTimestamp timestamp) + ] + (Lucid.toHtml (formatRelativeTime now timestamp)) + +metaSep :: (Monad m) => Lucid.HtmlT m () +metaSep = Lucid.span_ [Lucid.class_ "meta-sep"] "·" + +data TaskFilters = TaskFilters + { filterStatus :: Maybe TaskCore.Status, + filterPriority :: Maybe TaskCore.Priority, + filterNamespace :: Maybe Text, + filterType :: Maybe TaskCore.TaskType + } + deriving (Show, Eq) + +data TimeRange = Today | Week | Month | AllTime + deriving (Show, Eq) + +data SortOrder + = SortNewest + | SortOldest + | SortUpdated + | SortPriorityHigh + | SortPriorityLow + deriving (Show, Eq) + +parseSortOrder :: Maybe Text -> SortOrder +parseSortOrder (Just "oldest") = SortOldest +parseSortOrder (Just "updated") = SortUpdated +parseSortOrder (Just "priority-high") = SortPriorityHigh +parseSortOrder (Just "priority-low") = SortPriorityLow +parseSortOrder _ = SortNewest + +sortOrderToParam :: SortOrder -> Text +sortOrderToParam SortNewest = "newest" +sortOrderToParam SortOldest = "oldest" +sortOrderToParam SortUpdated = "updated" +sortOrderToParam SortPriorityHigh = "priority-high" +sortOrderToParam SortPriorityLow = "priority-low" + +sortOrderLabel :: SortOrder -> Text +sortOrderLabel SortNewest = "Newest First" +sortOrderLabel SortOldest = "Oldest First" +sortOrderLabel SortUpdated = "Recently Updated" +sortOrderLabel SortPriorityHigh = "Priority (High to Low)" +sortOrderLabel SortPriorityLow = "Priority (Low to High)" + +sortTasks :: SortOrder -> [TaskCore.Task] -> [TaskCore.Task] +sortTasks SortNewest = List.sortBy (comparing (Down <. TaskCore.taskCreatedAt)) +sortTasks SortOldest = List.sortBy (comparing TaskCore.taskCreatedAt) +sortTasks SortUpdated = List.sortBy (comparing (Down <. TaskCore.taskUpdatedAt)) +sortTasks SortPriorityHigh = List.sortBy (comparing TaskCore.taskPriority) +sortTasks SortPriorityLow = List.sortBy (comparing (Down <. TaskCore.taskPriority)) + +parseTimeRange :: Maybe Text -> TimeRange +parseTimeRange (Just "today") = Today +parseTimeRange (Just "week") = Week +parseTimeRange (Just "month") = Month +parseTimeRange _ = AllTime + +timeRangeToParam :: TimeRange -> Text +timeRangeToParam Today = "today" +timeRangeToParam Week = "week" +timeRangeToParam Month = "month" +timeRangeToParam AllTime = "all" + +getTimeRangeStart :: TimeRange -> UTCTime -> Maybe UTCTime +getTimeRangeStart AllTime _ = Nothing +getTimeRangeStart Today now = Just (startOfDay now) +getTimeRangeStart Week now = Just (startOfWeek now) +getTimeRangeStart Month now = Just (startOfMonth now) + +startOfDay :: UTCTime -> UTCTime +startOfDay t = UTCTime (utctDay t) 0 + +startOfWeek :: UTCTime -> UTCTime +startOfWeek t = + let day = utctDay t + dow = dayOfWeek day + daysBack = case dow of + Monday -> 0 + Tuesday -> 1 + Wednesday -> 2 + Thursday -> 3 + Friday -> 4 + Saturday -> 5 + Sunday -> 6 + in UTCTime (addDays (negate daysBack) day) 0 + +addDays :: Integer -> Day -> Day +addDays n d = + let (y, m, dayNum) = toGregorian d + in fromGregorian y m (dayNum + fromInteger n) + +fromGregorian :: Integer -> Int -> Int -> Day +fromGregorian y m d = toEnum (fromInteger (daysSinceEpoch y m d)) + +daysSinceEpoch :: Integer -> Int -> Int -> Integer +daysSinceEpoch y m d = + let a = (14 - m) `div` 12 + y' = y + 4800 - toInteger a + m' = m + 12 * a - 3 + jdn = d + (153 * m' + 2) `div` 5 + 365 * fromInteger y' + fromInteger y' `div` 4 - fromInteger y' `div` 100 + fromInteger y' `div` 400 - 32045 + in toInteger jdn - 2440588 + +startOfMonth :: UTCTime -> UTCTime +startOfMonth t = + let day = utctDay t + (y, m, _) = toGregorian day + in UTCTime (fromGregorian y m 1) 0 + +computeMetricsFromActivities :: [TaskCore.Task] -> [TaskCore.TaskActivity] -> TaskCore.AggregatedMetrics +computeMetricsFromActivities tasks activities = + let completedCount = length [t | t <- tasks, TaskCore.taskStatus t == TaskCore.Done] + totalCost = sum [c | act <- activities, Just c <- [TaskCore.activityCostCents act]] + totalTokens = sum [t | act <- activities, Just t <- [TaskCore.activityTokensUsed act]] + totalDuration = sum [calcDuration act | act <- activities] + in TaskCore.AggregatedMetrics + { TaskCore.aggTotalCostCents = totalCost, + TaskCore.aggTotalDurationSeconds = totalDuration, + TaskCore.aggCompletedTasks = completedCount, + TaskCore.aggTotalTokens = totalTokens + } + where + calcDuration act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of + (Just start, Just end) -> floor (diffUTCTime end start) + _ -> 0 + +type API = + QueryParam "range" Text :> Get '[Lucid.HTML] HomePage + :<|> "style.css" :> Get '[CSS] LazyText.Text + :<|> "ready" :> QueryParam "sort" Text :> Get '[Lucid.HTML] ReadyQueuePage + :<|> "blocked" :> QueryParam "sort" Text :> Get '[Lucid.HTML] BlockedPage + :<|> "intervention" :> QueryParam "sort" Text :> Get '[Lucid.HTML] InterventionPage + :<|> "stats" :> QueryParam "epic" Text :> Get '[Lucid.HTML] StatsPage + :<|> "tasks" + :> QueryParam "status" Text + :> QueryParam "priority" Text + :> QueryParam "namespace" Text + :> QueryParam "type" Text + :> QueryParam "sort" Text + :> Get '[Lucid.HTML] TaskListPage + :<|> "kb" :> Get '[Lucid.HTML] KBPage + :<|> "kb" :> "create" :> ReqBody '[FormUrlEncoded] FactCreateForm :> PostRedirect + :<|> "kb" :> Capture "id" Int :> Get '[Lucid.HTML] FactDetailPage + :<|> "kb" :> Capture "id" Int :> "edit" :> ReqBody '[FormUrlEncoded] FactEditForm :> PostRedirect + :<|> "kb" :> Capture "id" Int :> "delete" :> PostRedirect + :<|> "epics" :> QueryParam "sort" Text :> Get '[Lucid.HTML] EpicsPage + :<|> "tasks" :> Capture "id" Text :> Get '[Lucid.HTML] TaskDetailPage + :<|> "tasks" :> Capture "id" Text :> "status" :> ReqBody '[FormUrlEncoded] StatusForm :> Post '[Lucid.HTML] StatusBadgePartial + :<|> "tasks" :> Capture "id" Text :> "priority" :> ReqBody '[FormUrlEncoded] PriorityForm :> Post '[Lucid.HTML] PriorityBadgePartial + :<|> "tasks" :> Capture "id" Text :> "description" :> "view" :> Get '[Lucid.HTML] DescriptionViewPartial + :<|> "tasks" :> Capture "id" Text :> "description" :> "edit" :> Get '[Lucid.HTML] DescriptionEditPartial + :<|> "tasks" :> Capture "id" Text :> "description" :> ReqBody '[FormUrlEncoded] DescriptionForm :> Post '[Lucid.HTML] DescriptionViewPartial + :<|> "tasks" :> Capture "id" Text :> "notes" :> ReqBody '[FormUrlEncoded] NotesForm :> PostRedirect + :<|> "tasks" :> Capture "id" Text :> "comment" :> ReqBody '[FormUrlEncoded] CommentForm :> PostRedirect + :<|> "tasks" :> Capture "id" Text :> "review" :> Get '[Lucid.HTML] TaskReviewPage + :<|> "tasks" :> Capture "id" Text :> "diff" :> Capture "commit" Text :> Get '[Lucid.HTML] TaskDiffPage + :<|> "tasks" :> Capture "id" Text :> "accept" :> PostRedirect + :<|> "tasks" :> Capture "id" Text :> "reject" :> ReqBody '[FormUrlEncoded] RejectForm :> PostRedirect + :<|> "tasks" :> Capture "id" Text :> "reset-retries" :> PostRedirect + :<|> "partials" :> "recent-activity-new" :> QueryParam "since" Int :> Get '[Lucid.HTML] RecentActivityNewPartial + :<|> "partials" :> "recent-activity-more" :> QueryParam "offset" Int :> Get '[Lucid.HTML] RecentActivityMorePartial + :<|> "partials" :> "ready-count" :> Get '[Lucid.HTML] ReadyCountPartial + :<|> "partials" + :> "task-list" + :> QueryParam "status" Text + :> QueryParam "priority" Text + :> QueryParam "namespace" Text + :> QueryParam "type" Text + :> QueryParam "sort" Text + :> Get '[Lucid.HTML] TaskListPartial + :<|> "partials" :> "task" :> Capture "id" Text :> "metrics" :> Get '[Lucid.HTML] TaskMetricsPartial + +data CSS + +instance Accept CSS where + contentType _ = "text/css" + +instance MimeRender CSS LazyText.Text where + mimeRender _ = LazyText.encodeUtf8 + +data HomePage = HomePage TaskCore.TaskStats [TaskCore.Task] [TaskCore.Task] Bool TaskCore.AggregatedMetrics TimeRange UTCTime + +data ReadyQueuePage = ReadyQueuePage [TaskCore.Task] SortOrder UTCTime + +data BlockedPage = BlockedPage [(TaskCore.Task, Int)] SortOrder UTCTime + +data InterventionPage = InterventionPage TaskCore.HumanActionItems SortOrder UTCTime + +data TaskListPage = TaskListPage [TaskCore.Task] TaskFilters SortOrder UTCTime + +data TaskDetailPage + = TaskDetailFound TaskCore.Task [TaskCore.Task] [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) [GitCommit] (Maybe TaskCore.AggregatedMetrics) UTCTime + | TaskDetailNotFound Text + +data GitCommit = GitCommit + { commitHash :: Text, + commitShortHash :: Text, + commitSummary :: Text, + commitAuthor :: Text, + commitRelativeDate :: Text, + commitFilesChanged :: Int + } + deriving (Show, Eq) + +data TaskReviewPage + = ReviewPageFound TaskCore.Task ReviewInfo + | ReviewPageNotFound Text + +data ReviewInfo + = ReviewNoCommit + | ReviewMergeConflict Text [Text] + | ReviewReady Text Text + +data TaskDiffPage + = DiffPageFound Text Text Text + | DiffPageNotFound Text Text + +data StatsPage = StatsPage TaskCore.TaskStats (Maybe Text) + +newtype KBPage = KBPage [TaskCore.Fact] + +data FactDetailPage + = FactDetailFound TaskCore.Fact UTCTime + | FactDetailNotFound Int + +data FactEditForm = FactEditForm Text Text Text + +instance FromForm FactEditForm where + fromForm form = do + content <- parseUnique "content" form + let files = fromRight "" (lookupUnique "files" form) + let confidence = fromRight "0.8" (lookupUnique "confidence" form) + Right (FactEditForm content files confidence) + +data FactCreateForm = FactCreateForm Text Text Text Text + +instance FromForm FactCreateForm where + fromForm form = do + project <- parseUnique "project" form + content <- parseUnique "content" form + let files = fromRight "" (lookupUnique "files" form) + let confidence = fromRight "0.8" (lookupUnique "confidence" form) + Right (FactCreateForm project content files confidence) + +data EpicsPage = EpicsPage [TaskCore.Task] [TaskCore.Task] SortOrder + +data RecentActivityNewPartial = RecentActivityNewPartial [TaskCore.Task] (Maybe Int) + +data RecentActivityMorePartial = RecentActivityMorePartial [TaskCore.Task] Int Bool + +newtype ReadyCountPartial = ReadyCountPartial Int + +data StatusBadgePartial = StatusBadgePartial TaskCore.Status Text + +data PriorityBadgePartial = PriorityBadgePartial TaskCore.Priority Text + +newtype TaskListPartial = TaskListPartial [TaskCore.Task] + +data TaskMetricsPartial = TaskMetricsPartial Text [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) UTCTime + +data DescriptionViewPartial = DescriptionViewPartial Text Text Bool + +data DescriptionEditPartial = DescriptionEditPartial Text Text Bool + +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" + +newtype PriorityForm = PriorityForm TaskCore.Priority + +instance FromForm PriorityForm where + fromForm form = do + priorityText <- parseUnique "priority" form + case readMaybe (Text.unpack priorityText) of + Just p -> Right (PriorityForm p) + Nothing -> Left "Invalid priority" + +newtype DescriptionForm = DescriptionForm Text + +instance FromForm DescriptionForm where + fromForm form = do + desc <- parseUnique "description" form + Right (DescriptionForm desc) + +newtype NotesForm = NotesForm Text + +instance FromForm NotesForm where + fromForm form = do + notes <- parseUnique "notes" form + Right (NotesForm notes) + +newtype CommentForm = CommentForm Text + +instance FromForm CommentForm where + fromForm form = do + commentText <- parseUnique "comment" form + Right (CommentForm commentText) + +pageHead :: (Monad m) => Text -> Lucid.HtmlT m () +pageHead title = + Lucid.head_ <| do + Lucid.title_ (Lucid.toHtml title) + Lucid.meta_ [Lucid.charset_ "utf-8"] + Lucid.meta_ + [ Lucid.name_ "viewport", + Lucid.content_ "width=device-width, initial-scale=1" + ] + Lucid.link_ [Lucid.rel_ "stylesheet", Lucid.href_ "/style.css"] + Lucid.script_ + [ Lucid.src_ "https://unpkg.com/htmx.org@2.0.4", + Lucid.integrity_ "sha384-HGfztofotfshcF7+8n44JQL2oJmowVChPTg48S+jvZoztPfvwD79OC/LTtG6dMp+", + Lucid.crossorigin_ "anonymous" + ] + ("" :: Text) + Lucid.script_ [] statusDropdownJs + Lucid.script_ [] priorityDropdownJs + Lucid.script_ [] navbarDropdownJs + +navbarDropdownJs :: Text +navbarDropdownJs = + Text.unlines + [ "document.addEventListener('DOMContentLoaded', function() {", + " document.querySelectorAll('.navbar-dropdown-btn').forEach(function(btn) {", + " btn.addEventListener('click', function(e) {", + " e.preventDefault();", + " var dropdown = btn.closest('.navbar-dropdown');", + " var isOpen = dropdown.classList.contains('open');", + " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {", + " d.classList.remove('open');", + " });", + " if (!isOpen) {", + " dropdown.classList.add('open');", + " }", + " });", + " });", + " document.addEventListener('click', function(e) {", + " if (!e.target.closest('.navbar-dropdown')) {", + " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {", + " d.classList.remove('open');", + " });", + " }", + " });", + "});" + ] + +statusDropdownJs :: Text +statusDropdownJs = + Text.unlines + [ "function toggleStatusDropdown(el) {", + " var container = el.parentElement;", + " var isOpen = container.classList.toggle('open');", + " el.setAttribute('aria-expanded', isOpen);", + " if (isOpen) {", + " var firstItem = container.querySelector('[role=\"menuitem\"]');", + " if (firstItem) firstItem.focus();", + " }", + "}", + "", + "function closeStatusDropdown(container) {", + " container.classList.remove('open');", + " var badge = container.querySelector('[role=\"button\"]');", + " if (badge) {", + " badge.setAttribute('aria-expanded', 'false');", + " badge.focus();", + " }", + "}", + "", + "function handleStatusKeydown(event, el) {", + " if (event.key === 'Enter' || event.key === ' ') {", + " event.preventDefault();", + " toggleStatusDropdown(el);", + " } else if (event.key === 'Escape') {", + " closeStatusDropdown(el.parentElement);", + " } else if (event.key === 'ArrowDown') {", + " event.preventDefault();", + " var container = el.parentElement;", + " if (!container.classList.contains('open')) {", + " toggleStatusDropdown(el);", + " } else {", + " var firstItem = container.querySelector('[role=\"menuitem\"]');", + " if (firstItem) firstItem.focus();", + " }", + " }", + "}", + "", + "function handleMenuItemKeydown(event) {", + " var container = event.target.closest('.status-badge-dropdown');", + " var items = container.querySelectorAll('[role=\"menuitem\"]');", + " var currentIndex = Array.from(items).indexOf(event.target);", + " ", + " if (event.key === 'ArrowDown') {", + " event.preventDefault();", + " var next = (currentIndex + 1) % items.length;", + " items[next].focus();", + " } else if (event.key === 'ArrowUp') {", + " event.preventDefault();", + " var prev = (currentIndex - 1 + items.length) % items.length;", + " items[prev].focus();", + " } else if (event.key === 'Escape') {", + " event.preventDefault();", + " closeStatusDropdown(container);", + " } else if (event.key === 'Tab') {", + " closeStatusDropdown(container);", + " }", + "}", + "", + "document.addEventListener('click', function(e) {", + " var dropdowns = document.querySelectorAll('.status-badge-dropdown.open');", + " dropdowns.forEach(function(d) {", + " if (!d.contains(e.target)) {", + " closeStatusDropdown(d);", + " }", + " });", + "});" + ] + +priorityDropdownJs :: Text +priorityDropdownJs = + Text.unlines + [ "function togglePriorityDropdown(el) {", + " var container = el.parentElement;", + " var isOpen = container.classList.toggle('open');", + " el.setAttribute('aria-expanded', isOpen);", + " if (isOpen) {", + " var firstItem = container.querySelector('[role=\"menuitem\"]');", + " if (firstItem) firstItem.focus();", + " }", + "}", + "", + "function closePriorityDropdown(container) {", + " container.classList.remove('open');", + " var badge = container.querySelector('[role=\"button\"]');", + " if (badge) {", + " badge.setAttribute('aria-expanded', 'false');", + " badge.focus();", + " }", + "}", + "", + "function handlePriorityKeydown(event, el) {", + " if (event.key === 'Enter' || event.key === ' ') {", + " event.preventDefault();", + " togglePriorityDropdown(el);", + " } else if (event.key === 'Escape') {", + " closePriorityDropdown(el.parentElement);", + " } else if (event.key === 'ArrowDown') {", + " event.preventDefault();", + " var container = el.parentElement;", + " if (!container.classList.contains('open')) {", + " togglePriorityDropdown(el);", + " } else {", + " var firstItem = container.querySelector('[role=\"menuitem\"]');", + " if (firstItem) firstItem.focus();", + " }", + " }", + "}", + "", + "function handlePriorityMenuItemKeydown(event) {", + " var container = event.target.closest('.priority-badge-dropdown');", + " var items = container.querySelectorAll('[role=\"menuitem\"]');", + " var currentIndex = Array.from(items).indexOf(event.target);", + " ", + " if (event.key === 'ArrowDown') {", + " event.preventDefault();", + " var next = (currentIndex + 1) % items.length;", + " items[next].focus();", + " } else if (event.key === 'ArrowUp') {", + " event.preventDefault();", + " var prev = (currentIndex - 1 + items.length) % items.length;", + " items[prev].focus();", + " } else if (event.key === 'Escape') {", + " event.preventDefault();", + " closePriorityDropdown(container);", + " } else if (event.key === 'Tab') {", + " closePriorityDropdown(container);", + " }", + "}", + "", + "document.addEventListener('click', function(e) {", + " var dropdowns = document.querySelectorAll('.priority-badge-dropdown.open');", + " dropdowns.forEach(function(d) {", + " if (!d.contains(e.target)) {", + " closePriorityDropdown(d);", + " }", + " });", + "});" + ] + +pageBody :: (Monad m) => Lucid.HtmlT m () -> Lucid.HtmlT m () +pageBody content = + Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do + navbar + content + +data Breadcrumb = Breadcrumb + { _crumbLabel :: Text, + _crumbHref :: Maybe Text + } + +type Breadcrumbs = [Breadcrumb] + +pageBodyWithCrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m () -> Lucid.HtmlT m () +pageBodyWithCrumbs crumbs content = + Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do + navbar + unless (null crumbs) <| do + Lucid.div_ [Lucid.class_ "breadcrumb-container"] <| do + Lucid.div_ [Lucid.class_ "container"] <| renderBreadcrumbs crumbs + content + +renderBreadcrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m () +renderBreadcrumbs [] = pure () +renderBreadcrumbs crumbs = + Lucid.nav_ [Lucid.class_ "breadcrumbs", Lucid.makeAttribute "aria-label" "Breadcrumb"] <| do + Lucid.ol_ [Lucid.class_ "breadcrumb-list"] <| do + traverse_ renderCrumb (zip [0 ..] crumbs) + where + renderCrumb :: (Monad m') => (Int, Breadcrumb) -> Lucid.HtmlT m' () + renderCrumb (idx, Breadcrumb label mHref) = do + Lucid.li_ [Lucid.class_ "breadcrumb-item"] <| do + when (idx > 0) <| Lucid.span_ [Lucid.class_ "breadcrumb-sep"] ">" + case mHref of + Just href -> Lucid.a_ [Lucid.href_ href] (Lucid.toHtml label) + Nothing -> Lucid.span_ [Lucid.class_ "breadcrumb-current"] (Lucid.toHtml label) + +getAncestors :: [TaskCore.Task] -> TaskCore.Task -> [TaskCore.Task] +getAncestors allTasks task = + case TaskCore.taskParent task of + Nothing -> [task] + Just pid -> case TaskCore.findTask pid allTasks of + Nothing -> [task] + Just parent -> getAncestors allTasks parent ++ [task] + +taskBreadcrumbs :: [TaskCore.Task] -> TaskCore.Task -> Breadcrumbs +taskBreadcrumbs allTasks task = + let ancestors = getAncestors allTasks task + taskCrumbs = [Breadcrumb (TaskCore.taskId t) (Just ("/tasks/" <> TaskCore.taskId t)) | t <- List.init ancestors] + currentCrumb = Breadcrumb (TaskCore.taskId task) Nothing + in [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks")] + ++ taskCrumbs + ++ [currentCrumb] + +navbar :: (Monad m) => Lucid.HtmlT m () +navbar = + Lucid.nav_ [Lucid.class_ "navbar"] <| do + Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-brand"] "Jr" + Lucid.input_ + [ Lucid.type_ "checkbox", + Lucid.id_ "navbar-toggle", + Lucid.class_ "navbar-toggle-checkbox" + ] + Lucid.label_ + [ Lucid.for_ "navbar-toggle", + Lucid.class_ "navbar-hamburger" + ] + <| do + Lucid.span_ [Lucid.class_ "hamburger-line"] "" + Lucid.span_ [Lucid.class_ "hamburger-line"] "" + Lucid.span_ [Lucid.class_ "hamburger-line"] "" + Lucid.div_ [Lucid.class_ "navbar-links"] <| do + Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-link"] "Dashboard" + 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"] "Human Action" + 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_ "/epics", 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 () +statusBadge status = + let (cls, label) = case status of + TaskCore.Draft -> ("badge badge-draft", "Draft") + 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 + +sortDropdown :: (Monad m) => Text -> SortOrder -> Lucid.HtmlT m () +sortDropdown basePath currentSort = + Lucid.div_ [Lucid.class_ "sort-dropdown"] <| do + Lucid.span_ [Lucid.class_ "sort-label"] "Sort:" + Lucid.div_ [Lucid.class_ "sort-dropdown-wrapper navbar-dropdown"] <| do + Lucid.button_ [Lucid.class_ "sort-dropdown-btn navbar-dropdown-btn"] + <| Lucid.toHtml (sortOrderLabel currentSort <> " ▾") + Lucid.div_ [Lucid.class_ "sort-dropdown-content navbar-dropdown-content"] <| do + sortOption basePath SortNewest currentSort + sortOption basePath SortOldest currentSort + sortOption basePath SortUpdated currentSort + sortOption basePath SortPriorityHigh currentSort + sortOption basePath SortPriorityLow currentSort + +sortOption :: (Monad m) => Text -> SortOrder -> SortOrder -> Lucid.HtmlT m () +sortOption basePath option currentSort = + let cls = "sort-dropdown-item navbar-dropdown-item" <> if option == currentSort then " active" else "" + href = basePath <> "?sort=" <> sortOrderToParam option + in Lucid.a_ [Lucid.href_ href, Lucid.class_ cls] (Lucid.toHtml (sortOrderLabel option)) + +multiColorProgressBar :: (Monad m) => TaskCore.TaskStats -> Lucid.HtmlT m () +multiColorProgressBar stats = + let total = TaskCore.totalTasks stats + doneCount = TaskCore.doneTasks stats + inProgressCount = TaskCore.inProgressTasks stats + openCount = TaskCore.openTasks stats + TaskCore.reviewTasks stats + TaskCore.approvedTasks stats + donePct = if total == 0 then 0 else (doneCount * 100) `div` total + inProgressPct = if total == 0 then 0 else (inProgressCount * 100) `div` total + openPct = if total == 0 then 0 else (openCount * 100) `div` total + in Lucid.div_ [Lucid.class_ "multi-progress-container"] <| do + Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do + when (donePct > 0) + <| Lucid.div_ + [ Lucid.class_ "multi-progress-segment progress-done", + Lucid.style_ ("width: " <> tshow donePct <> "%"), + Lucid.title_ (tshow doneCount <> " done") + ] + "" + when (inProgressPct > 0) + <| Lucid.div_ + [ Lucid.class_ "multi-progress-segment progress-inprogress", + Lucid.style_ ("width: " <> tshow inProgressPct <> "%"), + Lucid.title_ (tshow inProgressCount <> " in progress") + ] + "" + when (openPct > 0) + <| Lucid.div_ + [ Lucid.class_ "multi-progress-segment progress-open", + Lucid.style_ ("width: " <> tshow openPct <> "%"), + Lucid.title_ (tshow openCount <> " open") + ] + "" + Lucid.div_ [Lucid.class_ "progress-legend"] <| do + Lucid.span_ [Lucid.class_ "legend-item"] <| do + Lucid.span_ [Lucid.class_ "legend-dot legend-done"] "" + Lucid.toHtml ("Done " <> tshow doneCount) + Lucid.span_ [Lucid.class_ "legend-item"] <| do + Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] "" + Lucid.toHtml ("In Progress " <> tshow inProgressCount) + Lucid.span_ [Lucid.class_ "legend-item"] <| do + Lucid.span_ [Lucid.class_ "legend-dot legend-open"] "" + Lucid.toHtml ("Open " <> tshow openCount) + +statusBadgeWithForm :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m () +statusBadgeWithForm status tid = + Lucid.div_ + [ Lucid.id_ "status-badge-container", + Lucid.class_ "status-badge-dropdown" + ] + <| do + clickableBadge status tid + statusDropdownOptions status tid + +clickableBadge :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m () +clickableBadge status _tid = + let (cls, label) = case status of + TaskCore.Draft -> ("badge badge-draft status-badge-clickable", "Draft" :: Text) + TaskCore.Open -> ("badge badge-open status-badge-clickable", "Open") + TaskCore.InProgress -> ("badge badge-inprogress status-badge-clickable", "In Progress") + TaskCore.Review -> ("badge badge-review status-badge-clickable", "Review") + TaskCore.Approved -> ("badge badge-approved status-badge-clickable", "Approved") + TaskCore.Done -> ("badge badge-done status-badge-clickable", "Done") + in Lucid.span_ + [ Lucid.class_ cls, + Lucid.tabindex_ "0", + Lucid.role_ "button", + Lucid.makeAttribute "aria-haspopup" "true", + Lucid.makeAttribute "aria-expanded" "false", + Lucid.makeAttribute "onclick" "toggleStatusDropdown(this)", + Lucid.makeAttribute "onkeydown" "handleStatusKeydown(event, this)" + ] + <| do + Lucid.toHtml label + Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾" + +statusDropdownOptions :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m () +statusDropdownOptions currentStatus tid = + Lucid.div_ + [ Lucid.class_ "status-dropdown-menu", + Lucid.role_ "menu", + Lucid.makeAttribute "aria-label" "Change task status" + ] + <| do + statusOption TaskCore.Draft currentStatus tid + statusOption TaskCore.Open currentStatus tid + statusOption TaskCore.InProgress currentStatus tid + statusOption TaskCore.Review currentStatus tid + statusOption TaskCore.Approved currentStatus tid + statusOption TaskCore.Done currentStatus tid + +statusOption :: (Monad m) => TaskCore.Status -> TaskCore.Status -> Text -> Lucid.HtmlT m () +statusOption opt currentStatus tid = + let (cls, label) = case opt of + TaskCore.Draft -> ("badge badge-draft", "Draft" :: Text) + 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") + isSelected = opt == currentStatus + optClass = cls <> " status-dropdown-option" <> if isSelected then " selected" else "" + in Lucid.form_ + [ Lucid.class_ "status-option-form", + Lucid.role_ "none", + Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/status"), + Lucid.makeAttribute "hx-target" "#status-badge-container", + Lucid.makeAttribute "hx-swap" "outerHTML" + ] + <| do + Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ (tshow opt)] + Lucid.button_ + [ Lucid.type_ "submit", + Lucid.class_ optClass, + Lucid.role_ "menuitem", + Lucid.tabindex_ "-1", + Lucid.makeAttribute "onkeydown" "handleMenuItemKeydown(event)" + ] + (Lucid.toHtml label) + +priorityBadgeWithForm :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m () +priorityBadgeWithForm priority tid = + Lucid.div_ + [ Lucid.id_ "priority-badge-container", + Lucid.class_ "priority-badge-dropdown" + ] + <| do + clickablePriorityBadge priority tid + priorityDropdownOptions priority tid + +clickablePriorityBadge :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m () +clickablePriorityBadge priority _tid = + let (cls, label) = case priority of + TaskCore.P0 -> ("badge badge-p0 priority-badge-clickable", "P0 Critical" :: Text) + TaskCore.P1 -> ("badge badge-p1 priority-badge-clickable", "P1 High") + TaskCore.P2 -> ("badge badge-p2 priority-badge-clickable", "P2 Normal") + TaskCore.P3 -> ("badge badge-p3 priority-badge-clickable", "P3 Low") + TaskCore.P4 -> ("badge badge-p4 priority-badge-clickable", "P4 Defer") + in Lucid.span_ + [ Lucid.class_ cls, + Lucid.tabindex_ "0", + Lucid.role_ "button", + Lucid.makeAttribute "aria-haspopup" "true", + Lucid.makeAttribute "aria-expanded" "false", + Lucid.makeAttribute "onclick" "togglePriorityDropdown(this)", + Lucid.makeAttribute "onkeydown" "handlePriorityKeydown(event, this)" + ] + <| do + Lucid.toHtml label + Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾" + +priorityDropdownOptions :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m () +priorityDropdownOptions currentPriority tid = + Lucid.div_ + [ Lucid.class_ "priority-dropdown-menu", + Lucid.role_ "menu", + Lucid.makeAttribute "aria-label" "Change task priority" + ] + <| do + priorityOption TaskCore.P0 currentPriority tid + priorityOption TaskCore.P1 currentPriority tid + priorityOption TaskCore.P2 currentPriority tid + priorityOption TaskCore.P3 currentPriority tid + priorityOption TaskCore.P4 currentPriority tid + +priorityOption :: (Monad m) => TaskCore.Priority -> TaskCore.Priority -> Text -> Lucid.HtmlT m () +priorityOption opt currentPriority tid = + let (cls, label) = case opt of + TaskCore.P0 -> ("badge badge-p0", "P0 Critical" :: Text) + TaskCore.P1 -> ("badge badge-p1", "P1 High") + TaskCore.P2 -> ("badge badge-p2", "P2 Normal") + TaskCore.P3 -> ("badge badge-p3", "P3 Low") + TaskCore.P4 -> ("badge badge-p4", "P4 Defer") + isSelected = opt == currentPriority + optClass = cls <> " priority-dropdown-option" <> if isSelected then " selected" else "" + in Lucid.form_ + [ Lucid.class_ "priority-option-form", + Lucid.role_ "none", + Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/priority"), + Lucid.makeAttribute "hx-target" "#priority-badge-container", + Lucid.makeAttribute "hx-swap" "outerHTML" + ] + <| do + Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "priority", Lucid.value_ (tshow opt)] + Lucid.button_ + [ Lucid.type_ "submit", + Lucid.class_ optClass, + Lucid.role_ "menuitem", + Lucid.tabindex_ "-1", + Lucid.makeAttribute "onkeydown" "handlePriorityMenuItemKeydown(event)" + ] + (Lucid.toHtml label) + +renderTaskCard :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m () +renderTaskCard 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.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) + Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t)) + +renderBlockedTaskCard :: (Monad m) => (TaskCore.Task, Int) -> Lucid.HtmlT m () +renderBlockedTaskCard (t, impact) = + 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.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) + when (impact > 0) + <| Lucid.span_ [Lucid.class_ "blocking-impact"] (Lucid.toHtml ("Blocks " <> tshow impact)) + Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t)) + +renderListGroupItem :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m () +renderListGroupItem t = + Lucid.a_ + [ Lucid.class_ "list-group-item", + Lucid.href_ ("/tasks/" <> TaskCore.taskId t) + ] + <| do + Lucid.div_ [Lucid.class_ "list-group-item-content"] <| do + Lucid.span_ [Lucid.class_ "list-group-item-id"] (Lucid.toHtml (TaskCore.taskId t)) + Lucid.span_ [Lucid.class_ "list-group-item-title"] (Lucid.toHtml (TaskCore.taskTitle t)) + Lucid.div_ [Lucid.class_ "list-group-item-meta"] <| do + statusBadge (TaskCore.taskStatus t) + Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) + +instance Lucid.ToHtml HomePage where + toHtmlRaw = Lucid.toHtml + toHtml (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics currentRange _now) = + Lucid.doctypehtml_ <| do + pageHead "Jr Dashboard" + pageBody <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.h2_ "Task Status" + Lucid.div_ [Lucid.class_ "time-filter"] <| do + timeFilterBtn "Today" Today currentRange + timeFilterBtn "This Week" Week currentRange + timeFilterBtn "This Month" Month currentRange + timeFilterBtn "All Time" AllTime currentRange + Lucid.div_ [Lucid.class_ "stats-grid"] <| do + statCard "Open" (TaskCore.openTasks stats) "badge-open" "/tasks?status=Open" + statCard "In Progress" (TaskCore.inProgressTasks stats) "badge-inprogress" "/tasks?status=InProgress" + statCard "Review" (TaskCore.reviewTasks stats) "badge-review" "/tasks?status=Review" + statCard "Approved" (TaskCore.approvedTasks stats) "badge-approved" "/tasks?status=Approved" + statCard "Done" (TaskCore.doneTasks stats) "badge-done" "/tasks?status=Done" + metricCard "Cost" (formatCost (TaskCore.aggTotalCostCents globalMetrics)) + metricCard "Duration" (formatDuration (TaskCore.aggTotalDurationSeconds globalMetrics)) + + Lucid.h2_ <| do + "Ready Queue " + Lucid.span_ + [ Lucid.class_ "ready-count", + Lucid.makeAttribute "hx-get" "/partials/ready-count", + Lucid.makeAttribute "hx-trigger" "every 5s" + ] + <| do + 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_ "list-group"] + <| traverse_ renderListGroupItem (take 5 readyTasks) + + Lucid.h2_ "Recent Activity" + let newestTimestamp = maybe 0 taskToUnixTs (head recentTasks) + Lucid.div_ + [ Lucid.class_ "recent-activity", + Lucid.id_ "recent-activity", + Lucid.makeAttribute "data-newest-ts" (tshow newestTimestamp), + Lucid.makeAttribute "hx-get" "/partials/recent-activity-new", + Lucid.makeAttribute "hx-trigger" "every 10s", + Lucid.makeAttribute "hx-vals" "js:{since: this.dataset.newestTs}", + Lucid.makeAttribute "hx-target" "#activity-list", + Lucid.makeAttribute "hx-swap" "afterbegin" + ] + <| do + Lucid.div_ [Lucid.id_ "activity-list", Lucid.class_ "list-group"] + <| traverse_ renderListGroupItem recentTasks + when hasMoreRecent + <| Lucid.button_ + [ Lucid.id_ "activity-load-more", + Lucid.class_ "btn btn-secondary load-more-btn", + Lucid.makeAttribute "hx-get" "/partials/recent-activity-more?offset=5", + Lucid.makeAttribute "hx-target" "#activity-list", + Lucid.makeAttribute "hx-swap" "beforeend" + ] + "Load More" + where + statCard :: (Monad m) => Text -> Int -> Text -> Text -> Lucid.HtmlT m () + statCard label count badgeClass href = + Lucid.a_ [Lucid.href_ href, 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) + + metricCard :: (Monad m) => Text -> Text -> Lucid.HtmlT m () + metricCard label value = + Lucid.div_ [Lucid.class_ "stat-card badge-neutral"] <| do + Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml value) + Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label) + + formatCost :: Int -> Text + formatCost cents = + let dollars = fromIntegral cents / 100.0 :: Double + in Text.pack ("$" <> showFFloat (Just 2) dollars "") + + formatDuration :: Int -> Text + formatDuration totalSeconds + | totalSeconds < 60 = tshow totalSeconds <> "s" + | totalSeconds < 3600 = + let mins = totalSeconds `div` 60 + in tshow mins <> "m" + | otherwise = + let hours = totalSeconds `div` 3600 + mins = (totalSeconds `mod` 3600) `div` 60 + in tshow hours <> "h " <> tshow mins <> "m" + + timeFilterBtn :: (Monad m) => Text -> TimeRange -> TimeRange -> Lucid.HtmlT m () + timeFilterBtn label range current = + let activeClass = if range == current then " active" else "" + href = "/?" <> "range=" <> timeRangeToParam range + in Lucid.a_ + [ Lucid.href_ href, + Lucid.class_ ("time-filter-btn" <> activeClass) + ] + (Lucid.toHtml label) + +instance Lucid.ToHtml ReadyQueuePage where + toHtmlRaw = Lucid.toHtml + toHtml (ReadyQueuePage tasks currentSort _now) = + let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Ready Queue" Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Ready Queue - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.div_ [Lucid.class_ "page-header-row"] <| do + Lucid.h1_ <| Lucid.toHtml ("Ready Queue (" <> tshow (length tasks) <> " tasks)") + sortDropdown "/ready" currentSort + if null tasks + then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks are ready for work." + else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks + +instance Lucid.ToHtml BlockedPage where + toHtmlRaw = Lucid.toHtml + toHtml (BlockedPage tasksWithImpact currentSort _now) = + let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Blocked" Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Blocked Tasks - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.div_ [Lucid.class_ "page-header-row"] <| do + Lucid.h1_ <| Lucid.toHtml ("Blocked Tasks (" <> tshow (length tasksWithImpact) <> " tasks)") + sortDropdown "/blocked" currentSort + Lucid.p_ [Lucid.class_ "info-msg"] "Tasks with unmet blocking dependencies, sorted by blocking impact." + if null tasksWithImpact + then Lucid.p_ [Lucid.class_ "empty-msg"] "No blocked tasks." + else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderBlockedTaskCard tasksWithImpact + +instance Lucid.ToHtml InterventionPage where + toHtmlRaw = Lucid.toHtml + toHtml (InterventionPage actionItems currentSort _now) = + let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Needs Human Action" Nothing] + failed = TaskCore.failedTasks actionItems + epicsReady = TaskCore.epicsInReview actionItems + human = TaskCore.humanTasks actionItems + totalCount = length failed + length epicsReady + length human + in Lucid.doctypehtml_ <| do + pageHead "Needs Human Action - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.div_ [Lucid.class_ "page-header-row"] <| do + Lucid.h1_ <| Lucid.toHtml ("Needs Human Action (" <> tshow totalCount <> " items)") + sortDropdown "/intervention" currentSort + if totalCount == 0 + then Lucid.p_ [Lucid.class_ "empty-msg"] "No items need human action." + else do + unless (null failed) <| do + Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Failed Tasks (" <> tshow (length failed) <> ")") + Lucid.p_ [Lucid.class_ "info-msg"] "Tasks that have failed 3+ times and need human help." + Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (sortTasks currentSort failed) + unless (null epicsReady) <| do + Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Epics Ready for Review (" <> tshow (length epicsReady) <> ")") + Lucid.p_ [Lucid.class_ "info-msg"] "Epics with all children completed. Verify before closing." + Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderEpicReviewCard epicsReady + unless (null human) <| do + Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Human Tasks (" <> tshow (length human) <> ")") + Lucid.p_ [Lucid.class_ "info-msg"] "Tasks explicitly marked as needing human work." + Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (sortTasks currentSort human) + +renderEpicReviewCard :: (Monad m) => TaskCore.EpicForReview -> Lucid.HtmlT m () +renderEpicReviewCard epicReview = do + let task = TaskCore.epicTask epicReview + total = TaskCore.epicTotal epicReview + completed = TaskCore.epicCompleted epicReview + progressText = tshow completed <> "/" <> tshow total <> " subtasks done" + Lucid.div_ [Lucid.class_ "task-card"] <| do + Lucid.div_ [Lucid.class_ "task-card-header"] <| do + Lucid.div_ [Lucid.class_ "task-title-row"] <| do + Lucid.a_ + [Lucid.href_ ("/tasks/" <> TaskCore.taskId task), Lucid.class_ "task-link"] + <| Lucid.toHtml (TaskCore.taskTitle task) + Lucid.span_ [Lucid.class_ "badge badge-epic"] "Epic" + Lucid.span_ [Lucid.class_ "task-id"] <| Lucid.toHtml (TaskCore.taskId task) + Lucid.div_ [Lucid.class_ "task-card-body"] <| do + Lucid.div_ [Lucid.class_ "progress-info"] <| do + Lucid.span_ [Lucid.class_ "badge badge-success"] <| Lucid.toHtml progressText + Lucid.div_ [Lucid.class_ "epic-actions"] <| do + Lucid.form_ + [ Lucid.method_ "POST", + Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/status"), + Lucid.class_ "inline-form" + ] + <| do + Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ "done"] + Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-success btn-sm"] "Approve & Close" + +instance Lucid.ToHtml KBPage where + toHtmlRaw = Lucid.toHtml + toHtml (KBPage facts) = + let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Knowledge Base - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.h1_ "Knowledge Base" + Lucid.p_ [Lucid.class_ "info-msg"] "Facts learned during task execution." + + Lucid.details_ [Lucid.class_ "create-fact-section"] <| do + Lucid.summary_ [Lucid.class_ "btn btn-primary create-fact-toggle"] "Create New Fact" + Lucid.form_ + [ Lucid.method_ "POST", + Lucid.action_ "/kb/create", + Lucid.class_ "fact-create-form" + ] + <| do + Lucid.div_ [Lucid.class_ "form-group"] <| do + Lucid.label_ [Lucid.for_ "project"] "Project:" + Lucid.input_ + [ Lucid.type_ "text", + Lucid.name_ "project", + Lucid.id_ "project", + Lucid.class_ "form-input", + Lucid.required_ "required", + Lucid.placeholder_ "e.g., Omni/Jr" + ] + Lucid.div_ [Lucid.class_ "form-group"] <| do + Lucid.label_ [Lucid.for_ "content"] "Fact Content:" + Lucid.textarea_ + [ Lucid.name_ "content", + Lucid.id_ "content", + Lucid.class_ "form-textarea", + Lucid.rows_ "4", + Lucid.required_ "required", + Lucid.placeholder_ "Describe the fact or knowledge..." + ] + "" + Lucid.div_ [Lucid.class_ "form-group"] <| do + Lucid.label_ [Lucid.for_ "files"] "Related Files (comma-separated):" + Lucid.input_ + [ Lucid.type_ "text", + Lucid.name_ "files", + Lucid.id_ "files", + Lucid.class_ "form-input", + Lucid.placeholder_ "path/to/file1.hs, path/to/file2.hs" + ] + Lucid.div_ [Lucid.class_ "form-group"] <| do + Lucid.label_ [Lucid.for_ "confidence"] "Confidence (0.0 - 1.0):" + Lucid.input_ + [ Lucid.type_ "number", + Lucid.name_ "confidence", + Lucid.id_ "confidence", + Lucid.class_ "form-input", + Lucid.step_ "0.1", + Lucid.min_ "0", + Lucid.max_ "1", + Lucid.value_ "0.8" + ] + Lucid.div_ [Lucid.class_ "form-actions"] <| do + Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Create Fact" + + if null facts + then Lucid.p_ [Lucid.class_ "empty-msg"] "No facts recorded yet." + else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderFactCard facts + where + renderFactCard :: (Monad m) => TaskCore.Fact -> Lucid.HtmlT m () + renderFactCard f = + let factUrl = "/kb/" <> maybe "-" tshow (TaskCore.factId f) + in Lucid.a_ + [ Lucid.class_ "task-card task-card-link", + Lucid.href_ factUrl + ] + <| do + Lucid.div_ [Lucid.class_ "task-header"] <| do + Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (maybe "-" tshow (TaskCore.factId f))) + confidenceBadge (TaskCore.factConfidence f) + Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (TaskCore.factProject f)) + Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (Text.take 80 (TaskCore.factContent f) <> if Text.length (TaskCore.factContent f) > 80 then "..." else "")) + unless (null (TaskCore.factRelatedFiles f)) <| do + Lucid.p_ [Lucid.class_ "kb-files"] <| do + Lucid.span_ [Lucid.class_ "files-label"] "Files: " + Lucid.toHtml (Text.intercalate ", " (take 3 (TaskCore.factRelatedFiles f))) + when (length (TaskCore.factRelatedFiles f) > 3) <| do + Lucid.toHtml (" +" <> tshow (length (TaskCore.factRelatedFiles f) - 3) <> " more") + + confidenceBadge :: (Monad m) => Double -> Lucid.HtmlT m () + confidenceBadge conf = + let pct = floor (conf * 100) :: Int + cls + | conf >= 0.8 = "badge badge-done" + | conf >= 0.5 = "badge badge-inprogress" + | otherwise = "badge badge-open" + in Lucid.span_ [Lucid.class_ cls] (Lucid.toHtml (tshow pct <> "%")) + +instance Lucid.ToHtml FactDetailPage where + toHtmlRaw = Lucid.toHtml + toHtml (FactDetailNotFound fid) = + let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" (Just "/kb"), Breadcrumb ("Fact #" <> tshow fid) Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Fact Not Found - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.h1_ "Fact Not Found" + Lucid.p_ [Lucid.class_ "error-msg"] (Lucid.toHtml ("Fact with ID " <> tshow fid <> " not found.")) + Lucid.a_ [Lucid.href_ "/kb", Lucid.class_ "btn btn-secondary"] "Back to Knowledge Base" + toHtml (FactDetailFound fact now) = + let fid' = maybe "-" tshow (TaskCore.factId fact) + crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" (Just "/kb"), Breadcrumb ("Fact #" <> fid') Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Fact Detail - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.div_ [Lucid.class_ "task-detail-header"] <| do + Lucid.h1_ <| do + Lucid.span_ [Lucid.class_ "detail-id"] (Lucid.toHtml ("Fact #" <> maybe "-" tshow (TaskCore.factId fact))) + Lucid.div_ [Lucid.class_ "task-meta-row"] <| do + Lucid.span_ [Lucid.class_ "meta-label"] "Project:" + Lucid.span_ [Lucid.class_ "meta-value"] (Lucid.toHtml (TaskCore.factProject fact)) + Lucid.span_ [Lucid.class_ "meta-label"] "Confidence:" + confidenceBadgeDetail (TaskCore.factConfidence fact) + Lucid.span_ [Lucid.class_ "meta-label"] "Created:" + Lucid.span_ [Lucid.class_ "meta-value"] (renderRelativeTimestamp now (TaskCore.factCreatedAt fact)) + + Lucid.div_ [Lucid.class_ "detail-section"] <| do + Lucid.h2_ "Content" + Lucid.form_ + [ Lucid.method_ "POST", + Lucid.action_ ("/kb/" <> maybe "-" tshow (TaskCore.factId fact) <> "/edit"), + Lucid.class_ "fact-edit-form" + ] + <| do + Lucid.div_ [Lucid.class_ "form-group"] <| do + Lucid.label_ [Lucid.for_ "content"] "Fact Content:" + Lucid.textarea_ + [ Lucid.name_ "content", + Lucid.id_ "content", + Lucid.class_ "form-textarea", + Lucid.rows_ "6" + ] + (Lucid.toHtml (TaskCore.factContent fact)) + + Lucid.div_ [Lucid.class_ "form-group"] <| do + Lucid.label_ [Lucid.for_ "files"] "Related Files (comma-separated):" + Lucid.input_ + [ Lucid.type_ "text", + Lucid.name_ "files", + Lucid.id_ "files", + Lucid.class_ "form-input", + Lucid.value_ (Text.intercalate ", " (TaskCore.factRelatedFiles fact)) + ] + + Lucid.div_ [Lucid.class_ "form-group"] <| do + Lucid.label_ [Lucid.for_ "confidence"] "Confidence (0.0 - 1.0):" + Lucid.input_ + [ Lucid.type_ "number", + Lucid.name_ "confidence", + Lucid.id_ "confidence", + Lucid.class_ "form-input", + Lucid.step_ "0.1", + Lucid.min_ "0", + Lucid.max_ "1", + Lucid.value_ (tshow (TaskCore.factConfidence fact)) + ] + + Lucid.div_ [Lucid.class_ "form-actions"] <| do + Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Save Changes" + + case TaskCore.factSourceTask fact of + Nothing -> pure () + Just tid -> do + Lucid.div_ [Lucid.class_ "detail-section"] <| do + Lucid.h2_ "Source Task" + Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "task-link"] (Lucid.toHtml tid) + + Lucid.div_ [Lucid.class_ "detail-section danger-zone"] <| do + Lucid.h2_ "Danger Zone" + Lucid.form_ + [ Lucid.method_ "POST", + Lucid.action_ ("/kb/" <> maybe "-" tshow (TaskCore.factId fact) <> "/delete"), + Lucid.class_ "delete-form", + Lucid.makeAttribute "onsubmit" "return confirm('Are you sure you want to delete this fact?');" + ] + <| do + Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-danger"] "Delete Fact" + + Lucid.div_ [Lucid.class_ "back-link"] <| do + Lucid.a_ [Lucid.href_ "/kb"] "← Back to Knowledge Base" + where + confidenceBadgeDetail :: (Monad m) => Double -> Lucid.HtmlT m () + confidenceBadgeDetail conf = + let pct = floor (conf * 100) :: Int + cls + | conf >= 0.8 = "badge badge-done" + | conf >= 0.5 = "badge badge-inprogress" + | otherwise = "badge badge-open" + in Lucid.span_ [Lucid.class_ cls] (Lucid.toHtml (tshow pct <> "%")) + +instance Lucid.ToHtml EpicsPage where + toHtmlRaw = Lucid.toHtml + toHtml (EpicsPage epics allTasks currentSort) = + let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Epics" Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Epics - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.div_ [Lucid.class_ "page-header-row"] <| do + Lucid.h1_ <| Lucid.toHtml ("Epics (" <> tshow (length epics) <> ")") + sortDropdown "/epics" currentSort + Lucid.p_ [Lucid.class_ "info-msg"] "All epics (large, multi-task projects)." + if null epics + then Lucid.p_ [Lucid.class_ "empty-msg"] "No epics found." + else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ (renderEpicCardWithStats allTasks) epics + +epicProgressBar :: (Monad m) => Int -> Int -> Int -> Int -> Lucid.HtmlT m () +epicProgressBar doneCount inProgressCount openCount totalCount = + let donePct = if totalCount == 0 then 0 else (doneCount * 100) `div` totalCount + inProgressPct = if totalCount == 0 then 0 else (inProgressCount * 100) `div` totalCount + openPct = if totalCount == 0 then 0 else (openCount * 100) `div` totalCount + in Lucid.div_ [Lucid.class_ "multi-progress-container epic-progress"] <| do + Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do + when (donePct > 0) + <| Lucid.div_ + [ Lucid.class_ "multi-progress-segment progress-done", + Lucid.style_ ("width: " <> tshow donePct <> "%"), + Lucid.title_ (tshow doneCount <> " done") + ] + "" + when (inProgressPct > 0) + <| Lucid.div_ + [ Lucid.class_ "multi-progress-segment progress-inprogress", + Lucid.style_ ("width: " <> tshow inProgressPct <> "%"), + Lucid.title_ (tshow inProgressCount <> " in progress") + ] + "" + when (openPct > 0) + <| Lucid.div_ + [ Lucid.class_ "multi-progress-segment progress-open", + Lucid.style_ ("width: " <> tshow openPct <> "%"), + Lucid.title_ (tshow openCount <> " open") + ] + "" + Lucid.div_ [Lucid.class_ "progress-legend"] <| do + Lucid.span_ [Lucid.class_ "legend-item"] <| do + Lucid.span_ [Lucid.class_ "legend-dot legend-done"] "" + Lucid.toHtml (tshow doneCount) + Lucid.span_ [Lucid.class_ "legend-item"] <| do + Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] "" + Lucid.toHtml (tshow inProgressCount) + Lucid.span_ [Lucid.class_ "legend-item"] <| do + Lucid.span_ [Lucid.class_ "legend-dot legend-open"] "" + Lucid.toHtml (tshow openCount) + +renderEpicCardWithStats :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> Lucid.HtmlT m () +renderEpicCardWithStats allTasks t = + let children = getDescendants allTasks (TaskCore.taskId t) + openCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Open] + inProgressCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.InProgress] + reviewCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Review] + doneCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Done] + totalCount = length children + openAndReview = openCount + reviewCount + in 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.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) + Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t)) + when (totalCount > 0) <| epicProgressBar doneCount inProgressCount openAndReview totalCount + unless (Text.null (TaskCore.taskDescription t)) + <| Lucid.p_ [Lucid.class_ "kb-preview"] (Lucid.toHtml (Text.take 200 (TaskCore.taskDescription t) <> "...")) + +getDescendants :: [TaskCore.Task] -> Text -> [TaskCore.Task] +getDescendants allTasks parentId = + let children = [c | c <- allTasks, maybe False (TaskCore.matchesId parentId) (TaskCore.taskParent c)] + in children ++ concatMap (getDescendants allTasks <. TaskCore.taskId) children + +instance Lucid.ToHtml TaskListPage where + toHtmlRaw = Lucid.toHtml + toHtml (TaskListPage tasks filters currentSort _now) = + let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Tasks - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.div_ [Lucid.class_ "page-header-row"] <| do + Lucid.h1_ <| Lucid.toHtml ("Tasks (" <> tshow (length tasks) <> ")") + sortDropdown "/tasks" currentSort + + Lucid.div_ [Lucid.class_ "filter-form"] <| do + 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", + Lucid.makeAttribute "hx-get" "/partials/task-list", + Lucid.makeAttribute "hx-target" "#task-list", + Lucid.makeAttribute "hx-push-url" "/tasks" + ] + "Clear" + + 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_ "list-group"] <| traverse_ renderListGroupItem 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)) + +instance Lucid.ToHtml TaskDetailPage where + toHtmlRaw = Lucid.toHtml + toHtml (TaskDetailNotFound tid) = + let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Task Not Found - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.h1_ "Task Not Found" + Lucid.p_ <| do + "The task " + Lucid.code_ (Lucid.toHtml tid) + " could not be found." + toHtml (TaskDetailFound task allTasks activities maybeRetry commits maybeAggMetrics now) = + let crumbs = taskBreadcrumbs allTasks task + in Lucid.doctypehtml_ <| do + pageHead (TaskCore.taskId task <> " - Jr") + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.h1_ <| Lucid.toHtml (TaskCore.taskTitle task) + + renderRetryContextBanner (TaskCore.taskId task) maybeRetry + + Lucid.div_ [Lucid.class_ "task-detail"] <| do + Lucid.div_ [Lucid.class_ "task-meta"] <| do + Lucid.div_ [Lucid.class_ "task-meta-primary"] <| do + Lucid.code_ [Lucid.class_ "task-meta-id"] (Lucid.toHtml (TaskCore.taskId task)) + metaSep + Lucid.span_ [Lucid.class_ "task-meta-type"] (Lucid.toHtml (tshow (TaskCore.taskType task))) + metaSep + statusBadgeWithForm (TaskCore.taskStatus task) (TaskCore.taskId task) + metaSep + priorityBadgeWithForm (TaskCore.taskPriority task) (TaskCore.taskId task) + case TaskCore.taskNamespace task of + Nothing -> pure () + Just ns -> do + metaSep + Lucid.span_ [Lucid.class_ "task-meta-ns"] (Lucid.toHtml ns) + + Lucid.div_ [Lucid.class_ "task-meta-secondary"] <| do + case TaskCore.taskParent task of + Nothing -> pure () + Just pid -> do + Lucid.span_ [Lucid.class_ "task-meta-label"] "Parent:" + Lucid.a_ [Lucid.href_ ("/tasks/" <> pid), Lucid.class_ "task-link"] (Lucid.toHtml pid) + metaSep + Lucid.span_ [Lucid.class_ "task-meta-label"] "Created" + renderRelativeTimestamp now (TaskCore.taskCreatedAt task) + metaSep + Lucid.span_ [Lucid.class_ "task-meta-label"] "Updated" + renderRelativeTimestamp now (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 + + when (TaskCore.taskType task == TaskCore.Epic) <| do + for_ maybeAggMetrics (renderAggregatedMetrics allTasks task) + + Lucid.div_ [Lucid.class_ "detail-section"] <| do + Lucid.toHtml (DescriptionViewPartial (TaskCore.taskId task) (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic)) + + let comments = TaskCore.taskComments task + Lucid.div_ [Lucid.class_ "detail-section comments-section"] <| do + Lucid.h3_ (Lucid.toHtml ("Comments (" <> tshow (length comments) <> ")")) + if null comments + then Lucid.p_ [Lucid.class_ "empty-msg"] "No comments yet." + else traverse_ (renderComment now) comments + commentForm (TaskCore.taskId task) + + 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 + + unless (null commits) <| do + Lucid.div_ [Lucid.class_ "detail-section"] <| do + Lucid.h3_ "Git Commits" + Lucid.div_ [Lucid.class_ "commit-list"] <| do + traverse_ (renderCommit (TaskCore.taskId task)) commits + + let hasRunningActivity = any (\a -> TaskCore.activityStage a == TaskCore.Running) activities + when hasRunningActivity <| do + let isInProgress = TaskCore.taskStatus task == TaskCore.InProgress + htmxAttrs = + [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> TaskCore.taskId task <> "/metrics"), + Lucid.makeAttribute "hx-trigger" "every 5s", + Lucid.makeAttribute "hx-swap" "innerHTML" + ] + sectionAttrs = + [Lucid.class_ "execution-section", Lucid.id_ "execution-details"] + <> [attr | isInProgress, attr <- htmxAttrs] + Lucid.div_ sectionAttrs <| do + Lucid.h3_ "Execution Details" + renderExecutionDetails (TaskCore.taskId task) activities maybeRetry + + when (TaskCore.taskStatus task == TaskCore.InProgress && not (null activities)) <| do + Lucid.div_ [Lucid.class_ "activity-section"] <| do + Lucid.h3_ "Activity Timeline" + Lucid.div_ [Lucid.class_ "activity-timeline"] <| do + traverse_ renderActivity activities + + 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" + where + 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) <> "]") + + renderComment :: (Monad m) => UTCTime -> TaskCore.Comment -> Lucid.HtmlT m () + renderComment currentTime c = + Lucid.div_ [Lucid.class_ "comment-card"] <| do + Lucid.p_ [Lucid.class_ "comment-text"] (Lucid.toHtml (TaskCore.commentText c)) + Lucid.span_ [Lucid.class_ "comment-time"] (renderRelativeTimestamp currentTime (TaskCore.commentCreatedAt c)) + + commentForm :: (Monad m) => Text -> Lucid.HtmlT m () + commentForm tid = + Lucid.form_ + [ Lucid.method_ "POST", + Lucid.action_ ("/tasks/" <> tid <> "/comment"), + Lucid.class_ "comment-form" + ] + <| do + Lucid.textarea_ + [ Lucid.name_ "comment", + Lucid.placeholder_ "Add a comment...", + Lucid.rows_ "3", + Lucid.class_ "comment-textarea" + ] + "" + Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Post Comment" + + renderCommit :: (Monad m) => Text -> GitCommit -> Lucid.HtmlT m () + renderCommit tid c = + Lucid.div_ [Lucid.class_ "commit-item"] <| do + Lucid.div_ [Lucid.class_ "commit-header"] <| do + Lucid.a_ + [ Lucid.href_ ("/tasks/" <> tid <> "/diff/" <> commitHash c), + Lucid.class_ "commit-hash" + ] + (Lucid.toHtml (commitShortHash c)) + Lucid.span_ [Lucid.class_ "commit-summary"] (Lucid.toHtml (commitSummary c)) + Lucid.div_ [Lucid.class_ "commit-meta"] <| do + Lucid.span_ [Lucid.class_ "commit-author"] (Lucid.toHtml (commitAuthor c)) + Lucid.span_ [Lucid.class_ "commit-date"] (Lucid.toHtml (commitRelativeDate c)) + Lucid.span_ [Lucid.class_ "commit-files"] (Lucid.toHtml (tshow (commitFilesChanged c) <> " files")) + + renderActivity :: (Monad m) => TaskCore.TaskActivity -> Lucid.HtmlT m () + renderActivity act = + Lucid.div_ [Lucid.class_ ("activity-item " <> stageClass (TaskCore.activityStage act))] <| do + Lucid.div_ [Lucid.class_ "activity-icon"] (stageIcon (TaskCore.activityStage act)) + Lucid.div_ [Lucid.class_ "activity-content"] <| do + Lucid.div_ [Lucid.class_ "activity-header"] <| do + Lucid.span_ [Lucid.class_ "activity-stage"] (Lucid.toHtml (tshow (TaskCore.activityStage act))) + Lucid.span_ [Lucid.class_ "activity-time"] (renderRelativeTimestamp now (TaskCore.activityTimestamp act)) + case TaskCore.activityMessage act of + Nothing -> pure () + Just msg -> Lucid.p_ [Lucid.class_ "activity-message"] (Lucid.toHtml msg) + case TaskCore.activityMetadata act of + Nothing -> pure () + Just meta -> + Lucid.details_ [Lucid.class_ "activity-metadata"] <| do + Lucid.summary_ "Metadata" + Lucid.pre_ [Lucid.class_ "metadata-json"] (Lucid.toHtml meta) + + stageClass :: TaskCore.ActivityStage -> Text + stageClass stage = case stage of + TaskCore.Claiming -> "stage-claiming" + TaskCore.Running -> "stage-running" + TaskCore.Reviewing -> "stage-reviewing" + TaskCore.Retrying -> "stage-retrying" + TaskCore.Completed -> "stage-completed" + TaskCore.Failed -> "stage-failed" + + stageIcon :: (Monad m) => TaskCore.ActivityStage -> Lucid.HtmlT m () + stageIcon stage = case stage of + TaskCore.Claiming -> "●" + TaskCore.Running -> "▶" + TaskCore.Reviewing -> "◎" + TaskCore.Retrying -> "↻" + TaskCore.Completed -> "✓" + TaskCore.Failed -> "✗" + + renderExecutionDetails :: (Monad m) => Text -> [TaskCore.TaskActivity] -> Maybe TaskCore.RetryContext -> Lucid.HtmlT m () + renderExecutionDetails _ acts retryCtx = + let runningActs = filter (\a -> TaskCore.activityStage a == TaskCore.Running) acts + in if null runningActs + then Lucid.p_ [Lucid.class_ "empty-msg"] "No worker execution data available." + else + Lucid.div_ [Lucid.class_ "execution-details"] <| do + let totalCost = sum [c | act <- runningActs, Just c <- [TaskCore.activityCostCents act]] + totalDuration = sum [calcDurSecs act | act <- runningActs] + attemptCount = length runningActs + + case retryCtx of + Nothing -> pure () + Just ctx -> + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Retry Attempt:" + Lucid.span_ [Lucid.class_ "metric-value retry-count"] (Lucid.toHtml (tshow (TaskCore.retryAttempt ctx) <> "/3")) + + when (attemptCount > 1) <| do + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Total Attempts:" + Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow attemptCount)) + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Total Duration:" + Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDurSecs totalDuration)) + when (totalCost > 0) + <| Lucid.div_ [Lucid.class_ "metric-row"] + <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Total Cost:" + Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCostVal totalCost)) + Lucid.hr_ [Lucid.class_ "attempts-divider"] + + traverse_ (renderAttempt attemptCount) (zip [1 ..] (reverse runningActs)) + where + calcDurSecs :: TaskCore.TaskActivity -> Int + calcDurSecs act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of + (Just start, Just end) -> floor (diffUTCTime end start) + _ -> 0 + + formatDurSecs :: Int -> Text + formatDurSecs secs + | secs < 60 = tshow secs <> "s" + | secs < 3600 = tshow (secs `div` 60) <> "m " <> tshow (secs `mod` 60) <> "s" + | otherwise = tshow (secs `div` 3600) <> "h " <> tshow ((secs `mod` 3600) `div` 60) <> "m" + + renderAttempt :: (Monad m) => Int -> (Int, TaskCore.TaskActivity) -> Lucid.HtmlT m () + renderAttempt totalAttempts (attemptNum, act) = do + when (totalAttempts > 1) + <| Lucid.div_ [Lucid.class_ "attempt-header"] (Lucid.toHtml ("Attempt " <> tshow attemptNum :: Text)) + case TaskCore.activityThreadUrl act of + Nothing -> pure () + Just url -> + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Session:" + Lucid.a_ [Lucid.href_ url, Lucid.target_ "_blank", Lucid.class_ "amp-thread-btn"] "View in Amp ↗" + + case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of + (Just start, Just end) -> + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Duration:" + Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDur start end)) + (Just start, Nothing) -> + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Started:" + Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp now start) + _ -> pure () + + case TaskCore.activityCostCents act of + Nothing -> pure () + Just cents -> + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Cost:" + Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCostVal cents)) + + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Timestamp:" + Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp now (TaskCore.activityTimestamp act)) + + formatDur :: UTCTime -> UTCTime -> Text + formatDur start end = + let diffSecs = floor (diffUTCTime end start) :: Int + mins = diffSecs `div` 60 + secs = diffSecs `mod` 60 + in if mins > 0 + then tshow mins <> "m " <> tshow secs <> "s" + else tshow secs <> "s" + + formatCostVal :: Int -> Text + formatCostVal cents = + let dollars = fromIntegral cents / 100.0 :: Double + in "$" <> Text.pack (showFFloat (Just 2) dollars "") + +renderAggregatedMetrics :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> TaskCore.AggregatedMetrics -> Lucid.HtmlT m () +renderAggregatedMetrics allTasks task metrics = + let descendants = getDescendants allTasks (TaskCore.taskId task) + totalCount = length descendants + costCents = TaskCore.aggTotalCostCents metrics + durationSecs = TaskCore.aggTotalDurationSeconds metrics + completedCount = TaskCore.aggCompletedTasks metrics + tokensUsed = TaskCore.aggTotalTokens metrics + in Lucid.div_ [Lucid.class_ "detail-section aggregated-metrics"] <| do + Lucid.h3_ "Execution Summary" + Lucid.div_ [Lucid.class_ "metrics-grid"] <| do + Lucid.div_ [Lucid.class_ "metric-card"] <| do + Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow completedCount <> "/" <> tshow totalCount)) + Lucid.div_ [Lucid.class_ "metric-label"] "Tasks Completed" + Lucid.div_ [Lucid.class_ "metric-card"] <| do + Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost costCents)) + Lucid.div_ [Lucid.class_ "metric-label"] "Total Cost" + Lucid.div_ [Lucid.class_ "metric-card"] <| do + Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDuration durationSecs)) + Lucid.div_ [Lucid.class_ "metric-label"] "Total Time" + when (tokensUsed > 0) <| do + Lucid.div_ [Lucid.class_ "metric-card"] <| do + Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatTokens tokensUsed)) + Lucid.div_ [Lucid.class_ "metric-label"] "Tokens Used" + where + formatCost :: Int -> Text + formatCost cents = + let dollars = fromIntegral cents / 100.0 :: Double + in "$" <> Text.pack (showFFloat (Just 2) dollars "") + + formatDuration :: Int -> Text + formatDuration secs + | secs < 60 = tshow secs <> "s" + | secs < 3600 = + let mins = secs `div` 60 + remSecs = secs `mod` 60 + in tshow mins <> "m " <> tshow remSecs <> "s" + | otherwise = + let hrs = secs `div` 3600 + mins = (secs `mod` 3600) `div` 60 + in tshow hrs <> "h " <> tshow mins <> "m" + + formatTokens :: Int -> Text + formatTokens t + | t < 1000 = tshow t + | t < 1000000 = Text.pack (showFFloat (Just 1) (fromIntegral t / 1000.0 :: Double) "") <> "K" + | otherwise = Text.pack (showFFloat (Just 2) (fromIntegral t / 1000000.0 :: Double) "") <> "M" + +renderRetryContextBanner :: (Monad m) => Text -> Maybe TaskCore.RetryContext -> Lucid.HtmlT m () +renderRetryContextBanner _ Nothing = pure () +renderRetryContextBanner tid (Just ctx) = + Lucid.div_ [Lucid.class_ bannerClass] <| do + Lucid.div_ [Lucid.class_ "retry-banner-header"] <| do + Lucid.span_ [Lucid.class_ "retry-icon"] retryIcon + Lucid.span_ [Lucid.class_ "retry-attempt"] (Lucid.toHtml attemptText) + when maxRetriesExceeded + <| Lucid.span_ [Lucid.class_ "retry-warning-badge"] "Needs Human Intervention" + + Lucid.div_ [Lucid.class_ "retry-banner-details"] <| do + Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do + Lucid.span_ [Lucid.class_ "retry-label"] "Failure Reason:" + Lucid.span_ [Lucid.class_ "retry-value"] (Lucid.toHtml (summarizeReason (TaskCore.retryReason ctx))) + + let commit = TaskCore.retryOriginalCommit ctx + unless (Text.null commit) <| do + Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do + Lucid.span_ [Lucid.class_ "retry-label"] "Original Commit:" + Lucid.code_ [Lucid.class_ "retry-commit"] (Lucid.toHtml (Text.take 8 commit)) + + let conflicts = TaskCore.retryConflictFiles ctx + unless (null conflicts) <| do + Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do + Lucid.span_ [Lucid.class_ "retry-label"] "Conflict Files:" + Lucid.ul_ [Lucid.class_ "retry-conflict-list"] + <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflicts + + when maxRetriesExceeded <| do + Lucid.div_ + [Lucid.class_ "retry-warning-message"] + "This task has exceeded the maximum number of retries. A human must review the failure and either fix the issue manually or reset the retry count." + + Lucid.p_ [Lucid.class_ "retry-hint"] "Use comments below to provide guidance for retry." + + Lucid.div_ [Lucid.class_ "retry-reset-section"] <| do + Lucid.h4_ "Reset Retries" + Lucid.p_ [Lucid.class_ "notes-help"] "Clear retry context and give task a fresh start:" + Lucid.form_ [Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> tid <> "/reset-retries")] <| do + Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reset-btn"] "Reset Retries" + where + attempt = TaskCore.retryAttempt ctx + maxRetriesExceeded = attempt >= 3 + bannerClass = if maxRetriesExceeded then "retry-banner retry-banner-critical" else "retry-banner retry-banner-warning" + retryIcon = if maxRetriesExceeded then "⚠" else "↻" + attemptText = "Attempt " <> tshow attempt <> " of 3" + + summarizeReason :: Text -> Text + summarizeReason reason + | "rejected:" `Text.isPrefixOf` reason = "Rejected: " <> Text.strip (Text.drop 9 reason) + | "Test failure:" `Text.isPrefixOf` reason = "Test failure (see details below)" + | "MERGE CONFLICT" `Text.isPrefixOf` reason = "Merge conflict with concurrent changes" + | otherwise = Text.take 100 reason <> if Text.length reason > 100 then "..." else "" + +instance Lucid.ToHtml TaskReviewPage where + toHtmlRaw = Lucid.toHtml + toHtml (ReviewPageNotFound tid) = + let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb "Review" Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Task Not Found - Jr Review" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.h1_ "Task Not Found" + Lucid.p_ <| do + "The task " + Lucid.code_ (Lucid.toHtml tid) + " could not be found." + toHtml (ReviewPageFound task reviewInfo) = + let tid = TaskCore.taskId task + crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb "Review" Nothing] + in Lucid.doctypehtml_ <| do + pageHead ("Review: " <> TaskCore.taskId task <> " - Jr") + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + 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 -> + 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 -> + 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" + +instance Lucid.ToHtml TaskDiffPage where + toHtmlRaw = Lucid.toHtml + toHtml (DiffPageNotFound tid commitHash') = + let shortHash = Text.take 8 commitHash' + crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb ("Diff " <> shortHash) Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Commit Not Found - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.h1_ "Commit Not Found" + Lucid.p_ <| do + "Could not find commit " + Lucid.code_ (Lucid.toHtml commitHash') + Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "back-link"] "← Back to task" + toHtml (DiffPageFound tid commitHash' diffOutput) = + let shortHash = Text.take 8 commitHash' + crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb ("Diff " <> shortHash) Nothing] + in Lucid.doctypehtml_ <| do + pageHead ("Diff " <> shortHash <> " - Jr") + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.div_ [Lucid.class_ "diff-header"] <| do + Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "back-link"] "← Back to task" + Lucid.h1_ <| do + "Commit " + Lucid.code_ (Lucid.toHtml shortHash) + Lucid.pre_ [Lucid.class_ "diff-block"] (Lucid.toHtml diffOutput) + +instance Lucid.ToHtml StatsPage where + toHtmlRaw = Lucid.toHtml + toHtml (StatsPage stats maybeEpic) = + let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Stats" Nothing] + in Lucid.doctypehtml_ <| do + pageHead "Task Statistics - Jr" + pageBodyWithCrumbs crumbs <| do + Lucid.div_ [Lucid.class_ "container"] <| do + Lucid.h1_ <| case maybeEpic of + Nothing -> "Task Statistics" + Just epicId -> Lucid.toHtml ("Statistics for Epic: " <> epicId) + + Lucid.form_ [Lucid.method_ "GET", Lucid.action_ "/stats", Lucid.class_ "filter-form"] <| do + Lucid.div_ [Lucid.class_ "filter-row"] <| do + Lucid.div_ [Lucid.class_ "filter-group"] <| do + Lucid.label_ [Lucid.for_ "epic"] "Epic:" + Lucid.input_ + [ Lucid.type_ "text", + Lucid.name_ "epic", + Lucid.id_ "epic", + Lucid.class_ "filter-input", + Lucid.placeholder_ "Epic ID (optional)", + Lucid.value_ (fromMaybe "" maybeEpic) + ] + Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter" + Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "clear-btn"] "Clear" + + Lucid.h2_ "By Status" + multiColorProgressBar stats + Lucid.div_ [Lucid.class_ "stats-grid"] <| do + statCard "Open" (TaskCore.openTasks stats) (TaskCore.totalTasks stats) + statCard "In Progress" (TaskCore.inProgressTasks stats) (TaskCore.totalTasks stats) + statCard "Review" (TaskCore.reviewTasks stats) (TaskCore.totalTasks stats) + statCard "Approved" (TaskCore.approvedTasks stats) (TaskCore.totalTasks stats) + statCard "Done" (TaskCore.doneTasks stats) (TaskCore.totalTasks stats) + + Lucid.h2_ "By Priority" + Lucid.div_ [Lucid.class_ "stats-section"] <| do + traverse_ (uncurry renderPriorityRow) (TaskCore.tasksByPriority stats) + + Lucid.h2_ "By Namespace" + Lucid.div_ [Lucid.class_ "stats-section"] <| do + if null (TaskCore.tasksByNamespace stats) + then Lucid.p_ [Lucid.class_ "empty-msg"] "No namespaces found." + else traverse_ (uncurry (renderNamespaceRow (TaskCore.totalTasks stats))) (TaskCore.tasksByNamespace stats) + + Lucid.h2_ "Summary" + Lucid.div_ [Lucid.class_ "summary-section"] <| do + Lucid.div_ [Lucid.class_ "detail-row"] <| do + Lucid.span_ [Lucid.class_ "detail-label"] "Total Tasks:" + Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.totalTasks stats))) + Lucid.div_ [Lucid.class_ "detail-row"] <| do + Lucid.span_ [Lucid.class_ "detail-label"] "Epics:" + Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.totalEpics stats))) + Lucid.div_ [Lucid.class_ "detail-row"] <| do + Lucid.span_ [Lucid.class_ "detail-label"] "Ready:" + Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.readyTasks stats))) + Lucid.div_ [Lucid.class_ "detail-row"] <| do + Lucid.span_ [Lucid.class_ "detail-label"] "Blocked:" + Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.blockedTasks stats))) + where + statCard :: (Monad m) => Text -> Int -> Int -> Lucid.HtmlT m () + statCard label count total = + let pct = if total == 0 then 0 else (count * 100) `div` total + in Lucid.div_ [Lucid.class_ "stat-card"] <| do + Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml (tshow count)) + Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label) + Lucid.div_ [Lucid.class_ "progress-bar"] <| do + Lucid.div_ + [ Lucid.class_ "progress-fill", + Lucid.style_ ("width: " <> tshow pct <> "%") + ] + "" + + renderPriorityRow :: (Monad m) => TaskCore.Priority -> Int -> Lucid.HtmlT m () + renderPriorityRow priority count = + let total = TaskCore.totalTasks stats + pct = if total == 0 then 0 else (count * 100) `div` total + in Lucid.div_ [Lucid.class_ "stats-row"] <| do + Lucid.span_ [Lucid.class_ "stats-label"] (Lucid.toHtml (tshow priority)) + Lucid.div_ [Lucid.class_ "stats-bar-container"] <| do + Lucid.div_ [Lucid.class_ "progress-bar"] <| do + Lucid.div_ + [ Lucid.class_ "progress-fill", + Lucid.style_ ("width: " <> tshow pct <> "%") + ] + "" + Lucid.span_ [Lucid.class_ "stats-count"] (Lucid.toHtml (tshow count)) + + renderNamespaceRow :: (Monad m) => Int -> Text -> Int -> Lucid.HtmlT m () + renderNamespaceRow total ns count = + let pct = if total == 0 then 0 else (count * 100) `div` total + in Lucid.div_ [Lucid.class_ "stats-row"] <| do + Lucid.span_ [Lucid.class_ "stats-label"] (Lucid.toHtml ns) + Lucid.div_ [Lucid.class_ "stats-bar-container"] <| do + Lucid.div_ [Lucid.class_ "progress-bar"] <| do + Lucid.div_ + [ Lucid.class_ "progress-fill", + Lucid.style_ ("width: " <> tshow pct <> "%") + ] + "" + Lucid.span_ [Lucid.class_ "stats-count"] (Lucid.toHtml (tshow count)) + +instance Lucid.ToHtml RecentActivityNewPartial where + toHtmlRaw = Lucid.toHtml + toHtml (RecentActivityNewPartial tasks maybeNewestTs) = do + traverse_ renderListGroupItem tasks + case maybeNewestTs of + Nothing -> pure () + Just ts -> + Lucid.div_ + [ Lucid.id_ "recent-activity", + Lucid.makeAttribute "data-newest-ts" (tshow ts), + Lucid.makeAttribute "hx-swap-oob" "attributes:#recent-activity data-newest-ts" + ] + "" + +instance Lucid.ToHtml RecentActivityMorePartial where + toHtmlRaw = Lucid.toHtml + toHtml (RecentActivityMorePartial tasks nextOffset hasMore) = do + traverse_ renderListGroupItem tasks + if hasMore + then + Lucid.button_ + [ Lucid.id_ "activity-load-more", + Lucid.class_ "btn btn-secondary load-more-btn", + Lucid.makeAttribute "hx-get" ("/partials/recent-activity-more?offset=" <> tshow nextOffset), + Lucid.makeAttribute "hx-target" "#activity-list", + Lucid.makeAttribute "hx-swap" "beforeend", + Lucid.makeAttribute "hx-swap-oob" "true" + ] + "Load More" + else Lucid.span_ [Lucid.id_ "activity-load-more", Lucid.makeAttribute "hx-swap-oob" "true"] "" + +instance Lucid.ToHtml ReadyCountPartial where + toHtmlRaw = Lucid.toHtml + toHtml (ReadyCountPartial count) = + 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 PriorityBadgePartial where + toHtmlRaw = Lucid.toHtml + toHtml (PriorityBadgePartial priority tid) = + priorityBadgeWithForm priority 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_ "list-group"] <| traverse_ renderListGroupItem tasks + +instance Lucid.ToHtml TaskMetricsPartial where + toHtmlRaw = Lucid.toHtml + toHtml (TaskMetricsPartial _tid activities maybeRetry now) = + let runningActs = filter (\a -> TaskCore.activityStage a == TaskCore.Running) activities + in if null runningActs + then Lucid.p_ [Lucid.class_ "empty-msg"] "No worker execution data available." + else + Lucid.div_ [Lucid.class_ "execution-details"] <| do + let totalCost = sum [c | act <- runningActs, Just c <- [TaskCore.activityCostCents act]] + totalDuration = sum [calcDurSecs act | act <- runningActs] + attemptCount = length runningActs + + case maybeRetry of + Nothing -> pure () + Just ctx -> + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Retry Attempt:" + Lucid.span_ [Lucid.class_ "metric-value retry-count"] (Lucid.toHtml (tshow (TaskCore.retryAttempt ctx) <> "/3")) + + when (attemptCount > 1) <| do + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Total Attempts:" + Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow attemptCount)) + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Total Duration:" + Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDurSecs totalDuration)) + when (totalCost > 0) + <| Lucid.div_ [Lucid.class_ "metric-row"] + <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Total Cost:" + Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost totalCost)) + Lucid.hr_ [Lucid.class_ "attempts-divider"] + + traverse_ (renderAttempt attemptCount now) (zip [1 ..] (reverse runningActs)) + where + calcDurSecs :: TaskCore.TaskActivity -> Int + calcDurSecs act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of + (Just start, Just end) -> floor (diffUTCTime end start) + _ -> 0 + + formatDurSecs :: Int -> Text + formatDurSecs secs + | secs < 60 = tshow secs <> "s" + | secs < 3600 = tshow (secs `div` 60) <> "m " <> tshow (secs `mod` 60) <> "s" + | otherwise = tshow (secs `div` 3600) <> "h " <> tshow ((secs `mod` 3600) `div` 60) <> "m" + + renderAttempt :: (Monad m) => Int -> UTCTime -> (Int, TaskCore.TaskActivity) -> Lucid.HtmlT m () + renderAttempt totalAttempts currentTime (attemptNum, act) = do + when (totalAttempts > 1) + <| Lucid.div_ [Lucid.class_ "attempt-header"] (Lucid.toHtml ("Attempt " <> tshow attemptNum :: Text)) + case TaskCore.activityThreadUrl act of + Nothing -> pure () + Just url -> + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Session:" + Lucid.a_ [Lucid.href_ url, Lucid.target_ "_blank", Lucid.class_ "amp-thread-btn"] "View in Amp ↗" + + case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of + (Just start, Just end) -> + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Duration:" + Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDuration start end)) + (Just start, Nothing) -> + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Started:" + Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp currentTime start) + _ -> pure () + + case TaskCore.activityCostCents act of + Nothing -> pure () + Just cents -> + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Cost:" + Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost cents)) + + Lucid.div_ [Lucid.class_ "metric-row"] <| do + Lucid.span_ [Lucid.class_ "metric-label"] "Timestamp:" + Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp currentTime (TaskCore.activityTimestamp act)) + + formatDuration :: UTCTime -> UTCTime -> Text + formatDuration start end = + let diffSecs = floor (diffUTCTime end start) :: Int + mins = diffSecs `div` 60 + secs = diffSecs `mod` 60 + in if mins > 0 + then tshow mins <> "m " <> tshow secs <> "s" + else tshow secs <> "s" + + formatCost :: Int -> Text + formatCost cents = + let dollars = fromIntegral cents / 100.0 :: Double + in "$" <> Text.pack (showFFloat (Just 2) dollars "") + +instance Lucid.ToHtml DescriptionViewPartial where + toHtmlRaw = Lucid.toHtml + toHtml (DescriptionViewPartial tid desc isEpic) = + Lucid.div_ [Lucid.id_ "description-block", Lucid.class_ "description-block"] <| do + Lucid.div_ [Lucid.class_ "description-header"] <| do + Lucid.h3_ (if isEpic then "Design" else "Description") + Lucid.a_ + [ Lucid.href_ "#", + Lucid.class_ "edit-link", + Lucid.makeAttribute "hx-get" ("/tasks/" <> tid <> "/description/edit"), + Lucid.makeAttribute "hx-target" "#description-block", + Lucid.makeAttribute "hx-swap" "outerHTML" + ] + "Edit" + if Text.null desc + then Lucid.p_ [Lucid.class_ "empty-msg"] (if isEpic then "No design document yet." else "No description yet.") + else Lucid.div_ [Lucid.class_ "markdown-content"] (renderMarkdown desc) + +instance Lucid.ToHtml DescriptionEditPartial where + toHtmlRaw = Lucid.toHtml + toHtml (DescriptionEditPartial tid desc isEpic) = + Lucid.div_ [Lucid.id_ "description-block", Lucid.class_ "description-block editing"] <| do + Lucid.div_ [Lucid.class_ "description-header"] <| do + Lucid.h3_ (if isEpic then "Design" else "Description") + Lucid.button_ + [ Lucid.type_ "button", + Lucid.class_ "cancel-link", + Lucid.makeAttribute "hx-get" ("/tasks/" <> tid <> "/description/view"), + Lucid.makeAttribute "hx-target" "#description-block", + Lucid.makeAttribute "hx-swap" "outerHTML", + Lucid.makeAttribute "hx-confirm" "Discard changes?" + ] + "Cancel" + Lucid.form_ + [ Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/description"), + Lucid.makeAttribute "hx-target" "#description-block", + Lucid.makeAttribute "hx-swap" "outerHTML" + ] + <| do + Lucid.textarea_ + [ Lucid.name_ "description", + Lucid.class_ "description-textarea", + Lucid.rows_ (if isEpic then "15" else "10"), + Lucid.placeholder_ (if isEpic then "Enter design in Markdown..." else "Enter description...") + ] + (Lucid.toHtml desc) + Lucid.div_ [Lucid.class_ "form-actions"] <| do + Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Save" + +-- | Simple markdown renderer for epic descriptions +-- Supports: headers (#, ##, ###), lists (- or *), code blocks (```), inline code (`) +renderMarkdown :: (Monad m) => Text -> Lucid.HtmlT m () +renderMarkdown input = renderBlocks (parseBlocks (Text.lines input)) + +data MarkdownBlock + = MdHeader Int Text + | MdParagraph [Text] + | MdCodeBlock [Text] + | MdList [Text] + deriving (Show, Eq) + +parseBlocks :: [Text] -> [MarkdownBlock] +parseBlocks [] = [] +parseBlocks lns = case lns of + (l : rest) + | "```" `Text.isPrefixOf` l -> + let (codeLines, afterCode) = List.span (not <. Text.isPrefixOf "```") rest + remaining = List.drop 1 afterCode + in MdCodeBlock codeLines : parseBlocks remaining + | "### " `Text.isPrefixOf` l -> + MdHeader 3 (Text.drop 4 l) : parseBlocks rest + | "## " `Text.isPrefixOf` l -> + MdHeader 2 (Text.drop 3 l) : parseBlocks rest + | "# " `Text.isPrefixOf` l -> + MdHeader 1 (Text.drop 2 l) : parseBlocks rest + | isListItem l -> + let (listLines, afterList) = List.span isListItem lns + in MdList (map stripListPrefix listLines) : parseBlocks afterList + | Text.null (Text.strip l) -> + parseBlocks rest + | otherwise -> + let (paraLines, afterPara) = List.span isParagraphLine lns + in MdParagraph paraLines : parseBlocks afterPara + where + isListItem t = + let stripped = Text.stripStart t + in "- " `Text.isPrefixOf` stripped || "* " `Text.isPrefixOf` stripped + stripListPrefix t = + let stripped = Text.stripStart t + in Text.drop 2 stripped + isParagraphLine t = + not (Text.null (Text.strip t)) + && not ("```" `Text.isPrefixOf` t) + && not ("#" `Text.isPrefixOf` t) + && not (isListItem t) + +renderBlocks :: (Monad m) => [MarkdownBlock] -> Lucid.HtmlT m () +renderBlocks = traverse_ renderBlock + +renderBlock :: (Monad m) => MarkdownBlock -> Lucid.HtmlT m () +renderBlock block = case block of + MdHeader 1 txt -> Lucid.h2_ [Lucid.class_ "md-h1"] (renderInline txt) + MdHeader 2 txt -> Lucid.h3_ [Lucid.class_ "md-h2"] (renderInline txt) + MdHeader 3 txt -> Lucid.h4_ [Lucid.class_ "md-h3"] (renderInline txt) + MdHeader _ txt -> Lucid.h4_ (renderInline txt) + MdParagraph lns -> Lucid.p_ [Lucid.class_ "md-para"] (renderInline (Text.unlines lns)) + MdCodeBlock lns -> Lucid.pre_ [Lucid.class_ "md-code"] (Lucid.code_ (Lucid.toHtml (Text.unlines lns))) + MdList items -> Lucid.ul_ [Lucid.class_ "md-list"] (traverse_ renderListItem items) + +renderListItem :: (Monad m) => Text -> Lucid.HtmlT m () +renderListItem txt = Lucid.li_ (renderInline txt) + +-- | Render inline markdown (backtick code, bold, italic) +renderInline :: (Monad m) => Text -> Lucid.HtmlT m () +renderInline txt = renderInlineParts (parseInline txt) + +data InlinePart = PlainText Text | InlineCode Text | BoldText Text + deriving (Show, Eq) + +parseInline :: Text -> [InlinePart] +parseInline t + | Text.null t = [] + | otherwise = case Text.breakOn "`" t of + (before, rest) + | Text.null rest -> parseBold before + | otherwise -> + let afterTick = Text.drop 1 rest + in case Text.breakOn "`" afterTick of + (code, rest2) + | Text.null rest2 -> + parseBold before ++ [PlainText ("`" <> afterTick)] + | otherwise -> + parseBold before ++ [InlineCode code] ++ parseInline (Text.drop 1 rest2) + +parseBold :: Text -> [InlinePart] +parseBold t + | Text.null t = [] + | otherwise = case Text.breakOn "**" t of + (before, rest) + | Text.null rest -> [PlainText before | not (Text.null before)] + | otherwise -> + let afterBold = Text.drop 2 rest + in case Text.breakOn "**" afterBold of + (boldText, rest2) + | Text.null rest2 -> + [PlainText before | not (Text.null before)] ++ [PlainText ("**" <> afterBold)] + | otherwise -> + [PlainText before | not (Text.null before)] + ++ [BoldText boldText] + ++ parseBold (Text.drop 2 rest2) + +renderInlineParts :: (Monad m) => [InlinePart] -> Lucid.HtmlT m () +renderInlineParts = traverse_ renderInlinePart + +renderInlinePart :: (Monad m) => InlinePart -> Lucid.HtmlT m () +renderInlinePart part = case part of + PlainText txt -> Lucid.toHtml txt + InlineCode txt -> Lucid.code_ [Lucid.class_ "md-inline-code"] (Lucid.toHtml txt) + BoldText txt -> Lucid.strong_ (Lucid.toHtml txt) + +api :: Proxy API +api = Proxy + +server :: Server API +server = + homeHandler + :<|> styleHandler + :<|> readyQueueHandler + :<|> blockedHandler + :<|> interventionHandler + :<|> statsHandler + :<|> taskListHandler + :<|> kbHandler + :<|> factCreateHandler + :<|> factDetailHandler + :<|> factEditHandler + :<|> factDeleteHandler + :<|> epicsHandler + :<|> taskDetailHandler + :<|> taskStatusHandler + :<|> taskPriorityHandler + :<|> descriptionViewHandler + :<|> descriptionEditHandler + :<|> descriptionPostHandler + :<|> taskNotesHandler + :<|> taskCommentHandler + :<|> taskReviewHandler + :<|> taskDiffHandler + :<|> taskAcceptHandler + :<|> taskRejectHandler + :<|> taskResetRetriesHandler + :<|> recentActivityNewHandler + :<|> recentActivityMoreHandler + :<|> readyCountHandler + :<|> taskListPartialHandler + :<|> taskMetricsPartialHandler + where + styleHandler :: Servant.Handler LazyText.Text + styleHandler = pure Style.css + + homeHandler :: Maybe Text -> Servant.Handler HomePage + homeHandler maybeRangeText = do + now <- liftIO getCurrentTime + let range = parseTimeRange maybeRangeText + maybeStart = getTimeRangeStart range now + allTasks <- liftIO TaskCore.loadTasks + let filteredTasks = case maybeStart of + Nothing -> allTasks + Just start -> [t | t <- allTasks, TaskCore.taskUpdatedAt t >= start] + stats = TaskCore.computeTaskStatsFromList filteredTasks + readyTasks <- liftIO TaskCore.getReadyTasks + allActivities <- liftIO <| concat </ traverse (TaskCore.getActivitiesForTask <. TaskCore.taskId) allTasks + let filteredActivities = case maybeStart of + Nothing -> allActivities + Just start -> [a | a <- allActivities, TaskCore.activityTimestamp a >= start] + globalMetrics = computeMetricsFromActivities filteredTasks filteredActivities + sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) filteredTasks + recentTasks = take 5 sortedTasks + hasMoreRecent = length filteredTasks > 5 + pure (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics range now) + + readyQueueHandler :: Maybe Text -> Servant.Handler ReadyQueuePage + readyQueueHandler maybeSortText = do + now <- liftIO getCurrentTime + readyTasks <- liftIO TaskCore.getReadyTasks + let sortOrder = parseSortOrder maybeSortText + sortedTasks = sortTasks sortOrder readyTasks + pure (ReadyQueuePage sortedTasks sortOrder now) + + blockedHandler :: Maybe Text -> Servant.Handler BlockedPage + blockedHandler maybeSortText = do + now <- liftIO getCurrentTime + blockedTasks <- liftIO TaskCore.getBlockedTasks + allTasks <- liftIO TaskCore.loadTasks + let sortOrder = parseSortOrder maybeSortText + tasksWithImpact = [(t, TaskCore.getBlockingImpact allTasks t) | t <- blockedTasks] + sorted = List.sortBy (comparing (Down <. snd)) tasksWithImpact + pure (BlockedPage sorted sortOrder now) + + interventionHandler :: Maybe Text -> Servant.Handler InterventionPage + interventionHandler maybeSortText = do + now <- liftIO getCurrentTime + actionItems <- liftIO TaskCore.getHumanActionItems + let sortOrder = parseSortOrder maybeSortText + pure (InterventionPage actionItems sortOrder now) + + statsHandler :: Maybe Text -> Servant.Handler StatsPage + statsHandler maybeEpic = do + let epicId = emptyToNothing maybeEpic + stats <- liftIO <| TaskCore.getTaskStats epicId + pure (StatsPage stats epicId) + + taskListHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPage + taskListHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText maybeSortText = do + now <- liftIO getCurrentTime + allTasks <- liftIO TaskCore.loadTasks + let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText + maybePriority = parsePriority =<< emptyToNothing maybePriorityText + maybeType = parseTaskType =<< emptyToNothing maybeTypeText + filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType + sortOrder = parseSortOrder maybeSortText + filteredTasks = sortTasks sortOrder (applyFilters filters allTasks) + pure (TaskListPage filteredTasks filters sortOrder now) + + kbHandler :: Servant.Handler KBPage + kbHandler = do + facts <- liftIO Fact.getAllFacts + pure (KBPage facts) + + factCreateHandler :: FactCreateForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent) + factCreateHandler (FactCreateForm project content filesText confText) = do + let files = filter (not <. Text.null) (Text.splitOn "," (Text.strip filesText)) + confidence = fromMaybe 0.8 (readMaybe (Text.unpack confText)) + fid <- liftIO (Fact.createFact project content files Nothing confidence) + pure <| addHeader ("/kb/" <> tshow fid) NoContent + + factDetailHandler :: Int -> Servant.Handler FactDetailPage + factDetailHandler fid = do + now <- liftIO getCurrentTime + maybeFact <- liftIO (Fact.getFact fid) + case maybeFact of + Nothing -> pure (FactDetailNotFound fid) + Just fact -> pure (FactDetailFound fact now) + + factEditHandler :: Int -> FactEditForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent) + factEditHandler fid (FactEditForm content filesText confText) = do + let files = filter (not <. Text.null) (Text.splitOn "," (Text.strip filesText)) + confidence = fromMaybe 0.8 (readMaybe (Text.unpack confText)) + liftIO (Fact.updateFact fid content files confidence) + pure <| addHeader ("/kb/" <> tshow fid) NoContent + + factDeleteHandler :: Int -> Servant.Handler (Headers '[Header "Location" Text] NoContent) + factDeleteHandler fid = do + liftIO (Fact.deleteFact fid) + pure <| addHeader "/kb" NoContent + + epicsHandler :: Maybe Text -> Servant.Handler EpicsPage + epicsHandler maybeSortText = do + allTasks <- liftIO TaskCore.loadTasks + let epicTasks = filter (\t -> TaskCore.taskType t == TaskCore.Epic) allTasks + sortOrder = parseSortOrder maybeSortText + sortedEpics = sortTasks sortOrder epicTasks + pure (EpicsPage sortedEpics allTasks sortOrder) + + 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 + + applyFilters :: TaskFilters -> [TaskCore.Task] -> [TaskCore.Task] + applyFilters filters = filter matchesAllFilters + where + matchesAllFilters task = + matchesStatus task + && matchesPriority task + && matchesNamespace task + && matchesType 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 + + matchesType task = case filterType filters of + Nothing -> True + Just t -> TaskCore.taskType task == t + + taskDetailHandler :: Text -> Servant.Handler TaskDetailPage + taskDetailHandler tid = do + now <- liftIO getCurrentTime + tasks <- liftIO TaskCore.loadTasks + case TaskCore.findTask tid tasks of + Nothing -> pure (TaskDetailNotFound tid) + Just task -> do + activities <- liftIO (TaskCore.getActivitiesForTask tid) + retryCtx <- liftIO (TaskCore.getRetryContext tid) + commits <- liftIO (getCommitsForTask tid) + aggMetrics <- + if TaskCore.taskType task == TaskCore.Epic + then Just </ liftIO (TaskCore.getAggregatedMetrics tid) + else pure Nothing + pure (TaskDetailFound task tasks activities retryCtx commits aggMetrics now) + + taskStatusHandler :: Text -> StatusForm -> Servant.Handler StatusBadgePartial + taskStatusHandler tid (StatusForm newStatus) = do + liftIO <| TaskCore.updateTaskStatus tid newStatus [] + pure (StatusBadgePartial newStatus tid) + + taskPriorityHandler :: Text -> PriorityForm -> Servant.Handler PriorityBadgePartial + taskPriorityHandler tid (PriorityForm newPriority) = do + _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskPriority = newPriority}) + pure (PriorityBadgePartial newPriority tid) + + descriptionViewHandler :: Text -> Servant.Handler DescriptionViewPartial + descriptionViewHandler tid = do + tasks <- liftIO TaskCore.loadTasks + case TaskCore.findTask tid tasks of + Nothing -> throwError err404 + Just task -> pure (DescriptionViewPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic)) + + descriptionEditHandler :: Text -> Servant.Handler DescriptionEditPartial + descriptionEditHandler tid = do + tasks <- liftIO TaskCore.loadTasks + case TaskCore.findTask tid tasks of + Nothing -> throwError err404 + Just task -> pure (DescriptionEditPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic)) + + descriptionPostHandler :: Text -> DescriptionForm -> Servant.Handler DescriptionViewPartial + descriptionPostHandler tid (DescriptionForm desc) = do + let descText = Text.strip desc + _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskDescription = descText}) + tasks <- liftIO TaskCore.loadTasks + case TaskCore.findTask tid tasks of + Nothing -> throwError err404 + Just task -> pure (DescriptionViewPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic)) + + taskNotesHandler :: Text -> NotesForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent) + taskNotesHandler tid (NotesForm notes) = do + liftIO <| TaskCore.updateRetryNotes tid notes + pure <| addHeader ("/tasks/" <> tid) NoContent + + taskCommentHandler :: Text -> CommentForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent) + taskCommentHandler tid (CommentForm commentText) = do + _ <- liftIO (TaskCore.addComment tid commentText) + 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) + + taskDiffHandler :: Text -> Text -> Servant.Handler TaskDiffPage + taskDiffHandler tid commitSha = do + diffOutput <- liftIO <| getDiffForCommit commitSha + case diffOutput of + Nothing -> pure (DiffPageNotFound tid commitSha) + Just output -> pure (DiffPageFound tid commitSha output) + + 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 currentReason = "attempt " <> tshow attempt <> ": rejected: " <> fromMaybe "(no notes)" maybeNotes + let accumulatedReason = case maybeCtx of + Nothing -> currentReason + Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason + TaskCore.setRetryContext + TaskCore.RetryContext + { TaskCore.retryTaskId = tid, + TaskCore.retryOriginalCommit = commitSha, + TaskCore.retryConflictFiles = [], + TaskCore.retryAttempt = attempt, + TaskCore.retryReason = accumulatedReason, + TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes + } + TaskCore.updateTaskStatus tid TaskCore.Open [] + pure <| addHeader ("/tasks/" <> tid) NoContent + + taskResetRetriesHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent) + taskResetRetriesHandler tid = do + liftIO <| do + TaskCore.clearRetryContext tid + TaskCore.updateTaskStatus tid TaskCore.Open [] + pure <| addHeader ("/tasks/" <> tid) NoContent + + recentActivityNewHandler :: Maybe Int -> Servant.Handler RecentActivityNewPartial + recentActivityNewHandler maybeSince = do + allTasks <- liftIO TaskCore.loadTasks + let sinceTime = maybe (posixSecondsToUTCTime 0) (posixSecondsToUTCTime <. fromIntegral) maybeSince + sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks + newTasks = filter (\t -> TaskCore.taskUpdatedAt t > sinceTime) sortedTasks + newestTs = maybe maybeSince (Just <. taskToUnixTs) (head newTasks) + pure (RecentActivityNewPartial newTasks newestTs) + + recentActivityMoreHandler :: Maybe Int -> Servant.Handler RecentActivityMorePartial + recentActivityMoreHandler maybeOffset = do + allTasks <- liftIO TaskCore.loadTasks + let offset = fromMaybe 0 maybeOffset + pageSize = 5 + sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks + pageTasks = take pageSize <| drop offset sortedTasks + hasMore = length sortedTasks > offset + pageSize + nextOffset = offset + pageSize + pure (RecentActivityMorePartial pageTasks nextOffset hasMore) + + readyCountHandler :: Servant.Handler ReadyCountPartial + readyCountHandler = do + readyTasks <- liftIO TaskCore.getReadyTasks + pure (ReadyCountPartial (length readyTasks)) + + taskListPartialHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPartial + taskListPartialHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText maybeSortText = do + allTasks <- liftIO TaskCore.loadTasks + let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText + maybePriority = parsePriority =<< emptyToNothing maybePriorityText + maybeType = parseTaskType =<< emptyToNothing maybeTypeText + filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType + sortOrder = parseSortOrder maybeSortText + filteredTasks = sortTasks sortOrder (applyFilters filters allTasks) + pure (TaskListPartial filteredTasks) + + taskMetricsPartialHandler :: Text -> Servant.Handler TaskMetricsPartial + taskMetricsPartialHandler tid = do + now <- liftIO getCurrentTime + activities <- liftIO (TaskCore.getActivitiesForTask tid) + maybeRetry <- liftIO (TaskCore.getRetryContext tid) + pure (TaskMetricsPartial tid activities maybeRetry now) + +taskToUnixTs :: TaskCore.Task -> Int +taskToUnixTs t = round (utcTimeToPOSIXSeconds (TaskCore.taskUpdatedAt t)) + +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)) + +getDiffForCommit :: Text -> IO (Maybe Text) +getDiffForCommit commitSha = do + (code, diffOut, _) <- + Process.readProcessWithExitCode + "git" + ["show", Text.unpack commitSha] + "" + case code of + Exit.ExitSuccess -> pure (Just (Text.pack diffOut)) + Exit.ExitFailure _ -> pure Nothing + +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 + +getCommitsForTask :: Text -> IO [GitCommit] +getCommitsForTask tid = do + let grepArg = "--grep=Task-Id: " <> Text.unpack tid + (code, out, _) <- + Process.readProcessWithExitCode + "git" + ["log", "--pretty=format:%H|%h|%s|%an|%ar", grepArg] + "" + if code /= Exit.ExitSuccess || null out + then pure [] + else do + let commitLines = filter (not <. null) (List.lines out) + traverse parseCommitLine commitLines + where + parseCommitLine :: String -> IO GitCommit + parseCommitLine line = + case Text.splitOn "|" (Text.pack line) of + [sha, shortSha, summary, author, relDate] -> do + filesCount <- getFilesChangedCount (Text.unpack sha) + pure + GitCommit + { commitHash = sha, + commitShortHash = shortSha, + commitSummary = summary, + commitAuthor = author, + commitRelativeDate = relDate, + commitFilesChanged = filesCount + } + _ -> + pure + GitCommit + { commitHash = Text.pack line, + commitShortHash = Text.take 7 (Text.pack line), + commitSummary = "(parse error)", + commitAuthor = "", + commitRelativeDate = "", + commitFilesChanged = 0 + } + + getFilesChangedCount :: String -> IO Int + getFilesChangedCount sha = do + (code', out', _) <- + Process.readProcessWithExitCode + "git" + ["show", "--stat", "--format=", sha] + "" + pure + <| if code' /= Exit.ExitSuccess + then 0 + else + let statLines = filter (not <. null) (List.lines out') + in max 0 (length statLines - 1) + +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 + TaskCore.initTaskDb + putText <| "Starting Jr web server on port " <> tshow port + Warp.run port app |