path: root/Omni/Jr/Web.hs

{-# 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 (UTCTime, defaultTimeLocale, formatTime)
import qualified Lucid
import qualified Lucid.Base as Lucid
import qualified Network.Wai.Handler.Warp as Warp
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

data TaskFilters = TaskFilters
  { filterStatus :: Maybe TaskCore.Status,
    filterPriority :: Maybe TaskCore.Priority,
    filterNamespace :: Maybe Text
  }
  deriving (Show, Eq)

type API =
  Get '[Lucid.HTML] HomePage
    :<|> "style.css" :> Get '[CSS] LazyText.Text
    :<|> "ready" :> Get '[Lucid.HTML] ReadyQueuePage
    :<|> "blocked" :> Get '[Lucid.HTML] BlockedPage
    :<|> "intervention" :> Get '[Lucid.HTML] InterventionPage
    :<|> "stats" :> QueryParam "epic" Text :> Get '[Lucid.HTML] StatsPage
    :<|> "tasks"
      :> QueryParam "status" Text
      :> QueryParam "priority" Text
      :> QueryParam "namespace" Text
      :> Get '[Lucid.HTML] TaskListPage
    :<|> "tasks" :> Capture "id" Text :> Get '[Lucid.HTML] TaskDetailPage
    :<|> "tasks" :> Capture "id" Text :> "status" :> ReqBody '[FormUrlEncoded] StatusForm :> PostRedirect
    :<|> "tasks" :> Capture "id" Text :> "description" :> ReqBody '[FormUrlEncoded] DescriptionForm :> PostRedirect
    :<|> "tasks" :> Capture "id" Text :> "review" :> Get '[Lucid.HTML] TaskReviewPage
    :<|> "tasks" :> Capture "id" Text :> "accept" :> PostRedirect
    :<|> "tasks" :> Capture "id" Text :> "reject" :> ReqBody '[FormUrlEncoded] RejectForm :> PostRedirect
    :<|> "partials" :> "recent-activity" :> Get '[Lucid.HTML] RecentActivityPartial
    :<|> "partials" :> "ready-count" :> Get '[Lucid.HTML] ReadyCountPartial

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]

newtype ReadyQueuePage = ReadyQueuePage [TaskCore.Task]

newtype BlockedPage = BlockedPage [TaskCore.Task]

newtype InterventionPage = InterventionPage [TaskCore.Task]

data TaskListPage = TaskListPage [TaskCore.Task] TaskFilters

data TaskDetailPage
  = TaskDetailFound TaskCore.Task [TaskCore.Task] [TaskCore.TaskActivity]
  | TaskDetailNotFound Text

data TaskReviewPage
  = ReviewPageFound TaskCore.Task ReviewInfo
  | ReviewPageNotFound Text

data ReviewInfo
  = ReviewNoCommit
  | ReviewMergeConflict Text [Text]
  | ReviewReady Text Text

data StatsPage = StatsPage TaskCore.TaskStats (Maybe Text)

newtype RecentActivityPartial = RecentActivityPartial [TaskCore.Task]

newtype ReadyCountPartial = ReadyCountPartial Int

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 DescriptionForm = DescriptionForm Text

instance FromForm DescriptionForm where
  fromForm form = do
    desc <- parseUnique "description" form
    Right (DescriptionForm desc)

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)

navbar :: (Monad m) => Lucid.HtmlT m ()
navbar =
  Lucid.nav_ [Lucid.class_ "navbar"] <| do
    Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-brand"] "Jr"
    Lucid.div_ [Lucid.class_ "navbar-links"] <| do
      Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-link"] "Dashboard"
      Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "navbar-link"] "Tasks"
      Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "navbar-link"] "Ready"
      Lucid.a_ [Lucid.href_ "/blocked", Lucid.class_ "navbar-link"] "Blocked"
      Lucid.a_ [Lucid.href_ "/intervention", Lucid.class_ "navbar-link"] "Intervention"
      Lucid.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.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

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))

