path: root/Omni/Jr/Web/Types.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- : dep servant-server
-- : dep lucid
-- : dep http-api-data
-- : dep aeson
module Omni.Jr.Web.Types
  ( TaskFilters (..),
    TimeRange (..),
    SortOrder (..),
    parseSortOrder,
    sortOrderToParam,
    sortOrderLabel,
    sortTasks,
    parseTimeRange,
    timeRangeToParam,
    getTimeRangeStart,
    startOfDay,
    startOfWeek,
    addDays,
    fromGregorian,
    daysSinceEpoch,
    startOfMonth,
    computeMetricsFromActivities,
    HomePage (..),
    ReadyQueuePage (..),
    BlockedPage (..),
    InterventionPage (..),
    TaskListPage (..),
    TaskDetailPage (..),
    GitCommit (..),
    TaskReviewPage (..),
    ReviewInfo (..),
    TaskDiffPage (..),
    StatsPage (..),
    KBPage (..),
    FactDetailPage (..),
    EpicsPage (..),
    RecentActivityNewPartial (..),
    RecentActivityMorePartial (..),
    ReadyCountPartial (..),
    StatusBadgePartial (..),
    PriorityBadgePartial (..),
    TaskListPartial (..),
    TaskMetricsPartial (..),
    AgentEventsPartial (..),
    DescriptionViewPartial (..),
    DescriptionEditPartial (..),
    FactEditForm (..),
    FactCreateForm (..),
    RejectForm (..),
    StatusForm (..),
    PriorityForm (..),
    DescriptionForm (..),
    NotesForm (..),
    CommentForm (..),
    Breadcrumb (..),
    Breadcrumbs,
    CSS,
    SSE,
  )
where

import Alpha
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
import Data.Time (Day, UTCTime (..), diffUTCTime, toGregorian)
import Data.Time.Calendar (DayOfWeek (..))
import Data.Time.Calendar.WeekDate (toWeekCalendar)
import qualified Lucid
import qualified Omni.Task.Core as TaskCore
import Servant (Accept (..), MimeRender (..))
import Web.FormUrlEncoded (FromForm (..), lookupUnique, parseUnique)

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) = toWeekCalendar day
      daysBack = dow - 1
   in UTCTime (addDays (negate (toInteger 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

data CSS

instance Accept CSS where
  contentType _ = "text/css"

instance MimeRender CSS LazyText.Text where
  mimeRender _ = LazyText.encodeUtf8

data SSE

instance Accept SSE where
  contentType _ = "text/event-stream"

instance MimeRender SSE BS.ByteString where
  mimeRender _ = LBS.fromStrict

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) [TaskCore.StoredEvent] 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 AgentEventsPartial = AgentEventsPartial Text [TaskCore.StoredEvent] Bool 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)

data Breadcrumb = Breadcrumb
  { breadcrumbLabel :: Text,
    breadcrumbUrl :: Maybe Text
  }

type Breadcrumbs = [Breadcrumb]