diff options
Diffstat (limited to 'Omni/Jr/Web/Handlers.hs')
| -rw-r--r-- | Omni/Jr/Web/Handlers.hs | 649 |
1 files changed, 649 insertions, 0 deletions
diff --git a/Omni/Jr/Web/Handlers.hs b/Omni/Jr/Web/Handlers.hs new file mode 100644 index 0000000..9dd5847 --- /dev/null +++ b/Omni/Jr/Web/Handlers.hs @@ -0,0 +1,649 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- : dep warp +-- : dep servant-server +-- : dep lucid +-- : dep servant-lucid +-- : dep process +-- : dep aeson +module Omni.Jr.Web.Handlers + ( API, + server, + api, + streamAgentEvents, + ) +where + +import Alpha +import qualified Control.Concurrent as Concurrent +import qualified Data.Aeson as Aeson +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import Data.Time (getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import qualified Omni.Fact as Fact +import qualified Omni.Jr.Web.Style as Style +import Omni.Jr.Web.Types +import qualified Omni.Task.Core as TaskCore +import Servant +import qualified Servant.HTML.Lucid as Lucid +import qualified Servant.Types.SourceT as Source +import qualified System.Exit as Exit +import qualified System.Process as Process + +type PostRedirect = Verb 'POST 303 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent) + +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 :> "complexity" :> ReqBody '[FormUrlEncoded] ComplexityForm :> Post '[Lucid.HTML] ComplexityBadgePartial + :<|> "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 + :<|> "partials" :> "task" :> Capture "id" Text :> "events" :> QueryParam "since" Int :> Get '[Lucid.HTML] AgentEventsPartial + :<|> "tasks" :> Capture "id" Text :> "events" :> "stream" :> StreamGet NoFraming SSE (SourceIO ByteString) + +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 + :<|> taskComplexityHandler + :<|> descriptionViewHandler + :<|> descriptionEditHandler + :<|> descriptionPostHandler + :<|> taskNotesHandler + :<|> taskCommentHandler + :<|> taskReviewHandler + :<|> taskDiffHandler + :<|> taskAcceptHandler + :<|> taskRejectHandler + :<|> taskResetRetriesHandler + :<|> recentActivityNewHandler + :<|> recentActivityMoreHandler + :<|> readyCountHandler + :<|> taskListPartialHandler + :<|> taskMetricsPartialHandler + :<|> agentEventsPartialHandler + :<|> taskEventsStreamHandler + 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 + agentEvents <- liftIO (TaskCore.getAllEventsForTask tid) + pure (TaskDetailFound task tasks activities retryCtx commits aggMetrics agentEvents now) + + taskStatusHandler :: Text -> StatusForm -> Servant.Handler StatusBadgePartial + taskStatusHandler tid (StatusForm newStatus) = do + liftIO <| TaskCore.updateTaskStatusWithActor tid newStatus [] TaskCore.Human + 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) + + taskComplexityHandler :: Text -> ComplexityForm -> Servant.Handler ComplexityBadgePartial + taskComplexityHandler tid (ComplexityForm newComplexity) = do + _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskComplexity = newComplexity}) + pure (ComplexityBadgePartial newComplexity 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 TaskCore.Human) + 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.updateTaskStatusWithActor tid TaskCore.Done [] TaskCore.Human + 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.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human + pure <| addHeader ("/tasks/" <> tid) NoContent + + taskResetRetriesHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent) + taskResetRetriesHandler tid = do + liftIO <| do + TaskCore.clearRetryContext tid + TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human + 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) + + agentEventsPartialHandler :: Text -> Maybe Int -> Servant.Handler AgentEventsPartial + agentEventsPartialHandler tid _maybeSince = do + now <- liftIO getCurrentTime + events <- liftIO (TaskCore.getAllEventsForTask tid) + tasks <- liftIO TaskCore.loadTasks + let isInProgress = case TaskCore.findTask tid tasks of + Nothing -> False + Just task -> TaskCore.taskStatus task == TaskCore.InProgress + pure (AgentEventsPartial tid events isInProgress now) + + taskEventsStreamHandler :: Text -> Servant.Handler (SourceIO ByteString) + taskEventsStreamHandler tid = do + maybeSession <- liftIO (TaskCore.getLatestSessionForTask tid) + case maybeSession of + Nothing -> pure (Source.source []) + Just sid -> liftIO (streamAgentEvents tid sid) + +streamAgentEvents :: Text -> Text -> IO (SourceIO ByteString) +streamAgentEvents tid sid = do + existingEvents <- TaskCore.getEventsForSession sid + let lastId = if null existingEvents then 0 else maximum (map TaskCore.storedEventId existingEvents) + let existingSSE = map eventToSSE existingEvents + pure <| Source.fromStepT <| streamEventsStep tid sid lastId existingSSE True + +streamEventsStep :: Text -> Text -> Int -> [ByteString] -> Bool -> Source.StepT IO ByteString +streamEventsStep tid sid lastId buffer sendExisting = case (sendExisting, buffer) of + (True, b : bs) -> Source.Yield b (streamEventsStep tid sid lastId bs True) + (True, []) -> streamEventsStep tid sid lastId [] False + (False, _) -> + Source.Effect <| do + tasks <- TaskCore.loadTasks + let isComplete = case TaskCore.findTask tid tasks of + Nothing -> True + Just task -> TaskCore.taskStatus task /= TaskCore.InProgress + + if isComplete + then do + let completeSSE = formatSSE "complete" "{}" + pure <| Source.Yield completeSSE Source.Stop + else do + Concurrent.threadDelay 500000 + newEvents <- TaskCore.getEventsSince sid lastId + if null newEvents + then pure <| streamEventsStep tid sid lastId [] False + else do + let newLastId = maximum (map TaskCore.storedEventId newEvents) + let newSSE = map eventToSSE newEvents + case newSSE of + (e : es) -> pure <| Source.Yield e (streamEventsStep tid sid newLastId es False) + [] -> pure <| streamEventsStep tid sid newLastId [] False + +eventToSSE :: TaskCore.StoredEvent -> ByteString +eventToSSE event = + let eventType = Text.toLower (TaskCore.storedEventType event) + content = TaskCore.storedEventContent event + jsonData = case eventType of + "assistant" -> Aeson.object ["content" Aeson..= content] + "toolcall" -> + let (tool, args) = parseToolCallContent content + in Aeson.object ["tool" Aeson..= tool, "args" Aeson..= Aeson.object ["data" Aeson..= args]] + "toolresult" -> + Aeson.object ["tool" Aeson..= ("unknown" :: Text), "success" Aeson..= True, "output" Aeson..= content] + "cost" -> Aeson.object ["cost" Aeson..= content] + "error" -> Aeson.object ["error" Aeson..= content] + "complete" -> Aeson.object [] + _ -> Aeson.object ["content" Aeson..= content] + in formatSSE eventType (str (Aeson.encode jsonData)) + +formatSSE :: Text -> ByteString -> ByteString +formatSSE eventType jsonData = + str + <| "event: " + <> eventType + <> "\n" + <> "data: " + <> str jsonData + <> "\n\n" + +parseToolCallContent :: Text -> (Text, Text) +parseToolCallContent content = + case Text.breakOn ":" content of + (name, rest) + | Text.null rest -> (content, "") + | otherwise -> (Text.strip name, Text.strip (Text.drop 1 rest)) + +taskToUnixTs :: TaskCore.Task -> Int +taskToUnixTs t = ceiling (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 |