instance Lucid.ToHtml HomePage where
  toHtmlRaw = Lucid.toHtml
  toHtml (HomePage stats readyTasks recentTasks) =
    Lucid.doctypehtml_ <| do
      pageHead "Jr Dashboard"
      Lucid.body_ <| do
        navbar
        Lucid.div_ [Lucid.class_ "container"] <| do
          Lucid.h1_ "Jr Dashboard"

          Lucid.div_ [Lucid.class_ "actions"] <| do
            Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "action-btn"] "View All Tasks"
            Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "action-btn action-btn-primary"] "View Ready Queue"
            Lucid.a_ [Lucid.href_ "/blocked", Lucid.class_ "action-btn"] "View Blocked"
            Lucid.a_ [Lucid.href_ "/intervention", Lucid.class_ "action-btn"] "Needs Intervention"
            Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "action-btn"] "View Statistics"

          Lucid.h2_ "Task Status"
          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"

          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_ "task-list"]
                <| traverse_ renderTaskCard (take 5 readyTasks)

          Lucid.h2_ "Recent Activity"
          Lucid.div_
            [ Lucid.class_ "recent-activity",
              Lucid.makeAttribute "hx-get" "/partials/recent-activity",
              Lucid.makeAttribute "hx-trigger" "every 10s"
            ]
            <| if null recentTasks
              then Lucid.p_ [Lucid.class_ "empty-msg"] "No recent tasks."
              else
                Lucid.div_ [Lucid.class_ "task-list"]
                  <| traverse_ renderTaskCard recentTasks
    where
      statCard :: (Monad m) => Text -> Int -> Text -> 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)

instance Lucid.ToHtml ReadyQueuePage where
  toHtmlRaw = Lucid.toHtml
  toHtml (ReadyQueuePage tasks) =
    Lucid.doctypehtml_ <| do
      pageHead "Ready Queue - Jr"
      Lucid.body_ <| do
        navbar
        Lucid.div_ [Lucid.class_ "container"] <| do
          Lucid.h1_ <| Lucid.toHtml ("Ready Queue (" <> tshow (length tasks) <> " tasks)")
          if null tasks
            then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks are ready for work."
            else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks

instance Lucid.ToHtml BlockedPage where
  toHtmlRaw = Lucid.toHtml
  toHtml (BlockedPage tasks) =
    Lucid.doctypehtml_ <| do
      pageHead "Blocked Tasks - Jr"
      Lucid.body_ <| do
        navbar
        Lucid.div_ [Lucid.class_ "container"] <| do
          Lucid.h1_ <| Lucid.toHtml ("Blocked Tasks (" <> tshow (length tasks) <> " tasks)")
          Lucid.p_ [Lucid.class_ "info-msg"] "Tasks with unmet blocking dependencies."
          if null tasks
            then Lucid.p_ [Lucid.class_ "empty-msg"] "No blocked tasks."
            else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks

instance Lucid.ToHtml InterventionPage where
  toHtmlRaw = Lucid.toHtml
  toHtml (InterventionPage tasks) =
    Lucid.doctypehtml_ <| do
      pageHead "Needs Intervention - Jr"
      Lucid.body_ <| do
        navbar
        Lucid.div_ [Lucid.class_ "container"] <| do
          Lucid.h1_ <| Lucid.toHtml ("Needs Intervention (" <> tshow (length tasks) <> " tasks)")
          Lucid.p_ [Lucid.class_ "info-msg"] "Tasks that have failed 3+ times and need human help."
          if null tasks
            then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks need intervention."
            else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks

instance Lucid.ToHtml TaskListPage where
  toHtmlRaw = Lucid.toHtml
  toHtml (TaskListPage tasks filters) =
    Lucid.doctypehtml_ <| do
      pageHead "Tasks - Jr"
      Lucid.body_ <| do
        navbar
        Lucid.div_ [Lucid.class_ "container"] <| do
          Lucid.h1_ <| Lucid.toHtml ("Tasks (" <> tshow (length tasks) <> ")")

          Lucid.div_ [Lucid.class_ "filter-form"] <| do
            Lucid.form_ [Lucid.method_ "GET", Lucid.action_ "/tasks"] <| do
              Lucid.div_ [Lucid.class_ "filter-row"] <| do
                Lucid.div_ [Lucid.class_ "filter-group"] <| do
                  Lucid.label_ [Lucid.for_ "status"] "Status:"
                  Lucid.select_ [Lucid.name_ "status", Lucid.id_ "status", Lucid.class_ "filter-select"] <| do
                    Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterStatus filters)) "All"
                    statusFilterOption TaskCore.Open (filterStatus filters)
                    statusFilterOption TaskCore.InProgress (filterStatus filters)
                    statusFilterOption TaskCore.Review (filterStatus filters)
                    statusFilterOption TaskCore.Approved (filterStatus filters)
                    statusFilterOption TaskCore.Done (filterStatus filters)

                Lucid.div_ [Lucid.class_ "filter-group"] <| do
                  Lucid.label_ [Lucid.for_ "priority"] "Priority:"
                  Lucid.select_ [Lucid.name_ "priority", Lucid.id_ "priority", Lucid.class_ "filter-select"] <| do
                    Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterPriority filters)) "All"
                    priorityFilterOption TaskCore.P0 (filterPriority filters)
                    priorityFilterOption TaskCore.P1 (filterPriority filters)
                    priorityFilterOption TaskCore.P2 (filterPriority filters)
                    priorityFilterOption TaskCore.P3 (filterPriority filters)
                    priorityFilterOption TaskCore.P4 (filterPriority filters)

                Lucid.div_ [Lucid.class_ "filter-group"] <| do
                  Lucid.label_ [Lucid.for_ "namespace"] "Namespace:"
                  Lucid.input_
                    [ Lucid.type_ "text",
                      Lucid.name_ "namespace",
                      Lucid.id_ "namespace",
                      Lucid.class_ "filter-input",
                      Lucid.placeholder_ "e.g. Omni/Jr",
                      Lucid.value_ (fromMaybe "" (filterNamespace filters))
                    ]

                Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter"
                Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "clear-btn"] "Clear"

          if null tasks
            then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters."
            else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard 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) =
    Lucid.doctypehtml_ <| do
      pageHead "Task Not Found - Jr"
      Lucid.body_ <| do
        navbar
        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) =
    Lucid.doctypehtml_ <| do
      pageHead (TaskCore.taskId task <> " - Jr")
      Lucid.body_ <| do
        navbar
        Lucid.div_ [Lucid.class_ "container"] <| do
          Lucid.h1_ <| Lucid.toHtml (TaskCore.taskTitle task)

          Lucid.div_ [Lucid.class_ "task-detail"] <| do
            Lucid.div_ [Lucid.class_ "detail-row"] <| do
              Lucid.span_ [Lucid.class_ "detail-label"] "ID:"
              Lucid.code_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskId task))

            Lucid.div_ [Lucid.class_ "detail-row"] <| do
              Lucid.span_ [Lucid.class_ "detail-label"] "Type:"
              Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.taskType task)))

            Lucid.div_ [Lucid.class_ "detail-row"] <| do
              Lucid.span_ [Lucid.class_ "detail-label"] "Status:"
              Lucid.span_ [Lucid.class_ "detail-value"] <| statusBadge (TaskCore.taskStatus task)

            Lucid.div_ [Lucid.class_ "detail-row"] <| do
              Lucid.span_ [Lucid.class_ "detail-label"] "Priority:"
              Lucid.span_ [Lucid.class_ "detail-value"] <| do
                Lucid.toHtml (tshow (TaskCore.taskPriority task))
                Lucid.span_ [Lucid.class_ "priority-desc"] (Lucid.toHtml (priorityDesc (TaskCore.taskPriority task)))

            case TaskCore.taskNamespace task of
              Nothing -> pure ()
              Just ns ->
                Lucid.div_ [Lucid.class_ "detail-row"] <| do
                  Lucid.span_ [Lucid.class_ "detail-label"] "Namespace:"
                  Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml ns)

            case TaskCore.taskParent task of
              Nothing -> pure ()
              Just pid ->
                Lucid.div_ [Lucid.class_ "detail-row"] <| do
                  Lucid.span_ [Lucid.class_ "detail-label"] "Parent:"
                  Lucid.a_ [Lucid.href_ ("/tasks/" <> pid), Lucid.class_ "detail-value task-link"] (Lucid.toHtml pid)

            Lucid.div_ [Lucid.class_ "detail-row"] <| do
              Lucid.span_ [Lucid.class_ "detail-label"] "Created:"
              Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.taskCreatedAt task)))

            Lucid.div_ [Lucid.class_ "detail-row"] <| do
              Lucid.span_ [Lucid.class_ "detail-label"] "Updated:"
              Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.taskUpdatedAt task)))

            let deps = TaskCore.taskDependencies task
            unless (null deps) <| do
              Lucid.div_ [Lucid.class_ "detail-section"] <| do
                Lucid.h3_ "Dependencies"
                Lucid.ul_ [Lucid.class_ "dep-list"] <| do
                  traverse_ renderDependency deps

            case TaskCore.taskType task of
              TaskCore.Epic -> do
                Lucid.div_ [Lucid.class_ "detail-section"] <| do
                  Lucid.h3_ "Design"
                  case TaskCore.taskDescription task of
                    Nothing -> Lucid.p_ [Lucid.class_ "empty-msg"] "No design document yet."
                    Just desc -> Lucid.div_ [Lucid.class_ "markdown-content"] (renderMarkdown desc)
                  Lucid.details_ [Lucid.class_ "edit-description"] <| do
                    Lucid.summary_ "Edit Design"
                    Lucid.form_ [Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/description")] <| do
                      Lucid.textarea_
                        [ Lucid.name_ "description",
                          Lucid.class_ "description-textarea",
                          Lucid.rows_ "15",
                          Lucid.placeholder_ "Enter design in Markdown format..."
                        ]
                        (Lucid.toHtml (fromMaybe "" (TaskCore.taskDescription task)))
                      Lucid.div_ [Lucid.class_ "form-actions"] <| do
                        Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "submit-btn"] "Save Design"
              _ ->
                case TaskCore.taskDescription task of
                  Nothing -> pure ()
                  Just desc ->
                    Lucid.div_ [Lucid.class_ "detail-section"] <| do
                      Lucid.h3_ "Description"
                      Lucid.pre_ [Lucid.class_ "description"] (Lucid.toHtml desc)

            let children = filter (maybe False (TaskCore.matchesId (TaskCore.taskId task)) <. TaskCore.taskParent) allTasks
            unless (null children) <| do
              Lucid.div_ [Lucid.class_ "detail-section"] <| do
                Lucid.h3_ "Child Tasks"
                Lucid.ul_ [Lucid.class_ "child-list"] <| do
                  traverse_ renderChild children

          when (TaskCore.taskStatus task == TaskCore.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"

          Lucid.div_ [Lucid.class_ "status-form"] <| do
            Lucid.h3_ "Update Status"
            Lucid.form_ [Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/status")] <| do
              Lucid.select_ [Lucid.name_ "status", Lucid.class_ "status-select"] <| do
                statusOption TaskCore.Open (TaskCore.taskStatus task)
                statusOption TaskCore.InProgress (TaskCore.taskStatus task)
                statusOption TaskCore.Review (TaskCore.taskStatus task)
                statusOption TaskCore.Approved (TaskCore.taskStatus task)
                statusOption TaskCore.Done (TaskCore.taskStatus task)
              Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "submit-btn"] "Submit"
    where
      priorityDesc :: TaskCore.Priority -> Text
      priorityDesc p = case p of
        TaskCore.P0 -> " (Critical)"
        TaskCore.P1 -> " (High)"
        TaskCore.P2 -> " (Medium)"
        TaskCore.P3 -> " (Low)"
        TaskCore.P4 -> " (Backlog)"

      statusOption :: (Monad m) => TaskCore.Status -> TaskCore.Status -> Lucid.HtmlT m ()
      statusOption opt current =
        let attrs = [Lucid.value_ (tshow opt)] <> [Lucid.selected_ "selected" | opt == current]
         in Lucid.option_ attrs (Lucid.toHtml (tshow opt))

      renderDependency :: (Monad m) => TaskCore.Dependency -> Lucid.HtmlT m ()
      renderDependency dep =
        Lucid.li_ <| do
          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) <> "]")

      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"] (Lucid.toHtml (formatTimestamp (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 -> "✗"

      formatTimestamp :: UTCTime -> Text
      formatTimestamp = Text.pack <. formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S"

instance Lucid.ToHtml TaskReviewPage where
  toHtmlRaw = Lucid.toHtml
  toHtml (ReviewPageNotFound tid) =
    Lucid.doctypehtml_ <| do
      pageHead "Task Not Found - Jr Review"
      Lucid.body_ <| do
        navbar
        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) =
    Lucid.doctypehtml_ <| do
      pageHead ("Review: " <> TaskCore.taskId task <> " - Jr")
      Lucid.body_ <| do
        navbar
        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 StatsPage where
  toHtmlRaw = Lucid.toHtml
  toHtml (StatsPage stats maybeEpic) =
    Lucid.doctypehtml_ <| do
      pageHead "Task Statistics - Jr"
      Lucid.body_ <| do
        navbar
        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"
          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 RecentActivityPartial where
  toHtmlRaw = Lucid.toHtml
  toHtml (RecentActivityPartial recentTasks) =
    if null recentTasks
      then Lucid.p_ [Lucid.class_ "empty-msg"] "No recent tasks."
      else
        Lucid.div_ [Lucid.class_ "task-list"]
          <| traverse_ renderTaskCard recentTasks

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)")

-- | 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
    :<|> taskDetailHandler
    :<|> taskStatusHandler
    :<|> taskDescriptionHandler
    :<|> taskReviewHandler
    :<|> taskAcceptHandler
    :<|> taskRejectHandler
    :<|> recentActivityHandler
    :<|> readyCountHandler
  where
    styleHandler :: Servant.Handler LazyText.Text
    styleHandler = pure Style.css

    homeHandler :: Servant.Handler HomePage
    homeHandler = do
      stats <- liftIO <| TaskCore.getTaskStats Nothing
      readyTasks <- liftIO TaskCore.getReadyTasks
      allTasks <- liftIO TaskCore.loadTasks
      let recentTasks = take 5 <| List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
      pure (HomePage stats readyTasks recentTasks)

    readyQueueHandler :: Servant.Handler ReadyQueuePage
    readyQueueHandler = do
      readyTasks <- liftIO TaskCore.getReadyTasks
      let sortedTasks = List.sortBy (compare `on` TaskCore.taskPriority) readyTasks
      pure (ReadyQueuePage sortedTasks)

    blockedHandler :: Servant.Handler BlockedPage
    blockedHandler = do
      blockedTasks <- liftIO TaskCore.getBlockedTasks
      let sortedTasks = List.sortBy (compare `on` TaskCore.taskPriority) blockedTasks
      pure (BlockedPage sortedTasks)

    interventionHandler :: Servant.Handler InterventionPage
    interventionHandler = do
      interventionTasks <- liftIO TaskCore.getInterventionTasks
      let sortedTasks = List.sortBy (compare `on` TaskCore.taskPriority) interventionTasks
      pure (InterventionPage sortedTasks)

    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 -> Servant.Handler TaskListPage
    taskListHandler maybeStatusText maybePriorityText maybeNamespace = do
      allTasks <- liftIO TaskCore.loadTasks
      let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText
          maybePriority = parsePriority =<< emptyToNothing maybePriorityText
          filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace)
          filteredTasks = applyFilters filters allTasks
      pure (TaskListPage filteredTasks filters)

    parseStatus :: Text -> Maybe TaskCore.Status
    parseStatus = readMaybe <. Text.unpack

    parsePriority :: Text -> Maybe TaskCore.Priority
    parsePriority = 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

        matchesStatus task = case filterStatus filters of
          Nothing -> True
          Just s -> TaskCore.taskStatus task == s

        matchesPriority task = case filterPriority filters of
          Nothing -> True
          Just p -> TaskCore.taskPriority task == p

        matchesNamespace task = case filterNamespace filters of
          Nothing -> True
          Just ns -> case TaskCore.taskNamespace task of
            Nothing -> False
            Just taskNs -> ns `Text.isPrefixOf` taskNs

    taskDetailHandler :: Text -> Servant.Handler TaskDetailPage
    taskDetailHandler tid = do
      tasks <- liftIO TaskCore.loadTasks
      case TaskCore.findTask tid tasks of
        Nothing -> pure (TaskDetailNotFound tid)
        Just task -> do
          activities <- liftIO (TaskCore.getActivitiesForTask tid)
          pure (TaskDetailFound task tasks activities)

    taskStatusHandler :: Text -> StatusForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
    taskStatusHandler tid (StatusForm newStatus) = do
      liftIO <| TaskCore.updateTaskStatus tid newStatus []
      pure <| addHeader ("/tasks/" <> tid) NoContent

    taskDescriptionHandler :: Text -> DescriptionForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
    taskDescriptionHandler tid (DescriptionForm desc) = do
      let descMaybe = if Text.null (Text.strip desc) then Nothing else Just desc
      _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskDescription = descMaybe})
      pure <| addHeader ("/tasks/" <> tid) NoContent

    taskReviewHandler :: Text -> Servant.Handler TaskReviewPage
    taskReviewHandler tid = do
      tasks <- liftIO TaskCore.loadTasks
      case TaskCore.findTask tid tasks of
        Nothing -> pure (ReviewPageNotFound tid)
        Just task -> do
          reviewInfo <- liftIO <| getReviewInfo tid
          pure (ReviewPageFound task reviewInfo)

    taskAcceptHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
    taskAcceptHandler tid = do
      liftIO <| do
        TaskCore.clearRetryContext tid
        TaskCore.updateTaskStatus tid TaskCore.Done []
      pure <| addHeader ("/tasks/" <> tid) NoContent

    taskRejectHandler :: Text -> RejectForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
    taskRejectHandler tid (RejectForm maybeNotes) = do
      liftIO <| do
        maybeCommit <- findCommitForTask tid
        let commitSha = fromMaybe "" maybeCommit
        maybeCtx <- TaskCore.getRetryContext tid
        let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx
        let reason = "rejected: " <> fromMaybe "(no notes)" maybeNotes
        TaskCore.setRetryContext
          TaskCore.RetryContext
            { TaskCore.retryTaskId = tid,
              TaskCore.retryOriginalCommit = commitSha,
              TaskCore.retryConflictFiles = [],
              TaskCore.retryAttempt = attempt,
              TaskCore.retryReason = reason
            }
        TaskCore.updateTaskStatus tid TaskCore.Open []
      pure <| addHeader ("/tasks/" <> tid) NoContent

    recentActivityHandler :: Servant.Handler RecentActivityPartial
    recentActivityHandler = do
      allTasks <- liftIO TaskCore.loadTasks
      let recentTasks = take 5 <| List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
      pure (RecentActivityPartial recentTasks)

    readyCountHandler :: Servant.Handler ReadyCountPartial
    readyCountHandler = do
      readyTasks <- liftIO TaskCore.getReadyTasks
      pure (ReadyCountPartial (length readyTasks))

getReviewInfo :: Text -> IO ReviewInfo
getReviewInfo tid = do
  maybeCommit <- findCommitForTask tid
  case maybeCommit of
    Nothing -> pure ReviewNoCommit
    Just commitSha -> do
      conflictResult <- checkMergeConflict (Text.unpack commitSha)
      case conflictResult of
        Just conflictFiles -> pure (ReviewMergeConflict commitSha conflictFiles)
        Nothing -> do
          (_, diffOut, _) <-
            Process.readProcessWithExitCode
              "git"
              ["show", Text.unpack commitSha]
              ""
          pure (ReviewReady commitSha (Text.pack diffOut))

findCommitForTask :: Text -> IO (Maybe Text)
findCommitForTask tid = do
  let grepArg = "--grep=" <> Text.unpack tid
  (code, shaOut, _) <-
    Process.readProcessWithExitCode
      "git"
      ["log", "--pretty=format:%H", "-n", "1", grepArg]
      ""
  if code /= Exit.ExitSuccess || null shaOut
    then pure Nothing
    else case List.lines shaOut of
      (x : _) -> pure (Just (Text.pack x))
      [] -> pure Nothing

checkMergeConflict :: String -> IO (Maybe [Text])
checkMergeConflict commitSha = do
  (_, origHead, _) <- Process.readProcessWithExitCode "git" ["rev-parse", "HEAD"] ""

  (cpCode, _, cpErr) <-
    Process.readProcessWithExitCode
      "git"
      ["cherry-pick", "--no-commit", commitSha]
      ""

  _ <- Process.readProcessWithExitCode "git" ["cherry-pick", "--abort"] ""
  _ <- Process.readProcessWithExitCode "git" ["reset", "--hard", List.head (List.lines origHead)] ""

  case cpCode of
    Exit.ExitSuccess -> pure Nothing
    Exit.ExitFailure _ -> do
      let errLines = Text.lines (Text.pack cpErr)
          conflictLines = filter (Text.isPrefixOf "CONFLICT") errLines
          files = mapMaybe extractConflictFile conflictLines
      pure (Just (if null files then ["(unknown files)"] else files))

extractConflictFile :: Text -> Maybe Text
extractConflictFile line =
  case Text.breakOn "Merge conflict in " line of
    (_, rest)
      | not (Text.null rest) -> Just (Text.strip (Text.drop 18 rest))
    _ -> case Text.breakOn "in " line of
      (_, rest)
        | not (Text.null rest) -> Just (Text.strip (Text.drop 3 rest))
      _ -> Nothing

app :: Application
app = serve api server

run :: Warp.Port -> IO ()
run port = do
  TaskCore.initTaskDb
  putText <| "Starting Jr web server on port " <> tshow port
  Warp.run port app