diff options
Diffstat (limited to 'Omni')
74 files changed, 13743 insertions, 642 deletions
diff --git a/Omni/Agent.hs b/Omni/Agent.hs new file mode 100644 index 0000000..0bae0b5 --- /dev/null +++ b/Omni/Agent.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Agent system entry point and combined test runner. +-- +-- This module provides the main entry point for the agent system +-- and re-exports core types from sub-modules. +-- +-- : out omni-agent +-- : dep aeson +module Omni.Agent + ( -- * Engine + module Omni.Agent.Engine, + + -- * Tools + module Omni.Agent.Tools, + + -- * Core + module Omni.Agent.Core, + + -- * Test + main, + test, + ) +where + +import Alpha +import Omni.Agent.Core +import Omni.Agent.Engine hiding (main, test) +import qualified Omni.Agent.Engine as Engine +import Omni.Agent.Tools hiding (ToolResult, main, test) +import qualified Omni.Agent.Tools as Tools +import qualified Omni.Test as Test + +main :: IO () +main = Test.run test + +test :: Test.Tree +test = + Test.group + "Omni.Agent" + [ Engine.test, + Tools.test, + Test.unit "Core types are re-exported" <| do + let status = Idle :: WorkerStatus + status Test.@=? status, + Test.unit "Engine and Tools integrate correctly" <| do + let tools = Tools.allTools + length tools Test.@=? 5 + let config = + Engine.defaultAgentConfig + { Engine.agentTools = tools + } + Engine.agentMaxIterations config Test.@=? 10 + ] diff --git a/Omni/Agent/Core.hs b/Omni/Agent/Core.hs new file mode 100644 index 0000000..88f7237 --- /dev/null +++ b/Omni/Agent/Core.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Omni.Agent.Core where + +import Alpha +import Data.Aeson (FromJSON, ToJSON) + +-- | Status of a worker agent +data WorkerStatus + = Idle + | Syncing + | -- | Task ID + Working Text + | -- | Task ID + Submitting Text + | -- | Error message + Error Text + deriving (Show, Eq, Generic) + +instance ToJSON WorkerStatus + +instance FromJSON WorkerStatus + +-- | Representation of a worker agent +data Worker = Worker + { workerName :: Text, + workerPid :: Maybe Int, + workerStatus :: WorkerStatus, + workerPath :: FilePath, + workerQuiet :: Bool -- Disable ANSI status bar (for loop mode) + } + deriving (Show, Eq, Generic) + +instance ToJSON Worker + +instance FromJSON Worker diff --git a/Omni/Agent/DESIGN.md b/Omni/Agent/DESIGN.md new file mode 100644 index 0000000..ae1f6b3 --- /dev/null +++ b/Omni/Agent/DESIGN.md @@ -0,0 +1,117 @@ +# Multi-Agent System 2.0 Design + +**Goal:** Replace the current bash-script based worker system (`start-worker.sh`, etc.) with a robust, type-safe Haskell application `Omni/Agent.hs`. + +## 1. CLI Interface + +The `agent` command (compiled from `Omni/Agent.hs`) will provide a unified interface for managing workers. + +```bash +agent start <name> [--background] # Start a worker (foreground by default, background with flag) +agent stop <name> # Stop a background worker +agent status # List all workers and their status +agent log <name> [-f] # View/tail worker logs +agent sync # Sync local state with live (helper) +``` + +## 2. Module Structure (`Omni/Agent/`) + +We will refactor the bash logic into Haskell modules: + +- **Omni.Agent** (`Omni/Agent.hs`): Main entry point and CLI parsing (Docopt). +- **Omni.Agent.Core**: Core data types and state management. +- **Omni.Agent.Worker**: The worker loop logic (sync, claim, work, submit). +- **Omni.Agent.Git**: Git operations (worktree, branch, merge, commit). +- **Omni.Agent.Process**: Process management (PID files, signals). +- **Omni.Agent.Log**: Log streaming and filtering (the "monitor" logic). + +## 3. Data Types + +```haskell +data WorkerStatus + = Idle + | Syncing + | Working TaskId + | Submitting TaskId + | Error Text + deriving (Show, Eq, Generic) + +data Worker = Worker + { workerName :: Text + , workerPid :: Maybe Int + , workerStatus :: WorkerStatus + , workerPath :: FilePath + } +``` + +## 4. Implementation Details + +### 4.1 Worker Loop (`agent start`) +The Haskell implementation should replicate the logic of `start-worker.sh` but with better error handling and logging. + +1. **Setup**: Ensure worktree exists (or create it). +2. **Loop**: + - `Git.syncWithLive` (Rebase-based to preserve local history) + - `Task.sync` + - `task <- Task.findReady` + - If `task`: + - `Task.claim task` + - `baseBranch <- Git.determineBaseBranch task` (Check dependencies) + - `Git.checkoutTaskBranch task baseBranch` (Force checkout to clean untracked files) + - `Engine.runAgent prompt` (Native LLM agent via OpenRouter) + - `Git.commit` + - `Git.checkoutBase` + - `Task.submitReview task` + - Else: `sleep 60` + +### 4.2 Process Management +- Store PIDs in `.tasks/workers/<name>.pid`. +- `agent stop` sends SIGTERM to the PID. +- `agent status` checks if PID is alive. + +### 4.3 Logging +- The Engine module uses callbacks to report activity and costs in real-time. +- `agent log` displays the status bar with worker progress information. +- **UI Design**: + - **Two-line Status**: The CLI should maintain two reserved lines at the bottom (or top) of the output for each worker: + - **Line 1 (Meta)**: `[Worker: omni-worker-1] Task: t-123 | Files: 3 | Credits: $0.45 | Time: 05:23` + - **Line 2 (Activity)**: `[14:05:22] 🤖 Thinking...` (updates in place) + - **Task Details**: When claiming a task, print the full task description/details to the log/console so the user can see what is being worked on without looking it up. + - **Completion**: When a task finishes, print a summary line (e.g., `[✓] Task t-123 completed in 12m 30s`) and a hard line break before starting the next loop. + - **History**: Previous log lines (tool outputs, thoughts) scroll up above these two status lines. + +### 4.5 Git Robustness (Learnings) +- **Identity**: Configure `git config user.name "Omni Worker"` and `user.email` in the worktree to clearly distinguish worker commits from human commits. +- **Force Checkout**: The worker must use `git checkout -f` (or equivalent) when switching to task branches to ensure untracked files (like `.tasks/counters.jsonl`) don't block the switch. +- **Base Branch Logic**: + - If the task depends on another task that is *not* yet in `live` (e.g., in `Review`), the worker should branch off the dependency's branch (`task/<dep-id>`). + - Otherwise, branch off `live` directly. Do NOT use the local worker branch (`omni-worker-N`) as the base, as it may contain temporary sync commits that shouldn't be merged. +- **Commit Hygiene**: Bundle the task status update (marking as 'Review') *inside* the feature implementation commit. This keeps the history clean (one commit per feature) and avoids separate "sync" commits for status changes. +- **Clean State**: The worker should ensure the workspace is clean (no uncommitted changes) before starting a new loop iteration. +- **Rebase Safety**: Always check the exit code of `git rebase`. If it fails (conflicts), abort immediately (`git rebase --abort`) to avoid leaving the repo in a broken interactive rebase state. +- **Status Verification**: Verify that task status updates actually succeed. Check `task ready` output against `live` state to prevent "zombie" tasks (completed in live but stuck in local loop) from being re-claimed. +- **Binary Freshness**: Ensure the `task` binary used by the worker is rebuilt/updated when source code changes, otherwise logic fixes (like `task ready` filtering) won't take effect. + +## 5. Migration Strategy + +1. **Parallel Existence**: Keep bash scripts while developing Haskell version. +2. **Feature Parity**: Ensure `agent start` works exactly like `start-worker.sh`. +3. **Cutover**: Update `WORKER_AGENT_GUIDE.md` to use `agent` command. +4. **Cleanup**: Delete bash scripts. + +## 6. Testing Plan + +### 6.1 Unit Tests (`Omni/Agent/Test.hs`) +- Test `Git` module commands (mocked). +- Test `Log` filtering logic. +- Test CLI argument parsing. + +### 6.2 Integration Tests +- Create a temporary test repo. +- Spawn a worker. +- Mock the Engine LLM calls or use a test API key. +- Verify task moves from Open -> InProgress -> Review. + +## 7. References +- `Omni/Agent/start-worker.sh` (Current implementation) +- `Omni/Task.hs` (Task manager integration) diff --git a/Omni/Agent/Engine.hs b/Omni/Agent/Engine.hs new file mode 100644 index 0000000..e019341 --- /dev/null +++ b/Omni/Agent/Engine.hs @@ -0,0 +1,582 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | LLM Agent Engine - Tool protocol and LLM provider abstraction. +-- +-- This module provides the core abstractions for building LLM-powered agents: +-- - Tool: Defines tools that agents can use +-- - LLM: OpenAI-compatible chat completions API provider +-- - AgentConfig: Configuration for running agents +-- +-- : out omni-agent-engine +-- : dep http-conduit +-- : dep aeson +-- : dep case-insensitive +module Omni.Agent.Engine + ( Tool (..), + LLM (..), + EngineConfig (..), + AgentConfig (..), + AgentResult (..), + Message (..), + Role (..), + ToolCall (..), + FunctionCall (..), + ToolResult (..), + ChatCompletionRequest (..), + ChatCompletionResponse (..), + Choice (..), + Usage (..), + defaultLLM, + defaultEngineConfig, + defaultAgentConfig, + chat, + runAgent, + main, + test, + ) +where + +import Alpha +import Data.Aeson ((.!=), (.:), (.:?), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import qualified Network.HTTP.Simple as HTTP +import qualified Omni.Test as Test + +main :: IO () +main = Test.run test + +test :: Test.Tree +test = + Test.group + "Omni.Agent.Engine" + [ Test.unit "Tool JSON roundtrip" <| do + let tool = + Tool + { toolName = "get_weather", + toolDescription = "Get weather for a location", + toolJsonSchema = Aeson.object ["type" .= ("object" :: Text), "properties" .= Aeson.object []], + toolExecute = \_ -> pure (Aeson.String "sunny") + } + let encoded = encodeToolForApi tool + case Aeson.decode (Aeson.encode encoded) of + Nothing -> Test.assertFailure "Failed to decode tool" + Just decoded -> toolName tool Test.@=? toolApiName decoded, + Test.unit "Message JSON roundtrip" <| do + let msg = Message User "Hello" Nothing Nothing + case Aeson.decode (Aeson.encode msg) of + Nothing -> Test.assertFailure "Failed to decode message" + Just decoded -> msgContent msg Test.@=? msgContent decoded, + Test.unit "defaultLLM has correct endpoint" <| do + llmBaseUrl defaultLLM Test.@=? "https://openrouter.ai/api/v1", + Test.unit "defaultLLM has OpenRouter headers" <| do + length (llmExtraHeaders defaultLLM) Test.@=? 2 + llmModel defaultLLM Test.@=? "anthropic/claude-sonnet-4.5", + Test.unit "defaultAgentConfig has sensible defaults" <| do + agentMaxIterations defaultAgentConfig Test.@=? 10, + Test.unit "defaultEngineConfig has no-op callbacks" <| do + engineOnCost defaultEngineConfig 100 5 + engineOnActivity defaultEngineConfig "test" + engineOnToolCall defaultEngineConfig "tool" "result" + True Test.@=? True, + Test.unit "buildToolMap creates correct map" <| do + let tool1 = + Tool + { toolName = "tool1", + toolDescription = "First tool", + toolJsonSchema = Aeson.object [], + toolExecute = \_ -> pure Aeson.Null + } + tool2 = + Tool + { toolName = "tool2", + toolDescription = "Second tool", + toolJsonSchema = Aeson.object [], + toolExecute = \_ -> pure Aeson.Null + } + toolMap = buildToolMap [tool1, tool2] + Map.size toolMap Test.@=? 2 + Map.member "tool1" toolMap Test.@=? True + Map.member "tool2" toolMap Test.@=? True, + Test.unit "Usage JSON parsing" <| do + let json = "{\"prompt_tokens\":100,\"completion_tokens\":50,\"total_tokens\":150}" + case Aeson.decode json of + Nothing -> Test.assertFailure "Failed to decode usage" + Just usage -> do + usagePromptTokens usage Test.@=? 100 + usageCompletionTokens usage Test.@=? 50 + usageTotalTokens usage Test.@=? 150, + Test.unit "AgentResult JSON roundtrip" <| do + let result = + AgentResult + { resultFinalMessage = "Done", + resultToolCallCount = 3, + resultIterations = 2, + resultTotalCost = 50, + resultTotalTokens = 1500 + } + case Aeson.decode (Aeson.encode result) of + Nothing -> Test.assertFailure "Failed to decode AgentResult" + Just decoded -> do + resultFinalMessage decoded Test.@=? "Done" + resultToolCallCount decoded Test.@=? 3 + resultIterations decoded Test.@=? 2, + Test.unit "estimateCost calculates correctly" <| do + let gpt4oCost = estimateCost "gpt-4o" 1000 + gpt4oMiniCost = estimateCost "gpt-4o-mini" 1000 + (gpt4oCost >= gpt4oMiniCost) Test.@=? True, + Test.unit "ToolCall JSON roundtrip" <| do + let tc = + ToolCall + { tcId = "call_123", + tcType = "function", + tcFunction = FunctionCall "read_file" "{\"path\":\"/tmp/test\"}" + } + case Aeson.decode (Aeson.encode tc) of + Nothing -> Test.assertFailure "Failed to decode ToolCall" + Just decoded -> tcId decoded Test.@=? "call_123", + Test.unit "FunctionCall JSON roundtrip" <| do + let fc = FunctionCall "test_func" "{\"arg\":\"value\"}" + case Aeson.decode (Aeson.encode fc) of + Nothing -> Test.assertFailure "Failed to decode FunctionCall" + Just decoded -> do + fcName decoded Test.@=? "test_func" + fcArguments decoded Test.@=? "{\"arg\":\"value\"}", + Test.unit "Role JSON roundtrip for all roles" <| do + let roles = [System, User, Assistant, ToolRole] + forM_ roles <| \role -> + case Aeson.decode (Aeson.encode role) of + Nothing -> Test.assertFailure ("Failed to decode Role: " <> show role) + Just decoded -> decoded Test.@=? role + ] + +data Tool = Tool + { toolName :: Text, + toolDescription :: Text, + toolJsonSchema :: Aeson.Value, + toolExecute :: Aeson.Value -> IO Aeson.Value + } + +data ToolApi = ToolApi + { toolApiName :: Text, + toolApiDescription :: Text, + toolApiParameters :: Aeson.Value + } + deriving (Generic) + +instance Aeson.ToJSON ToolApi where + toJSON t = + Aeson.object + [ "type" .= ("function" :: Text), + "function" + .= Aeson.object + [ "name" .= toolApiName t, + "description" .= toolApiDescription t, + "parameters" .= toolApiParameters t + ] + ] + +instance Aeson.FromJSON ToolApi where + parseJSON = + Aeson.withObject "ToolApi" <| \v -> do + fn <- v .: "function" + (ToolApi </ (fn .: "name")) + <*> (fn .: "description") + <*> (fn .: "parameters") + +encodeToolForApi :: Tool -> ToolApi +encodeToolForApi t = + ToolApi + { toolApiName = toolName t, + toolApiDescription = toolDescription t, + toolApiParameters = toolJsonSchema t + } + +data LLM = LLM + { llmBaseUrl :: Text, + llmApiKey :: Text, + llmModel :: Text, + llmExtraHeaders :: [(ByteString, ByteString)] + } + deriving (Show, Eq, Generic) + +instance Aeson.ToJSON LLM where + toJSON l = + Aeson.object + [ "llmBaseUrl" .= llmBaseUrl l, + "llmApiKey" .= llmApiKey l, + "llmModel" .= llmModel l + ] + +instance Aeson.FromJSON LLM where + parseJSON = + Aeson.withObject "LLM" <| \v -> + (LLM </ (v .: "llmBaseUrl")) + <*> (v .: "llmApiKey") + <*> (v .: "llmModel") + <*> pure [] + +defaultLLM :: LLM +defaultLLM = + LLM + { llmBaseUrl = "https://openrouter.ai/api/v1", + llmApiKey = "", + llmModel = "anthropic/claude-sonnet-4.5", + llmExtraHeaders = + [ ("HTTP-Referer", "https://omni.dev"), + ("X-Title", "Omni Agent") + ] + } + +data AgentConfig = AgentConfig + { agentModel :: Text, + agentTools :: [Tool], + agentSystemPrompt :: Text, + agentMaxIterations :: Int + } + +defaultAgentConfig :: AgentConfig +defaultAgentConfig = + AgentConfig + { agentModel = "gpt-4", + agentTools = [], + agentSystemPrompt = "You are a helpful assistant.", + agentMaxIterations = 10 + } + +data EngineConfig = EngineConfig + { engineLLM :: LLM, + engineOnCost :: Int -> Int -> IO (), + engineOnActivity :: Text -> IO (), + engineOnToolCall :: Text -> Text -> IO () + } + +defaultEngineConfig :: EngineConfig +defaultEngineConfig = + EngineConfig + { engineLLM = defaultLLM, + engineOnCost = \_ _ -> pure (), + engineOnActivity = \_ -> pure (), + engineOnToolCall = \_ _ -> pure () + } + +data AgentResult = AgentResult + { resultFinalMessage :: Text, + resultToolCallCount :: Int, + resultIterations :: Int, + resultTotalCost :: Int, + resultTotalTokens :: Int + } + deriving (Show, Eq, Generic) + +instance Aeson.ToJSON AgentResult + +instance Aeson.FromJSON AgentResult + +data Role = System | User | Assistant | ToolRole + deriving (Show, Eq, Generic) + +instance Aeson.ToJSON Role where + toJSON System = Aeson.String "system" + toJSON User = Aeson.String "user" + toJSON Assistant = Aeson.String "assistant" + toJSON ToolRole = Aeson.String "tool" + +instance Aeson.FromJSON Role where + parseJSON = Aeson.withText "Role" parseRole + where + parseRole "system" = pure System + parseRole "user" = pure User + parseRole "assistant" = pure Assistant + parseRole "tool" = pure ToolRole + parseRole _ = empty + +data Message = Message + { msgRole :: Role, + msgContent :: Text, + msgToolCalls :: Maybe [ToolCall], + msgToolCallId :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance Aeson.ToJSON Message where + toJSON m = + Aeson.object + <| catMaybes + [ Just ("role" .= msgRole m), + Just ("content" .= msgContent m), + ("tool_calls" .=) </ msgToolCalls m, + ("tool_call_id" .=) </ msgToolCallId m + ] + +instance Aeson.FromJSON Message where + parseJSON = + Aeson.withObject "Message" <| \v -> + (Message </ (v .: "role")) + <*> (v .:? "content" .!= "") + <*> (v .:? "tool_calls") + <*> (v .:? "tool_call_id") + +data ToolCall = ToolCall + { tcId :: Text, + tcType :: Text, + tcFunction :: FunctionCall + } + deriving (Show, Eq, Generic) + +instance Aeson.ToJSON ToolCall where + toJSON tc = + Aeson.object + [ "id" .= tcId tc, + "type" .= tcType tc, + "function" .= tcFunction tc + ] + +instance Aeson.FromJSON ToolCall where + parseJSON = + Aeson.withObject "ToolCall" <| \v -> + (ToolCall </ (v .: "id")) + <*> (v .:? "type" .!= "function") + <*> (v .: "function") + +data FunctionCall = FunctionCall + { fcName :: Text, + fcArguments :: Text + } + deriving (Show, Eq, Generic) + +instance Aeson.ToJSON FunctionCall where + toJSON fc = + Aeson.object + [ "name" .= fcName fc, + "arguments" .= fcArguments fc + ] + +instance Aeson.FromJSON FunctionCall where + parseJSON = + Aeson.withObject "FunctionCall" <| \v -> + (FunctionCall </ (v .: "name")) + <*> (v .: "arguments") + +data ToolResult = ToolResult + { trToolCallId :: Text, + trContent :: Text + } + deriving (Show, Eq, Generic) + +instance Aeson.ToJSON ToolResult + +instance Aeson.FromJSON ToolResult + +data ChatCompletionRequest = ChatCompletionRequest + { reqModel :: Text, + reqMessages :: [Message], + reqTools :: Maybe [ToolApi] + } + deriving (Generic) + +instance Aeson.ToJSON ChatCompletionRequest where + toJSON r = + Aeson.object + <| catMaybes + [ Just ("model" .= reqModel r), + Just ("messages" .= reqMessages r), + ("tools" .=) </ reqTools r + ] + +data Choice = Choice + { choiceIndex :: Int, + choiceMessage :: Message, + choiceFinishReason :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance Aeson.FromJSON Choice where + parseJSON = + Aeson.withObject "Choice" <| \v -> + (Choice </ (v .: "index")) + <*> (v .: "message") + <*> (v .:? "finish_reason") + +data Usage = Usage + { usagePromptTokens :: Int, + usageCompletionTokens :: Int, + usageTotalTokens :: Int + } + deriving (Show, Eq, Generic) + +instance Aeson.FromJSON Usage where + parseJSON = + Aeson.withObject "Usage" <| \v -> + (Usage </ (v .: "prompt_tokens")) + <*> (v .: "completion_tokens") + <*> (v .: "total_tokens") + +data ChatCompletionResponse = ChatCompletionResponse + { respId :: Text, + respChoices :: [Choice], + respModel :: Text, + respUsage :: Maybe Usage + } + deriving (Show, Eq, Generic) + +instance Aeson.FromJSON ChatCompletionResponse where + parseJSON = + Aeson.withObject "ChatCompletionResponse" <| \v -> + (ChatCompletionResponse </ (v .: "id")) + <*> (v .: "choices") + <*> (v .: "model") + <*> (v .:? "usage") + +data ChatResult = ChatResult + { chatMessage :: Message, + chatUsage :: Maybe Usage + } + deriving (Show, Eq) + +chatWithUsage :: LLM -> [Tool] -> [Message] -> IO (Either Text ChatResult) +chatWithUsage llm tools messages = do + let url = Text.unpack (llmBaseUrl llm) <> "/chat/completions" + req0 <- HTTP.parseRequest url + let toolApis = [encodeToolForApi t | not (null tools), t <- tools] + body = + ChatCompletionRequest + { reqModel = llmModel llm, + reqMessages = messages, + reqTools = if null toolApis then Nothing else Just toolApis + } + baseReq = + HTTP.setRequestMethod "POST" + <| HTTP.setRequestHeader "Content-Type" ["application/json"] + <| HTTP.setRequestHeader "Authorization" ["Bearer " <> TE.encodeUtf8 (llmApiKey llm)] + <| HTTP.setRequestBodyLBS (Aeson.encode body) + <| req0 + req = foldr addHeader baseReq (llmExtraHeaders llm) + addHeader (name, value) = HTTP.addRequestHeader (CI.mk name) value + + response <- HTTP.httpLBS req + let status = HTTP.getResponseStatusCode response + if status >= 200 && status < 300 + then case Aeson.decode (HTTP.getResponseBody response) of + Just resp -> + case respChoices resp of + (c : _) -> pure (Right (ChatResult (choiceMessage c) (respUsage resp))) + [] -> pure (Left "No choices in response") + Nothing -> pure (Left "Failed to parse response") + else pure (Left ("HTTP error: " <> tshow status <> " - " <> TE.decodeUtf8 (BL.toStrict (HTTP.getResponseBody response)))) + +chat :: LLM -> [Tool] -> [Message] -> IO (Either Text Message) +chat llm tools messages = do + result <- chatWithUsage llm tools messages + pure (chatMessage </ result) + +runAgent :: EngineConfig -> AgentConfig -> Text -> IO (Either Text AgentResult) +runAgent engineCfg agentCfg userPrompt = do + let llm = + (engineLLM engineCfg) + { llmModel = agentModel agentCfg + } + tools = agentTools agentCfg + toolMap = buildToolMap tools + systemMsg = Message System (agentSystemPrompt agentCfg) Nothing Nothing + userMsg = Message User userPrompt Nothing Nothing + initialMessages = [systemMsg, userMsg] + + engineOnActivity engineCfg "Starting agent loop" + loop llm tools toolMap initialMessages 0 0 0 + where + maxIter = agentMaxIterations agentCfg + + loop :: LLM -> [Tool] -> Map.Map Text Tool -> [Message] -> Int -> Int -> Int -> IO (Either Text AgentResult) + loop llm tools' toolMap msgs iteration totalCalls totalTokens + | iteration >= maxIter = + pure + <| Left + <| "Max iterations (" + <> tshow maxIter + <> ") reached" + | otherwise = do + engineOnActivity engineCfg <| "Iteration " <> tshow (iteration + 1) + result <- chatWithUsage llm tools' msgs + case result of + Left err -> pure (Left err) + Right chatRes -> do + let msg = chatMessage chatRes + tokens = maybe 0 usageTotalTokens (chatUsage chatRes) + cost = estimateCost (llmModel llm) tokens + engineOnCost engineCfg tokens cost + let newTokens = totalTokens + tokens + case msgToolCalls msg of + Nothing -> do + engineOnActivity engineCfg "Agent completed" + pure + <| Right + <| AgentResult + { resultFinalMessage = msgContent msg, + resultToolCallCount = totalCalls, + resultIterations = iteration + 1, + resultTotalCost = estimateTotalCost (llmModel llm) newTokens, + resultTotalTokens = newTokens + } + Just [] -> do + engineOnActivity engineCfg "Agent completed (empty tool calls)" + pure + <| Right + <| AgentResult + { resultFinalMessage = msgContent msg, + resultToolCallCount = totalCalls, + resultIterations = iteration + 1, + resultTotalCost = estimateTotalCost (llmModel llm) newTokens, + resultTotalTokens = newTokens + } + Just tcs -> do + toolResults <- executeToolCalls engineCfg toolMap tcs + let newMsgs = msgs <> [msg] <> toolResults + newCalls = totalCalls + length tcs + loop llm tools' toolMap newMsgs (iteration + 1) newCalls newTokens + +buildToolMap :: [Tool] -> Map.Map Text Tool +buildToolMap = Map.fromList <. map (\t -> (toolName t, t)) + +executeToolCalls :: EngineConfig -> Map.Map Text Tool -> [ToolCall] -> IO [Message] +executeToolCalls engineCfg toolMap = traverse executeSingle + where + executeSingle tc = do + let name = fcName (tcFunction tc) + argsText = fcArguments (tcFunction tc) + callId = tcId tc + engineOnActivity engineCfg <| "Executing tool: " <> name + case Map.lookup name toolMap of + Nothing -> do + let errMsg = "Tool not found: " <> name + engineOnToolCall engineCfg name errMsg + pure <| Message ToolRole errMsg Nothing (Just callId) + Just tool -> do + case Aeson.decode (BL.fromStrict (TE.encodeUtf8 argsText)) of + Nothing -> do + let errMsg = "Invalid JSON arguments: " <> argsText + engineOnToolCall engineCfg name errMsg + pure <| Message ToolRole errMsg Nothing (Just callId) + Just args -> do + resultValue <- toolExecute tool args + let resultText = TE.decodeUtf8 (BL.toStrict (Aeson.encode resultValue)) + summary = Text.take 100 resultText + engineOnToolCall engineCfg name summary + pure <| Message ToolRole resultText Nothing (Just callId) + +estimateCost :: Text -> Int -> Int +estimateCost model tokens + | "gpt-4o-mini" `Text.isInfixOf` model = tokens * 15 `div` 1000000 + | "gpt-4o" `Text.isInfixOf` model = tokens * 250 `div` 100000 + | "gpt-4" `Text.isInfixOf` model = tokens * 3 `div` 100000 + | "claude" `Text.isInfixOf` model = tokens * 3 `div` 100000 + | otherwise = tokens `div` 100000 + +estimateTotalCost :: Text -> Int -> Int +estimateTotalCost = estimateCost diff --git a/Omni/Agent/Git.hs b/Omni/Agent/Git.hs new file mode 100644 index 0000000..4c06cf6 --- /dev/null +++ b/Omni/Agent/Git.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Git operations for the agent. +-- +-- : out omni-agent-git +-- : dep temporary +module Omni.Agent.Git + ( checkout, + syncWithLive, + commit, + createBranch, + getCurrentBranch, + branchExists, + isMerged, + listBranches, + showFile, + getRepoRoot, + runGit, + main, + test, + ) +where + +import Alpha +import qualified Data.Text as Text +import qualified Omni.Log as Log +import Omni.Test ((@=?)) +import qualified Omni.Test as Test +import qualified System.Directory as Directory +import qualified System.Exit as Exit +import qualified System.IO.Temp as Temp +import qualified System.Process as Process + +main :: IO () +main = Test.run test + +test :: Test.Tree +test = + Test.group + "Omni.Agent.Git" + [ Test.unit "checkout works" <| do + Temp.withSystemTempDirectory "omni-agent-git-test" <| \tmpDir -> do + let repo = tmpDir <> "/repo" + Directory.createDirectory repo + -- init repo + git repo ["init"] + git repo ["branch", "-m", "master"] + git repo ["config", "user.email", "you@example.com"] + git repo ["config", "user.name", "Your Name"] + + -- commit A + writeFile (repo <> "/a.txt") "A" + git repo ["add", "a.txt"] + git repo ["commit", "-m", "A"] + shaA <- getSha repo "HEAD" + + -- create branch dev + git repo ["checkout", "-b", "dev"] + + -- commit B + writeFile (repo <> "/b.txt") "B" + git repo ["add", "b.txt"] + git repo ["commit", "-m", "B"] + shaB <- getSha repo "HEAD" + + -- switch back to master + git repo ["checkout", "master"] + + -- Test 1: checkout dev + checkout repo "dev" + current <- getSha repo "HEAD" + shaB @=? current + + -- Test 2: checkout master + checkout repo "master" + current' <- getSha repo "HEAD" + shaA @=? current' + + -- Test 3: dirty state + writeFile (repo <> "/a.txt") "DIRTY" + checkout repo "dev" + current'' <- getSha repo "HEAD" + shaB @=? current'' + -- Verify dirty file is gone/overwritten (b.txt should exist, a.txt should be A from master? No, a.txt is in A and B) + -- Wait, in dev, a.txt is "A". + content <- readFile (repo <> "/a.txt") + "A" @=? content + + -- Test 4: untracked file + writeFile (repo <> "/untracked.txt") "DELETE ME" + checkout repo "master" + exists <- Directory.doesFileExist (repo <> "/untracked.txt") + False @=? exists + ] + +getSha :: FilePath -> String -> IO String +getSha dir ref = do + let cmd = (Process.proc "git" ["rev-parse", ref]) {Process.cwd = Just dir} + (code, out, _) <- Process.readCreateProcessWithExitCode cmd "" + case code of + Exit.ExitSuccess -> pure <| strip out + _ -> panic "getSha failed" + +-- | Checkout a specific ref (SHA, branch, tag) in the given repository path. +-- This function ensures the repository is in the correct state by: +-- 1. Fetching all updates +-- 2. Checking out the ref (forcing overwrites of local changes) +-- 3. Resetting hard to the ref (to ensure clean state) +-- 4. Cleaning untracked files +-- 5. Updating submodules +checkout :: FilePath -> Text -> IO () +checkout repoPath ref = do + let r = Text.unpack ref + + Log.info ["git", "checkout", ref, "in", Text.pack repoPath] + + -- Fetch all refs to ensure we have the target + git repoPath ["fetch", "--all", "--tags"] + + -- Checkout the ref, discarding local changes + git repoPath ["checkout", "--force", r] + + -- Reset hard to ensure we are exactly at the target state + git repoPath ["reset", "--hard", r] + + -- Remove untracked files and directories + git repoPath ["clean", "-fdx"] + + -- Update submodules + git repoPath ["submodule", "update", "--init", "--recursive"] + + Log.good ["git", "checkout", "complete"] + Log.br + +-- | Run a git command in the given directory. +git :: FilePath -> [String] -> IO () +git dir args = do + let cmd = (Process.proc "git" args) {Process.cwd = Just dir} + (exitCode, out, err) <- Process.readCreateProcessWithExitCode cmd "" + case exitCode of + Exit.ExitSuccess -> pure () + Exit.ExitFailure code -> do + Log.fail ["git command failed", Text.pack (show args), "code: " <> show code] + Log.info [Text.pack out] + Log.info [Text.pack err] + Log.br + panic <| "git command failed: git " <> show args + +syncWithLive :: FilePath -> IO () +syncWithLive repo = do + Log.info ["git", "syncing with live"] + -- git repo ["fetch", "origin", "live"] -- Optional + + -- Try sync (branchless sync), if fail, panic + -- This replaces manual rebase and handles stack movement + let cmd = (Process.proc "git" ["sync"]) {Process.cwd = Just repo} + (code, out, err) <- Process.readCreateProcessWithExitCode cmd "" + case code of + Exit.ExitSuccess -> pure () + Exit.ExitFailure _ -> do + Log.warn ["git sync failed", Text.pack err] + Log.info [Text.pack out] + panic "Sync with live failed (git sync)" + +commit :: FilePath -> Text -> IO () +commit repo msg = do + Log.info ["git", "commit", msg] + git repo ["add", "."] + + -- Check for changes before committing to avoid error + let checkCmd = (Process.proc "git" ["diff", "--cached", "--quiet"]) {Process.cwd = Just repo} + (code, _, _) <- Process.readCreateProcessWithExitCode checkCmd "" + + case code of + Exit.ExitSuccess -> Log.warn ["git", "nothing to commit", "skipping"] + Exit.ExitFailure 1 -> git repo ["commit", "-m", Text.unpack msg] + Exit.ExitFailure c -> panic <| "git diff failed with code " <> show c + +createBranch :: FilePath -> Text -> IO () +createBranch repo branch = do + Log.info ["git", "create branch", branch] + git repo ["checkout", "-b", Text.unpack branch] + +getCurrentBranch :: FilePath -> IO Text +getCurrentBranch repo = do + let cmd = (Process.proc "git" ["branch", "--show-current"]) {Process.cwd = Just repo} + (code, out, _) <- Process.readCreateProcessWithExitCode cmd "" + case code of + Exit.ExitSuccess -> pure <| Text.strip (Text.pack out) + _ -> panic "git branch failed" + +branchExists :: FilePath -> Text -> IO Bool +branchExists repo branch = do + let cmd = (Process.proc "git" ["show-ref", "--verify", "refs/heads/" <> Text.unpack branch]) {Process.cwd = Just repo} + (code, _, _) <- Process.readCreateProcessWithExitCode cmd "" + pure (code == Exit.ExitSuccess) + +isMerged :: FilePath -> Text -> Text -> IO Bool +isMerged repo branch target = do + -- Check if 'branch' is merged into 'target' + -- git merge-base --is-ancestor <branch> <target> + let cmd = (Process.proc "git" ["merge-base", "--is-ancestor", Text.unpack branch, Text.unpack target]) {Process.cwd = Just repo} + (code, _, _) <- Process.readCreateProcessWithExitCode cmd "" + pure (code == Exit.ExitSuccess) + +listBranches :: FilePath -> Text -> IO [Text] +listBranches repo pat = do + let cmd = (Process.proc "git" ["branch", "--list", Text.unpack pat, "--format=%(refname:short)"]) {Process.cwd = Just repo} + (code, out, _) <- Process.readCreateProcessWithExitCode cmd "" + case code of + Exit.ExitSuccess -> pure <| filter (not <. Text.null) (Text.lines (Text.pack out)) + _ -> panic "git branch list failed" + +showFile :: FilePath -> Text -> FilePath -> IO (Maybe Text) +showFile repo branch path = do + let cmd = (Process.proc "git" ["show", Text.unpack branch <> ":" <> path]) {Process.cwd = Just repo} + (code, out, _) <- Process.readCreateProcessWithExitCode cmd "" + case code of + Exit.ExitSuccess -> pure <| Just (Text.pack out) + _ -> pure Nothing + +getRepoRoot :: FilePath -> IO FilePath +getRepoRoot dir = do + let cmd = (Process.proc "git" ["rev-parse", "--show-toplevel"]) {Process.cwd = Just dir} + (code, out, _) <- Process.readCreateProcessWithExitCode cmd "" + case code of + Exit.ExitSuccess -> pure <| strip out + _ -> panic "git rev-parse failed" + +runGit :: FilePath -> [String] -> IO () +runGit = git diff --git a/Omni/Agent/Log.hs b/Omni/Agent/Log.hs new file mode 100644 index 0000000..46ea009 --- /dev/null +++ b/Omni/Agent/Log.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Status of the agent for the UI +module Omni.Agent.Log where + +import Alpha +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) +import qualified Data.Text as Text +import qualified Data.Text.IO as TIO +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) +import Data.Time.Format (defaultTimeLocale, parseTimeOrError) +import qualified System.Console.ANSI as ANSI +import qualified System.IO as IO +import System.IO.Unsafe (unsafePerformIO) +import Text.Printf (printf) + +-- | Status of the agent for the UI +data Status = Status + { statusWorker :: Text, + statusTask :: Maybe Text, + statusThread :: Maybe Text, + statusFiles :: Int, + statusCredits :: Double, + statusStartTime :: UTCTime, + statusActivity :: Text + } + deriving (Show, Eq) + +emptyStatus :: Text -> UTCTime -> Status +emptyStatus workerName startTime = + Status + { statusWorker = workerName, + statusTask = Nothing, + statusThread = Nothing, + statusFiles = 0, + statusCredits = 0.0, + statusStartTime = startTime, + statusActivity = "Idle" + } + +-- | Global state for the status bar +{-# NOINLINE currentStatus #-} +currentStatus :: IORef Status +currentStatus = unsafePerformIO (newIORef (emptyStatus "Unknown" defaultStartTime)) + +defaultStartTime :: UTCTime +defaultStartTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" "2000-01-01 00:00:00 UTC" + +-- | Initialize the status bar system +init :: Text -> IO () +init workerName = do + IO.hSetBuffering IO.stderr IO.LineBuffering + startTime <- getCurrentTime + writeIORef currentStatus (emptyStatus workerName startTime) + -- Reserve 5 lines at bottom + IO.hPutStrLn IO.stderr "" + IO.hPutStrLn IO.stderr "" + IO.hPutStrLn IO.stderr "" + IO.hPutStrLn IO.stderr "" + IO.hPutStrLn IO.stderr "" + ANSI.hCursorUp IO.stderr 5 + +-- | Update the status +update :: (Status -> Status) -> IO () +update f = do + modifyIORef' currentStatus f + render + +-- | Get the current status +getStatus :: IO Status +getStatus = readIORef currentStatus + +-- | Set the activity message +updateActivity :: Text -> IO () +updateActivity msg = update (\s -> s {statusActivity = msg}) + +-- | Log a scrolling message (appears above status bars) +log :: Text -> IO () +log msg = do + -- Clear status bars + ANSI.hClearLine IO.stderr + ANSI.hCursorDown IO.stderr 1 + ANSI.hClearLine IO.stderr + ANSI.hCursorDown IO.stderr 1 + ANSI.hClearLine IO.stderr + ANSI.hCursorDown IO.stderr 1 + ANSI.hClearLine IO.stderr + ANSI.hCursorDown IO.stderr 1 + ANSI.hClearLine IO.stderr + ANSI.hCursorUp IO.stderr 4 + + -- Print message (scrolls screen) + TIO.hPutStrLn IO.stderr msg + + -- Re-render status bars at bottom + -- (Since we scrolled, we are now on the line above where the first status line should be) + render + +-- | Render the five status lines +render :: IO () +render = do + Status {..} <- readIORef currentStatus + now <- getCurrentTime + let taskStr = maybe "None" identity statusTask + threadStr = maybe "None" identity statusThread + elapsed = diffUTCTime now statusStartTime + elapsedStr = formatElapsed elapsed + + -- Line 1: Worker | Thread + ANSI.hSetCursorColumn IO.stderr 0 + ANSI.hClearLine IO.stderr + TIO.hPutStr IO.stderr ("[Worker: " <> statusWorker <> "] Thread: " <> threadStr) + + -- Line 2: Task + ANSI.hCursorDown IO.stderr 1 + ANSI.hSetCursorColumn IO.stderr 0 + ANSI.hClearLine IO.stderr + TIO.hPutStr IO.stderr ("Task: " <> taskStr) + + -- Line 3: Files | Credits + ANSI.hCursorDown IO.stderr 1 + ANSI.hSetCursorColumn IO.stderr 0 + ANSI.hClearLine IO.stderr + let creditsStr = Text.pack (printf "%.2f" statusCredits) + TIO.hPutStr IO.stderr ("Files: " <> tshow statusFiles <> " | Credits: $" <> creditsStr) + + -- Line 4: Time (elapsed duration) + ANSI.hCursorDown IO.stderr 1 + ANSI.hSetCursorColumn IO.stderr 0 + ANSI.hClearLine IO.stderr + TIO.hPutStr IO.stderr ("Time: " <> elapsedStr) + + -- Line 5: Activity + ANSI.hCursorDown IO.stderr 1 + ANSI.hSetCursorColumn IO.stderr 0 + ANSI.hClearLine IO.stderr + TIO.hPutStr IO.stderr ("> " <> statusActivity) + + -- Return cursor to line 1 + ANSI.hCursorUp IO.stderr 4 + IO.hFlush IO.stderr + +-- | Format elapsed time as MM:SS or HH:MM:SS +formatElapsed :: NominalDiffTime -> Text +formatElapsed elapsed = + let totalSecs = floor elapsed :: Int + hours = totalSecs `div` 3600 + mins = (totalSecs `mod` 3600) `div` 60 + secs = totalSecs `mod` 60 + in if hours > 0 + then Text.pack (printf "%02d:%02d:%02d" hours mins secs) + else Text.pack (printf "%02d:%02d" mins secs) diff --git a/Omni/Agent/Tools.hs b/Omni/Agent/Tools.hs new file mode 100644 index 0000000..0312924 --- /dev/null +++ b/Omni/Agent/Tools.hs @@ -0,0 +1,582 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Core coding tools for Jr agent. +-- +-- Provides implementations for: +-- - readFile: Read file contents +-- - writeFile: Write file contents +-- - editFile: Search/replace edit +-- - runBash: Execute shell commands +-- - searchCodebase: Ripgrep wrapper for code search +-- +-- All tools return structured JSON results. +-- +-- : out omni-agent-tools +-- : dep aeson +-- : dep directory +module Omni.Agent.Tools + ( readFileTool, + writeFileTool, + editFileTool, + runBashTool, + searchCodebaseTool, + allTools, + ReadFileArgs (..), + WriteFileArgs (..), + EditFileArgs (..), + RunBashArgs (..), + SearchCodebaseArgs (..), + ToolResult (..), + main, + test, + ) +where + +import Alpha +import Data.Aeson ((.!=), (.:), (.:?), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO +import qualified Omni.Agent.Engine as Engine +import qualified Omni.Test as Test +import qualified System.Directory as Directory +import qualified System.Exit as Exit +import qualified System.Process as Process + +main :: IO () +main = Test.run test + +test :: Test.Tree +test = + Test.group + "Omni.Agent.Tools" + [ Test.unit "readFileTool schema is valid" <| do + let schema = Engine.toolJsonSchema readFileTool + case schema of + Aeson.Object _ -> pure () + _ -> Test.assertFailure "Schema should be an object", + Test.unit "writeFileTool schema is valid" <| do + let schema = Engine.toolJsonSchema writeFileTool + case schema of + Aeson.Object _ -> pure () + _ -> Test.assertFailure "Schema should be an object", + Test.unit "editFileTool schema is valid" <| do + let schema = Engine.toolJsonSchema editFileTool + case schema of + Aeson.Object _ -> pure () + _ -> Test.assertFailure "Schema should be an object", + Test.unit "runBashTool schema is valid" <| do + let schema = Engine.toolJsonSchema runBashTool + case schema of + Aeson.Object _ -> pure () + _ -> Test.assertFailure "Schema should be an object", + Test.unit "searchCodebaseTool schema is valid" <| do + let schema = Engine.toolJsonSchema searchCodebaseTool + case schema of + Aeson.Object _ -> pure () + _ -> Test.assertFailure "Schema should be an object", + Test.unit "allTools contains 5 tools" <| do + length allTools Test.@=? 5, + Test.unit "ReadFileArgs parses correctly" <| do + let json = Aeson.object ["path" .= ("test.txt" :: Text)] + case Aeson.fromJSON json of + Aeson.Success (args :: ReadFileArgs) -> readFilePath args Test.@=? "test.txt" + Aeson.Error e -> Test.assertFailure e, + Test.unit "WriteFileArgs parses correctly" <| do + let json = Aeson.object ["path" .= ("test.txt" :: Text), "content" .= ("hello" :: Text)] + case Aeson.fromJSON json of + Aeson.Success (args :: WriteFileArgs) -> do + writeFilePath args Test.@=? "test.txt" + writeFileContent args Test.@=? "hello" + Aeson.Error e -> Test.assertFailure e, + Test.unit "EditFileArgs parses correctly" <| do + let json = + Aeson.object + [ "path" .= ("test.txt" :: Text), + "old_str" .= ("foo" :: Text), + "new_str" .= ("bar" :: Text) + ] + case Aeson.fromJSON json of + Aeson.Success (args :: EditFileArgs) -> do + editFilePath args Test.@=? "test.txt" + editFileOldStr args Test.@=? "foo" + editFileNewStr args Test.@=? "bar" + Aeson.Error e -> Test.assertFailure e, + Test.unit "RunBashArgs parses correctly" <| do + let json = Aeson.object ["command" .= ("ls -la" :: Text)] + case Aeson.fromJSON json of + Aeson.Success (args :: RunBashArgs) -> runBashCommand args Test.@=? "ls -la" + Aeson.Error e -> Test.assertFailure e, + Test.unit "SearchCodebaseArgs parses correctly" <| do + let json = Aeson.object ["pattern" .= ("TODO" :: Text)] + case Aeson.fromJSON json of + Aeson.Success (args :: SearchCodebaseArgs) -> searchPattern args Test.@=? "TODO" + Aeson.Error e -> Test.assertFailure e, + Test.unit "ToolResult success JSON roundtrip" <| do + let result = ToolResult True "done" Nothing + case Aeson.decode (Aeson.encode result) of + Nothing -> Test.assertFailure "Failed to decode ToolResult" + Just decoded -> toolResultSuccess decoded Test.@=? True, + Test.unit "ToolResult failure JSON roundtrip" <| do + let result = ToolResult False "" (Just "error occurred") + case Aeson.decode (Aeson.encode result) of + Nothing -> Test.assertFailure "Failed to decode ToolResult" + Just decoded -> toolResultError decoded Test.@=? Just "error occurred", + Test.unit "readFileTool handles missing files" <| do + let args = Aeson.object ["path" .= ("/nonexistent/path/to/file.txt" :: Text)] + result <- Engine.toolExecute readFileTool args + case Aeson.fromJSON result of + Aeson.Success (tr :: ToolResult) -> do + toolResultSuccess tr Test.@=? False + isJust (toolResultError tr) Test.@=? True + Aeson.Error e -> Test.assertFailure e, + Test.unit "editFileTool handles no-match case" <| do + let args = + Aeson.object + [ "path" .= ("/nonexistent/file.txt" :: Text), + "old_str" .= ("needle" :: Text), + "new_str" .= ("replacement" :: Text) + ] + result <- Engine.toolExecute editFileTool args + case Aeson.fromJSON result of + Aeson.Success (tr :: ToolResult) -> toolResultSuccess tr Test.@=? False + Aeson.Error e -> Test.assertFailure e, + Test.unit "runBashTool captures exit codes" <| do + let args = Aeson.object ["command" .= ("exit 42" :: Text)] + result <- Engine.toolExecute runBashTool args + case Aeson.fromJSON result of + Aeson.Success (tr :: ToolResult) -> do + toolResultSuccess tr Test.@=? False + toolResultError tr Test.@=? Just "Exit code: 42" + Aeson.Error e -> Test.assertFailure e, + Test.unit "runBashTool captures stdout" <| do + let args = Aeson.object ["command" .= ("echo hello" :: Text)] + result <- Engine.toolExecute runBashTool args + case Aeson.fromJSON result of + Aeson.Success (tr :: ToolResult) -> do + toolResultSuccess tr Test.@=? True + ("hello" `Text.isInfixOf` toolResultOutput tr) Test.@=? True + Aeson.Error e -> Test.assertFailure e, + Test.unit "searchCodebaseTool returns structured results" <| do + let args = + Aeson.object + [ "pattern" .= ("module" :: Text), + "path" .= ("." :: Text), + "max_results" .= (5 :: Int) + ] + result <- Engine.toolExecute searchCodebaseTool args + case Aeson.fromJSON result of + Aeson.Success (tr :: ToolResult) -> toolResultSuccess tr Test.@=? True + Aeson.Error e -> Test.assertFailure e + ] + +data ToolResult = ToolResult + { toolResultSuccess :: Bool, + toolResultOutput :: Text, + toolResultError :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance Aeson.ToJSON ToolResult where + toJSON r = + Aeson.object + <| catMaybes + [ Just ("success" .= toolResultSuccess r), + Just ("output" .= toolResultOutput r), + ("error" .=) </ toolResultError r + ] + +instance Aeson.FromJSON ToolResult where + parseJSON = + Aeson.withObject "ToolResult" <| \v -> + (ToolResult </ (v .: "success")) + <*> (v .:? "output" .!= "") + <*> (v .:? "error") + +mkSuccess :: Text -> Aeson.Value +mkSuccess output = Aeson.toJSON <| ToolResult True output Nothing + +mkError :: Text -> Aeson.Value +mkError err = Aeson.toJSON <| ToolResult False "" (Just err) + +allTools :: [Engine.Tool] +allTools = + [ readFileTool, + writeFileTool, + editFileTool, + runBashTool, + searchCodebaseTool + ] + +data ReadFileArgs = ReadFileArgs + { readFilePath :: Text, + readFileStartLine :: Maybe Int, + readFileEndLine :: Maybe Int + } + deriving (Show, Eq, Generic) + +instance Aeson.FromJSON ReadFileArgs where + parseJSON = + Aeson.withObject "ReadFileArgs" <| \v -> + (ReadFileArgs </ (v .: "path")) + <*> (v .:? "start_line") + <*> (v .:? "end_line") + +readFileTool :: Engine.Tool +readFileTool = + Engine.Tool + { Engine.toolName = "read_file", + Engine.toolDescription = "Read the contents of a file. Can optionally read a specific line range.", + Engine.toolJsonSchema = + Aeson.object + [ "type" .= ("object" :: Text), + "properties" + .= Aeson.object + [ "path" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("Absolute path to the file to read" :: Text) + ], + "start_line" + .= Aeson.object + [ "type" .= ("integer" :: Text), + "description" .= ("Optional: first line to read (1-indexed)" :: Text) + ], + "end_line" + .= Aeson.object + [ "type" .= ("integer" :: Text), + "description" .= ("Optional: last line to read (1-indexed)" :: Text) + ] + ], + "required" .= (["path"] :: [Text]) + ], + Engine.toolExecute = executeReadFile + } + +executeReadFile :: Aeson.Value -> IO Aeson.Value +executeReadFile v = + case Aeson.fromJSON v of + Aeson.Error e -> pure <| mkError (Text.pack e) + Aeson.Success args -> do + let path = Text.unpack (readFilePath args) + exists <- Directory.doesFileExist path + if exists + then do + content <- TextIO.readFile path + let allLines = Text.lines content + startIdx = maybe 0 (\n -> n - 1) (readFileStartLine args) + endIdx = maybe (length allLines) identity (readFileEndLine args) + selectedLines = take (endIdx - startIdx) (drop startIdx allLines) + numberedLines = zipWith formatLine [(startIdx + 1) ..] selectedLines + result = Text.unlines numberedLines + pure <| mkSuccess result + else pure <| mkError ("File not found: " <> readFilePath args) + where + formatLine :: Int -> Text -> Text + formatLine n line = Text.pack (show n) <> ": " <> line + +data WriteFileArgs = WriteFileArgs + { writeFilePath :: Text, + writeFileContent :: Text + } + deriving (Show, Eq, Generic) + +instance Aeson.FromJSON WriteFileArgs where + parseJSON = + Aeson.withObject "WriteFileArgs" <| \v -> + (WriteFileArgs </ (v .: "path")) + <*> (v .: "content") + +writeFileTool :: Engine.Tool +writeFileTool = + Engine.Tool + { Engine.toolName = "write_file", + Engine.toolDescription = "Create or overwrite a file with the given content.", + Engine.toolJsonSchema = + Aeson.object + [ "type" .= ("object" :: Text), + "properties" + .= Aeson.object + [ "path" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("Absolute path to the file to write" :: Text) + ], + "content" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("Content to write to the file" :: Text) + ] + ], + "required" .= (["path", "content"] :: [Text]) + ], + Engine.toolExecute = executeWriteFile + } + +executeWriteFile :: Aeson.Value -> IO Aeson.Value +executeWriteFile v = + case Aeson.fromJSON v of + Aeson.Error e -> pure <| mkError (Text.pack e) + Aeson.Success args -> do + let path = Text.unpack (writeFilePath args) + let dir = takeDirectory path + dirExists <- Directory.doesDirectoryExist dir + if dirExists + then do + TextIO.writeFile path (writeFileContent args) + pure <| mkSuccess ("File written: " <> writeFilePath args) + else pure <| mkError ("Parent directory does not exist: " <> Text.pack dir) + where + takeDirectory :: FilePath -> FilePath + takeDirectory p = + let parts = Text.splitOn "/" (Text.pack p) + in Text.unpack (Text.intercalate "/" (List.init parts)) + +data EditFileArgs = EditFileArgs + { editFilePath :: Text, + editFileOldStr :: Text, + editFileNewStr :: Text, + editFileReplaceAll :: Maybe Bool + } + deriving (Show, Eq, Generic) + +instance Aeson.FromJSON EditFileArgs where + parseJSON = + Aeson.withObject "EditFileArgs" <| \v -> + (EditFileArgs </ (v .: "path")) + <*> (v .: "old_str") + <*> (v .: "new_str") + <*> (v .:? "replace_all") + +editFileTool :: Engine.Tool +editFileTool = + Engine.Tool + { Engine.toolName = "edit_file", + Engine.toolDescription = "Edit a file by replacing old_str with new_str. By default replaces only the first occurrence unless replace_all is true.", + Engine.toolJsonSchema = + Aeson.object + [ "type" .= ("object" :: Text), + "properties" + .= Aeson.object + [ "path" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("Absolute path to the file to edit" :: Text) + ], + "old_str" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("The text to search for and replace" :: Text) + ], + "new_str" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("The replacement text" :: Text) + ], + "replace_all" + .= Aeson.object + [ "type" .= ("boolean" :: Text), + "description" .= ("If true, replace all occurrences; otherwise replace only the first" :: Text) + ] + ], + "required" .= (["path", "old_str", "new_str"] :: [Text]) + ], + Engine.toolExecute = executeEditFile + } + +executeEditFile :: Aeson.Value -> IO Aeson.Value +executeEditFile v = + case Aeson.fromJSON v of + Aeson.Error e -> pure <| mkError (Text.pack e) + Aeson.Success args -> do + let path = Text.unpack (editFilePath args) + exists <- Directory.doesFileExist path + if exists + then do + content <- TextIO.readFile path + let oldStr = editFileOldStr args + newStr = editFileNewStr args + replaceAll = fromMaybe False (editFileReplaceAll args) + if Text.isInfixOf oldStr content + then do + let newContent = + if replaceAll + then Text.replace oldStr newStr content + else replaceFirst oldStr newStr content + TextIO.writeFile path newContent + let count = + if replaceAll + then Text.count oldStr content + else 1 + pure <| mkSuccess ("Replaced " <> tshow count <> " occurrence(s)") + else pure <| mkError ("old_str not found in file: " <> editFilePath args) + else pure <| mkError ("File not found: " <> editFilePath args) + +replaceFirst :: Text -> Text -> Text -> Text +replaceFirst old new content = + case Text.breakOn old content of + (before, after) -> + if Text.null after + then content + else before <> new <> Text.drop (Text.length old) after + +data RunBashArgs = RunBashArgs + { runBashCommand :: Text, + runBashCwd :: Maybe Text, + runBashTimeout :: Maybe Int + } + deriving (Show, Eq, Generic) + +instance Aeson.FromJSON RunBashArgs where + parseJSON = + Aeson.withObject "RunBashArgs" <| \v -> + (RunBashArgs </ (v .: "command")) + <*> (v .:? "cwd") + <*> (v .:? "timeout") + +runBashTool :: Engine.Tool +runBashTool = + Engine.Tool + { Engine.toolName = "run_bash", + Engine.toolDescription = "Execute a shell command and return stdout/stderr.", + Engine.toolJsonSchema = + Aeson.object + [ "type" .= ("object" :: Text), + "properties" + .= Aeson.object + [ "command" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("The shell command to execute" :: Text) + ], + "cwd" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("Optional: working directory for the command" :: Text) + ], + "timeout" + .= Aeson.object + [ "type" .= ("integer" :: Text), + "description" .= ("Optional: timeout in seconds (default: 300)" :: Text) + ] + ], + "required" .= (["command"] :: [Text]) + ], + Engine.toolExecute = executeRunBash + } + +executeRunBash :: Aeson.Value -> IO Aeson.Value +executeRunBash v = + case Aeson.fromJSON v of + Aeson.Error e -> pure <| mkError (Text.pack e) + Aeson.Success args -> do + let cmd = Text.unpack (runBashCommand args) + proc = + (Process.shell cmd) + { Process.cwd = Text.unpack </ runBashCwd args + } + (exitCode, stdoutStr, stderrStr) <- Process.readCreateProcessWithExitCode proc "" + let output = Text.pack stdoutStr <> Text.pack stderrStr + case exitCode of + Exit.ExitSuccess -> + pure + <| Aeson.toJSON + <| ToolResult + { toolResultSuccess = True, + toolResultOutput = output, + toolResultError = Nothing + } + Exit.ExitFailure code -> + pure + <| Aeson.toJSON + <| ToolResult + { toolResultSuccess = False, + toolResultOutput = output, + toolResultError = Just ("Exit code: " <> tshow code) + } + +data SearchCodebaseArgs = SearchCodebaseArgs + { searchPattern :: Text, + searchPath :: Maybe Text, + searchGlob :: Maybe Text, + searchCaseSensitive :: Maybe Bool, + searchMaxResults :: Maybe Int + } + deriving (Show, Eq, Generic) + +instance Aeson.FromJSON SearchCodebaseArgs where + parseJSON = + Aeson.withObject "SearchCodebaseArgs" <| \v -> + (SearchCodebaseArgs </ (v .: "pattern")) + <*> (v .:? "path") + <*> (v .:? "glob") + <*> (v .:? "case_sensitive") + <*> (v .:? "max_results") + +searchCodebaseTool :: Engine.Tool +searchCodebaseTool = + Engine.Tool + { Engine.toolName = "search_codebase", + Engine.toolDescription = "Search the codebase using ripgrep. Returns matching lines with file paths and line numbers.", + Engine.toolJsonSchema = + Aeson.object + [ "type" .= ("object" :: Text), + "properties" + .= Aeson.object + [ "pattern" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("The regex pattern to search for" :: Text) + ], + "path" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("Optional: directory or file path to search in" :: Text) + ], + "glob" + .= Aeson.object + [ "type" .= ("string" :: Text), + "description" .= ("Optional: file glob pattern (e.g., '*.hs')" :: Text) + ], + "case_sensitive" + .= Aeson.object + [ "type" .= ("boolean" :: Text), + "description" .= ("Optional: case sensitive search (default: false)" :: Text) + ], + "max_results" + .= Aeson.object + [ "type" .= ("integer" :: Text), + "description" .= ("Optional: maximum number of results (default: 100)" :: Text) + ] + ], + "required" .= (["pattern"] :: [Text]) + ], + Engine.toolExecute = executeSearchCodebase + } + +executeSearchCodebase :: Aeson.Value -> IO Aeson.Value +executeSearchCodebase v = + case Aeson.fromJSON v of + Aeson.Error e -> pure <| mkError (Text.pack e) + Aeson.Success args -> do + let pat = Text.unpack (searchPattern args) + maxRes = fromMaybe 100 (searchMaxResults args) + caseSensitive = fromMaybe False (searchCaseSensitive args) + baseArgs = + ["--line-number", "--no-heading", "--max-count=" <> show maxRes, pat] + caseArgs = ["--ignore-case" | not caseSensitive] + globArgs = maybe [] (\g -> ["--glob", Text.unpack g]) (searchGlob args) + pathArg = maybe ["."] (\p -> [Text.unpack p]) (searchPath args) + allArgs = caseArgs <> globArgs <> baseArgs <> pathArg + proc = Process.proc "rg" allArgs + (exitCode, stdoutStr, stderrStr) <- Process.readCreateProcessWithExitCode proc "" + case exitCode of + Exit.ExitSuccess -> + pure <| mkSuccess (Text.pack stdoutStr) + Exit.ExitFailure 1 -> + pure <| mkSuccess "No matches found" + Exit.ExitFailure code -> + pure <| mkError ("ripgrep failed with code " <> tshow code <> ": " <> Text.pack stderrStr) diff --git a/Omni/Agent/Worker.hs b/Omni/Agent/Worker.hs new file mode 100644 index 0000000..61c392b --- /dev/null +++ b/Omni/Agent/Worker.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Omni.Agent.Worker where + +import Alpha +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as AesonKey +import qualified Data.ByteString.Lazy as BSL +import Data.IORef (modifyIORef', newIORef, readIORef) +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import qualified Data.Time +import qualified Omni.Agent.Core as Core +import qualified Omni.Agent.Engine as Engine +import qualified Omni.Agent.Log as AgentLog +import qualified Omni.Agent.Tools as Tools +import qualified Omni.Fact as Fact +import qualified Omni.Task.Core as TaskCore +import qualified System.Directory as Directory +import qualified System.Environment as Env +import qualified System.Exit as Exit +import System.FilePath ((</>)) +import qualified System.Process as Process + +start :: Core.Worker -> Maybe Text -> IO () +start worker maybeTaskId = do + if Core.workerQuiet worker + then putText ("[worker] Starting for " <> Core.workerName worker) + else do + AgentLog.init (Core.workerName worker) + AgentLog.log ("[worker] Starting for " <> Core.workerName worker) + case maybeTaskId of + Just tid -> logMsg worker ("[worker] Target task: " <> tid) + Nothing -> logMsg worker "[worker] No specific task, will pick from ready queue" + runOnce worker maybeTaskId + +-- | Log message respecting quiet mode +logMsg :: Core.Worker -> Text -> IO () +logMsg worker msg = + if Core.workerQuiet worker + then putText msg + else AgentLog.log msg + +-- | Convert key-value pairs to JSON metadata string +toMetadata :: [(Text, Text)] -> Text +toMetadata pairs = + let obj = Aeson.object [(AesonKey.fromText k, Aeson.String v) | (k, v) <- pairs] + in TE.decodeUtf8 (BSL.toStrict (Aeson.encode obj)) + +runOnce :: Core.Worker -> Maybe Text -> IO () +runOnce worker maybeTaskId = do + -- Find work + targetTask <- case maybeTaskId of + Just tid -> do + TaskCore.findTask tid </ TaskCore.loadTasks + Nothing -> do + readyTasks <- TaskCore.getReadyTasks + case readyTasks of + [] -> pure Nothing + (task : _) -> pure (Just task) + + case targetTask of + Nothing -> do + case maybeTaskId of + Just tid -> do + unless (Core.workerQuiet worker) <| AgentLog.updateActivity ("Task " <> tid <> " not found.") + logMsg worker ("[worker] Task " <> tid <> " not found.") + Nothing -> do + unless (Core.workerQuiet worker) <| AgentLog.updateActivity "No work found." + logMsg worker "[worker] No ready tasks found." + Just task -> do + processTask worker task + +processTask :: Core.Worker -> TaskCore.Task -> IO () +processTask worker task = do + let repo = Core.workerPath worker + let tid = TaskCore.taskId task + let quiet = Core.workerQuiet worker + let say = logMsg worker + + unless quiet <| AgentLog.update (\s -> s {AgentLog.statusTask = Just tid}) + say ("[worker] Claiming task " <> tid) + + -- Claim task + TaskCore.logActivity tid TaskCore.Claiming Nothing + TaskCore.updateTaskStatus tid TaskCore.InProgress [] + say "[worker] Status -> InProgress" + + -- Run agent with timing + startTime <- Data.Time.getCurrentTime + activityId <- TaskCore.logActivityWithMetrics tid TaskCore.Running Nothing Nothing (Just startTime) Nothing Nothing Nothing + + say "[worker] Starting engine..." + (exitCode, output, costCents) <- runWithEngine repo task + + endTime <- Data.Time.getCurrentTime + say ("[worker] Agent exited with: " <> tshow exitCode) + + -- Update the activity record with metrics + TaskCore.updateActivityMetrics activityId Nothing (Just endTime) (Just costCents) Nothing + + case exitCode of + Exit.ExitSuccess -> do + TaskCore.logActivity tid TaskCore.Reviewing Nothing + say "[worker] Running formatters..." + _ <- runFormatters repo + + -- Try to commit (this runs git hooks which may fail) + let commitMsg = formatCommitMessage task output + say "[worker] Attempting commit..." + commitResult <- tryCommit repo commitMsg + + case commitResult of + CommitFailed commitErr -> do + say ("[worker] Commit failed: " <> commitErr) + + -- Save failure context and reopen task for retry + maybeCtx <- TaskCore.getRetryContext tid + let attempt = maybe 1 (\c -> TaskCore.retryAttempt c + 1) maybeCtx + + if attempt > 3 + then do + say "[worker] Task failed 3 times, needs human intervention" + TaskCore.logActivity tid TaskCore.Failed (Just (toMetadata [("reason", "max_retries_exceeded")])) + TaskCore.updateTaskStatus tid TaskCore.Open [] + else do + let currentReason = "attempt " <> tshow attempt <> ": commit_failed: " <> commitErr + let accumulatedReason = case maybeCtx of + Nothing -> currentReason + Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason + TaskCore.setRetryContext + TaskCore.RetryContext + { TaskCore.retryTaskId = tid, + TaskCore.retryOriginalCommit = "", + TaskCore.retryConflictFiles = [], + TaskCore.retryAttempt = attempt, + TaskCore.retryReason = accumulatedReason, + TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes + } + TaskCore.logActivity tid TaskCore.Retrying (Just (toMetadata [("attempt", tshow attempt)])) + TaskCore.updateTaskStatus tid TaskCore.Open [] + say ("[worker] Task reopened (attempt " <> tshow attempt <> "/3)") + NoChanges -> do + -- No changes = task already implemented, mark as Done + say "[worker] No changes to commit - task already done" + TaskCore.clearRetryContext tid + TaskCore.logActivity tid TaskCore.Completed (Just (toMetadata [("result", "no_changes")])) + TaskCore.updateTaskStatus tid TaskCore.Done [] + say ("[worker] ✓ Task " <> tid <> " -> Done (no changes)") + unless quiet <| AgentLog.update (\s -> s {AgentLog.statusTask = Nothing}) + CommitSuccess -> do + -- Commit succeeded, set to Review + TaskCore.logActivity tid TaskCore.Completed (Just (toMetadata [("result", "committed")])) + TaskCore.updateTaskStatus tid TaskCore.Review [] + say ("[worker] ✓ Task " <> tid <> " -> Review") + unless quiet <| AgentLog.update (\s -> s {AgentLog.statusTask = Nothing}) + Exit.ExitFailure code -> do + say ("[worker] Engine failed with code " <> tshow code) + TaskCore.logActivity tid TaskCore.Failed (Just (toMetadata [("exit_code", tshow code)])) + -- Don't set back to Open here - leave in InProgress for debugging + say "[worker] Task left in InProgress (engine failure)" + +-- | Run lint --fix to format and fix lint issues +runFormatters :: FilePath -> IO (Either Text ()) +runFormatters repo = do + let cmd = (Process.proc "lint" ["--fix"]) {Process.cwd = Just repo} + (code, _, _) <- Process.readCreateProcessWithExitCode cmd "" + case code of + Exit.ExitSuccess -> pure (Right ()) + Exit.ExitFailure _ -> pure (Right ()) -- lint --fix may exit non-zero but still fix things + +data CommitResult = CommitSuccess | NoChanges | CommitFailed Text + deriving (Show, Eq) + +-- | Try to commit, returning result +tryCommit :: FilePath -> Text -> IO CommitResult +tryCommit repo msg = do + -- Stage all changes + let addCmd = (Process.proc "git" ["add", "."]) {Process.cwd = Just repo} + (addCode, _, addErr) <- Process.readCreateProcessWithExitCode addCmd "" + case addCode of + Exit.ExitFailure _ -> pure <| CommitFailed (Text.pack addErr) + Exit.ExitSuccess -> do + -- Check for changes + let checkCmd = (Process.proc "git" ["diff", "--cached", "--quiet"]) {Process.cwd = Just repo} + (checkCode, _, _) <- Process.readCreateProcessWithExitCode checkCmd "" + case checkCode of + Exit.ExitSuccess -> pure NoChanges + Exit.ExitFailure 1 -> do + -- There are changes, commit them + let commitCmd = (Process.proc "git" ["commit", "-m", Text.unpack msg]) {Process.cwd = Just repo} + (commitCode, _, commitErr) <- Process.readCreateProcessWithExitCode commitCmd "" + case commitCode of + Exit.ExitSuccess -> pure CommitSuccess + Exit.ExitFailure _ -> pure <| CommitFailed (Text.pack commitErr) + Exit.ExitFailure c -> pure <| CommitFailed ("git diff failed with code " <> tshow c) + +-- | Run task using native Engine +-- Returns (ExitCode, output text, cost in cents) +runWithEngine :: FilePath -> TaskCore.Task -> IO (Exit.ExitCode, Text, Int) +runWithEngine repo task = do + -- Read API key from environment + maybeApiKey <- Env.lookupEnv "OPENROUTER_API_KEY" + case maybeApiKey of + Nothing -> pure (Exit.ExitFailure 1, "OPENROUTER_API_KEY not set", 0) + Just apiKey -> do + -- Check for retry context + maybeRetry <- TaskCore.getRetryContext (TaskCore.taskId task) + + -- Build the full prompt + let ns = fromMaybe "." (TaskCore.taskNamespace task) + let basePrompt = buildBasePrompt task ns repo + + -- Add retry context if present + let retryPrompt = buildRetryPrompt maybeRetry + + let prompt = basePrompt <> retryPrompt + + -- Read AGENTS.md + agentsMd <- + fmap (fromMaybe "") <| do + exists <- Directory.doesFileExist (repo </> "AGENTS.md") + if exists + then Just </ readFile (repo </> "AGENTS.md") + else pure Nothing + + -- Get relevant facts from the knowledge base + relevantFacts <- getRelevantFacts task + let factsSection = formatFacts relevantFacts + + -- Build system prompt + let systemPrompt = + prompt + <> "\n\nREPOSITORY GUIDELINES (AGENTS.md):\n" + <> agentsMd + <> factsSection + + -- Build user prompt from task comments + let userPrompt = formatTask task + + -- Select model based on task complexity (simple heuristic) + let model = selectModel task + + -- Build Engine config with callbacks + totalCostRef <- newIORef (0 :: Int) + let engineCfg = + Engine.EngineConfig + { Engine.engineLLM = + Engine.defaultLLM + { Engine.llmApiKey = Text.pack apiKey + }, + Engine.engineOnCost = \tokens cost -> do + modifyIORef' totalCostRef (+ cost) + AgentLog.log <| "Cost: " <> tshow cost <> " cents (" <> tshow tokens <> " tokens)", + Engine.engineOnActivity = \activity -> do + AgentLog.log <| "[engine] " <> activity, + Engine.engineOnToolCall = \toolName result -> do + AgentLog.log <| "[tool] " <> toolName <> ": " <> Text.take 100 result + } + + -- Build Agent config + let agentCfg = + Engine.AgentConfig + { Engine.agentModel = model, + Engine.agentTools = Tools.allTools, + Engine.agentSystemPrompt = systemPrompt, + Engine.agentMaxIterations = 20 + } + + -- Run the agent + result <- Engine.runAgent engineCfg agentCfg userPrompt + totalCost <- readIORef totalCostRef + + case result of + Left err -> pure (Exit.ExitFailure 1, "Engine error: " <> err, totalCost) + Right agentResult -> do + let output = Engine.resultFinalMessage agentResult + pure (Exit.ExitSuccess, output, totalCost) + +-- | Build the base prompt for the agent +buildBasePrompt :: TaskCore.Task -> Text -> FilePath -> Text +buildBasePrompt task ns repo = + "You are a Worker Agent.\n" + <> "Your goal is to implement the following task:\n\n" + <> formatTask task + <> "\n\nCRITICAL INSTRUCTIONS:\n" + <> "1. Analyze the codebase to understand where to make changes.\n" + <> "2. Implement the changes by editing files.\n" + <> "3. BEFORE finishing, you MUST run: bild --test " + <> ns + <> "\n" + <> "4. Fix ALL errors from bild --test (including hlint suggestions).\n" + <> "5. Keep running bild --test until it passes with no errors.\n" + <> "6. Do NOT update task status or manage git.\n" + <> "7. Only exit after bild --test passes.\n\n" + <> "IMPORTANT: The git commit will fail if hlint finds issues.\n" + <> "You must fix hlint suggestions like:\n" + <> "- 'Use list comprehension' -> use [x | cond] instead of if/else\n" + <> "- 'Avoid lambda' -> use function composition\n" + <> "- 'Redundant bracket' -> remove unnecessary parens\n\n" + <> "Context:\n" + <> "- Working directory: " + <> Text.pack repo + <> "\n" + <> "- Namespace: " + <> ns + <> "\n" + +-- | Build retry context prompt +buildRetryPrompt :: Maybe TaskCore.RetryContext -> Text +buildRetryPrompt Nothing = "" +buildRetryPrompt (Just ctx) = + "\n\n## RETRY CONTEXT (IMPORTANT)\n\n" + <> "This task was previously attempted but failed. Attempt: " + <> tshow (TaskCore.retryAttempt ctx) + <> "/3\n" + <> "Reason: " + <> TaskCore.retryReason ctx + <> "\n\n" + <> ( if null (TaskCore.retryConflictFiles ctx) + then "" + else + "Conflicting files from previous attempt:\n" + <> Text.unlines (map (" - " <>) (TaskCore.retryConflictFiles ctx)) + <> "\n" + ) + <> "Original commit: " + <> TaskCore.retryOriginalCommit ctx + <> "\n\n" + <> maybe "" (\notes -> "## HUMAN NOTES/GUIDANCE\n\n" <> notes <> "\n\n") (TaskCore.retryNotes ctx) + <> "INSTRUCTIONS FOR RETRY:\n" + <> "- The codebase has changed since your last attempt\n" + <> "- Re-implement this task on top of the CURRENT codebase\n" + <> "- If there were merge conflicts, the conflicting files may have been modified by others\n" + <> "- Review the current state of those files before making changes\n" + +-- | Select model based on task complexity (1-5 scale) +-- Uses OpenRouter model identifiers for Claude models +selectModel :: TaskCore.Task -> Text +selectModel task = selectModelByComplexity (TaskCore.taskComplexity task) + +-- | Select model based on complexity level +selectModelByComplexity :: Maybe Int -> Text +selectModelByComplexity Nothing = "anthropic/claude-sonnet-4.5" +selectModelByComplexity (Just 1) = "anthropic/claude-haiku-4.5" +selectModelByComplexity (Just 2) = "anthropic/claude-haiku-4.5" +selectModelByComplexity (Just 3) = "anthropic/claude-sonnet-4.5" +selectModelByComplexity (Just 4) = "anthropic/claude-sonnet-4.5" +selectModelByComplexity (Just 5) = "anthropic/claude-opus-4.5" +selectModelByComplexity (Just _) = "anthropic/claude-sonnet-4.5" + +formatTask :: TaskCore.Task -> Text +formatTask t = + "Task: " + <> TaskCore.taskId t + <> "\n" + <> "Title: " + <> TaskCore.taskTitle t + <> "\n" + <> "Type: " + <> Text.pack (show (TaskCore.taskType t)) + <> "\n" + <> "Status: " + <> Text.pack (show (TaskCore.taskStatus t)) + <> "\n" + <> "Priority: " + <> Text.pack (show (TaskCore.taskPriority t)) + <> "\n" + <> maybe "" (\p -> "Parent: " <> p <> "\n") (TaskCore.taskParent t) + <> maybe "" (\ns -> "Namespace: " <> ns <> "\n") (TaskCore.taskNamespace t) + <> "Created: " + <> Text.pack (show (TaskCore.taskCreatedAt t)) + <> "\n" + <> "Updated: " + <> Text.pack (show (TaskCore.taskUpdatedAt t)) + <> "\n" + <> (if Text.null (TaskCore.taskDescription t) then "" else "Description:\n" <> TaskCore.taskDescription t <> "\n\n") + <> formatDeps (TaskCore.taskDependencies t) + <> formatComments (TaskCore.taskComments t) + where + formatDeps [] = "" + formatDeps deps = "\nDependencies:\n" <> Text.unlines (map formatDep deps) + formatDep dep = " - " <> TaskCore.depId dep <> " [" <> Text.pack (show (TaskCore.depType dep)) <> "]" + formatComments [] = "" + formatComments cs = "\nComments/Notes:\n" <> Text.unlines (map formatComment cs) + formatComment c = " [" <> Text.pack (show (TaskCore.commentCreatedAt c)) <> "] " <> TaskCore.commentText c + +formatCommitMessage :: TaskCore.Task -> Text -> Text +formatCommitMessage task agentOutput = + let tid = TaskCore.taskId task + subject = cleanSubject (TaskCore.taskTitle task) + body = cleanBody agentOutput + in if Text.null body + then subject <> "\n\nTask-Id: " <> tid + else subject <> "\n\n" <> body <> "\n\nTask-Id: " <> tid + where + cleanSubject s = + let trailingPunct = ['.', ':', '!', '?', ',', ';', ' ', '-'] + stripped = Text.dropWhileEnd (`elem` trailingPunct) s + truncated = Text.take 72 stripped + noPunct = Text.dropWhileEnd (`elem` trailingPunct) truncated + capitalized = case Text.uncons noPunct of + Just (c, rest) -> Text.cons (toUpper c) rest + Nothing -> noPunct + in capitalized + + cleanBody :: Text -> Text + cleanBody output = + let stripped = Text.strip output + in if Text.null stripped + then "" + else + let lns = Text.lines stripped + cleaned = [Text.take 72 ln | ln <- lns] + in Text.intercalate "\n" cleaned + +-- | Get facts relevant to a task based on namespace/project +getRelevantFacts :: TaskCore.Task -> IO [TaskCore.Fact] +getRelevantFacts task = do + let namespace = fromMaybe "Omni" (TaskCore.taskNamespace task) + projectFacts <- Fact.getFactsByProject namespace + let sorted = List.sortBy (comparing (Down <. TaskCore.factConfidence)) projectFacts + pure (take 10 sorted) + +-- | Format facts for inclusion in the prompt +formatFacts :: [TaskCore.Fact] -> Text +formatFacts [] = "" +formatFacts facts = + Text.unlines + [ "\n\nKNOWLEDGE BASE FACTS:", + "(These are learned patterns/conventions from previous work)", + "" + ] + <> Text.unlines (map formatFact facts) + +-- | Format a single fact for the prompt +formatFact :: TaskCore.Fact -> Text +formatFact f = + "- " + <> TaskCore.factContent f + <> ( if null (TaskCore.factRelatedFiles f) + then "" + else " [" <> Text.intercalate ", " (TaskCore.factRelatedFiles f) <> "]" + ) diff --git a/Omni/App.py b/Omni/App.py index 0c6776c..d42bb75 100644 --- a/Omni/App.py +++ b/Omni/App.py @@ -4,6 +4,10 @@ import enum import os +class AreaError(Exception): + """Error raised when area configuration is invalid or missing.""" + + class Area(enum.Enum): """The area we are running.""" @@ -15,7 +19,7 @@ def from_env() -> Area: """Load AREA from environment variable. Raises: - ValueError: if AREA is not defined + AreaError: if AREA is not defined """ var = os.getenv("AREA", "Test") if var == "Test": @@ -23,4 +27,4 @@ def from_env() -> Area: if var == "Live": return Area.Live msg = "AREA not defined" - raise ValueError(msg) + raise AreaError(msg) diff --git a/Omni/Bild.hs b/Omni/Bild.hs index 967d143..e1f5c46 100755..100644 --- a/Omni/Bild.hs +++ b/Omni/Bild.hs @@ -119,6 +119,9 @@ module Omni.Bild where import Alpha hiding (sym, (<.>)) import qualified Conduit import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.QSemN as QSemN +import Control.Concurrent.STM (TQueue, TVar, modifyTVar', newTQueue, newTVar, readTVar, readTVarIO, tryReadTQueue, writeTQueue) +import qualified Control.Exception as Exception import qualified Data.Aeson as Aeson import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as Char8 @@ -128,6 +131,9 @@ import qualified Data.Char as Char import Data.Conduit ((.|)) import qualified Data.Conduit.Combinators as Conduit import qualified Data.Conduit.Process as Conduit +import Data.Graph (SCC (..), stronglyConnComp) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) +import Data.List (partition) import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set @@ -136,9 +142,11 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified GHC.Conc as GHC import qualified Network.HostName as HostName +import qualified Numeric import qualified Omni.Bild.Meta as Meta import qualified Omni.Cli as Cli import qualified Omni.Log as Log +import qualified Omni.Log.Concurrent as LogC import Omni.Namespace (Namespace (..)) import qualified Omni.Namespace as Namespace import Omni.Test ((@=?)) @@ -146,13 +154,22 @@ import qualified Omni.Test as Test import qualified System.Directory as Dir import qualified System.Environment as Env import qualified System.Exit as Exit -import System.FilePath (replaceExtension, (</>)) +import System.FilePath (dropExtension, replaceExtension, takeDirectory, (</>)) import qualified System.IO as IO import System.IO.Unsafe (unsafePerformIO) import qualified System.Process as Process import qualified System.Timeout as Timeout import qualified Text.Regex.Applicative as Regex +mapConcurrentlyBounded :: Int -> (a -> IO b) -> [a] -> IO [b] +mapConcurrentlyBounded n f xs = do + sem <- QSemN.newQSemN n + Async.forConcurrently xs <| \x -> + Exception.bracket_ + (QSemN.waitQSemN sem 1) + (QSemN.signalQSemN sem 1) + (f x) + main :: IO () main = Cli.Plan help move test_ pure |> Cli.main where @@ -163,19 +180,20 @@ main = Cli.Plan help move test_ pure |> Cli.main test_bildExamples, test_isGitIgnored, test_isGitHook, - test_detectPythonImports + test_detectPythonImports, + test_buildHsModuleGraph ] test_bildBild :: Test.Tree test_bildBild = Test.unit "can bild bild" <| do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot path <- Dir.makeAbsolute "Omni/Bild.hs" case Namespace.fromPath root path of Nothing -> Test.assertFailure "can't find ns for bild" Just ns -> - analyze mempty ns - +> build False False 1 2 + analyzeAll True [ns] + +> build False True 1 2 +> \case [Exit.ExitFailure _] -> Test.assertFailure "can't bild bild" @@ -185,40 +203,63 @@ test_bildBild = test_bildExamples :: Test.Tree test_bildExamples = Test.unit "can bild examples" <| do - Env.getEnv "CODEROOT" +> \root -> + getCoderoot +> \root -> ["c", "hs", "lisp", "rs"] |> map ("Omni/Bild/Example." <>) |> traverse Dir.makeAbsolute /> map (Namespace.fromPath root) /> catMaybes - +> foldM analyze mempty - +> build False False 4 1 + +> analyzeAll True + +> build False True 4 1 +> \case [] -> Test.assertFailure "asdf" xs -> all (== Exit.ExitSuccess) xs @=? True move :: Cli.Arguments -> IO () -move args = +move args = do IO.hSetBuffering stdout IO.NoBuffering - >> Env.getEnv "CODEROOT" - +> \root -> - Cli.getAllArgs args (Cli.argument "target") - |> filterM Dir.doesFileExist - +> filterM (\x -> isGitIgnored x /> don't) - /> filter (\x -> isGitHook x |> don't) - +> traverse Dir.makeAbsolute - +> traverse (namespaceFromPathOrDie root) - /> filter isBuildableNs - +> foldM analyze mempty - +> printOrBuild - |> Timeout.timeout (toMillis minutes) - +> \case - Nothing -> - Log.br - >> Log.fail ["bild", "timeout after " <> tshow minutes <> " minutes"] - >> Log.br - >> exitWith (ExitFailure 124) - Just s -> exitSummary s + root <- getCoderoot + loadGhcPkgCache + allNamespaces <- + Cli.getAllArgs args (Cli.argument "target") + |> filterM Dir.doesFileExist + +> filterGitIgnored + /> filter (\x -> isGitHook x |> don't) + +> traverse Dir.makeAbsolute + +> traverse (namespaceFromPathOrDie root) + let (namespaces, skippedNamespaces) = partition isBuildableNs allNamespaces + let isPlanMode = args `Cli.has` Cli.longOption "plan" + if isPlanMode + then do + analysis <- analyzeAll True namespaces + if Map.null analysis + then Log.wipe >> Log.fail ["bild", "nothing to build"] >> Log.br >> exitWith (ExitFailure 1) + else putJSON analysis + else do + when (null allNamespaces) <| do + Log.wipe >> Log.fail ["bild", "nothing to build"] >> Log.br >> exitWith (ExitFailure 1) + nproc <- GHC.getNumProcessors + createHier root + let runWithManager action = + if isLoud + then action + else + LogC.withLineManager allNamespaces <| \mgr -> do + LogC.initializeLines mgr + forM_ skippedNamespaces <| \ns -> LogC.updateLineState ns LogC.Skipped + action + runWithManager <| do + pipelineBuild isTest isLoud 8 jobs (cpus nproc) namespaces analyzeOne + |> Timeout.timeout (toMillis minutes) + +> \case + Nothing -> + Log.br + >> Log.fail ["bild", "timeout after " <> tshow minutes <> " minutes"] + >> Log.br + >> exitWith (ExitFailure 124) + Just s -> do + when (all isSuccess s) saveGhcPkgCache + exitSummary s where minutes = Cli.getArgWithDefault args "10" (Cli.longOption "time") @@ -226,20 +267,6 @@ move args = |> \case Nothing -> panic "could not read --time argument" Just n -> (n == 0) ?: (-1, n) - printOrBuild :: Analysis -> IO [ExitCode] - printOrBuild targets - | Map.null targets = - Log.wipe - >> Log.fail ["bild", "nothing to build"] - >> Log.br - >> exitWith (ExitFailure 1) - | args `Cli.has` Cli.longOption "plan" = - Log.wipe >> putJSON targets >> pure [Exit.ExitSuccess] - | otherwise = do - root <- Env.getEnv "CODEROOT" - nproc <- GHC.getNumProcessors - createHier root - build isTest isLoud jobs (cpus nproc) targets cpus :: Int -> Int cpus nproc = Cli.longOption "cpus" @@ -268,6 +295,20 @@ isGitIgnored path = (ExitSuccess, _, _) -> pure True (ExitFailure _, _, _) -> pure False +filterGitIgnored :: [FilePath] -> IO [FilePath] +filterGitIgnored [] = pure [] +filterGitIgnored paths = do + (exitCode, out, _) <- + Process.readProcessWithExitCode + "git" + ["check-ignore", "--stdin"] + (List.intercalate "\n" paths) + case exitCode of + ExitSuccess -> + let ignoredPaths = Set.fromList (String.lines out) + in pure [p | p <- paths, don't (Set.member p ignoredPaths)] + ExitFailure _ -> pure paths + test_isGitIgnored :: Test.Tree test_isGitIgnored = Test.group @@ -289,10 +330,10 @@ test_isGitHook = Test.group "isGitHook" [ Test.unit "filters pre-commit hook" <| do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot True @=? (isGitHook <| root <> "/Omni/Ide/hooks/pre-commit"), Test.unit "doesn't filter non-hooks" <| do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot False @=? (isGitHook <| root <> "/Omni/Bild.hs") ] @@ -401,20 +442,37 @@ data Target = Target -- | Wrapper script (if necessary) wrapper :: Maybe Text, -- | Runtime dependences - rundeps :: Set Meta.Run + rundeps :: Set Meta.Run, + -- | Haskell module graph for per-module builds (Nothing means fallback to monolithic) + hsGraph :: Maybe HsModuleGraph + } + deriving (Show, Generic, Aeson.ToJSON) + +type ModuleName = Text + +data HsModuleNode = HsModuleNode + { nodePath :: FilePath, + nodeImports :: [ModuleName], + nodeHasTH :: Bool + } + deriving (Show, Generic, Aeson.ToJSON) + +data HsModuleGraph = HsModuleGraph + { graphEntry :: ModuleName, + graphModules :: Map ModuleName HsModuleNode } deriving (Show, Generic, Aeson.ToJSON) -- | Use this to just get a target to play with at the repl. dev_getTarget :: FilePath -> IO Target dev_getTarget fp = do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot path <- Dir.makeAbsolute fp Namespace.fromPath root path |> \case Nothing -> panic "Could not get namespace from path" Just ns -> - analyze mempty ns + analyzeAll False [ns] /> Map.lookup ns /> \case Nothing -> panic "Could not retrieve target from analysis" @@ -456,7 +514,7 @@ isBuildableNs = \case (Namespace _ Namespace.Sh) -> False (Namespace _ Namespace.Scm) -> True (Namespace _ Namespace.Rs) -> True - (Namespace _ Namespace.Toml) -> True + (Namespace _ Namespace.Toml) -> False -- | The default output directory. This is not IO because I don't want to -- refactor all of my code right now, but it probably should be. @@ -502,100 +560,100 @@ removeVersion = takeWhile (/= '.') .> butlast2 type Analysis = Map Namespace Target -analyze :: Analysis -> Namespace -> IO Analysis -analyze hmap ns = case Map.lookup ns hmap of - Nothing -> do - mTarget <- analyzeOne ns - pure <| maybe hmap (\t -> Map.insert ns t hmap) mTarget - Just _ -> pure hmap - where - analyzeOne :: Namespace -> IO (Maybe Target) - analyzeOne namespace@(Namespace parts ext) = do - let path = Namespace.toPath namespace - root <- Env.getEnv "CODEROOT" - let abspath = root </> path - let quapath = path - user <- Env.getEnv "USER" /> Text.pack - host <- HostName.getHostName /> Text.pack - Log.info ["bild", "analyze", str path] - contentLines <- - withFile abspath ReadMode <| \h -> - IO.hSetEncoding h IO.utf8_bom - >> Text.IO.hGetContents h - /> Text.lines - -- if the file is exe but doesn't have 'out' metadata, just use the - -- dot-separated namespace instead - isExe <- Dir.getPermissions quapath /> Dir.executable - let defaultOut = isExe ?: (Just <| Namespace.dotSeparated parts, Nothing) - case ext of - -- basically we don't support building these - Namespace.Css -> pure Nothing - Namespace.Json -> pure Nothing - Namespace.Keys -> pure Nothing - Namespace.Md -> pure Nothing - Namespace.None -> pure Nothing - Namespace.Html -> pure Nothing - Namespace.Toml -> pure Nothing - Namespace.Py -> - contentLines - |> Meta.detectAll "#" - |> \Meta.Parsed {..} -> - detectPythonImports contentLines +> \srcs -> - Target - { builder = "python", - wrapper = Nothing, - compiler = CPython, - compilerFlags = - -- This doesn't really make sense for python, but I'll leave - -- it here for eventual --dev builds - [ "-c", - "\"import py_compile;import os;" - <> "py_compile.compile(file='" - <> str quapath - <> "', cfile=os.getenv('CODEROOT')+'/_/int/" - <> str quapath - <> "', doraise=True)\"" - ], - sysdeps = psys, - langdeps = pdep, - outPath = outToPath pout, - out = pout <|> defaultOut, - packageSet = "python.packages", - mainModule = Namespace.toModule namespace, - rundeps = prun, - .. - } - |> Just - |> pure - Namespace.Sh -> pure Nothing - Namespace.C -> - Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> do +analyzeAll :: Bool -> [Namespace] -> IO Analysis +analyzeAll _isPlanMode nss = do + targets <- mapConcurrentlyBounded 8 analyzeOne nss + pure <| Map.fromList <| catMaybes <| zipWith (\ns mt -> (ns,) </ mt) nss targets + +analyzeOne :: Namespace -> IO (Maybe Target) +analyzeOne namespace@(Namespace parts ext) = do + let path = Namespace.toPath namespace + root <- getCoderoot + let abspath = root </> path + let quapath = path + user <- Env.getEnv "USER" /> Text.pack + host <- HostName.getHostName /> Text.pack + contentLines <- + withFile abspath ReadMode <| \h -> + IO.hSetEncoding h IO.utf8_bom + >> Text.IO.hGetContents h + /> Text.lines + isExe <- Dir.getPermissions quapath /> Dir.executable + let defaultOut = isExe ?: (Just <| Namespace.dotSeparated parts, Nothing) + case ext of + Namespace.Css -> pure Nothing + Namespace.Json -> pure Nothing + Namespace.Keys -> pure Nothing + Namespace.Md -> pure Nothing + Namespace.None -> pure Nothing + Namespace.Html -> pure Nothing + Namespace.Toml -> pure Nothing + Namespace.Py -> + contentLines + |> Meta.detectAll "#" + |> \Meta.Parsed {..} -> + detectPythonImports mempty contentLines +> \(srcs, transitiveDeps) -> Target - { langdeps = pdep, - sysdeps = psys, + { builder = "python", wrapper = Nothing, - compiler = Gcc, - builder = "c", + compiler = CPython, + compilerFlags = + -- This doesn't really make sense for python, but I'll leave + -- it here for eventual --dev builds + [ "-c", + "\"import py_compile;import os;" + <> "py_compile.compile(file='" + <> str quapath + <> "', cfile=os.getenv('CODEROOT')+'/_/int/" + <> str quapath + <> "', doraise=True)\"" + ], + sysdeps = psys, + langdeps = pdep <> transitiveDeps, + outPath = outToPath pout, out = pout <|> defaultOut, - packageSet = "c.packages", + packageSet = "python.packages", mainModule = Namespace.toModule namespace, - compilerFlags = case pout of - Just o -> - ["-o", o, path] <> Set.toList parg |> map Text.pack - Nothing -> panic "can only bild C exes, not libs", - outPath = outToPath pout, - -- implement detectCImports, then I can fill this out - srcs = Set.empty, rundeps = prun, + hsGraph = Nothing, .. } |> Just |> pure - Namespace.Hs -> - contentLines - |> Meta.detectAll "--" - |> \Meta.Parsed {..} -> - detectHaskellImports hmap contentLines +> \(langdeps, srcs) -> + Namespace.Sh -> pure Nothing + Namespace.C -> + Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> do + Target + { langdeps = pdep, + sysdeps = psys, + wrapper = Nothing, + compiler = Gcc, + builder = "c", + out = pout <|> defaultOut, + packageSet = "c.packages", + mainModule = Namespace.toModule namespace, + compilerFlags = case pout of + Just o -> + ["-o", o, path] <> Set.toList parg |> map Text.pack + Nothing -> panic "can only bild C exes, not libs", + outPath = outToPath pout, + -- implement detectCImports, then I can fill this out + srcs = Set.empty, + rundeps = prun, + hsGraph = Nothing, + .. + } + |> Just + |> pure + Namespace.Hs -> + contentLines + |> Meta.detectAll "--" + |> \Meta.Parsed {..} -> + detectHaskellImports mempty contentLines +> \(autoDeps, srcs) -> do + let langdeps = autoDeps <> pdep + graph <- buildHsModuleGraph namespace quapath srcs + pure + <| Just Target { builder = "haskell", wrapper = Nothing, @@ -629,182 +687,181 @@ analyze hmap ns = case Map.lookup ns hmap of outPath = outToPath pout, rundeps = prun, out = pout <|> defaultOut, + hsGraph = graph, .. } - |> Just - |> pure - Namespace.Lisp -> - Meta.detectOut (Meta.out ";;") contentLines |> \out -> do - langdeps <- detectLispImports contentLines - Just - </ pure - Target - { sysdeps = Set.empty, - wrapper = Nothing, - compiler = Sbcl, - packageSet = "lisp.sbclWith", - mainModule = Namespace.toModule namespace, - compilerFlags = - map - Text.pack - [ "--eval", - "(require :asdf)", - "--load", - quapath, - "--eval", - "(sb-ext:save-lisp-and-die #p\"" <> (root </> outToPath out) <> "\" :toplevel #'main :executable t)" - ], - builder = "base", - outPath = outToPath out, - -- add local src imports to detectLispImports, then i can fill this out - srcs = Set.empty, - rundeps = Set.empty, - .. - } - Namespace.Nix -> - (host == "lithium") ?: (Local user "lithium", Remote user "dev.bensima.com") |> \builder -> + Namespace.Lisp -> + Meta.detectOut (Meta.out ";;") contentLines |> \out -> do + langdeps <- detectLispImports contentLines + Just + </ pure Target - { langdeps = Set.empty, + { sysdeps = Set.empty, wrapper = Nothing, - sysdeps = Set.empty, - compiler = NixBuild, - compilerFlags = - [ quapath, - "--out-link", - root </> nixdir </> Namespace.toPath namespace, - "--builders", - toNixFlag builder, - "--arg", - "bild", - str <| "import " <> root </> "Omni/Bild.nix {}" - ] - |> map Text.pack, - out = Nothing, - outPath = outToPath Nothing, - srcs = Set.empty, - packageSet = "", - mainModule = Namespace.toModule namespace, - builder = "base", - rundeps = Set.empty, - .. - } - |> Just - |> pure - Namespace.Scm -> - Meta.detectAll ";;" contentLines |> \Meta.Parsed {..} -> - Target - { langdeps = pdep, - sysdeps = psys, - compiler = Guile, - packageSet = "scheme.guilePackages", + compiler = Sbcl, + packageSet = "lisp.sbclWith", mainModule = Namespace.toModule namespace, compilerFlags = - [ "compile", - "--r7rs", - "--load-path=" ++ root, - "--output=" ++ root </> intdir </> replaceExtension quapath ".scm.go", - quapath - ] - |> map Text.pack, - builder = "base", - outPath = outToPath pout, - out = pout <|> defaultOut, - srcs = Set.empty, -- implement detectSchemeImports - -- TODO: wrapper should just be removed, instead rely on - -- upstream nixpkgs builders to make wrappers - wrapper = - isNothing pout - ?: ( Nothing, - [ "#!/usr/bin/env bash", - "guile -C \"" - <> root - </> intdir - <> "\" -e main " - <> "-s " - <> Namespace.toPath namespace - <> " \"$@\"" - ] - |> joinWith "\n" - |> Text.pack - |> Just - ), - rundeps = prun, - .. - } - |> Just - |> pure - Namespace.Rs -> - Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> - Target - { langdeps = pdep, - -- this packageSet doesn't actually exist because everyone in - -- nix just generates nix expressions for rust dependencies with - -- Cargo.lock, so I have to make it in order to use rust deps - packageSet = "rust.packages", - mainModule = Namespace.toModule namespace, - wrapper = Nothing, - sysdeps = psys <> Set.singleton "rustc", - out = pout <|> defaultOut, - compiler = Rustc, - compilerFlags = case pout of - Just o -> - map - Text.pack - [ "$CODEROOT" </> path, - "-o", - o - ] - Nothing -> panic "can't build rust libs", + map + Text.pack + [ "--eval", + "(require :asdf)", + "--load", + quapath, + "--eval", + "(sb-ext:save-lisp-and-die #p\"" <> (root </> outToPath out) <> "\" :toplevel #'main :executable t)" + ], builder = "base", - outPath = outToPath pout, - -- implement detectRustImports + outPath = outToPath out, + -- add local src imports to detectLispImports, then i can fill this out srcs = Set.empty, - rundeps = prun, + rundeps = Set.empty, + hsGraph = Nothing, .. } - |> Just - |> pure + Namespace.Nix -> + (host == "lithium") ?: (Local user "lithium", Remote user "dev.bensima.com") |> \builder -> + Target + { langdeps = Set.empty, + wrapper = Nothing, + sysdeps = Set.empty, + compiler = NixBuild, + compilerFlags = + [ quapath, + "--out-link", + root </> nixdir </> Namespace.toPath namespace, + "--builders", + toNixFlag builder, + "--arg", + "bild", + str <| "import " <> root </> "Omni/Bild.nix {}" + ] + |> map Text.pack, + out = Nothing, + outPath = outToPath Nothing, + srcs = Set.empty, + packageSet = "", + mainModule = Namespace.toModule namespace, + builder = "base", + rundeps = Set.empty, + hsGraph = Nothing, + .. + } + |> Just + |> pure + Namespace.Scm -> + Meta.detectAll ";;" contentLines |> \Meta.Parsed {..} -> + Target + { langdeps = pdep, + sysdeps = psys, + compiler = Guile, + packageSet = "scheme.guilePackages", + mainModule = Namespace.toModule namespace, + compilerFlags = + [ "compile", + "--r7rs", + "--load-path=" ++ root, + "--output=" ++ root </> intdir </> replaceExtension quapath ".scm.go", + quapath + ] + |> map Text.pack, + builder = "base", + outPath = outToPath pout, + out = pout <|> defaultOut, + srcs = Set.empty, -- implement detectSchemeImports + -- TODO: wrapper should just be removed, instead rely on + -- upstream nixpkgs builders to make wrappers + wrapper = + isNothing pout + ?: ( Nothing, + [ "#!/usr/bin/env bash", + "guile -C \"" + <> root + </> intdir + <> "\" -e main " + <> "-s " + <> Namespace.toPath namespace + <> " \"$@\"" + ] + |> joinWith "\n" + |> Text.pack + |> Just + ), + rundeps = prun, + hsGraph = Nothing, + .. + } + |> Just + |> pure + Namespace.Rs -> + Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> + Target + { langdeps = pdep, + -- this packageSet doesn't actually exist because everyone in + -- nix just generates nix expressions for rust dependencies with + -- Cargo.lock, so I have to make it in order to use rust deps + packageSet = "rust.packages", + mainModule = Namespace.toModule namespace, + wrapper = Nothing, + sysdeps = psys <> Set.singleton "rustc", + out = pout <|> defaultOut, + compiler = Rustc, + compilerFlags = case pout of + Just o -> + map + Text.pack + [ "$CODEROOT" </> path, + "-o", + o + ] + Nothing -> panic "can't build rust libs", + builder = "base", + outPath = outToPath pout, + -- implement detectRustImports + srcs = Set.empty, + rundeps = prun, + hsGraph = Nothing, + .. + } + |> Just + |> pure detectHaskellImports :: Analysis -> [Text] -> IO (Set Meta.Dep, Set FilePath) -detectHaskellImports hmap contentLines = - Env.getEnv "CODEROOT" +> \root -> - contentLines - /> Text.unpack - /> Regex.match haskellImports - |> catMaybes - |> \imports -> - foldM ghcPkgFindModule Set.empty imports - +> \pkgs -> - filepaths imports - +> \files -> - findDeps root files - +> \deps -> - (pkgs <> deps, map (stripRoot root) files |> Set.fromList) - |> pure +detectHaskellImports _ contentLines = do + root <- getCoderoot + let initialMods = catMaybes (Regex.match haskellImports </ (Text.unpack </ contentLines)) + initialLocals <- toLocalFiles root initialMods + let initialLocalsSet = Set.fromList initialLocals + let localMods = [m | m <- initialMods, (Namespace.fromHaskellModule m |> Namespace.toPath) `elem` initialLocals] + let initialExternals = filter (`notElem` localMods) initialMods + (srcs, transitiveExtMods) <- bfs root initialLocalsSet Set.empty Set.empty + let allExtMods = Set.fromList initialExternals <> transitiveExtMods + pkgSets <- Async.mapConcurrently ghcPkgFindModuleCached (Set.toList allExtMods) + let pkgs = mconcat pkgSets + pure (pkgs, srcs) where - filepaths :: [String] -> IO [FilePath] - filepaths imports = - imports - |> map Namespace.fromHaskellModule - |> map Namespace.toPath - |> traverse Dir.makeAbsolute - +> filterM Dir.doesFileExist - findDeps :: String -> [FilePath] -> IO (Set Meta.Dep) - findDeps root fps = - fps - |> traverse (pure <. Namespace.fromPath root) - /> catMaybes - -- this is still an inefficiency, because this recurses before the - -- hmap is updated by the fold, transitive imports will be - -- re-visited. you can see this with `TERM=dumb bild`. to fix this i - -- need shared state instead of a fold, or figure out how to do a - -- breadth-first search instead of depth-first. - +> foldM analyze (onlyHaskell hmap) - /> Map.elems - /> map langdeps - /> mconcat - onlyHaskell :: Analysis -> Analysis - onlyHaskell = Map.filterWithKey (\ns _ -> ext ns == Namespace.Hs) + bfs :: FilePath -> Set FilePath -> Set FilePath -> Set String -> IO (Set FilePath, Set String) + bfs root queue visited extMods + | Set.null queue = pure (visited, extMods) + | otherwise = do + let (rel, queue') = Set.deleteFindMin queue + fileLines <- + withFile (root </> rel) ReadMode <| \h -> + IO.hSetEncoding h IO.utf8_bom + >> Text.IO.hGetContents h + /> Text.lines + let mods = catMaybes (Regex.match haskellImports </ (Text.unpack </ fileLines)) + locals <- toLocalFiles root mods + let localsSet = Set.fromList locals + let localModsFromPaths = Set.fromList [m | m <- mods, (Namespace.fromHaskellModule m |> Namespace.toPath) `elem` locals] + let newExternals = Set.fromList mods Set.\\ localModsFromPaths + let newLocals = localsSet Set.\\ visited + bfs root (queue' <> newLocals) (Set.insert rel visited) (extMods <> newExternals) + + toLocalFiles :: FilePath -> [String] -> IO [FilePath] + toLocalFiles root mods = do + let rels = map (Namespace.fromHaskellModule .> Namespace.toPath) mods + filterM (\rel -> Dir.doesFileExist (root </> rel)) rels stripRoot :: FilePath -> FilePath -> FilePath stripRoot root f = fromMaybe f (List.stripPrefix (root <> "/") f) @@ -818,19 +875,14 @@ detectLispImports contentLines = |> Set.fromList |> pure --- | Finds local imports. Does not recurse to find transitive imports like --- 'detectHaskellImports' does. Someday I will refactor these detection --- functions and have a common, well-performing, complete solution. -detectPythonImports :: [Text] -> IO (Set FilePath) -detectPythonImports contentLines = - contentLines - /> Text.unpack - /> Regex.match pythonImport - |> catMaybes - /> Namespace.fromPythonModule - /> Namespace.toPath - |> filterM Dir.doesPathExist - /> Set.fromList +-- | Finds local imports and recursively finds transitive imports and langdeps. +-- Returns (srcs, transitive langdeps). +detectPythonImports :: Analysis -> [Text] -> IO (Set FilePath, Set Meta.Dep) +detectPythonImports _ contentLines = do + root <- getCoderoot + let initialMods = catMaybes (Regex.match pythonImport </ (Text.unpack </ contentLines)) + initialLocals <- toLocalFiles root initialMods + bfs root (Set.fromList initialLocals) Set.empty Set.empty where -- only detects 'import x' because I don't like 'from' pythonImport :: Regex.RE Char String @@ -840,18 +892,138 @@ detectPythonImports contentLines = *> Regex.many (Regex.psym isModuleChar) <* Regex.many Regex.anySym + bfs :: FilePath -> Set FilePath -> Set FilePath -> Set Meta.Dep -> IO (Set FilePath, Set Meta.Dep) + bfs root queue visited deps + | Set.null queue = pure (visited, deps) + | otherwise = do + let (rel, queue') = Set.deleteFindMin queue + fileLines <- + withFile (root </> rel) ReadMode <| \h -> + IO.hSetEncoding h IO.utf8_bom + >> Text.IO.hGetContents h + /> Text.lines + let mods = catMaybes (Regex.match pythonImport </ (Text.unpack </ fileLines)) + locals <- toLocalFiles root mods + let localsSet = Set.fromList locals + let newLocals = localsSet Set.\\ visited + -- Collect langdeps from this file's metadata + let Meta.Parsed {pdep = fileDeps} = Meta.detectAll "#" fileLines + bfs root (queue' <> newLocals) (Set.insert rel visited) (deps <> fileDeps) + + toLocalFiles :: FilePath -> [String] -> IO [FilePath] + toLocalFiles root mods = do + let rels = map (Namespace.fromPythonModule .> Namespace.toPath) mods + filterM (\rel -> Dir.doesFileExist (root </> rel)) rels + test_detectPythonImports :: Test.Tree test_detectPythonImports = Test.group "detectPythonImports" [ Test.unit "matches import statements" <| do - set <- detectPythonImports ["import Omni.Log"] - Set.fromList ["Omni/Log.py"] @=? set, + (srcs, _) <- detectPythonImports mempty ["import Omni.Log"] + Set.fromList ["Omni/Log.py"] @=? srcs, Test.unit "matches import as statements" <| do - set <- detectPythonImports ["import Omni.Log as Log"] - Set.fromList ["Omni/Log.py"] @=? set + (srcs, _) <- detectPythonImports mempty ["import Omni.Log as Log"] + Set.fromList ["Omni/Log.py"] @=? srcs + ] + +test_buildHsModuleGraph :: Test.Tree +test_buildHsModuleGraph = + Test.group + "buildHsModuleGraph" + [ Test.unit "includes entry point in graph" <| do + let ns = Namespace ["Omni", "Bild", "Example"] Namespace.Hs + let entryPoint = "Omni/Bild/Example.hs" + let deps = Set.fromList ["Alpha.hs", "Omni/Test.hs"] + + result <- buildHsModuleGraph ns entryPoint deps + case result of + Nothing -> Test.assertFailure "buildHsModuleGraph returned Nothing" + Just graph -> do + let modules = Map.keys (graphModules graph) + Text.pack "Omni.Bild.Example" `elem` modules @=? True ] +type GhcPkgCacheMem = Map String (Set String) + +type GhcPkgCacheDisk = Map String [String] + +{-# NOINLINE ghcPkgCache #-} +ghcPkgCache :: IORef GhcPkgCacheMem +ghcPkgCache = unsafePerformIO (newIORef Map.empty) + +cacheToDisk :: GhcPkgCacheMem -> GhcPkgCacheDisk +cacheToDisk = Map.map Set.toList + +cacheFromDisk :: GhcPkgCacheDisk -> GhcPkgCacheMem +cacheFromDisk = Map.map Set.fromList + +ghcPkgCacheHash :: IO (Maybe String) +ghcPkgCacheHash = do + mdb <- Env.lookupEnv "GHC_PACKAGE_PATH" + case mdb of + Nothing -> pure Nothing + Just db -> do + v <- + Exception.catch + ( Process.readProcess "ghc" ["--numeric-version"] "" + /> takeWhile (/= '\n') + ) + (\(_ :: Exception.SomeException) -> pure "") + if null v then pure Nothing else pure (Just (hashString (v <> "|" <> db))) + where + hashString :: String -> String + hashString s = + List.foldl' (\h c -> h * 131 + fromEnum c) (7 :: Int) s + |> abs + |> toInteger + |> \n -> Numeric.showHex n "" + +ghcPkgCachePath :: IO (Maybe FilePath) +ghcPkgCachePath = do + root <- getCoderoot + fmap (\h -> root </> vardir </> ("ghc-pkg-cache-" <> h <> ".json")) </ ghcPkgCacheHash + +loadGhcPkgCache :: IO () +loadGhcPkgCache = do + mpath <- ghcPkgCachePath + case mpath of + Nothing -> pure () + Just path -> do + exists <- Dir.doesFileExist path + if not exists + then pure () + else do + eres <- Exception.try (ByteString.Lazy.readFile path) :: IO (Either Exception.IOException ByteString.Lazy.ByteString) + case eres of + Left _ -> pure () + Right bs -> + case Aeson.eitherDecode bs :: Either String GhcPkgCacheDisk of + Left _ -> pure () + Right disk -> writeIORef ghcPkgCache (cacheFromDisk disk) + +saveGhcPkgCache :: IO () +saveGhcPkgCache = do + mpath <- ghcPkgCachePath + case mpath of + Nothing -> pure () + Just path -> do + cache <- readIORef ghcPkgCache + let tmp = path <> ".tmp" + Dir.createDirectoryIfMissing True (takeDirectory path) + ByteString.Lazy.writeFile tmp (Aeson.encode (cacheToDisk cache)) + Dir.renameFile tmp path + +ghcPkgFindModuleCached :: String -> IO (Set String) +ghcPkgFindModuleCached m = do + cache <- readIORef ghcPkgCache + case Map.lookup m cache of + Just pkgs -> pure pkgs + Nothing -> do + pkgs <- ghcPkgFindModule Set.empty m + modifyIORef' ghcPkgCache (Map.insert m pkgs) + pure pkgs + ghcPkgFindModule :: Set String -> String -> IO (Set String) ghcPkgFindModule acc m = Env.getEnv "GHC_PACKAGE_PATH" +> \packageDb -> @@ -863,6 +1035,81 @@ ghcPkgFindModule acc m = /> Set.fromList /> Set.union acc +-- | Build module graph for Haskell targets, returns Nothing if TH or cycles detected +buildHsModuleGraph :: Namespace -> FilePath -> Set FilePath -> IO (Maybe HsModuleGraph) +buildHsModuleGraph namespace entryPoint deps = do + root <- getCoderoot + -- Analyze all dependencies first + depNodes <- foldM (analyzeModule root) Map.empty (Set.toList deps) + -- Then analyze the entry point itself + allNodes <- analyzeModule root depNodes entryPoint + let hasTH = any nodeHasTH (Map.elems allNodes) + let hasCycles = detectCycles allNodes + if hasTH || hasCycles + then pure Nothing + else + pure + <| Just + HsModuleGraph + { graphEntry = Namespace.toHaskellModule namespace |> Text.pack, + graphModules = allNodes + } + where + analyzeModule :: FilePath -> Map ModuleName HsModuleNode -> FilePath -> IO (Map ModuleName HsModuleNode) + analyzeModule root acc srcPath = do + let modName = pathToModuleName srcPath + case Map.lookup modName acc of + Just _ -> pure acc + Nothing -> do + fileLines <- + withFile (root </> srcPath) ReadMode <| \h -> + IO.hSetEncoding h IO.utf8_bom + >> Text.IO.hGetContents h + /> Text.lines + let importedMods = catMaybes (Regex.match haskellImports </ (Text.unpack </ fileLines)) + localImportMods <- filterLocalImports root importedMods + let hasTH = detectTH fileLines + let node = + HsModuleNode + { nodePath = srcPath, + nodeImports = map Text.pack localImportMods, + nodeHasTH = hasTH + } + pure (Map.insert modName node acc) + + pathToModuleName :: FilePath -> ModuleName + pathToModuleName fp = + fp + |> dropExtension + |> map (\c -> if c == '/' then '.' else c) + |> Text.pack + + filterLocalImports :: FilePath -> [String] -> IO [String] + filterLocalImports root mods = do + let rels = map (Namespace.fromHaskellModule .> Namespace.toPath) mods + filterM (\rel -> Dir.doesFileExist (root </> rel)) rels + /> map (\rel -> replaceExtension rel "" |> map (\c -> if c == '/' then '.' else c)) + + detectTH :: [Text] -> Bool + detectTH = + any + ( \line -> + Text.isInfixOf "TemplateHaskell" line + || Text.isInfixOf "$(" line + ) + + detectCycles :: Map ModuleName HsModuleNode -> Bool + detectCycles nodes = + let sccs = stronglyConnComp (map nodeToEdge (Map.toList nodes)) + in any isNonTrivialSCC sccs + where + nodeToEdge :: (ModuleName, HsModuleNode) -> (HsModuleNode, ModuleName, [ModuleName]) + nodeToEdge (name, node) = (node, name, nodeImports node) + + isNonTrivialSCC :: SCC HsModuleNode -> Bool + isNonTrivialSCC (AcyclicSCC _) = False + isNonTrivialSCC (CyclicSCC sccNodes) = length sccNodes > 1 + isFailure :: Exit.ExitCode -> Bool isFailure (Exit.ExitFailure _) = True isFailure Exit.ExitSuccess = False @@ -873,7 +1120,7 @@ isSuccess _ = False test :: Bool -> Target -> IO (Exit.ExitCode, ByteString) test loud Target {..} = - Env.getEnv "CODEROOT" + getCoderoot +> \root -> case compiler of Ghc -> Proc @@ -881,8 +1128,8 @@ test loud Target {..} = cmd = root </> outToPath out, args = ["test"], ns = namespace, - onFailure = Log.fail ["test", nschunk namespace] >> Log.br, - onSuccess = Log.pass ["test", nschunk namespace] >> Log.br + onFailure = loud ?: (Log.fail ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Failed), + onSuccess = loud ?: (Log.pass ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Success) } |> run CPython -> @@ -891,41 +1138,42 @@ test loud Target {..} = cmd = root </> outToPath out, args = ["test"], ns = namespace, - onFailure = Log.fail ["test", nschunk namespace] >> Log.br, - onSuccess = Log.pass ["test", nschunk namespace] >> Log.br + onFailure = loud ?: (Log.fail ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Failed), + onSuccess = loud ?: (Log.pass ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Success) } |> run _ -> - Log.warn ["test", nschunk namespace, "unavailable"] - >> Log.br - >> pure (Exit.ExitFailure 1, mempty) + pure (Exit.ExitFailure 1, mempty) build :: Bool -> Bool -> Int -> Int -> Analysis -> IO [Exit.ExitCode] -build andTest loud jobs cpus analysis = - Env.getEnv "CODEROOT" +> \root -> - forM (Map.elems analysis) <| \target@Target {..} -> - fst </ case compiler of +build andTest loud jobs cpus analysis = do + root <- getCoderoot + let targets = Map.elems analysis + -- Build runs concurrently with --jobs parallelism + -- LineManager is set up by caller (move), so we just update states here + results <- mapConcurrentlyBounded jobs (buildTarget root) targets + pure (map fst results) + where + buildTarget :: FilePath -> Target -> IO (Exit.ExitCode, ByteString) + buildTarget root target@Target {..} = do + LogC.updateLineState namespace LogC.Building + result <- case compiler of CPython -> case out of Just _ -> - Log.info ["bild", "nix", "python", nschunk namespace] - >> nixBuild loud jobs cpus target + nixBuild loud jobs cpus target +> (\r -> (isSuccess (fst r) && andTest) ?: (test loud target, pure r)) Nothing -> - Log.info ["bild", "nix", "python", nschunk namespace, "cannot build library"] - >> pure (Exit.ExitSuccess, mempty) + pure (Exit.ExitSuccess, mempty) Gcc -> - Log.info ["bild", "nix", "gcc", nschunk namespace] - >> nixBuild loud jobs cpus target + nixBuild loud jobs cpus target Ghc -> case out of Nothing -> pure (Exit.ExitSuccess, mempty) Just _ -> do - Log.info ["bild", "nix", user <> "@" <> host, nschunk namespace] result <- nixBuild loud jobs cpus target if andTest && (isSuccess <| fst result) then test loud target else pure result Guile -> do - Log.info ["bild", "dev", "guile", nschunk namespace] _ <- proc loud namespace (toNixFlag compiler) compilerFlags case wrapper of Nothing -> pure (Exit.ExitSuccess, mempty) @@ -937,30 +1185,232 @@ build andTest loud jobs cpus analysis = NixBuild -> Dir.getPermissions quapath /> Dir.executable +> \isExe -> isExe - ?: ( Log.info ["bild", "nix", user <> "@" <> host, nschunk namespace] - >> proc - loud - namespace - (toNixFlag compiler) - ( compilerFlags - ++ [ "--max-jobs", - Text.pack <| str jobs, - "--cores", - Text.pack <| str cpus - ] - ), - Log.warn ["bild", "nix", nschunk namespace, "x bit not set, not building"] - >> pure (Exit.ExitSuccess, mempty) + ?: ( proc + loud + namespace + (toNixFlag compiler) + ( compilerFlags + ++ [ "--max-jobs", + Text.pack <| str jobs, + "--cores", + Text.pack <| str cpus + ] + ), + pure (Exit.ExitSuccess, mempty) ) - Copy -> do - Log.warn ["bild", "copy", "not implemented yet", nschunk namespace] + Copy -> pure (Exit.ExitSuccess, mempty) Rustc -> - Log.info ["bild", "dev", "rust", nschunk namespace] - >> nixBuild loud jobs cpus target - Sbcl -> do - Log.info ["bild", "dev", "lisp", nschunk namespace] + nixBuild loud jobs cpus target + Sbcl -> proc loud namespace (toNixFlag compiler) compilerFlags + LogC.updateLineState namespace (isSuccess (fst result) ?: (LogC.Success, LogC.Failed)) + pure result + +-- | Pipeline state machine for each target +data TargetState + = TSQueued + | TSAnalyzing + | TSAnalysisFailed + | TSWaitingForDeps Target (Set Namespace) + | TSReadyToBuild Target + | TSBuilding Target + | TSComplete Target Exit.ExitCode + +-- | Coordinator manages the pipelined analyze→build flow +data Coordinator = Coordinator + { coStates :: TVar (Map Namespace TargetState), + coAnalyzeQ :: TQueue Namespace, + coBuildQ :: TQueue Namespace, + coAllTargets :: Set Namespace, + coResults :: TVar [Exit.ExitCode], + coRemaining :: TVar Int, + coRoot :: FilePath + } + +initCoordinator :: FilePath -> [Namespace] -> IO Coordinator +initCoordinator root nss = + atomically <| do + let allTargets = Set.fromList nss + states <- newTVar (Map.fromList [(ns, TSQueued) | ns <- nss]) + analyzeQ <- newTQueue + buildQ <- newTQueue + results <- newTVar [] + remaining <- newTVar (length nss) + forM_ nss (writeTQueue analyzeQ) + pure + Coordinator + { coStates = states, + coAnalyzeQ = analyzeQ, + coBuildQ = buildQ, + coAllTargets = allTargets, + coResults = results, + coRemaining = remaining, + coRoot = root + } + +computeDeps :: Coordinator -> Target -> Set Namespace +computeDeps Coordinator {..} Target {..} = + let toNs path = Namespace.fromPath coRoot (coRoot </> path) + result = + srcs + |> Set.toList + |> map toNs + |> catMaybes + |> Set.fromList + |> flip Set.intersection coAllTargets + |> Set.delete namespace + in result + +tsIsComplete :: TargetState -> Bool +tsIsComplete (TSComplete _ _) = True +tsIsComplete _ = False + +pipelineAnalysisWorker :: Coordinator -> (Namespace -> IO (Maybe Target)) -> IO () +pipelineAnalysisWorker coord@Coordinator {..} analyzeFn = loop + where + loop = do + remaining <- readTVarIO coRemaining + when (remaining > 0) <| do + mNs <- atomically (tryReadTQueue coAnalyzeQ) + case mNs of + Nothing -> threadDelay 1000 >> loop + Just ns -> do + atomically <| modifyTVar' coStates (Map.insert ns TSAnalyzing) + LogC.updateLineState ns LogC.Analyzing + result <- analyzeFn ns + case result of + Nothing -> do + atomically <| do + modifyTVar' coStates (Map.insert ns TSAnalysisFailed) + modifyTVar' coRemaining (subtract 1) + LogC.updateLineState ns LogC.Failed + Just target -> do + let deps = computeDeps coord target + atomically <| do + states <- readTVar coStates + let pendingDeps = Set.filter (\d -> maybe True (tsIsComplete .> not) (Map.lookup d states)) deps + if Set.null pendingDeps + then do + modifyTVar' coStates (Map.insert ns (TSReadyToBuild target)) + writeTQueue coBuildQ ns + else modifyTVar' coStates (Map.insert ns (TSWaitingForDeps target pendingDeps)) + loop + +pipelineBuildWorker :: Bool -> Bool -> Int -> Int -> Coordinator -> IO () +pipelineBuildWorker andTest loud jobs cpus coord@Coordinator {..} = loop + where + loop = do + remaining <- readTVarIO coRemaining + when (remaining > 0) <| do + mNs <- atomically (tryReadTQueue coBuildQ) + case mNs of + Nothing -> threadDelay 1000 >> loop + Just ns -> do + mTarget <- + atomically <| do + states <- readTVar coStates + case Map.lookup ns states of + Just (TSReadyToBuild t) -> do + modifyTVar' coStates (Map.insert ns (TSBuilding t)) + pure (Just t) + _ -> pure Nothing + case mTarget of + Nothing -> loop + Just target -> do + LogC.updateLineState ns LogC.Building + exitCode <- pipelineBuildOne andTest loud jobs cpus target + atomically <| do + modifyTVar' coStates (Map.insert ns (TSComplete target exitCode)) + modifyTVar' coResults (exitCode :) + modifyTVar' coRemaining (subtract 1) + promoteWaiters coord ns + LogC.updateLineState ns (isSuccess exitCode ?: (LogC.Success, LogC.Failed)) + loop + +promoteWaiters :: Coordinator -> Namespace -> STM () +promoteWaiters Coordinator {..} completedNs = do + states <- readTVar coStates + forM_ (Map.toList states) <| \(ns, st) -> + case st of + TSWaitingForDeps target deps -> do + let deps' = Set.delete completedNs deps + if Set.null deps' + then do + modifyTVar' coStates (Map.insert ns (TSReadyToBuild target)) + writeTQueue coBuildQ ns + else modifyTVar' coStates (Map.insert ns (TSWaitingForDeps target deps')) + _ -> pure () + +pipelineBuildOne :: Bool -> Bool -> Int -> Int -> Target -> IO Exit.ExitCode +pipelineBuildOne andTest loud jobs cpus target@Target {..} = do + root <- getCoderoot + result <- case compiler of + CPython -> case out of + Just _ -> + nixBuild loud jobs cpus target + +> (\r -> (isSuccess (fst r) && andTest) ?: (test loud target, pure r)) + Nothing -> + pure (Exit.ExitSuccess, mempty) + Gcc -> + nixBuild loud jobs cpus target + Ghc -> case out of + Nothing -> pure (Exit.ExitSuccess, mempty) + Just _ -> do + r <- nixBuild loud jobs cpus target + if andTest && (isSuccess <| fst r) + then test loud target + else pure r + Guile -> do + _ <- proc loud namespace (toNixFlag compiler) compilerFlags + case wrapper of + Nothing -> pure (Exit.ExitSuccess, mempty) + Just content -> do + writeFile (root </> outToPath out) content + p <- Dir.getPermissions <| root </> outToPath out + Dir.setPermissions (root </> outToPath out) (Dir.setOwnerExecutable True p) + pure (Exit.ExitSuccess, mempty) + NixBuild -> + Dir.getPermissions quapath /> Dir.executable +> \isExe -> + isExe + ?: ( proc + loud + namespace + (toNixFlag compiler) + ( compilerFlags + ++ [ "--max-jobs", + Text.pack <| str jobs, + "--cores", + Text.pack <| str cpus + ] + ), + pure (Exit.ExitSuccess, mempty) + ) + Copy -> + pure (Exit.ExitSuccess, mempty) + Rustc -> + nixBuild loud jobs cpus target + Sbcl -> + proc loud namespace (toNixFlag compiler) compilerFlags + pure (fst result) + +pipelineBuild :: Bool -> Bool -> Int -> Int -> Int -> [Namespace] -> (Namespace -> IO (Maybe Target)) -> IO [Exit.ExitCode] +pipelineBuild andTest loud analysisWorkers buildWorkers cpus namespaces analyzeFn = do + root <- getCoderoot + coord <- initCoordinator root namespaces + let spawnAnalysis = replicateM analysisWorkers (Async.async (pipelineAnalysisWorker coord analyzeFn)) + let spawnBuild = replicateM buildWorkers (Async.async (pipelineBuildWorker andTest loud buildWorkers cpus coord)) + threads <- (<>) </ spawnAnalysis <*> spawnBuild + let waitLoop = do + remaining <- readTVarIO (coRemaining coord) + if remaining == 0 + then pure () + else do + threadDelay 10000 + waitLoop + waitLoop + traverse_ Async.cancel threads + readTVarIO (coResults coord) data Proc = Proc { loud :: Bool, @@ -983,7 +1433,8 @@ run Proc {..} = do Conduit.proc cmd args |> (\proc_ -> proc_ {Process.create_group = True}) |> Conduit.streamingProcess - +> \(Conduit.UseProvidedHandle, stdout_, stderr_, hdl) -> + +> \(stdin_, stdout_, stderr_, hdl) -> do + IO.hClose stdin_ -- Close stdin immediately since we don't use it (,,) </ Async.Concurrently (Conduit.waitForStreamingProcess hdl) <*> Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_)) @@ -1014,7 +1465,7 @@ proc loud namespace cmd args = cmd = cmd, args = map Text.unpack args, onFailure = Log.fail ["bild", nschunk namespace] >> Log.br, - onSuccess = Log.good ["bild", nschunk namespace] >> Log.br + onSuccess = pure () } |> run @@ -1041,10 +1492,11 @@ logs ns src = src .| Conduit.iterM ( ByteString.filter (/= BSI.c2w '\n') - .> (\t -> Log.fmt ["info", "bild", nschunk ns, decodeUtf8 t]) + .> decodeUtf8 .> Text.take (columns - 1) - .> (<> "…\r") - .> putStr + .> (<> "...") + .> LogC.updateLine ns + .> liftIO ) .| Conduit.foldC |> Conduit.runConduitRes @@ -1082,7 +1534,7 @@ lispRequires = nixBuild :: Bool -> Int -> Int -> Target -> IO (Exit.ExitCode, ByteString) nixBuild loud maxJobs cores target@(Target {..}) = - Env.getEnv "CODEROOT" +> \root -> + getCoderoot +> \root -> instantiate root |> run +> \case (_, "") -> panic "instantiate did not produce a drv" (Exit.ExitSuccess, drv) -> @@ -1092,7 +1544,9 @@ nixBuild loud maxJobs cores target@(Target {..}) = |> str |> realise |> run - >> run symlink + +> \case + (Exit.ExitSuccess, _) -> run symlink + failure -> pure failure x -> pure x where instantiate root = @@ -1129,7 +1583,7 @@ nixBuild loud maxJobs cores target@(Target {..}) = str cores ], onFailure = Log.fail ["bild", "realise", nschunk namespace] >> Log.br, - onSuccess = Log.good ["bild", nschunk namespace] >> Log.br + onSuccess = pure () } symlink = Proc @@ -1146,3 +1600,41 @@ nixBuild loud maxJobs cores target@(Target {..}) = onFailure = Log.fail ["bild", "symlink", nschunk namespace] >> Log.br, onSuccess = pure () } + +getCoderoot :: IO FilePath +getCoderoot = do + mEnvRoot <- Env.lookupEnv "CODEROOT" + cwd <- Dir.getCurrentDirectory + case mEnvRoot of + Just envRoot -> do + let isPrefix = envRoot `List.isPrefixOf` cwd + let validPrefix = + isPrefix + && ( length envRoot + == length cwd + || (length cwd > length envRoot && (List.!!) cwd (length envRoot) == '/') + ) + if validPrefix + then pure envRoot + else do + mRealRoot <- findRoot cwd + case mRealRoot of + Just realRoot -> pure realRoot + Nothing -> pure envRoot + Nothing -> do + mRealRoot <- findRoot cwd + case mRealRoot of + Just realRoot -> pure realRoot + Nothing -> panic "CODEROOT not set and could not find root" + +findRoot :: FilePath -> IO (Maybe FilePath) +findRoot dir = do + let marker = dir </> "Omni" + exists <- Dir.doesDirectoryExist marker + if exists + then pure (Just dir) + else do + let parent = takeDirectory dir + if parent == dir + then pure Nothing + else findRoot parent diff --git a/Omni/Bild.nix b/Omni/Bild.nix index c6c0fe7..b7e0801 100644 --- a/Omni/Bild.nix +++ b/Omni/Bild.nix @@ -13,7 +13,6 @@ ccacheStdenv haskell sbcl - python312 nixos mkShell dockerTools @@ -22,7 +21,7 @@ stdenv = stable.ccacheStdenv; }; - unstable = nixpkgs.nixos-unstable-small; + unstable = nixpkgs.nixos-unstable; # get the .src attributes of all drvs in each pkgset in the `sources` list, # and concat them with `:` into a Unix-style search path. @@ -69,6 +68,7 @@ ghcPackageSetBild = ghcWith (hpkgs: with hpkgs; [ aeson + ansi-terminal async base bytestring @@ -78,6 +78,7 @@ directory docopt filepath + hostname process protolude rainbow @@ -87,7 +88,6 @@ tasty-hunit tasty-quickcheck text - hostname wai # can remove when removed from Omni.Log ]); }; @@ -97,9 +97,9 @@ python = { packages = self.lib.attrsets.getAttrs (import ./Bild/Deps/Python.nix) - stable.python312.pkgs; - pythonWith = stable.python312.withPackages; - buildPythonApplication = stable.python312.pkgs.buildPythonApplication; + unstable.python312.pkgs; + pythonWith = unstable.python312.withPackages; + buildPythonApplication = unstable.python312.pkgs.buildPythonApplication; }; # c packages are just stable, filtered to just the list of deps i want @@ -113,16 +113,20 @@ bat bc cmark + coreutils universal-ctags - #datasette + datasette deadnix fd figlet + findutils + ffmpeg fzf git git-branchless gitlint gitstats + gnutar groff guile hlint @@ -134,17 +138,13 @@ pkg-config ripgrep rustc + sqlite + stripe-cli tree wemux ; - #aider-chat = unstable.aider-chat; llama-cpp = unstable.llama-cpp; - # can't put this in the dev namespace because it pulls in openai with - # python311, which conflicts with any other usage of openai with - # python312. so i need to make a target that exposese/wraps llm like i did - # with llamacpp - #llm = python311.withPackages - # (p: [ p.llm p.llm-ollama p.llm-sentence-transformers ]); + llm = unstable.python312.withPackages (p: [p.llm]); ollama = unstable.ollama; ruff = unstable.ruff; shellcheck = unstable.shellcheck; @@ -162,6 +162,8 @@ ../Omni/Bild/Meta.hs ../Omni/Cli.hs ../Omni/Log.hs + ../Omni/Log/Concurrent.hs + ../Omni/Log/Terminal.hs ../Omni/Namespace.hs ../Omni/Test.hs ]; @@ -224,6 +226,7 @@ + self.lib.strings.removePrefix (toString src) (toString target); buildPhase = '' export CODEROOT=$(pwd) + export NO_COLOR=1 mkdir $out ${self.bild}/bin/bild --plan "$TARGET" 1> $out/analysis.json \ 2> >(tee -a $out/stderr >&2) @@ -249,11 +252,10 @@ name = "omnidev"; # this should just be dev tools buildInputs = with self.pkgs; [ - #aider-chat bat bc self.bild - #datasette + datasette universal-ctags fd figlet @@ -262,9 +264,13 @@ git-branchless gitlint jq + llm lolcat ormolu ripgrep + ruff + sqlite + stripe-cli tree wemux ]; diff --git a/Omni/Bild/Audit.py b/Omni/Bild/Audit.py new file mode 100755 index 0000000..4df6c0b --- /dev/null +++ b/Omni/Bild/Audit.py @@ -0,0 +1,176 @@ +#!/usr/bin/env python3 +""" +Audit codebase builds. + +Iterates through every namespace in the project and runs 'bild'. +For every build failure encountered, it automatically creates a new task. +""" + +# : out bild-audit + +import argparse +import re +import shutil +import subprocess +import sys +from pathlib import Path + +# Extensions supported by bild (from Omni/Bild.hs and Omni/Namespace.hs) +EXTENSIONS = {".c", ".hs", ".lisp", ".nix", ".py", ".scm", ".rs", ".toml"} +MAX_TITLE_LENGTH = 50 + + +def strip_ansi(text: str) -> str: + """Strip ANSI escape codes from text.""" + ansi_escape = re.compile(r"\x1B(?:[@-Z\\-_]|\[[0-?]*[ -/]*[@-~])") + return ansi_escape.sub("", text) + + +def is_ignored(path: Path) -> bool: + """Check if a file is ignored by git.""" + res = subprocess.run( + ["git", "check-ignore", str(path)], + stdout=subprocess.DEVNULL, + stderr=subprocess.DEVNULL, + check=False, + ) + return res.returncode == 0 + + +def get_buildable_files(root_dir: str = ".") -> list[str]: + """Find all files that bild can build.""" + targets: list[str] = [] + + root = Path(root_dir) + if not root.exists(): + return [] + + for path in root.rglob("*"): + # Skip directories + if path.is_dir(): + continue + + # Skip hidden files/dirs and '_' dirs + parts = path.parts + if any(p.startswith(".") or p == "_" for p in parts): + continue + + if path.suffix in EXTENSIONS: + # Clean up path: keep it relative to cwd if possible + try: + # We want the path as a string, relative to current directory + # if possible + p_str = ( + str(path.relative_to(Path.cwd())) + if path.is_absolute() + else str(path) + ) + except ValueError: + p_str = str(path) + + if not is_ignored(Path(p_str)): + targets.append(p_str) + return targets + + +def run_bild(target: str) -> subprocess.CompletedProcess[str]: + """Run bild on the target.""" + # --time 0 disables timeout + # --loud enables output (which we capture) + cmd = ["bild", "--time", "0", "--loud", target] + return subprocess.run(cmd, capture_output=True, text=True, check=False) + + +def create_task( + target: str, + result: subprocess.CompletedProcess[str], + parent_id: str | None = None, +) -> None: + """Create a task for a build failure.""" + # Construct a descriptive title + # Try to get the last meaningful line of error output + lines = (result.stdout + result.stderr).strip().split("\n") + last_line = lines[-1] if lines else "Unknown error" + last_line = strip_ansi(last_line).strip() + + if len(last_line) > MAX_TITLE_LENGTH: + last_line = last_line[: MAX_TITLE_LENGTH - 3] + "..." + + title = f"Build failed: {target} - {last_line}" + + cmd = ["task", "create", title, "--priority", "2", "--json"] + + if parent_id: + cmd.append(f"--discovered-from={parent_id}") + + # Try to infer namespace + # e.g. Omni/Bild.hs -> Omni/Bild + ns = Path(target).parent + if str(ns) != ".": + cmd.append(f"--namespace={ns}") + + print(f"Creating task for {target}...") # noqa: T201 + proc = subprocess.run(cmd, capture_output=True, text=True, check=False) + + if proc.returncode != 0: + print(f"Error creating task: {proc.stderr}", file=sys.stderr) # noqa: T201 + else: + # task create --json returns the created task json + print(f"Task created: {proc.stdout.strip()}") # noqa: T201 + + +def main() -> None: + """Run the build audit.""" + parser = argparse.ArgumentParser(description="Audit codebase builds.") + parser.add_argument( + "--parent", + help="Parent task ID to link discovered tasks to", + ) + parser.add_argument( + "paths", + nargs="*", + default=["."], + help="Paths to search for targets", + ) + args = parser.parse_args() + + # Check if bild is available + if not shutil.which("bild"): + print( # noqa: T201 + "Warning: 'bild' command not found. Ensure it is in PATH.", + file=sys.stderr, + ) + + print(f"Scanning for targets in {args.paths}...") # noqa: T201 + targets: list[str] = [] + for path_str in args.paths: + path = Path(path_str) + if path.is_file(): + targets.append(str(path)) + else: + targets.extend(get_buildable_files(path_str)) + + # Remove duplicates + targets = sorted(set(targets)) + print(f"Found {len(targets)} targets.") # noqa: T201 + + failures = 0 + for target in targets: + res = run_bild(target) + + if res.returncode == 0: + print("OK") # noqa: T201 + else: + print("FAIL") # noqa: T201 + failures += 1 + create_task(target, res, args.parent) + + print(f"\nAudit complete. {failures} failures found.") # noqa: T201 + if failures > 0: + sys.exit(1) + else: + sys.exit(0) + + +if __name__ == "__main__": + main() diff --git a/Omni/Bild/Builder.nix b/Omni/Bild/Builder.nix index f755684..1191eca 100644 --- a/Omni/Bild/Builder.nix +++ b/Omni/Bild/Builder.nix @@ -32,20 +32,51 @@ with bild; let isEmpty = x: x == null || x == []; skip = ["_" ".direnv"]; + + # Normalize paths by removing leading "./" + normalize = p: lib.strings.removePrefix "./" p; + + # Given a list of path parts, produce all cumulative prefixes: + # ["a","b","c"] -> ["a","a/b","a/b/c"] + dirPrefixes = parts: + if parts == [] + then [] + else let + hd = lib.lists.head parts; + tl = lib.lists.tail parts; + rest = dirPrefixes tl; + in + [hd] ++ (lib.lists.map (r: "${hd}/${r}") rest); + + # Normalize all source file paths (relative to root) + allSourcesRel = lib.lists.map normalize allSources; + + # Allowed directories are the ancestors of all source files, plus the repo root "" + allowedDirs = lib.lists.unique ( + [""] + ++ lib.lists.concatMap + (p: let + parts = lib.strings.splitString "/" p; + in + dirPrefixes (lib.lists.init parts)) + allSourcesRel + ); + filter = file: type: if lib.lists.elem (builtins.baseNameOf file) skip then false - # TODO: this means any new directory will cause a rebuild. this bad. i - # should recurse into the directory and match against the srcs. for now I - # just use preBuild to delete empty dirs else if type == "directory" - then true + then let + rel = lib.strings.removePrefix "${root}/" file; + rel' = normalize rel; + in + lib.lists.elem rel' allowedDirs else if type == "regular" - then - lib.trivial.pipe file [ - (f: lib.strings.removePrefix "${root}/" f) - (f: lib.lists.elem f allSources) - ] + then let + rel = lib.strings.removePrefix "${root}/" file; + rel' = normalize rel; + in + lib.lists.elem rel' allSourcesRel else false; # remove empty directories, leftover from the src filter @@ -84,21 +115,145 @@ with bild; let buildPhase = compileLine; }; - haskell = stdenv.mkDerivation rec { - inherit name src CODEROOT preBuild; - nativeBuildInputs = [makeWrapper]; - buildInputs = - sysdeps_ - ++ [ - (haskell.ghcWith (p: (lib.attrsets.attrVals target.langdeps p))) - ]; - buildPhase = compileLine; - installPhase = '' - install -D ${name} $out/bin/${name} - wrapProgram $out/bin/${name} \ - --prefix PATH : ${lib.makeBinPath rundeps_} - ''; - }; + haskell = + if (target.hsGraph or null) == null + then + # Monolithic build (fallback for TH/cycles) + stdenv.mkDerivation rec { + inherit name src CODEROOT preBuild; + nativeBuildInputs = [makeWrapper]; + buildInputs = + sysdeps_ + ++ [ + (haskell.ghcWith (p: (lib.attrsets.attrVals target.langdeps p))) + ]; + buildPhase = compileLine; + installPhase = '' + install -D ${name} $out/bin/${name} + wrapProgram $out/bin/${name} \ + --prefix PATH : ${lib.makeBinPath rundeps_} + ''; + } + else + # Per-module incremental build + let + graph = target.hsGraph; + ghcPkg = haskell.ghcWith (p: (lib.attrsets.attrVals target.langdeps p)); + + # Helper to sanitize module names for Nix attr names + sanitize = builtins.replaceStrings ["."] ["_"]; + + # Create source filter for a single module + mkModuleSrc = modulePath: let + moduleFiles = [modulePath]; + moduleAllSources = moduleFiles; + moduleAllSourcesRel = lib.lists.map normalize moduleAllSources; + moduleAllowedDirs = lib.lists.unique ( + [""] + ++ lib.lists.concatMap + (p: let + parts = lib.strings.splitString "/" p; + in + dirPrefixes (lib.lists.init parts)) + moduleAllSourcesRel + ); + moduleFilter = file: type: + if lib.lists.elem (builtins.baseNameOf file) skip + then false + else if type == "directory" + then let + rel = lib.strings.removePrefix "${root}/" file; + rel' = normalize rel; + in + lib.lists.elem rel' moduleAllowedDirs + else if type == "regular" + then let + rel = lib.strings.removePrefix "${root}/" file; + rel' = normalize rel; + in + lib.lists.elem rel' moduleAllSourcesRel + else false; + in + lib.sources.cleanSourceWith { + filter = moduleFilter; + src = lib.sources.cleanSource root; + }; + + # Build one module derivation + mkModuleDrv = modName: node: depDrvs: + stdenv.mkDerivation { + name = "hs-mod-${sanitize modName}"; + src = mkModuleSrc node.nodePath; + inherit CODEROOT; + nativeBuildInputs = []; + buildInputs = sysdeps_ ++ depDrvs; + builder = "${stdenv.shell}"; + args = [ + "-c" + (let + copyDeps = + lib.strings.concatMapStringsSep "\n" (d: '' + ${pkgs.coreutils}/bin/cp -rfL ${d}/hidir/. . 2>/dev/null || true + ${pkgs.coreutils}/bin/cp -rfL ${d}/odir/. . 2>/dev/null || true + ${pkgs.coreutils}/bin/chmod -R +w . 2>/dev/null || true + '') + depDrvs; + in '' + set -eu + ${pkgs.coreutils}/bin/cp -rL $src/. . + ${pkgs.coreutils}/bin/chmod -R +w . + ${copyDeps} + ${ghcPkg}/bin/ghc -c \ + -Wall -Werror -haddock -Winvalid-haddock \ + -i. \ + ${node.nodePath} + ${pkgs.coreutils}/bin/mkdir -p $out/hidir $out/odir + ${pkgs.findutils}/bin/find . -name '*.hi' -exec ${pkgs.coreutils}/bin/cp --parents {} $out/hidir/ \; + ${pkgs.findutils}/bin/find . -name '*.o' -exec ${pkgs.coreutils}/bin/cp --parents {} $out/odir/ \; + '') + ]; + }; + + # Recursive attrset of all module derivations + # mapAttrs' creates {sanitized-name = drv}, while nodeImports use original names + modules = lib.fix (self: + lib.mapAttrs' + (modName: node: + lib.nameValuePair (sanitize modName) ( + mkModuleDrv modName node (map (dep: builtins.getAttr (sanitize dep) self) node.nodeImports) + )) + graph.graphModules); + in + # Final link derivation + stdenv.mkDerivation rec { + inherit name CODEROOT src; + nativeBuildInputs = [makeWrapper]; + dontConfigure = true; + dontStrip = true; + dontPatchShebangs = true; + buildPhase = let + pkgFlags = lib.strings.concatMapStringsSep " " (p: "-package ${p}") target.langdeps; + copyHiFiles = lib.strings.concatMapStringsSep "\n" (drv: "cp -rL ${drv}/hidir/. . 2>/dev/null || true") (lib.attrsets.attrValues modules); + in '' + set -eu + ${copyHiFiles} + chmod -R +w . || true + ${ghcPkg}/bin/ghc --make \ + ${target.quapath} \ + -i. \ + ${pkgFlags} \ + -threaded \ + -o ${name} \ + ${lib.optionalString (target.mainModule != "Main") "-main-is ${target.mainModule}"} + ''; + installPhase = '' + install -D ${name} $out/bin/${name} + ${lib.optionalString (rundeps_ != []) '' + wrapProgram $out/bin/${name} \ + --prefix PATH : ${lib.makeBinPath rundeps_} + ''} + ''; + }; c = stdenv.mkDerivation rec { inherit name src CODEROOT preBuild; @@ -132,7 +287,7 @@ with bild; let checkPhase = '' . ${commonBash} cp ${../../pyproject.toml} ./pyproject.toml - check ruff format --exclude 'setup.py' --check . + # check ruff format --exclude 'setup.py' --check . # ignore EXE here to support run.sh shebangs check ruff check \ --ignore EXE \ @@ -142,7 +297,7 @@ with bild; let touch ./py.typed check python -m mypy \ --explicit-package-bases \ - --no-error-summary \ + --no-color-output \ --exclude 'setup\.py$' \ . ''; diff --git a/Omni/Bild/Deps.nix b/Omni/Bild/Deps.nix index b410f3b..0822fb1 100644 --- a/Omni/Bild/Deps.nix +++ b/Omni/Bild/Deps.nix @@ -1,9 +1,13 @@ -_self: super: { +_self: super: let + dontCheck = drv: drv.overrideAttrs (_: {doCheck = false;}); +in { cgit = super.overrideSrc super.cgit super.sources.cgit; # Needs upgrading for guile 3 # inspekt3d = super.callPackage ./Deps/inspekt3d.nix {}; + gupnp = dontCheck super.gupnp; + guix = super.pkgs.stdenv.mkDerivation rec { pname = "guix"; name = "${pname}-${version}"; @@ -28,5 +32,13 @@ _self: super: { nostr-rs-relay = super.callPackage ./Deps/nostr-rs-relay.nix {}; - radicale = super.radicale.overrideAttrs (_old: {doCheck = false;}); + radicale = dontCheck super.radicale; + + sweph-data = super.callPackage ./Deps/sweph-data.nix {}; + + swtpm = dontCheck super.swtpm; + + thrift = dontCheck super.thrift; + + valkey = dontCheck super.valkey; } diff --git a/Omni/Bild/Deps/Haskell.nix b/Omni/Bild/Deps/Haskell.nix index 5d6abbb..7e3650a 100644 --- a/Omni/Bild/Deps/Haskell.nix +++ b/Omni/Bild/Deps/Haskell.nix @@ -50,10 +50,13 @@ "servant-lucid" "servant-server" "split" + "sqids" + "sqlite-simple" "stm" "tasty" "tasty-hunit" "tasty-quickcheck" + "temporary" "text" "time" "transformers" diff --git a/Omni/Bild/Deps/Python.nix b/Omni/Bild/Deps/Python.nix index 3a0562d..2b8531b 100644 --- a/Omni/Bild/Deps/Python.nix +++ b/Omni/Bild/Deps/Python.nix @@ -1,6 +1,11 @@ [ + "boto3" + "botocore" "cryptography" + "feedgen" "flask" + "httpx" + "itsdangerous" "llm" "llm-ollama" "ludic" @@ -8,10 +13,21 @@ "nltk" "ollama" "openai" + "psutil" + "pydantic" + "pydantic-ai" + "pydantic-ai-slim" + "pydantic-graph" + "pydub" + "pytest" + "pytest-asyncio" + "pytest-mock" "requests" "slixmpp" "sqids" "starlette" + "stripe" + "trafilatura" "types-requests" "uvicorn" ] diff --git a/Omni/Bild/Deps/kerykeion.nix b/Omni/Bild/Deps/kerykeion.nix new file mode 100644 index 0000000..d887231 --- /dev/null +++ b/Omni/Bild/Deps/kerykeion.nix @@ -0,0 +1,72 @@ +{ + buildPythonPackage, + lib, + poetry-core, + pytestCheckHook, + pytz, + pyswisseph, + pydantic, + requests, + requests-cache, + scour, + simple-ascii-tables, + typing-extensions, + sources, + setuptools, +}: +buildPythonPackage rec { + pname = "kerykeion"; + version = sources.kerykeion.version; + pyproject = true; + + src = sources.kerykeion; + + nativeBuildInputs = [poetry-core]; + + propagatedBuildInputs = [ + pyswisseph + pydantic + scour + requests-cache + requests + simple-ascii-tables + pytz + typing-extensions + setuptools + ]; + + preBuild = '' + cat <<EOF >> pyproject.toml + [project] + name = "kerykeion" + version = "${sources.kerykeion.version}" + + [tool.setuptools.packages.find] + where = ["."] + include = ["kerykeion*", "tests"] + namespaces = false + + [build-system] + build-backend = "setuptools.build_meta" + requires = ["setuptools"] + EOF + ''; + + nativeCheckInputs = [pytestCheckHook]; + + pythonImportsCheck = ["kerykeion"]; + + # almost all tests perform network requests to api.geonames.org + enabledTests = [ + "test_ephemeris_data" + "test_settings" + ]; + + meta = with lib; { + homepage = "https://www.kerykeion.net/"; + description = "A python library for astrology"; + changelog = "https://github.com/g-battaglia/kerykeion/releases/tag/v${version}"; + license = licenses.agpl3Only; + maintainers = with maintainers; [bsima]; + }; +} diff --git a/Omni/Bild/Deps/logfire-api.nix b/Omni/Bild/Deps/logfire-api.nix new file mode 100644 index 0000000..af6eedf --- /dev/null +++ b/Omni/Bild/Deps/logfire-api.nix @@ -0,0 +1,24 @@ +{ + lib, + buildPythonPackage, + sources, + hatchling, + pythonOlder, +}: +buildPythonPackage rec { + pname = "logfire-api"; + version = sources.logfire.rev; + pyproject = true; + disabled = pythonOlder "3.8"; + src = sources.logfire; + sourceRoot = "logfire-src/logfire-api"; + build-system = [hatchling]; + pythonImportsCheck = ["logfire_api"]; + meta = { + description = "Shim for the Logfire SDK which does nothing unless Logfire is installed"; + homepage = "https://pypi.org/project/logfire-api/"; + changelog = "https://github.com/pydantic/logfire/releases/tag/v${version}"; + license = lib.licenses.mit; + maintainers = with lib.maintainers; [bsima]; + }; +} diff --git a/Omni/Bild/Deps/openai-python.nix b/Omni/Bild/Deps/openai-python.nix deleted file mode 100644 index 79db11c..0000000 --- a/Omni/Bild/Deps/openai-python.nix +++ /dev/null @@ -1,99 +0,0 @@ -{ - lib, - buildPythonPackage, - pythonOlder, - # build-system - hatchling, - hatch-fancy-pypi-readme, - # dependencies - anyio, - distro, - httpx, - jiter, - pydantic, - sniffio, - tqdm, - typing-extensions, - numpy, - pandas, - pandas-stubs, - # check deps - pytestCheckHook, - dirty-equals, - inline-snapshot, - nest-asyncio, - pytest-asyncio, - pytest-mock, - respx, - sources, -}: -buildPythonPackage rec { - pname = "openai"; - version = sources.openai-python.version; - pyproject = true; - - disabled = pythonOlder "3.8"; - - src = sources.openai-python; - - build-system = [ - hatchling - hatch-fancy-pypi-readme - ]; - - dependencies = [ - anyio - distro - httpx - jiter - pydantic - sniffio - tqdm - typing-extensions - ]; - - optional-dependencies = { - datalib = [ - numpy - pandas - pandas-stubs - ]; - }; - - pythonImportsCheck = ["openai"]; - - nativeCheckInputs = [ - pytestCheckHook - dirty-equals - inline-snapshot - nest-asyncio - pytest-asyncio - pytest-mock - respx - ]; - - pytestFlagsArray = [ - "-W" - "ignore::DeprecationWarning" - ]; - - disabledTests = [ - # Tests make network requests - "test_copy_build_request" - "test_basic_attribute_access_works" - ]; - - disabledTestPaths = [ - # Test makes network requests - "tests/api_resources" - ]; - - meta = with lib; { - description = "Python client library for the OpenAI API"; - homepage = "https://github.com/openai/openai-python"; - changelog = "https://github.com/openai/openai-python/releases/tag/v${version}"; - license = licenses.mit; - maintainers = with maintainers; [malo]; - mainProgram = "openai"; - }; -} diff --git a/Omni/Bild/Deps/pydantic-ai-slim.nix b/Omni/Bild/Deps/pydantic-ai-slim.nix new file mode 100644 index 0000000..067508b --- /dev/null +++ b/Omni/Bild/Deps/pydantic-ai-slim.nix @@ -0,0 +1,90 @@ +{ + lib, + buildPythonPackage, + hatchling, + pydantic, + logfire-api, + httpx, + eval-type-backport, + griffe, + pydantic-graph, + pythonOlder, + sources, + writeTextFile, +}: let + version = sources.pydantic-ai.version; + pyproject_toml = writeTextFile { + name = "pyproject.toml"; + text = '' + [build-system] + requires = ["hatchling"] + build-backend = "hatchling.build" + + [project] + name = "pydantic-ai-slim" + version = "${version}" + description = "Agent Framework / shim to use Pydantic with LLMs, slim package" + authors = [{ name = "Samuel Colvin", email = "samuel@pydantic.dev" }] + license = "MIT" + readme = "README.md" + requires-python = ">=3.9" + dependencies = [ + "eval-type-backport>=0.2.0", + "griffe>=1.3.2", + "httpx>=0.27", + "pydantic>=2.10", + "pydantic-graph==0.1.9", + "exceptiongroup; python_version < '3.11'", + "opentelemetry-api>=1.28.0", + "typing-inspection>=0.4.0", + ] + + [tool.hatch.metadata] + allow-direct-references = true + + [project.scripts] + pai = "pydantic_ai._cli:app" + + [tool.hatch.build.targets.wheel] + packages = ["pydantic_ai"] + ''; + }; +in + buildPythonPackage rec { + pname = "pydantic-ai-slim"; + inherit version; + pyproject = true; + disabled = pythonOlder "3.8"; + src = sources.pydantic-ai; + build-system = [hatchling]; + sourceRoot = "pydantic-ai-src/pydantic_ai_slim"; + dependencies = [ + pydantic + logfire-api + httpx + eval-type-backport + griffe + pydantic-graph + ]; + nativeCheckInputs = [ + pydantic + logfire-api + httpx + eval-type-backport + griffe + pydantic-graph + ]; + preBuild = '' + cp ${pyproject_toml} ./pyproject.toml + ''; + pythonImportsCheck = [ + "pydantic-ai-slim[openai,vertexai,groq,anthropic,mistral,cohere]" + ]; + meta = { + description = "Graph and finite state machine library"; + homepage = "https://github.com/pydantic/pydantic-ai"; + changelog = "https://github.com/pydantic/pydantic-ai/releases/tag/v${version}"; + license = lib.licenses.mit; + maintainers = with lib.maintainers; [bsima]; + }; + } diff --git a/Omni/Bild/Deps/pydantic-ai.nix b/Omni/Bild/Deps/pydantic-ai.nix new file mode 100644 index 0000000..399649d --- /dev/null +++ b/Omni/Bild/Deps/pydantic-ai.nix @@ -0,0 +1,75 @@ +{ + lib, + buildPythonPackage, + hatchling, + pydantic-ai-slim, + pythonOlder, + pytest-vcr, + dirty-equals, + sources, + writeTextFile, +}: let + version = sources.pydantic-ai.version; + pyproject_toml = writeTextFile { + name = "pyproject.toml"; + text = '' + [build-system] + requires = ["hatchling"] + build-backend = "hatchling.build" + + [project] + name = "pydantic-ai" + version = "${version}" + description = "Agent Framework / shim to use Pydantic with LLMs" + authors = [ + { name = "Samuel Colvin", email = "samuel@pydantic.dev" }, + { name = "Marcelo Trylesinski", email = "marcelotryle@gmail.com" }, + { name = "David Montague", email = "david@pydantic.dev" }, + { name = "Alex Hall", email = "alex@pydantic.dev" }, + ] + license = "MIT" + readme = "README.md" + requires-python = ">=3.9" + dependencies = [ + "pydantic-ai-slim[openai,vertexai,groq,anthropic,mistral,cohere,bedrock,cli,mcp,evals]==${version}", + ] + + [project.urls] + Homepage = "https://ai.pydantic.dev" + Source = "https://github.com/pydantic/pydantic-ai" + Documentation = "https://ai.pydantic.dev" + Changelog = "https://github.com/pydantic/pydantic-ai/releases" + + [project.scripts] + pai = "pydantic_ai._cli:app" + ''; + }; +in + buildPythonPackage rec { + pname = "pydantic-ai"; + inherit version; + pyproject = true; + disabled = pythonOlder "3.8"; + src = sources.pydantic-ai; + build-system = [hatchling]; + dependencies = [pydantic-ai-slim]; + nativeCheckInputs = [ + pydantic-ai-slim + pytest-vcr + dirty-equals + # pytestCheckHook + ]; + preBuild = '' + cp ${pyproject_toml} ./pyproject.toml + ''; + pythonImportsCheck = [ + "pydantic_ai" + ]; + meta = { + description = "Agent Framework / shim to use Pydantic with LLMs"; + homepage = "https://github.com/pydantic/pydantic-ai"; + changelog = "https://github.com/pydantic/pydantic-ai/releases/tag/v${version}"; + license = lib.licenses.mit; + maintainers = with lib.maintainers; [bsima]; + }; + } diff --git a/Omni/Bild/Deps/pydantic-graph.nix b/Omni/Bild/Deps/pydantic-graph.nix new file mode 100644 index 0000000..e2797b9 --- /dev/null +++ b/Omni/Bild/Deps/pydantic-graph.nix @@ -0,0 +1,45 @@ +{ + lib, + buildPythonPackage, + hatchling, + pydantic, + logfire-api, + httpx, + opentelemetry-api, + pythonOlder, + sources, +}: +buildPythonPackage rec { + pname = "pydantic-graph"; + version = sources.pydantic-ai.version; + pyproject = true; + disabled = pythonOlder "3.8"; + src = sources.pydantic-ai; + sourceRoot = "pydantic-ai-src/pydantic_graph"; + build-system = [hatchling]; + dependencies = [ + pydantic + logfire-api + httpx + opentelemetry-api + ]; + nativeCheckInputs = [ + pydantic + logfire-api + httpx + ]; + pythonRelaxDeps = true; + postPatch = '' + substituteInPlace pyproject.toml \ + --replace-fail ', "uv-dynamic-versioning>=0.7.0"' "" \ + --replace-fail 'dynamic = ["version"]' 'version = "${version}"' + ''; + pythonImportsCheck = ["pydantic_graph"]; + meta = { + description = "PydanticAI core logic with minimal required dependencies."; + homepage = "https://github.com/pydantic/pydantic-ai"; + changelog = "https://github.com/pydantic/pydantic-ai/releases/tag/v${version}"; + license = lib.licenses.mit; + maintainers = with lib.maintainers; [bsima]; + }; +} diff --git a/Omni/Bild/Deps/pyswisseph.nix b/Omni/Bild/Deps/pyswisseph.nix new file mode 100644 index 0000000..36c805e --- /dev/null +++ b/Omni/Bild/Deps/pyswisseph.nix @@ -0,0 +1,41 @@ +{ + buildPythonPackage, + lib, + setuptools, + wheel, + sources, + sweph-data, +}: +buildPythonPackage rec { + pname = "pyswisseph"; + version = sources.pyswisseph.version; + format = "setuptools"; + + src = sources.pyswisseph; + + nativeBuildInputs = [ + setuptools + wheel + ]; + + # Disable system library detection to use bundled versions + preBuild = '' + substituteInPlace setup.py \ + --replace-fail "swe_detection = True" "swe_detection = False" \ + --replace-fail "sqlite3_detection = True" "sqlite3_detection = False" + ''; + + # Set ephemeris path to use sweph-data + postInstall = '' + export SE_EPHE_PATH=${sweph-data}/share/sweph/ephe + ''; + + pythonImportsCheck = ["swisseph"]; + + meta = with lib; { + homepage = "https://astrorigin.com/pyswisseph"; + description = "Python extension to the Swiss Ephemeris"; + license = licenses.agpl3Only; + maintainers = with maintainers; [bsima]; + }; +} diff --git a/Omni/Bild/Deps/simple-ascii-tables.nix b/Omni/Bild/Deps/simple-ascii-tables.nix new file mode 100644 index 0000000..f2aa5d9 --- /dev/null +++ b/Omni/Bild/Deps/simple-ascii-tables.nix @@ -0,0 +1,28 @@ +{ + buildPythonPackage, + lib, + poetry-core, + setuptools, + pytestCheckHook, + sources, +}: +buildPythonPackage rec { + pname = "simple-ascii-tables"; + version = sources.simple-ascii-tables.version; + pyproject = true; + + src = sources.simple-ascii-tables; + + nativeBuildInputs = [poetry-core setuptools]; + + nativeCheckInputs = [pytestCheckHook]; + + pythonImportsCheck = ["simple_ascii_tables"]; + + meta = with lib; { + homepage = "https://pypi.org/project/simple-ascii-tables/"; + description = "Simple, minimal, dependency-free ASCII tables for Python"; + license = licenses.mit; + maintainers = with maintainers; [bsima]; + }; +} diff --git a/Omni/Bild/Deps/sweph-data.nix b/Omni/Bild/Deps/sweph-data.nix new file mode 100644 index 0000000..02e373f --- /dev/null +++ b/Omni/Bild/Deps/sweph-data.nix @@ -0,0 +1,38 @@ +{ + stdenv, + fetchurl, + lib, +}: +stdenv.mkDerivation rec { + pname = "sweph-data"; + version = "2023"; + + srcs = [ + (fetchurl { + url = "https://github.com/aloistr/swisseph/raw/master/ephe/seas_18.se1"; + sha256 = "0nvbd2kx99zsq3mlinabvjvhjm3rdq3middflq4prqsl2smc5naz"; + }) + (fetchurl { + url = "https://github.com/aloistr/swisseph/raw/master/ephe/semo_18.se1"; + sha256 = "10191sx3nnbh827y7jpa4n3fj8d8563d4kp0qfdml2xwypdm9ypc"; + }) + (fetchurl { + url = "https://github.com/aloistr/swisseph/raw/master/ephe/sepl_18.se1"; + sha256 = "18bfgg13sj9s6rv3zwbx1qx7k1bngyp1sw8xvnhfds8v7ip42zhb"; + }) + ]; + + unpackPhase = "true"; + + installPhase = '' + mkdir -p $out/share/sweph/ephe + for src in $srcs; do + cp $src $out/share/sweph/ephe/$(stripHash $src) + done + ''; + + meta = with lib; { + description = "Swiss Ephemeris data files"; + license = licenses.agpl3Only; + }; +} diff --git a/Omni/Bild/Example.py b/Omni/Bild/Example.py index 58e941a..1b2f61d 100755 --- a/Omni/Bild/Example.py +++ b/Omni/Bild/Example.py @@ -8,8 +8,15 @@ Example Python file that also serves as a test case for bild. # : out example # : dep cryptography import cryptography.fernet +import logging +import Omni.App as App +import Omni.Log as Log +import Omni.Test as Test import sys +logger = logging.getLogger(__name__) +Log.setup(logger) + def cryptic_hello(name: str) -> str: """ @@ -23,6 +30,7 @@ def cryptic_hello(name: str) -> str: key = cryptography.fernet.Fernet.generate_key() f = cryptography.fernet.Fernet(key) token = f.encrypt(hello(name).encode("utf-8")) + logger.info("attempting decryption") ret = f.decrypt(token).decode("utf-8") if ret != hello(name): msg = "en/decryption failed!" @@ -35,8 +43,16 @@ def hello(name: str) -> str: return f"Hello {name}" +class TestExample(Test.TestCase): + """Test the Example module.""" + + def test_hello(self) -> None: + """Test `hello` function.""" + self.assertEqual("Hello Ben", hello("Ben")) + + def main() -> None: """Entrypoint.""" if "test" in sys.argv: - sys.stdout.write("testing success") + Test.run(App.Area.Test, [TestExample]) sys.stdout.write(cryptic_hello("world")) diff --git a/Omni/Bild/Haskell.nix b/Omni/Bild/Haskell.nix index 7e969da..e55dee9 100644 --- a/Omni/Bild/Haskell.nix +++ b/Omni/Bild/Haskell.nix @@ -26,6 +26,7 @@ in rec { servant-auth = doJailbreak sup.servant-auth; servant-auth-server = dontCheck sup.servant-auth-server; shellcheck = doJailbreak sup.shellcheck; + sqids = dontCheck sup.sqids; string-qq = doJailbreak sup.string-qq; syb-with-class = doJailbreak sup.syb-with-class; th-abstraction = doJailbreak sup.th-abstraction; diff --git a/Omni/Bild/Nixpkgs.nix b/Omni/Bild/Nixpkgs.nix index 3418673..ab13d40 100644 --- a/Omni/Bild/Nixpkgs.nix +++ b/Omni/Bild/Nixpkgs.nix @@ -23,7 +23,7 @@ let (import ./CcacheWrapper.nix) (import ./Functions.nix) depsOverlay - (_: _: {unstable = this.nixos-unstable-small.pkgs;}) + (_: _: {unstable = this.nixos-unstable.pkgs;}) (import ./Deps.nix) (import ./Python.nix) (import ./Haskell.nix) @@ -31,7 +31,7 @@ let ]; }; - nixos-unstable-small = import sources.nixos-unstable-small { + nixos-unstable = import sources.nixos-unstable { inherit system config; overlays = [ (_: _: {inherit sources;}) diff --git a/Omni/Bild/Python.nix b/Omni/Bild/Python.nix index 36abe25..ae14ebc 100644 --- a/Omni/Bild/Python.nix +++ b/Omni/Bild/Python.nix @@ -4,13 +4,19 @@ _self: super: { with pysuper.pkgs.python312Packages; let dontCheck = p: p.overridePythonAttrs (_: {doCheck = false;}); in { + aider-chat = pysuper.aider-chat.withOptional {withAll = false;}; + aiohttp = dontCheck pysuper.aiohttp; + anthropic = dontCheck pysuper.anthropic; + anyio = dontCheck pysuper.anyio; interegular = callPackage ./Deps/interegular.nix {}; ipython = dontCheck pysuper.ipython; + kerykeion = callPackage ./Deps/kerykeion.nix {}; llm = super.overrideSrc pysuper.llm super.sources.llm; llm-ollama = pysuper.pkgs.python312.pkgs.callPackage ./Deps/llm-ollama.nix { ollama = pyself.ollama; }; llm-sentence-transformers = callPackage ./Deps/llm-sentence-transformers.nix {}; + logfire-api = callPackage ./Deps/logfire-api.nix {}; ludic = callPackage ./Deps/ludic.nix {}; mypy = dontCheck pysuper.mypy; ollama = pysuper.ollama.overridePythonAttrs (old: rec { @@ -22,10 +28,18 @@ _self: super: { --replace-fail "0.0.0" "${version}" ''; }); - openai = callPackage ./Deps/openai-python.nix {}; + onnx = dontCheck pysuper.onnx; outlines = callPackage ./Deps/outlines.nix {}; + psycopg = dontCheck pysuper.psycopg; + pydantic-ai = callPackage ./Deps/pydantic-ai.nix {}; + pydantic-ai-slim = callPackage ./Deps/pydantic-ai-slim.nix {}; + pydantic-graph = callPackage ./Deps/pydantic-graph.nix {}; perscache = callPackage ./Deps/perscache.nix {}; + pyswisseph = callPackage ./Deps/pyswisseph.nix {}; + simple-ascii-tables = callPackage ./Deps/simple-ascii-tables.nix {}; + sphinx = dontCheck pysuper.sphinx; tokenizers = dontCheck pysuper.tokenizers; + uvloop = dontCheck pysuper.uvloop; }; }; diff --git a/Omni/Bild/README.md b/Omni/Bild/README.md new file mode 100644 index 0000000..e1c026c --- /dev/null +++ b/Omni/Bild/README.md @@ -0,0 +1,40 @@ +# Bild + +`bild` is the universal build tool. It can build and test everything in the repo. + +Examples: +```bash +bild --test Omni/Bild.hs # Build and test a namespace +bild --time 0 Omni/Cloud.nix # Build with no timeout +bild --plan Omni/Test.hs # Analyze build without building +``` + +When the executable is built, the output will go to `_/bin`. Example: + +```bash +# build the example executable +bild Omni/Bild/Example.py +# run the executable +_/bin/example +``` + +## Adding New Dependencies + +### Python Packages + +To add a new Python package as a dependency: + +1. Add the package name to `Omni/Bild/Deps/Python.nix` (alphabetically sorted) +2. Use it in your Python file with `# : dep <package-name>` comment at the top +3. Run `bild <yourfile.py>` to build with the new dependency + +Example: +```python +# : out myapp +# : dep stripe +# : dep pytest +import stripe +``` + +The package name must match the nixpkgs python package name (usually the PyPI name). +Check available packages: `nix-env -qaP -A nixpkgs.python3Packages | grep <name>` diff --git a/Omni/Bild/Sources.json b/Omni/Bild/Sources.json index cf5f856..a7d057a 100644 --- a/Omni/Bild/Sources.json +++ b/Omni/Bild/Sources.json @@ -73,18 +73,43 @@ "url": "https://github.com/MegaIng/interegular/archive/v0.2.1.tar.gz", "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" }, + "kerykeion": { + "branch": "master", + "description": "Data-Driven Astrology 💫 Kerykeion is a Python library for astrology. It generates SVG charts and extracts detailed structured data for birth charts, synastry, transits, composite charts, and more.", + "homepage": "https://kerykeion.net", + "owner": "g-battaglia", + "repo": "kerykeion", + "rev": "V4.26.0", + "sha256": "0c2r2q0qgjzzjp7d3b1f0mqb508kj3b6767cw7kd2nn47wihb8g8", + "type": "tarball", + "url": "https://github.com/g-battaglia/kerykeion/archive/V4.26.0.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz", + "version": "4.26.0" + }, "llm": { "branch": "main", "description": "Access large language models from the command-line", "homepage": "https://llm.datasette.io", "owner": "simonw", "repo": "llm", - "rev": "41d64a8f1239322e12aa11c17450054f0c654ed7", - "sha256": "1vyg0wmcxv8910iz4cx9vjb3y4fq28423p62cgzr308ra8jii719", + "rev": "0.27.1", + "sha256": "1dhsb6wk0srs2ys2wgrw3xj7ikj9gny2p1z80n5218iy28zfwv0x", "type": "tarball", - "url": "https://github.com/simonw/llm/archive/41d64a8f1239322e12aa11c17450054f0c654ed7.tar.gz", + "url": "https://github.com/simonw/llm/archive/0.27.1.tar.gz", "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz", - "version": "0.21" + "version": "0.27.1" + }, + "logfire": { + "branch": "main", + "description": "Uncomplicated Observability for Python and beyond! 🪵🔥", + "homepage": "https://logfire.pydantic.dev/docs/", + "owner": "pydantic", + "repo": "logfire", + "rev": "0ef05d9414232c82fb03d34860fb1a2ec9a50488", + "sha256": "16ffikhdh810lhj7rx9gy0sy9x4kk2621l02j5ydkar0vkcpy6vd", + "type": "tarball", + "url": "https://github.com/pydantic/logfire/archive/0ef05d9414232c82fb03d34860fb1a2ec9a50488.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" }, "niv": { "branch": "master", @@ -140,10 +165,10 @@ "homepage": "", "owner": "nixos", "repo": "nixpkgs", - "rev": "7105ae3957700a9646cc4b766f5815b23ed0c682", - "sha256": "0j3jd82iyyck4hpmz7pkak1v27l7pydl0c3vvyz6wfpi612x8xzi", + "rev": "50ab793786d9de88ee30ec4e4c24fb4236fc2674", + "sha256": "1s2gr5rcyqvpr58vxdcb095mdhblij9bfzaximrva2243aal3dgx", "type": "tarball", - "url": "https://github.com/nixos/nixpkgs/archive/7105ae3957700a9646cc4b766f5815b23ed0c682.tar.gz", + "url": "https://github.com/nixos/nixpkgs/archive/50ab793786d9de88ee30ec4e4c24fb4236fc2674.tar.gz", "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" }, "nixos-mailserver": { @@ -156,16 +181,16 @@ "url_template": "https://gitlab.com/simple-nixos-mailserver/nixos-mailserver/-/archive/<rev>/nixos-mailserver-<rev>.tar.gz", "version": "master" }, - "nixos-unstable-small": { - "branch": "nixos-unstable-small", + "nixos-unstable": { + "branch": "nixos-unstable", "description": "Nix Packages collection & NixOS", "homepage": "", "owner": "nixos", "repo": "nixpkgs", - "rev": "1750f3c1c89488e2ffdd47cab9d05454dddfb734", - "sha256": "1nrwlaxd0f875r2g6v9brrwmxanra8pga5ppvawv40hcalmlccm0", + "rev": "2fad6eac6077f03fe109c4d4eb171cf96791faa4", + "sha256": "14inw2gxia29f0qh9kyvdq9y1wcv43r4cc7fylz9v372z5chiamh", "type": "tarball", - "url": "https://github.com/nixos/nixpkgs/archive/1750f3c1c89488e2ffdd47cab9d05454dddfb734.tar.gz", + "url": "https://github.com/nixos/nixpkgs/archive/2fad6eac6077f03fe109c4d4eb171cf96791faa4.tar.gz", "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" }, "nvidia-patch-nixos": { @@ -186,23 +211,13 @@ "homepage": "https://ollama.com", "owner": "ollama", "repo": "ollama-python", - "rev": "ee349ecc6d05ea57c9e91bc9345e2db3bc79bb5b", + "rev": "115792583ed248411d68334050ffed03ce9bc065", "sha256": "1dkrdkw7gkr9ilfb34qh9vwm0231csg7raln69p00p4mvx2w53gi", "type": "tarball", "url": "https://github.com/ollama/ollama-python/archive/refs/tags/v0.4.5.tar.gz", "url_template": "https://github.com/<owner>/<repo>/archive/refs/tags/v<version>.tar.gz", "version": "0.4.5" }, - "openai-python": { - "branch": "main", - "description": "The official Python library for the OpenAI API", - "homepage": "https://pypi.org/project/openai/", - "owner": "openai", - "repo": "https://github.com/openai/openai-python", - "rev": "5e3e4d1b0f16ccc4469a90a5bff09cafe0de7a2e", - "type": "git", - "version": "1.56.1" - }, "outlines": { "branch": "main", "description": "Generative Model Programming", @@ -227,6 +242,33 @@ "url": "https://github.com/leshchenko1979/perscache/archive/0.6.1.tar.gz", "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" }, + "pydantic-ai": { + "branch": "main", + "description": "Agent Framework / shim to use Pydantic with LLMs", + "homepage": "https://ai.pydantic.dev", + "owner": "pydantic", + "repo": "pydantic-ai", + "rev": "1e561011e4d9e654b1eaecb6b96890bcc047982d", + "sha256": "02kx6j9nck4b8qxz86lzs5jvq01rh4641wdal2nwznwxwlinnyp5", + "type": "tarball", + "url": "https://github.com/pydantic/pydantic-ai/archive/1e561011e4d9e654b1eaecb6b96890bcc047982d.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz", + "version": "0.1.9" + }, + "pyswisseph": { + "branch": "master", + "description": "Python extension to the Swiss Ephemeris", + "homepage": "https://astrorigin.com/pyswisseph", + "repo": "https://github.com/astrorigin/pyswisseph", + "rev": "778903d59bed84b8da020cee77f1995b0df5106b", + "sha256": "1qbwnhw2rv6qh5nzgj47baxfmx29wim0bkrvfzfg6cy7g7xxfbz6", + "submodules": true, + "tag": "v2.10.03.2", + "type": "git", + "url": "https://github.com/astrorigin/pyswisseph/archive/v2.10.03.2.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz", + "version": "2.10.03.2" + }, "radicale": { "branch": "master", "description": "A simple CalDAV (calendar) and CardDAV (contact) server.", @@ -252,5 +294,18 @@ "url": "https://github.com/feuerbach/regex-applicative/archive/449519c38e65753345e9a008362c011cb7a0a4d9.tar.gz", "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz", "version": "0.3.4" + }, + "simple-ascii-tables": { + "branch": "master", + "description": "Simple, minimal, dependency-free ASCII tables for Python.", + "homepage": "https://pypi.org/project/simple-ascii-tables/", + "owner": "g-battaglia", + "repo": "simple-ascii-tables", + "rev": "V1.0.0", + "sha256": "0zzpis810kgwybaiyj2im3fcmjvadpb3gls4k2j13k0z909vind7", + "type": "tarball", + "url": "https://github.com/g-battaglia/simple-ascii-tables/archive/V1.0.0.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz", + "version": "1.0.0" } } diff --git a/Omni/Bild/Sources.nix b/Omni/Bild/Sources.nix index dbcd147..93bb9d8 100644 --- a/Omni/Bild/Sources.nix +++ b/Omni/Bild/Sources.nix @@ -44,11 +44,15 @@ let else abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; + submodules = + if spec ? submodules + then spec.submodules + else false; in builtins.fetchGit { url = spec.repo; inherit (spec) rev; - inherit ref; + inherit ref submodules; }; fetch_local = spec: spec.path; diff --git a/Omni/Ci.hs b/Omni/Ci.hs new file mode 100644 index 0000000..aff5c7b --- /dev/null +++ b/Omni/Ci.hs @@ -0,0 +1,191 @@ +#!/usr/bin/env run.sh +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | A robust CI program replacing Omni/Ci.sh +-- +-- : out ci +module Omni.Ci (main) where + +import Alpha +import qualified Data.Text as Text +import qualified Omni.Cli as Cli +import qualified Omni.Log as Log +import qualified Omni.Test as Test +import qualified System.Directory as Dir +import qualified System.Environment as Environment +import qualified System.Exit as Exit +import System.FilePath ((</>)) +import qualified System.Process as Process + +main :: IO () +main = Cli.main <| Cli.Plan help move test pure + +help :: Cli.Docopt +help = + [Cli.docopt| +omni-ci - Continuous Integration + +Usage: + ci test + ci [options] + +Options: + -h, --help Print this info +|] + +test :: Test.Tree +test = + Test.group + "Omni.Ci" + [ Test.unit "placeholder test" <| do + True Test.@=? True + ] + +move :: Cli.Arguments -> IO () +move _ = do + -- 1. Check for dirty worktree + status <- readProcess "git" ["status", "-s"] "" + unless (Text.null status) <| do + Log.fail ["ci", "dirty worktree"] + Exit.exitWith (Exit.ExitFailure 1) + + -- 2. Setup environment + -- We need to ensure timeout is disabled for CI builds + -- Equivalent to: BILD_ARGS="--time 0 ${BILD_ARGS:-""}" + currentBildArgs <- Environment.lookupEnv "BILD_ARGS" + let bildArgs = "--time 0 " <> fromMaybe "" currentBildArgs + Environment.setEnv "BILD_ARGS" bildArgs + + -- 3. Get user info + at <- readProcess "date" ["-R"] "" |> fmap chomp + user <- readProcess "git" ["config", "--get", "user.name"] "" |> fmap chomp + mail <- readProcess "git" ["config", "--get", "user.email"] "" |> fmap chomp + + -- 4. Check existing git notes + -- commit=$(git notes --ref=ci show HEAD || true) + (exitCode, noteContent, _) <- Process.readProcessWithExitCode "git" ["notes", "--ref=ci", "show", "HEAD"] "" + + let alreadyGood = case exitCode of + Exit.ExitSuccess -> + let content = Text.pack noteContent + in ("Lint-is: good" `Text.isInfixOf` content) && ("Test-is: good" `Text.isInfixOf` content) + _ -> False + + when alreadyGood <| do + Log.pass ["ci", "already verified"] + Exit.exitSuccess + + -- 5. Run Lint + coderoot <- getCoderoot + let runlint = coderoot </> "_/bin/lint" + + lintExists <- Dir.doesFileExist runlint + unless lintExists <| do + Log.info ["ci", "building lint"] + callProcess "bild" [coderoot </> "Omni/Lint.hs"] + + Log.info ["ci", "running lint"] + -- if "$runlint" "${CODEROOT:?}"/**/* + -- We need to expand **/* which shell does. + -- Since we are in Haskell, we can just pass "." or call git ls-files or similar. + -- Omni/Ci.sh used "${CODEROOT:?}"/**/* which relies on bash globbing. + -- Omni/Lint.hs recursively checks if passed directory or uses git diff if no args. + -- But Omni/Ci.sh passes **/*. + -- Let's try passing the root directory or just run it without args? + -- Omni/Lint.hs says: + -- "case Cli.getAllArgs args (Cli.argument "file") of [] -> changedFiles ..." + -- So if we pass nothing, it only checks changed files. + -- The CI script explicitly passed everything. + -- We can replicate "everything" by passing the coderoot, assuming Lint handles directories recursively? + -- Omni/Lint.hs: "traverse Directory.makeAbsolute /> map (Namespace.fromPath root) ... filter (not <. Namespace.isCab)" + -- It seems it expects files. + -- We can use `git ls-files` to get all files. + allFiles <- + readProcess "git" ["ls-files"] "" + /> lines + /> map Text.unpack + /> filter (not <. null) + + -- We can't pass all files as arguments if there are too many (ARG_MAX). + -- But wait, Omni/Lint.hs takes arguments. + -- If we want to check everything, maybe we should implement a "check all" mode in Lint or pass chunks. + -- However, looking at Omni/Ci.sh: `"$runlint" "${CODEROOT:?}"/**/*` + -- This globbing is handled by the shell. It might be huge. + -- If I run `lint` with `.` it might work if Lint supports directories. + -- Omni/Lint.hs: "files |> ... filterM Directory.doesFileExist" + -- It seems it filters for files. + -- If I pass a directory, `doesFileExist` will return False. + -- So I must pass files. + + -- Let's pass all files from git ls-files. + -- But we must be careful about ARG_MAX. + -- For now, let's try passing them. If it fails, we might need to batch. + + lintResult <- do + -- We run lint on all files. + -- Note: calling callProcess with huge list might fail. + -- Let's see if we can avoid passing all files if Lint supports it. + -- Omni/Lint.hs doesn't seem to support directory recursion on its own if passed a dir, + -- it treats args as file paths. + + -- We will try to run it. + (exitCodeLint, _, _) <- Process.readProcessWithExitCode runlint allFiles "" + pure <| case exitCodeLint of + Exit.ExitSuccess -> "good" + _ -> "fail" + + -- 6. Run Tests + -- if bild "${BILD_ARGS:-""}" --test "${CODEROOT:?}"/**/* + Log.info ["ci", "running tests"] + + testResult <- do + -- similarly, bild takes targets. + -- bild "${CODEROOT:?}"/**/* + -- We can pass namespaces. + -- Let's try passing all files again. + -- bild handles namespaces. + (exitCodeTest, _, _) <- Process.readProcessWithExitCode "bild" ("--test" : allFiles) "" + pure <| case exitCodeTest of + Exit.ExitSuccess -> "good" + _ -> "fail" + + -- 7. Create Note + let noteMsg = + Text.unlines + [ "Lint-is: " <> lintResult, + "Test-is: " <> testResult, + "Test-by: " <> user <> " <" <> mail <> ">", + "Test-at: " <> at + ] + + -- 8. Append Note + callProcess "git" ["notes", "--ref=ci", "append", "-m", Text.unpack noteMsg] + + -- 9. Exit + if lintResult == "good" && testResult == "good" + then Exit.exitSuccess + else do + Log.fail ["ci", "verification failed"] + Exit.exitWith (Exit.ExitFailure 1) + +-- Helpers + +readProcess :: FilePath -> [String] -> String -> IO Text +readProcess cmd args input = do + out <- Process.readProcess cmd args input + pure (Text.pack out) + +callProcess :: FilePath -> [String] -> IO () +callProcess cmd args = do + Process.callProcess cmd args + +getCoderoot :: IO FilePath +getCoderoot = do + mEnvRoot <- Environment.lookupEnv "CODEROOT" + case mEnvRoot of + Just envRoot -> pure envRoot + Nothing -> panic "CODEROOT not set" -- Simplified for now diff --git a/Omni/Ci.sh b/Omni/Ci.sh deleted file mode 100755 index 609e9aa..0000000 --- a/Omni/Ci.sh +++ /dev/null @@ -1,62 +0,0 @@ -#!/usr/bin/env bash -# -# A simple ci that saves its results in a git note, formatted according to -# RFC-2822, more or less. -# -# To run this manually, exec the script. It will by default run the tests for -# HEAD, whatever you currently have checked out. -# -# It would be cool to use a zero-knowledge proof mechanism here to prove that -# so-and-so ran the tests, but I'll have to research how to do that. -# -# ensure we don't exit on bild failure, only on CI script error - set +e - set -u -## - [[ -n $(git status -s) ]] && { echo fail: dirty worktree; exit 1; } -## - at=$(date -R) - user=$(git config --get user.name) - mail=$(git config --get user.email) -## - commit=$(git notes --ref=ci show HEAD || true) - if [[ -n "$commit" ]] - then - if grep -q "Lint-is: good" <<< "$commit" - then - exit 0 - fi - if grep -q "Test-is: good" <<< "$commit" - then - exit 0 - fi - fi -## - runlint="$CODEROOT"/_/bin/lint - [[ ! -f "$runlint" ]] && bild "${BILD_ARGS:-""}" "${CODEROOT:?}"/Omni/Lint.hs - if "$runlint" "${CODEROOT:?}"/**/* - then - lint_result="good" - else - lint_result="fail" - fi -## - if bild "${BILD_ARGS:-""}" --test "${CODEROOT:?}"/**/* - then - test_result="good" - else - test_result="fail" - fi -## - read -r -d '' note <<EOF -Lint-is: $lint_result -Test-is: $test_result -Test-by: $user <$mail> -Test-at: $at -EOF -## - git notes --ref=ci append -m "$note" -## -# exit 1 if failure - [[ ! "$lint_result" == "fail" && ! "$test_result" == "fail" ]] -## diff --git a/Omni/Cloud.nix b/Omni/Cloud.nix index 27db37a..21de9d2 100755 --- a/Omni/Cloud.nix +++ b/Omni/Cloud.nix @@ -17,6 +17,7 @@ bild.os { ./Cloud/Web.nix ./Cloud/Znc.nix ./Cloud/Monica.nix + ./Cloud/OpenWebui.nix "${bild.sources.nixos-mailserver}" ]; networking.hostName = "bensima"; diff --git a/Omni/Cloud/Comms/Xmpp.nix b/Omni/Cloud/Comms/Xmpp.nix index 93d7cfc..e48dd56 100644 --- a/Omni/Cloud/Comms/Xmpp.nix +++ b/Omni/Cloud/Comms/Xmpp.nix @@ -32,7 +32,7 @@ in { # this is necessary bc prosody needs access to the acme certs managed in Omni/Cloud/Web.nix, when # i learn how to use security.acme better, and use separate certs, then i can fix this group group = "nginx"; - admins = ["bsima@${rootDomain}"]; + admins = ["ben@${rootDomain}"]; allowRegistration = true; inherit ssl; uploadHttp = { diff --git a/Omni/Cloud/Mail.nix b/Omni/Cloud/Mail.nix index bccf5db..22551c2 100644 --- a/Omni/Cloud/Mail.nix +++ b/Omni/Cloud/Mail.nix @@ -23,6 +23,12 @@ Known issues: enableManageSieve = true; virusScanning = false; # ur on ur own localDnsResolver = true; + dmarcReporting = { + enable = true; + organizationName = "Ben Sima"; + domain = "bensima.com"; + localpart = "dmarc"; + }; # Define proper virtual aliases instead of placeholder extraVirtualAliases = { @@ -56,6 +62,10 @@ Known issues: hashedPasswordFile = "/home/ben/hashed-mail-password"; quota = "1G"; }; + "dmarc@bensima.com" = { + hashedPasswordFile = "/home/ben/hashed-mail-password"; + quota = "1G"; + }; }; }; diff --git a/Omni/Cloud/OpenWebui.nix b/Omni/Cloud/OpenWebui.nix new file mode 100644 index 0000000..fc662c2 --- /dev/null +++ b/Omni/Cloud/OpenWebui.nix @@ -0,0 +1,43 @@ +{ + config, + pkgs, + ... +}: let + ports = import ./Ports.nix; +in { + config.virtualisation.oci-containers.backend = "docker"; + + config.virtualisation.oci-containers.containers.open-webui-aichat = { + image = "ghcr.io/open-webui/open-webui:main"; + volumes = ["/var/lib/open-webui-aichat:/app/backend/data"]; + environment = { + PORT = toString ports.open-webui-aichat; + }; + extraOptions = ["--network=host"]; + }; + + # Add a service that updates and restarts the container + config.systemd.services."update-open-webui-aichat" = { + description = "pulling new open-webui image and restarting the service"; + wantedBy = ["multi-user.target"]; + after = ["network-online.target"]; + serviceConfig = { + Type = "oneshot"; + ExecStart = [ + # Pull the latest image + "${pkgs.docker}/bin/docker pull ghcr.io/open-webui/open-webui:main" + # Restart the container + "${pkgs.systemd}/bin/systemctl stop docker-open-webui-aichat" + "${pkgs.systemd}/bin/systemctl start docker-open-webui-aichat" + ]; + }; + }; + + # Add a timer that runs every Sunday at 3 AM + config.systemd.timers."update-open-webui-aichat" = { + wantedBy = ["timers.target"]; + timerConfig.OnCalendar = "Sun 03:00:00"; + timerConfig.Persistent = true; + unitConfig.Description = "Weekly timer for pulling new open-webui image and restarting service."; + }; +} diff --git a/Omni/Cloud/Ports.nix b/Omni/Cloud/Ports.nix index 7f16bf3..ac67d54 100644 --- a/Omni/Cloud/Ports.nix +++ b/Omni/Cloud/Ports.nix @@ -33,6 +33,7 @@ nostr-relay = 8084; ollama = 11434; open-webui = 8088; + open-webui-aichat = 4242; radicale = 5232; sabten = 8081; ssh = 22; diff --git a/Omni/Cloud/Web.nix b/Omni/Cloud/Web.nix index d99f3a6..45afc4d 100644 --- a/Omni/Cloud/Web.nix +++ b/Omni/Cloud/Web.nix @@ -77,7 +77,6 @@ in { "simatime.com" "www.bsima.me" "bsima.me" - "mail.bensima.com" ]; locations = { # nostr nip-5 verification @@ -171,6 +170,17 @@ in { }; }; }; + + "aichat.${rootDomain}" = { + forceSSL = true; + useACMEHost = rootDomain; + locations = { + "/" = { + proxyPass = "http://127.0.0.1:${toString ports.open-webui-aichat}"; + proxyWebsockets = true; + }; + }; + }; }; }; }; @@ -187,10 +197,10 @@ in { "jupyter" "git" "monica" - "syncthing" # xmpp stuff "upload" "conference" + "aichat" ]; }; } diff --git a/Omni/Dev/Beryllium.nix b/Omni/Dev/Beryllium.nix index d40ec38..023523e 100755 --- a/Omni/Dev/Beryllium.nix +++ b/Omni/Dev/Beryllium.nix @@ -11,6 +11,7 @@ bild.os { ./Docker.nix ./Vpn.nix ./Beryllium/OpenWebui.nix + ./Beryllium/Live.nix ../Syncthing.nix ]; networking.hostName = "beryllium"; diff --git a/Omni/Dev/Beryllium/Configuration.nix b/Omni/Dev/Beryllium/Configuration.nix index 8fa783b..3e39fe4 100644 --- a/Omni/Dev/Beryllium/Configuration.nix +++ b/Omni/Dev/Beryllium/Configuration.nix @@ -14,9 +14,6 @@ in { boot.loader.systemd-boot.enable = true; boot.loader.efi.canTouchEfiVariables = true; - boot.kernelModules = ["v4l2loopback"]; - boot.extraModulePackages = [pkgs.linuxPackages.v4l2loopback]; - # Enable networking networking.networkmanager.enable = true; @@ -52,24 +49,21 @@ in { services.xserver = { layout = "us"; xkbVariant = ""; + extraConfig = '' + Section "InputClass" + Identifier "Kensington Expert Mouse" + MatchProduct "Kensington Expert Mouse" + Option "ButtonMapping" "1 8 2 4 5 6 7 3 9" + Option "NaturalScrolling" "true" + Option "ScrollMethod" "button" + Option "ScrollButton" "3" + EndSection + ''; }; # Enable CUPS to print documents. services.printing.enable = true; - # Enable sound with pipewire. - hardware.pulseaudio.enable = false; - security.rtkit.enable = true; - services.pipewire = { - enable = true; - alsa.enable = true; - alsa.support32Bit = true; - pulse.enable = true; - # If you want to use JACK applications, uncomment this - jack.enable = true; - wireplumber.enable = true; - }; - hardware.opengl.enable = true; hardware.opengl.driSupport32Bit = true; services.xserver.videoDrivers = ["nvidia"]; @@ -100,6 +94,8 @@ in { services.eternal-terminal.enable = true; + services.pcscd.enable = true; + environment.systemPackages = with pkgs; [ v4l-utils linuxPackages.v4l2loopback diff --git a/Omni/Dev/Beryllium/Hardware.nix b/Omni/Dev/Beryllium/Hardware.nix index 5a8b583..c9632f5 100644 --- a/Omni/Dev/Beryllium/Hardware.nix +++ b/Omni/Dev/Beryllium/Hardware.nix @@ -12,7 +12,6 @@ boot.initrd.availableKernelModules = ["xhci_pci" "ahci" "nvme" "usbhid" "usb_storage" "sd_mod"]; boot.initrd.kernelModules = []; boot.kernelModules = ["kvm-amd"]; - boot.extraModulePackages = []; fileSystems."/" = { device = "/dev/disk/by-uuid/f96eaa16-d0e2-4230-aece-131ce7b630da"; diff --git a/Omni/Dev/Beryllium/Live.nix b/Omni/Dev/Beryllium/Live.nix new file mode 100644 index 0000000..a44452f --- /dev/null +++ b/Omni/Dev/Beryllium/Live.nix @@ -0,0 +1,135 @@ +{pkgs, ...}: { + programs.obs-studio = { + enable = true; + enableVirtualCamera = true; + plugins = with pkgs.obs-studio-plugins; [ + obs-pipewire-audio-capture + ]; + }; + + # Enable sound with pipewire. + hardware.pulseaudio.enable = false; + security.rtkit.enable = true; + + # Latency optimization + boot.kernelParams = ["threadirqs"]; + boot.kernel.sysctl."vm.swappiness" = 10; + + environment.systemPackages = with pkgs; [ + obs-do # cli for controlling obs + pamixer # cli volume control + patchage # another connection manager + pwvucontrol # gui for quick adjustments + qpwgraph # better than helvum + supercollider-with-plugins + ]; + + # Virtual sinks for routing audio + services.pipewire = { + enable = true; + alsa.enable = true; + alsa.support32Bit = true; + pulse.enable = true; + jack.enable = true; + wireplumber.enable = true; + + extraConfig.pipewire = { + "10-loopback" = { + # loopback my mic into my headphones so i can hear myself, this creates + # an auditory space that encourages focus and thinking + + "context.properties" = { + "default.clock.rate" = 48000; + "default.clock.quantum" = 128; # lower for less latency + "default.clock.min-quantum" = 32; + "default.clock.max-quantum" = 8192; + }; + + "context.exec" = [ + { + "path" = "${pkgs.writeShellScript "setup-mic-monitor" '' + sleep 1 + ${pkgs.pipewire}/bin/pw-link \ + "alsa_input.usb-Antlion_Audio_Antlion_USB_Microphone-00.pro-input-0:capture_AUX0" \ + "input.mic-monitor:input_FL" + + ${pkgs.pipewire}/bin/pw-link \ + "alsa_input.usb-Antlion_Audio_Antlion_USB_Microphone-00.pro-input-0:capture_AUX0" \ + "input.mic-monitor:input_FR" + ''}"; + } + ]; + + "context.modules" = [ + { + name = "libpipewire-module-loopback"; + args = { + "node.name" = "mic-monitor"; + "node.description" = "Microphone Monitor"; + "capture.props" = { + "target.object" = "alsa_input.usb-Antlion_Audio_Antlion_USB_Microphone-00.pro-input-0"; + "channelmix.normalize" = true; + "audio.channels" = 1; + "audio.position" = ["FR" "FL"]; + }; + "playback.props" = { + "target.object" = "alsa_output.usb-Focusrite_Scarlett_Solo_USB-00.HiFi__Line1__sink"; + "node.passive" = true; + "channelmix.normalize" = true; + "audio.channels" = 2; + "audio.position" = ["FR" "FL"]; + }; + }; + } + ]; + }; + + "10-combined" = { + "context.modules" = [ + { + name = "libpipewire-module-loopback"; + args = { + "node.name" = "combined-audio"; + "node.description" = "Combined Mic+Desktop Audio"; + "capture.props" = { + "media.class" = "Audio/Sink"; + "audio.class" = 2; + "audio.position" = ["FL" "FR"]; + "channelmix.normalize" = true; + }; + "playback.props" = { + "media.class" = "Audio/Source"; + "audio.channels" = 2; + "audio.position" = ["FL" "FR"]; + "channelmix.normalize" = true; + }; + }; + } + ]; + + "context.exec" = [ + { + "path" = "${pkgs.writeShellScript "setup-audio-routing" '' + sleep 1 + ${pkgs.pipewire}/bin/pw-link \ + "alsa_input.usb-Antlion_Audio_Antlion_USB_Microphone-00.pro-input-0:capture_AUX0" \ + "input.combined-audio:playback_FL" + + ${pkgs.pipewire}/bin/pw-link \ + "alsa_input.usb-Antlion_Audio_Antlion_USB_Microphone-00.pro-input-0:capture_AUX0" \ + "input.combined-audio:playback_FR" + + ${pkgs.pipewire}/bin/pw-link \ + "input.combined-audio:monitor_FL" \ + "alsa_output.usb-Focusrite_Scarlett_Solo_USB-00.HiFi__Line1__sink:playback_FL" + + ${pkgs.pipewire}/bin/pw-link \ + "input.combined-audio:monitor_FR" \ + "alsa_output.usb-Focusrite_Scarlett_Solo_USB-00.HiFi__Line1__sink:playback_FR" + ''}"; + } + ]; + }; + }; + }; +} diff --git a/Omni/Dev/Lithium/Configuration.nix b/Omni/Dev/Lithium/Configuration.nix index 82d23d1..a439ec4 100644 --- a/Omni/Dev/Lithium/Configuration.nix +++ b/Omni/Dev/Lithium/Configuration.nix @@ -61,7 +61,6 @@ in { services.bitcoind.mainnet.enable = true; services.bitcoind.mainnet.dataDir = "/mnt/campbell/bitcoind-mainnet/data"; services.bitcoind.mainnet.configFile = "/mnt/campbell/bitcoind-mainnet/bitcoin.conf"; - services.bitcoind.mainnet.prune = 10000; services.pcscd.enable = true; services.logind.lidSwitch = "ignore"; diff --git a/Omni/Fact.hs b/Omni/Fact.hs new file mode 100644 index 0000000..57db7fc --- /dev/null +++ b/Omni/Fact.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Fact module for the Jr knowledge base. +-- +-- Facts are pieces of knowledge learned during task execution that can +-- inform future work on similar tasks or files. +module Omni.Fact + ( Fact (..), + createFact, + getFact, + getAllFacts, + getFactsByProject, + getFactsByFile, + updateFact, + deleteFact, + ) +where + +import Alpha +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.Text as Text +import Data.Time (getCurrentTime) +import qualified Database.SQLite.Simple as SQL +import Omni.Task.Core + ( Fact (..), + getFactsForFile, + getFactsForProject, + loadFacts, + saveFact, + withDb, + ) +import qualified Omni.Task.Core as TaskCore + +-- | Create a new fact and return its ID. +createFact :: Text -> Text -> [Text] -> Maybe Text -> Double -> IO Int +createFact project content relatedFiles sourceTask confidence = do + now <- getCurrentTime + let fact = + Fact + { factId = Nothing, + factProject = project, + factContent = content, + factRelatedFiles = relatedFiles, + factSourceTask = sourceTask, + factConfidence = confidence, + factCreatedAt = now + } + saveFact fact + +-- | Get a fact by its ID. +getFact :: Int -> IO (Maybe Fact) +getFact fid = do + facts <- getAllFacts + pure <| find (\f -> factId f == Just fid) facts + +-- | Get all facts from the database. +getAllFacts :: IO [Fact] +getAllFacts = loadFacts + +-- | Get facts for a specific project. +getFactsByProject :: Text -> IO [Fact] +getFactsByProject = getFactsForProject + +-- | Get facts related to a specific file. +getFactsByFile :: Text -> IO [Fact] +getFactsByFile = getFactsForFile + +-- | Update an existing fact. +updateFact :: Int -> Text -> [Text] -> Double -> IO () +updateFact fid content relatedFiles confidence = + withDb <| \conn -> + SQL.execute + conn + "UPDATE facts SET fact = ?, related_files = ?, confidence = ? WHERE id = ?" + (content, Text.pack (BLC.unpack (encode relatedFiles)), confidence, fid) + +-- | Delete a fact by ID. +deleteFact :: Int -> IO () +deleteFact = TaskCore.deleteFact diff --git a/Omni/Ide/README.md b/Omni/Ide/README.md new file mode 100644 index 0000000..7511090 --- /dev/null +++ b/Omni/Ide/README.md @@ -0,0 +1,143 @@ +# Development Tools and Workflow + +## Tools + +### run.sh + +`run.sh` is a convenience wrapper that builds (if needed) and runs a namespace. + +Examples: +```bash +Omni/Ide/run.sh Omni/Task.hs # Build and run task manager +Omni/Ide/run.sh Biz/PodcastItLater/Web.py # Build and run web server +``` + +This script will: +1. Check if the binary exists in `_/bin/` +2. Build it if it doesn't exist (exits on build failure) +3. Execute the binary with any additional arguments + +### lint + +Universal lint and formatting tool. Errors if lints fail or code is not formatted properly. + +Examples: +```bash +lint Omni/Cli.hs # Lint a namespace +lint --fix **/*.py # Lint and fix all Python files +``` + +### repl.sh + +Like `nix-shell` but specific to this repo. Analyzes the namespace, pulls dependencies, and starts a shell or repl. + +Examples: +```bash +repl.sh Omni/Bild.hs # Start Haskell repl with namespace loaded +repl.sh --bash Omni/Log.py # Start bash shell for namespace +``` + +### typecheck.sh + +Like `lint` but only runs type checkers. Currently just supports Python with `mypy`, but eventually will support everything that `bild` supports. + +Examples: +```bash +typecheck.sh Omni/Bild/Example.py # Run the typechecker and report any errors +``` + +### Test Commands + +Run tests: +```bash +bild --test Omni/Task.hs # Build and test a namespace +``` + +The convention for all programs in the omnirepo is to run their tests if the first argument is `test`. So for example: + +```bash +# this will build a the latest executable and then run tests +bild --test Omni/Task.hs + +# this will just run the tests from the existing executable +_/bin/task test +``` + +## Git Workflow + +### Use git-branchless + +This repository uses **git-branchless** for a patch-based workflow instead of traditional branch-based git. + +Key concepts: +- Work with **patches** (commits) directly rather than branches +- Use **stacking** to organize related changes +- Leverage **smartlog** to visualize commit history + +### Common git-branchless Commands + +**View commit graph:** +```bash +git smartlog +``` + +**Create a new commit:** +```bash +# Make your changes +git add . +git commit -m "Your commit message" +``` + +**Amend the current commit:** +```bash +# Make additional changes +git add . +git amend +``` + +**Move/restack commits:** +```bash +git move -s <source> -d <destination> +git restack +``` + +### When to Record Changes in Git + +**DO record in git:** +- Completed features or bug fixes +- Working code that passes tests and linting +- Significant milestones in task completion + +**DO NOT record in git:** +- Work in progress (unless specifically requested) +- Broken or untested code +- Temporary debugging changes + +**NEVER do these git operations without explicit user request:** +- ❌ `git push` - NEVER push to remote unless explicitly asked +- ❌ `git pull` - NEVER pull from remote unless explicitly asked +- ❌ Force pushes or destructive operations +- ❌ Branch deletion or remote branch operations + +**Why:** The user maintains control over when code is shared with collaborators. Always ask before syncing with remote repositories. + +### Workflow Best Practices + +1. **Make small, focused commits** - Each commit should represent one logical change +2. **Write descriptive commit messages** - Explain what and why, not just what +3. **Rebase and clean up history** - Use `git commit --amend` and `git restack` to keep history clean +4. **Test before committing** - Run `bild --test` and `lint` on affected namespaces + +### Required Checks Before Completing Tasks + +After completing a task, **always** run these commands for the namespace(s) you modified: + +```bash +# Run tests +bild --test Omni/YourNamespace.hs + +# Run linter +lint Omni/YourNamespace.hs +``` + +**Fix all reported errors** related to your changes before marking the task as complete. This ensures code quality and prevents breaking the build for other contributors. diff --git a/Omni/Ide/ailint.sh b/Omni/Ide/ailint.sh new file mode 100755 index 0000000..a107be8 --- /dev/null +++ b/Omni/Ide/ailint.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash +set -xu +target=${1:?} +instructions=$(mktemp) +echo "Fix the following lint errors, or silence them with a `# noqa:` comment if they aren't problematic:" >> "$instructions" +if lint -f "$target" >> "$instructions" 2>&1 +then + echo "no bad lints" +else + aider --yes --message-file "$instructions" "$target" +fi diff --git a/Omni/Ide/hooks/commit-msg b/Omni/Ide/hooks/commit-msg index e07d1f4..c6197f9 100755 --- a/Omni/Ide/hooks/commit-msg +++ b/Omni/Ide/hooks/commit-msg @@ -1,7 +1,11 @@ #!/usr/bin/env bash +temp=$(mktemp) +# strip everything after >8 cut line, then strip comment lines +sed '/.*>8.*/,$d; /^#/d' "$1" | fmt -w 72 -u > "$temp" +mv "$temp" "$1" if ! gitlint --ignore-stdin --staged --msg-filename "$1" run-hook; then backup="$CODEROOT"/.git/COMMIT_EDITMSG.backup - cp "$CODEROOT"/.git/COMMIT_EDITMSG "$backup" + cp "$1" "$backup" echo "error: gitlint failed, saved your commit msg as $backup" exit 1 fi diff --git a/Omni/Ide/hooks/post-checkout b/Omni/Ide/hooks/post-checkout index 85541a2..a360517 100755 --- a/Omni/Ide/hooks/post-checkout +++ b/Omni/Ide/hooks/post-checkout @@ -14,6 +14,7 @@ elif [[ ${#changed[@]} -gt 0 ]] then MakeTags "${changed[@]}" fi + ## START BRANCHLESS CONFIG git branchless hook post-checkout "$@" diff --git a/Omni/Ide/hooks/post-merge b/Omni/Ide/hooks/post-merge index fcfd314..bf0e996 100755 --- a/Omni/Ide/hooks/post-merge +++ b/Omni/Ide/hooks/post-merge @@ -1,5 +1,6 @@ #!/usr/bin/env bash "${CODEROOT:?}"/Omni/Ide/hooks/post-checkout 'HEAD@{1}' HEAD + ## START BRANCHLESS CONFIG git branchless hook post-merge "$@" diff --git a/Omni/Ide/hooks/pre-push b/Omni/Ide/hooks/pre-push index 00110bd..adbf858 100755 --- a/Omni/Ide/hooks/pre-push +++ b/Omni/Ide/hooks/pre-push @@ -1,5 +1,11 @@ #!/usr/bin/env bash set -euo pipefail + +# Task manager: Ensure tasks are exported before push +if [ -d .tasks ]; then + task export --flush 2>/dev/null || true +fi + remote="$1" z40=0000000000000000000000000000000000000000 IFS=" " diff --git a/Omni/Ide/push.sh b/Omni/Ide/push.sh index 5c22e07..ce1df3d 100755 --- a/Omni/Ide/push.sh +++ b/Omni/Ide/push.sh @@ -19,6 +19,7 @@ ssh "$USER"@"$where" sudo nix-env --profile /nix/var/nix/profiles/system --set " switch_cmd=( systemd-run -E LOCALE_ARCHIVE + --setenv=XDG_RUNTIME_DIR="" --collect --no-ask-password --pipe diff --git a/Omni/Ide/repl.sh b/Omni/Ide/repl.sh index 3b6a536..6225078 100755 --- a/Omni/Ide/repl.sh +++ b/Omni/Ide/repl.sh @@ -10,6 +10,7 @@ ### ### Options: ### --bash start bash instead of the target language repl +### --cmd x run 'x' instead of bash, or the target language repl help() { sed -rn 's/^### ?//;T;p' "$0" } @@ -23,9 +24,13 @@ fi if [[ "$1" == "--bash" ]]; then CMD="bash" shift + elif [[ "$1" == "--cmd" ]]; then + shift + CMD="$1" + shift fi targets="${*:?}" - json=$(bild --plan "${targets[@]}") + json=$(bild --plan "${targets[@]}" 2>&1) mapfile -t langdeps < <(jq --raw-output '.[].langdeps | select(length > 0) | join("\n")' <<< "$json") mapfile -t sysdeps < <(jq --raw-output '.[].sysdeps | select(length > 0) | join("\n")' <<< "$json") mapfile -t rundeps < <(jq --raw-output '.[].rundeps | select(length > 0) | join("\n")' <<< "$json") diff --git a/Omni/Ide/run.sh b/Omni/Ide/run.sh index e300fcc..e49d8bd 100755 --- a/Omni/Ide/run.sh +++ b/Omni/Ide/run.sh @@ -2,6 +2,8 @@ set -eu target=$1 shift -out=$(bild --plan "$target" | jq --raw-output ".\"${target}\".out") -[[ -f "$out" ]] || bild "$target" +out=$(bild --plan "$target" 2>&1 | tail -1 | jq --raw-output ".\"${target}\".out") +if [[ ! -f "${CODEROOT:?}/_/bin/$out" ]]; then + bild "$target" || exit 1 +fi exec "${CODEROOT:?}/_/bin/$out" "$@" diff --git a/Omni/Ide/typecheck.sh b/Omni/Ide/typecheck.sh new file mode 100755 index 0000000..fe11ef5 --- /dev/null +++ b/Omni/Ide/typecheck.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash +### +### typecheck a given target +### +### > typecheck.sh <target..> +### +### Uses repl.sh to provision the environment for target, then runs the +### appropriate typechecker for the given module. +### +help() { + sed -rn 's/^### ?//;T;p' "$0" +} +if [[ $# == 0 ]] || [[ "$1" == "-h" ]]; then + help + exit 1 +fi +target="$1" + +# Determine file extension +ext="${target##*.}" + +case "$ext" in + py) + # Python: use mypy via repl.sh environment + repl.sh --cmd "python -m mypy $target" "$target" + ;; + hs) + # Haskell: use ghc -fno-code for typechecking without code generation + # Use repl.sh to provision the right GHC environment with dependencies + repl.sh --cmd "ghc -fno-code -i${CODEROOT:?} $target" "$target" + ;; + *) + echo "Unknown file extension: $ext" + echo "Typechecking not supported for this file type" + exit 1 + ;; +esac diff --git a/Omni/Jr.hs b/Omni/Jr.hs new file mode 100755 index 0000000..0690970 --- /dev/null +++ b/Omni/Jr.hs @@ -0,0 +1,762 @@ +#!/usr/bin/env run.sh +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- : out jr +-- : dep sqlite-simple +-- : dep warp +-- : dep servant-server +-- : dep lucid +-- : dep servant-lucid +module Omni.Jr where + +import Alpha +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Omni.Agent.Core as AgentCore +import qualified Omni.Agent.Worker as AgentWorker +import qualified Omni.Cli as Cli +import qualified Omni.Fact as Fact +import qualified Omni.Jr.Web as Web +import qualified Omni.Task as Task +import qualified Omni.Task.Core as TaskCore +import qualified Omni.Test as Test +import qualified System.Console.Docopt as Docopt +import qualified System.Directory as Directory +import System.Environment (withArgs) +import qualified System.Exit as Exit +import System.FilePath (takeFileName) +import qualified System.IO as IO +import qualified System.Process as Process + +main :: IO () +main = Cli.main plan + +plan :: Cli.Plan () +plan = + Cli.Plan + { Cli.help = help, + Cli.move = move, + Cli.test = test, + Cli.tidy = \_ -> pure () + } + +help :: Cli.Docopt +help = + [Cli.docopt| +jr + +Usage: + jr task [<args>...] + jr work [<task-id>] + jr web [--port=PORT] + jr review [<task-id>] [--auto] + jr loop [--delay=SECONDS] + jr facts list [--project=PROJECT] [--json] + jr facts show <fact-id> [--json] + jr facts add <project> <content> [--files=FILES] [--task=TASK] [--confidence=CONF] [--json] + jr facts delete <fact-id> [--json] + jr test + jr (-h | --help) + +Commands: + task Manage tasks + work Start a worker agent on a task + web Start the web UI server + review Review a completed task (show diff, accept/reject) + loop Run autonomous work+review loop + facts Manage knowledge base facts + +Options: + -h --help Show this help + --port=PORT Port for web server [default: 8080] + --auto Auto-review: accept if tests pass, reject if they fail + --delay=SECONDS Delay between loop iterations [default: 5] + --project=PROJECT Filter facts by project + --files=FILES Comma-separated list of related files + --task=TASK Source task ID + --confidence=CONF Confidence level 0.0-1.0 [default: 0.8] + --json Output in JSON format +|] + +move :: Cli.Arguments -> IO () +move args + | args `Cli.has` Cli.command "task" = do + let extraArgs = Cli.getAllArgs args (Cli.argument "args") + withArgs extraArgs Task.main + | args `Cli.has` Cli.command "web" = do + let port = case Cli.getArg args (Cli.longOption "port") of + Just p -> fromMaybe Web.defaultPort (readMaybe p) + Nothing -> Web.defaultPort + Web.run port + | args `Cli.has` Cli.command "work" = do + -- Always run in current directory + let path = "." + + -- Infer name from current directory + absPath <- Directory.getCurrentDirectory + let name = Text.pack (takeFileName absPath) + + let worker = + AgentCore.Worker + { AgentCore.workerName = name, + AgentCore.workerPid = Nothing, + AgentCore.workerStatus = AgentCore.Idle, + AgentCore.workerPath = path, + AgentCore.workerQuiet = False -- Show ANSI status bar for manual work + } + + let taskId = fmap Text.pack (Cli.getArg args (Cli.argument "task-id")) + + AgentWorker.start worker taskId + | args `Cli.has` Cli.command "review" = do + let autoMode = args `Cli.has` Cli.longOption "auto" + case Cli.getArg args (Cli.argument "task-id") of + Just tidStr -> reviewTask (Text.pack tidStr) autoMode + Nothing -> do + -- Find tasks in Review status + tasks <- TaskCore.loadTasks + let reviewTasks = filter (\t -> TaskCore.taskStatus t == TaskCore.Review) tasks + case reviewTasks of + [] -> putText "No tasks in Review status." + (t : _) -> reviewTask (TaskCore.taskId t) autoMode + | args `Cli.has` Cli.command "loop" = do + let delay = case Cli.getArg args (Cli.longOption "delay") of + Just d -> fromMaybe 5 (readMaybe d) + Nothing -> 5 + runLoop delay + | args `Cli.has` Cli.command "facts" = handleFacts args + | otherwise = putText (str <| Docopt.usage help) + +-- | Run the autonomous loop: work -> review -> repeat +runLoop :: Int -> IO () +runLoop delaySec = do + putText "[loop] Starting autonomous jr loop..." + putText ("[loop] Delay between iterations: " <> tshow delaySec <> "s") + go + where + go = do + -- First check for tasks to review (prioritize finishing work) + reviewResult <- reviewPending + if reviewResult + then do + -- Reviewed something, continue loop immediately + threadDelay (delaySec * 1000000) + go + else do + -- No reviews, check for ready work + readyTasks <- TaskCore.getReadyTasks + case readyTasks of + [] -> do + putText "[loop] No ready tasks, no pending reviews." + (task : _) -> do + putText "" + putText ("[loop] === Working on: " <> TaskCore.taskId task <> " ===") + -- Run worker (this blocks until the engine completes) + absPath <- Directory.getCurrentDirectory + let name = Text.pack (takeFileName absPath) + let worker = + AgentCore.Worker + { AgentCore.workerName = name, + AgentCore.workerPid = Nothing, + AgentCore.workerStatus = AgentCore.Idle, + AgentCore.workerPath = ".", + AgentCore.workerQuiet = True -- No ANSI status bar in loop mode + } + putText "[loop] Starting worker..." + AgentWorker.start worker (Just (TaskCore.taskId task)) + putText "[loop] Worker finished." + + -- Delay and loop + putText ("[loop] Sleeping " <> tshow delaySec <> "s...") + threadDelay (delaySec * 1000000) + go + + -- Returns True if a task was reviewed, False otherwise + reviewPending :: IO Bool + reviewPending = do + tasks <- TaskCore.loadTasks + let reviewTasks = filter (\t -> TaskCore.taskStatus t == TaskCore.Review) tasks + case reviewTasks of + [] -> pure False + (t : _) -> do + putText "" + putText ("[loop] === Reviewing: " <> TaskCore.taskId t <> " ===") + tryAutoReview (TaskCore.taskId t) + pure True + + -- Auto-review that doesn't exit on missing commit + tryAutoReview :: Text -> IO () + tryAutoReview tid = do + tasks <- TaskCore.loadTasks + case TaskCore.findTask tid tasks of + Nothing -> do + putText ("[review] Task " <> tid <> " not found.") + Just task -> 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 do + putText "[review] No commit found for this task." + putText "[review] Resetting to Open for retry." + TaskCore.updateTaskStatus tid TaskCore.Open [] + else do + let commitSha = case List.lines shaOut of + (x : _) -> x + [] -> "" + + -- Check for merge conflicts + conflictResult <- checkMergeConflict commitSha + case conflictResult of + Just conflictFiles -> do + putText "[review] MERGE CONFLICT DETECTED" + traverse_ (\f -> putText (" - " <> f)) conflictFiles + handleConflict tid conflictFiles commitSha + Nothing -> do + autoReview tid task commitSha + +-- | Handle merge conflict during review (Gerrit-style: provide rich context) +handleConflict :: Text -> [Text] -> String -> IO () +handleConflict tid conflictFiles commitSha = do + maybeCtx <- TaskCore.getRetryContext tid + let attempt = maybe 1 (\c -> TaskCore.retryAttempt c + 1) maybeCtx + + let conflictComment = buildConflictComment commitSha conflictFiles attempt + _ <- TaskCore.addComment tid conflictComment + + if attempt > 3 + then do + putText "[review] Task has failed 3 times. Needs human intervention." + TaskCore.updateTaskStatus tid TaskCore.Open [] + else do + conflictDetails <- gatherConflictContext commitSha conflictFiles + maybeExistingCtx <- TaskCore.getRetryContext tid + let currentReason = "attempt " <> tshow attempt <> ":\n" <> conflictDetails + let accumulatedReason = case maybeExistingCtx of + Nothing -> currentReason + Just ctx -> TaskCore.retryReason ctx <> "\n\n" <> currentReason + TaskCore.setRetryContext + TaskCore.RetryContext + { TaskCore.retryTaskId = tid, + TaskCore.retryOriginalCommit = Text.pack commitSha, + TaskCore.retryConflictFiles = conflictFiles, + TaskCore.retryAttempt = attempt, + TaskCore.retryReason = accumulatedReason, + TaskCore.retryNotes = maybeExistingCtx +> TaskCore.retryNotes + } + TaskCore.updateTaskStatus tid TaskCore.Open [] + putText ("[review] Task " <> tid <> " returned to queue (attempt " <> tshow attempt <> "/3).") + +-- | Build a review comment for merge conflicts +buildConflictComment :: String -> [Text] -> Int -> Text +buildConflictComment commitSha conflictFiles attempt = + Text.unlines + [ "## Auto-Review: Merge Conflict", + "", + "**Commit:** " <> Text.pack (take 8 commitSha), + "**Result:** ✗ MERGE CONFLICT", + "**Attempt:** " <> tshow attempt <> "/3", + "", + "### Conflicting Files", + Text.unlines (map ("- " <>) conflictFiles), + "Task returned to queue for conflict resolution." + ] + +-- | Gather Gerrit-style conflict context for the coder +gatherConflictContext :: String -> [Text] -> IO Text +gatherConflictContext commitSha conflictFiles = do + commitInfo <- getCommitInfo commitSha + currentHeadInfo <- getCurrentHeadInfo + fileDiffs <- traverse (getFileConflictInfo commitSha <. Text.unpack) conflictFiles + + pure + <| Text.unlines + [ "MERGE CONFLICT - Your changes could not be cleanly applied", + "", + "== Your Commit ==", + commitInfo, + "", + "== Current HEAD ==", + currentHeadInfo, + "", + "== Conflicting Files ==", + Text.unlines fileDiffs, + "", + "== Resolution Instructions ==", + "1. The codebase has been updated since your work", + "2. Review the current state of conflicting files", + "3. Re-implement your changes on top of the current code", + "4. Ensure your changes still make sense given the updates" + ] + +-- | Get info about the commit that caused the conflict +getCommitInfo :: String -> IO Text +getCommitInfo sha = do + (_, out, _) <- + Process.readProcessWithExitCode + "git" + ["log", "-1", "--format=%h %s%n%b", sha] + "" + pure <| Text.pack out + +-- | Get info about current HEAD +getCurrentHeadInfo :: IO Text +getCurrentHeadInfo = do + (_, out, _) <- + Process.readProcessWithExitCode + "git" + ["log", "-1", "--format=%h %s (%cr)"] + "" + pure <| Text.pack out + +-- | Get file-level conflict context showing what changed in both branches +getFileConflictInfo :: String -> FilePath -> IO Text +getFileConflictInfo commitSha filePath = do + yourChanges <- getYourChangesToFile commitSha filePath + recentChanges <- getRecentChangesToFile filePath + pure + <| Text.unlines + [ "--- " <> Text.pack filePath <> " ---", + "", + "Your changes to this file:", + yourChanges, + "", + "Recent changes by others:", + recentChanges + ] + +-- | Get a summary of changes in a specific commit to a file +getYourChangesToFile :: String -> FilePath -> IO Text +getYourChangesToFile commitSha filePath = do + (code, out, _) <- + Process.readProcessWithExitCode + "git" + ["show", "--stat", commitSha, "--", filePath] + "" + case code of + Exit.ExitSuccess -> pure <| Text.pack (take 500 out) + Exit.ExitFailure _ -> pure "(unable to get diff)" + +-- | Get recent changes to a file (last few commits) +getRecentChangesToFile :: FilePath -> IO Text +getRecentChangesToFile filePath = do + (code, out, _) <- + Process.readProcessWithExitCode + "git" + ["log", "-3", "--oneline", "--", filePath] + "" + case code of + Exit.ExitSuccess -> pure <| Text.pack out + Exit.ExitFailure _ -> pure "(unable to get history)" + +-- | Interactive review command (jr review <task-id>) +reviewTask :: Text -> Bool -> IO () +reviewTask tid autoMode = do + tasks <- TaskCore.loadTasks + case TaskCore.findTask tid tasks of + Nothing -> do + putText ("Task " <> tid <> " not found.") + Exit.exitFailure + Just task -> do + unless autoMode <| TaskCore.showTaskDetailed task + + let grepArg = "--grep=" <> Text.unpack tid + (code, shaOut, _) <- + Process.readProcessWithExitCode + "git" + ["log", "--pretty=format:%H", "-n", "1", grepArg] + "" + + when (code /= Exit.ExitSuccess || null shaOut) <| do + putText "\nNo commit found for this task." + putText "The worker may not have completed yet, or the commit message doesn't include the task ID." + Exit.exitFailure + + let commitSha = case List.lines shaOut of + (x : _) -> x + [] -> "" + + -- Check for merge conflicts before showing diff + conflictResult <- checkMergeConflict commitSha + case conflictResult of + Just conflictFiles -> do + putText "\n=== MERGE CONFLICT DETECTED ===" + traverse_ (\f -> putText (" - " <> f)) conflictFiles + handleConflict tid conflictFiles commitSha + Nothing -> do + if autoMode + then autoReview tid task commitSha + else interactiveReview tid task commitSha + +-- | Auto-review: run tests on namespace, accept if pass, reject if fail +autoReview :: Text -> TaskCore.Task -> String -> IO () +autoReview tid task commitSha = do + putText "[review] Running automated review..." + putText ("[review] Commit: " <> Text.pack (take 8 commitSha)) + + let namespace = fromMaybe "." (TaskCore.taskNamespace task) + let testTarget = Text.unpack namespace + + putText ("[review] Testing: " <> Text.pack testTarget) + + (testCode, testOut, testErr) <- + Process.readProcessWithExitCode + "bild" + ["--test", testTarget] + "" + + case testCode of + Exit.ExitSuccess -> do + putText "[review] ✓ Tests passed." + let reviewComment = buildReviewComment commitSha testTarget True testOut testErr + _ <- TaskCore.addComment tid reviewComment + TaskCore.clearRetryContext tid + TaskCore.updateTaskStatus tid TaskCore.Done [] + putText ("[review] Task " <> tid <> " -> Done") + checkEpicCompletion task + Exit.ExitFailure code -> do + putText ("[review] ✗ Tests failed (exit " <> tshow code <> ")") + let reason = "Test failure:\n" <> Text.pack testOut <> Text.pack testErr + + maybeCtx <- TaskCore.getRetryContext tid + let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx + + let reviewComment = buildReviewComment commitSha testTarget False testOut testErr + _ <- TaskCore.addComment tid reviewComment + + if attempt > 3 + then do + putText "[review] Task has failed 3 times. Needs human intervention." + TaskCore.updateTaskStatus tid TaskCore.Open [] + else do + let currentReason = "attempt " <> tshow attempt <> ": " <> reason + let accumulatedReason = case maybeCtx of + Nothing -> currentReason + Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason + TaskCore.setRetryContext + TaskCore.RetryContext + { TaskCore.retryTaskId = tid, + TaskCore.retryOriginalCommit = Text.pack commitSha, + TaskCore.retryConflictFiles = [], + TaskCore.retryAttempt = attempt, + TaskCore.retryReason = accumulatedReason, + TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes + } + TaskCore.updateTaskStatus tid TaskCore.Open [] + putText ("[review] Task " <> tid <> " reopened (attempt " <> tshow attempt <> "/3).") + +-- | Build a review comment summarizing what was tested and the result +buildReviewComment :: String -> String -> Bool -> String -> String -> Text +buildReviewComment commitSha testTarget passed testOut testErr = + Text.unlines + [ "## Auto-Review", + "", + "**Commit:** " <> Text.pack (take 8 commitSha), + "**Test target:** " <> Text.pack testTarget, + "**Result:** " <> if passed then "✓ PASSED" else "✗ FAILED", + "", + if passed + then "All tests passed. Task accepted." + else + Text.unlines + [ "### Test Output", + "```", + Text.pack (truncateOutput 1000 (testOut ++ testErr)), + "```", + "", + "Task rejected and returned to queue for retry." + ] + ] + +-- | Truncate output to a maximum number of characters +truncateOutput :: Int -> String -> String +truncateOutput maxLen s + | length s <= maxLen = s + | otherwise = take maxLen s ++ "\n... (truncated)" + +-- | Interactive review with user prompts +interactiveReview :: Text -> TaskCore.Task -> String -> IO () +interactiveReview tid task commitSha = do + putText "\n=== Diff for this task ===\n" + _ <- Process.rawSystem "git" ["show", commitSha] + + putText "\n[a]ccept / [r]eject / [s]kip? " + IO.hFlush IO.stdout + choice <- getLine + + case Text.toLower choice of + c + | "a" `Text.isPrefixOf` c -> do + let acceptComment = buildHumanReviewComment commitSha True Nothing + _ <- TaskCore.addComment tid acceptComment + TaskCore.clearRetryContext tid + TaskCore.updateTaskStatus tid TaskCore.Done [] + putText ("Task " <> tid <> " marked as Done.") + checkEpicCompletion task + | "r" `Text.isPrefixOf` c -> do + putText "Enter rejection reason: " + IO.hFlush IO.stdout + reason <- getLine + let rejectComment = buildHumanReviewComment commitSha False (Just reason) + _ <- TaskCore.addComment tid rejectComment + maybeCtx <- TaskCore.getRetryContext tid + let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx + let currentReason = "attempt " <> tshow attempt <> ": rejected: " <> reason + let accumulatedReason = case maybeCtx of + Nothing -> currentReason + Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason + TaskCore.setRetryContext + TaskCore.RetryContext + { TaskCore.retryTaskId = tid, + TaskCore.retryOriginalCommit = Text.pack commitSha, + TaskCore.retryConflictFiles = [], + TaskCore.retryAttempt = attempt, + TaskCore.retryReason = accumulatedReason, + TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes + } + TaskCore.updateTaskStatus tid TaskCore.Open [] + putText ("Task " <> tid <> " reopened (attempt " <> tshow attempt <> "/3).") + | otherwise -> putText "Skipped; no status change." + +-- | Build a human review comment +buildHumanReviewComment :: String -> Bool -> Maybe Text -> Text +buildHumanReviewComment commitSha accepted maybeReason = + Text.unlines + [ "## Human Review", + "", + "**Commit:** " <> Text.pack (take 8 commitSha), + "**Result:** " <> if accepted then "✓ ACCEPTED" else "✗ REJECTED", + case maybeReason of + Just reason -> "**Reason:** " <> reason + Nothing -> "" + ] + +-- | Check if a commit can be cleanly cherry-picked onto live +-- Returns Nothing if clean, Just [conflicting files] if conflict +checkMergeConflict :: String -> IO (Maybe [Text]) +checkMergeConflict commitSha = do + -- Save current state + (_, _, _) <- Process.readProcessWithExitCode "git" ["branch", "--show-current"] "" + (_, origHead, _) <- Process.readProcessWithExitCode "git" ["rev-parse", "HEAD"] "" + + -- Try cherry-pick + (cpCode, _, cpErr) <- + Process.readProcessWithExitCode + "git" + ["cherry-pick", "--no-commit", commitSha] + "" + + -- Always abort/reset regardless of result + _ <- 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 + -- Parse conflict files from error message + let errLines = Text.lines (Text.pack cpErr) + conflictLines = filter (Text.isPrefixOf "CONFLICT") errLines + -- Extract file names (rough parsing) + files = mapMaybe extractConflictFile conflictLines + pure (Just (if null files then ["(unknown files)"] else files)) + +extractConflictFile :: Text -> Maybe Text +extractConflictFile line = + -- CONFLICT (content): Merge conflict in path/to/file.hs + 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 + +-- | Check if all children of an epic are Done, and if so, transition epic to Review +checkEpicCompletion :: TaskCore.Task -> IO () +checkEpicCompletion task = + case TaskCore.taskParent task of + Nothing -> pure () + Just parentId -> do + tasks <- TaskCore.loadTasks + case TaskCore.findTask parentId tasks of + Nothing -> pure () + Just parentTask -> + when (TaskCore.taskType parentTask == TaskCore.Epic) <| do + let children = filter (hasParent parentId) tasks + allDone = all (\t -> TaskCore.taskStatus t == TaskCore.Done) children + when (allDone && not (null children)) <| do + putText ("[review] All children of epic " <> parentId <> " are Done.") + TaskCore.updateTaskStatus parentId TaskCore.Review [] + putText ("[review] Epic " <> parentId <> " -> Review") + where + hasParent pid t = maybe False (TaskCore.matchesId pid) (TaskCore.taskParent t) + +-- | Handle facts subcommands +handleFacts :: Cli.Arguments -> IO () +handleFacts args + | args `Cli.has` Cli.command "list" = do + let maybeProject = Text.pack </ Cli.getArg args (Cli.longOption "project") + jsonMode = args `Cli.has` Cli.longOption "json" + facts <- maybe Fact.getAllFacts Fact.getFactsByProject maybeProject + if jsonMode + then BLC.putStrLn (Aeson.encode facts) + else traverse_ printFact facts + | args `Cli.has` Cli.command "show" = do + let jsonMode = args `Cli.has` Cli.longOption "json" + case Cli.getArg args (Cli.argument "fact-id") of + Nothing -> putText "fact-id required" + Just fidStr -> case readMaybe fidStr of + Nothing -> putText "Invalid fact ID (must be integer)" + Just fid -> do + maybeFact <- Fact.getFact fid + case maybeFact of + Nothing -> putText "Fact not found" + Just fact -> + if jsonMode + then BLC.putStrLn (Aeson.encode fact) + else printFactDetailed fact + | args `Cli.has` Cli.command "add" = do + let jsonMode = args `Cli.has` Cli.longOption "json" + case (Cli.getArg args (Cli.argument "project"), Cli.getArg args (Cli.argument "content")) of + (Just proj, Just content) -> do + let files = case Cli.getArg args (Cli.longOption "files") of + Just f -> Text.splitOn "," (Text.pack f) + Nothing -> [] + sourceTask = Text.pack </ Cli.getArg args (Cli.longOption "task") + confidence = case Cli.getArg args (Cli.longOption "confidence") of + Just c -> fromMaybe 0.8 (readMaybe c) + Nothing -> 0.8 + factId <- Fact.createFact (Text.pack proj) (Text.pack content) files sourceTask confidence + if jsonMode + then BLC.putStrLn (Aeson.encode (Aeson.object ["id" Aeson..= factId, "success" Aeson..= True])) + else putText ("Created fact: " <> tshow factId) + _ -> putText "project and content required" + | args `Cli.has` Cli.command "delete" = do + let jsonMode = args `Cli.has` Cli.longOption "json" + case Cli.getArg args (Cli.argument "fact-id") of + Nothing -> putText "fact-id required" + Just fidStr -> case readMaybe fidStr of + Nothing -> putText "Invalid fact ID (must be integer)" + Just fid -> do + Fact.deleteFact fid + if jsonMode + then BLC.putStrLn (Aeson.encode (Aeson.object ["success" Aeson..= True, "message" Aeson..= ("Deleted fact " <> tshow fid)])) + else putText ("Deleted fact: " <> tshow fid) + | otherwise = putText "Unknown facts subcommand. Use: list, show, add, or delete" + +-- | Print a fact in a compact format +printFact :: TaskCore.Fact -> IO () +printFact fact = do + let fid = maybe "?" tshow (TaskCore.factId fact) + proj = TaskCore.factProject fact + content = Text.take 60 (TaskCore.factContent fact) + suffix = if Text.length (TaskCore.factContent fact) > 60 then "..." else "" + putText (fid <> "\t" <> proj <> "\t" <> content <> suffix) + +-- | Print a fact in detailed format +printFactDetailed :: TaskCore.Fact -> IO () +printFactDetailed fact = do + putText ("ID: " <> maybe "?" tshow (TaskCore.factId fact)) + putText ("Project: " <> TaskCore.factProject fact) + putText ("Content: " <> TaskCore.factContent fact) + putText ("Files: " <> Text.intercalate ", " (TaskCore.factRelatedFiles fact)) + putText ("Source: " <> fromMaybe "-" (TaskCore.factSourceTask fact)) + putText ("Confidence: " <> tshow (TaskCore.factConfidence fact)) + putText ("Created: " <> tshow (TaskCore.factCreatedAt fact)) + +test :: Test.Tree +test = + Test.group + "Omni.Jr" + [ Test.unit "can run tests" <| True Test.@?= True, + Test.unit "can parse task command" <| do + let result = Docopt.parseArgs help ["task"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'task': " <> show err + Right args -> args `Cli.has` Cli.command "task" Test.@?= True, + Test.unit "can parse task command with args" <| do + let result = Docopt.parseArgs help ["task", "list", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'task list --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "task" Test.@?= True + Cli.getAllArgs args (Cli.argument "args") Test.@?= ["list", "--json"], + Test.unit "can parse work command" <| do + let result = Docopt.parseArgs help ["work"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'work': " <> show err + Right args -> args `Cli.has` Cli.command "work" Test.@?= True, + Test.unit "can parse work command with task id" <| do + let result = Docopt.parseArgs help ["work", "t-123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'work t-123': " <> show err + Right args -> do + args `Cli.has` Cli.command "work" Test.@?= True + Cli.getArg args (Cli.argument "task-id") Test.@?= Just "t-123", + Test.unit "can parse facts list command" <| do + let result = Docopt.parseArgs help ["facts", "list"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'facts list': " <> show err + Right args -> do + args `Cli.has` Cli.command "facts" Test.@?= True + args `Cli.has` Cli.command "list" Test.@?= True, + Test.unit "can parse facts list with --project" <| do + let result = Docopt.parseArgs help ["facts", "list", "--project=myproj"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'facts list --project': " <> show err + Right args -> do + args `Cli.has` Cli.command "facts" Test.@?= True + args `Cli.has` Cli.command "list" Test.@?= True + Cli.getArg args (Cli.longOption "project") Test.@?= Just "myproj", + Test.unit "can parse facts list with --json" <| do + let result = Docopt.parseArgs help ["facts", "list", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'facts list --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "facts" Test.@?= True + args `Cli.has` Cli.command "list" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "can parse facts show command" <| do + let result = Docopt.parseArgs help ["facts", "show", "42"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'facts show 42': " <> show err + Right args -> do + args `Cli.has` Cli.command "facts" Test.@?= True + args `Cli.has` Cli.command "show" Test.@?= True + Cli.getArg args (Cli.argument "fact-id") Test.@?= Just "42", + Test.unit "can parse facts add command" <| do + let result = Docopt.parseArgs help ["facts", "add", "myproj", "This is a fact"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'facts add': " <> show err + Right args -> do + args `Cli.has` Cli.command "facts" Test.@?= True + args `Cli.has` Cli.command "add" Test.@?= True + Cli.getArg args (Cli.argument "project") Test.@?= Just "myproj" + Cli.getArg args (Cli.argument "content") Test.@?= Just "This is a fact", + Test.unit "can parse facts add with options" <| do + let result = Docopt.parseArgs help ["facts", "add", "myproj", "fact", "--files=a.hs,b.hs", "--task=t-123", "--confidence=0.9"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'facts add' with options: " <> show err + Right args -> do + args `Cli.has` Cli.command "facts" Test.@?= True + args `Cli.has` Cli.command "add" Test.@?= True + Cli.getArg args (Cli.longOption "files") Test.@?= Just "a.hs,b.hs" + Cli.getArg args (Cli.longOption "task") Test.@?= Just "t-123" + Cli.getArg args (Cli.longOption "confidence") Test.@?= Just "0.9", + Test.unit "can parse facts delete command" <| do + let result = Docopt.parseArgs help ["facts", "delete", "42"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'facts delete 42': " <> show err + Right args -> do + args `Cli.has` Cli.command "facts" Test.@?= True + args `Cli.has` Cli.command "delete" Test.@?= True + Cli.getArg args (Cli.argument "fact-id") Test.@?= Just "42" + ] 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 diff --git a/Omni/Jr/Web/Style.hs b/Omni/Jr/Web/Style.hs new file mode 100644 index 0000000..8c423bb --- /dev/null +++ b/Omni/Jr/Web/Style.hs @@ -0,0 +1,1733 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- : dep clay +module Omni.Jr.Web.Style + ( css, + statusBadgeClass, + priorityBadgeClass, + ) +where + +import Alpha hiding (wrap, (**), (|>)) +import Clay +import qualified Clay.Flexbox as Flexbox +import qualified Clay.Media as Media +import qualified Clay.Stylesheet as Stylesheet +import qualified Data.Text.Lazy as LazyText + +css :: LazyText.Text +css = render stylesheet + +stylesheet :: Css +stylesheet = do + baseStyles + layoutStyles + navigationStyles + breadcrumbStyles + cardStyles + listGroupStyles + statusBadges + buttonStyles + formStyles + executionDetailsStyles + activityTimelineStyles + commitStyles + markdownStyles + retryBannerStyles + commentStyles + taskMetaStyles + timeFilterStyles + sortDropdownStyles + responsiveStyles + darkModeStyles + +baseStyles :: Css +baseStyles = do + star ? boxSizing borderBox + html <> body ? do + margin (px 0) (px 0) (px 0) (px 0) + padding (px 0) (px 0) (px 0) (px 0) + body ? do + fontFamily + [ "-apple-system", + "BlinkMacSystemFont", + "Segoe UI", + "Roboto", + "Helvetica Neue", + "Arial", + "Noto Sans", + "sans-serif" + ] + [sansSerif] + fontSize (px 14) + lineHeight (em 1.3) + color "#1f2937" + backgroundColor "#f5f5f5" + minHeight (vh 100) + "h1" ? do + fontSize (px 20) + fontWeight bold + margin (px 0) (px 0) (em 0.3) (px 0) + "h2" ? do + fontSize (px 16) + fontWeight (weight 600) + color "#374151" + margin (em 1) (px 0) (em 0.5) (px 0) + "h3" ? do + fontSize (px 14) + fontWeight (weight 600) + color "#374151" + margin (em 0.75) (px 0) (em 0.25) (px 0) + a ? do + color "#0066cc" + textDecoration none + a # hover ? textDecoration underline + code ? do + fontFamily ["SF Mono", "Monaco", "Consolas", "monospace"] [monospace] + fontSize (em 0.9) + backgroundColor "#f3f4f6" + padding (px 1) (px 4) (px 1) (px 4) + borderRadius (px 2) (px 2) (px 2) (px 2) + pre ? do + fontFamily ["SF Mono", "Monaco", "Consolas", "monospace"] [monospace] + fontSize (px 12) + backgroundColor "#1e1e1e" + color "#d4d4d4" + padding (px 8) (px 8) (px 8) (px 8) + borderRadius (px 2) (px 2) (px 2) (px 2) + overflow auto + whiteSpace preWrap + maxHeight (px 500) + +layoutStyles :: Css +layoutStyles = do + ".container" ? do + width (pct 100) + maxWidth (px 960) + margin (px 0) auto (px 0) auto + padding (px 8) (px 12) (px 8) (px 12) + main_ ? do + Stylesheet.key "flex" ("1 0 auto" :: Text) + ".page-content" ? do + padding (px 0) (px 0) (px 0) (px 0) + ".stats-grid" ? do + display grid + Stylesheet.key "grid-template-columns" ("repeat(auto-fit, minmax(80px, 1fr))" :: Text) + Stylesheet.key "gap" ("6px" :: Text) + ".task-list" ? do + display flex + flexDirection column + Stylesheet.key "gap" ("2px" :: Text) + ".detail-row" ? do + display flex + flexWrap Flexbox.wrap + padding (px 6) (px 0) (px 6) (px 0) + marginBottom (px 4) + ".detail-label" ? do + fontWeight (weight 600) + width (px 100) + color "#6b7280" + minWidth (px 80) + fontSize (px 13) + ".detail-value" ? do + Stylesheet.key "flex" ("1" :: Text) + minWidth (px 0) + ".detail-section" ? do + marginTop (em 0.75) + paddingTop (em 0.75) + borderTop (px 1) solid "#e5e7eb" + ".dep-list" <> ".child-list" ? do + margin (px 4) (px 0) (px 4) (px 0) + paddingLeft (px 16) + (".dep-list" ** li) <> (".child-list" ** li) ? margin (px 2) (px 0) (px 2) (px 0) + ".dep-type" <> ".child-status" ? do + color "#6b7280" + fontSize (px 12) + ".child-title" ? color "#374151" + ".priority-desc" ? do + color "#6b7280" + marginLeft (px 4) + +navigationStyles :: Css +navigationStyles = do + ".navbar" ? do + backgroundColor white + padding (px 6) (px 12) (px 6) (px 12) + borderBottom (px 1) solid "#d0d0d0" + marginBottom (px 8) + display flex + alignItems center + justifyContent spaceBetween + flexWrap Flexbox.wrap + Stylesheet.key "gap" ("8px" :: Text) + ".navbar-brand" ? do + fontSize (px 18) + fontWeight bold + color "#0066cc" + textDecoration none + ".navbar-brand" # hover ? textDecoration none + ".navbar-toggle-checkbox" ? display none + ".navbar-hamburger" ? do + display none + flexDirection column + justifyContent center + alignItems center + width (px 32) + height (px 32) + cursor pointer + Stylesheet.key "gap" ("4px" :: Text) + ".hamburger-line" ? do + display block + width (px 20) + height (px 2) + backgroundColor "#374151" + borderRadius (px 1) (px 1) (px 1) (px 1) + transition "all" (ms 200) ease (sec 0) + ".navbar-links" ? do + display flex + Stylesheet.key "gap" ("2px" :: Text) + flexWrap Flexbox.wrap + alignItems center + ".navbar-link" ? do + display inlineBlock + padding (px 4) (px 10) (px 4) (px 10) + color "#374151" + textDecoration none + borderRadius (px 2) (px 2) (px 2) (px 2) + fontSize (px 13) + fontWeight (weight 500) + transition "background-color" (ms 150) ease (sec 0) + ".navbar-link" # hover ? do + backgroundColor "#f3f4f6" + textDecoration none + ".navbar-dropdown" ? do + position relative + display inlineBlock + ".navbar-dropdown-btn" ? do + display inlineBlock + padding (px 4) (px 10) (px 4) (px 10) + color "#374151" + backgroundColor transparent + border (px 0) none transparent + borderRadius (px 2) (px 2) (px 2) (px 2) + fontSize (px 13) + fontWeight (weight 500) + cursor pointer + transition "background-color" (ms 150) ease (sec 0) + ".navbar-dropdown-btn" # hover ? backgroundColor "#f3f4f6" + ".navbar-dropdown-content" ? do + display none + position absolute + left (px 0) + top (pct 100) + backgroundColor white + minWidth (px 120) + Stylesheet.key "box-shadow" ("0 2px 8px rgba(0,0,0,0.15)" :: Text) + borderRadius (px 2) (px 2) (px 2) (px 2) + zIndex 100 + Stylesheet.key "overflow" ("hidden" :: Text) + ".navbar-dropdown" # hover |> ".navbar-dropdown-content" ? display block + ".navbar-dropdown.open" |> ".navbar-dropdown-content" ? display block + ".navbar-dropdown-item" ? do + display block + padding (px 8) (px 12) (px 8) (px 12) + color "#374151" + textDecoration none + fontSize (px 13) + transition "background-color" (ms 150) ease (sec 0) + ".navbar-dropdown-item" # hover ? do + backgroundColor "#f3f4f6" + textDecoration none + header ? do + backgroundColor white + padding (px 6) (px 12) (px 6) (px 12) + borderBottom (px 1) solid "#d0d0d0" + marginBottom (px 8) + ".nav-content" ? do + maxWidth (px 960) + margin (px 0) auto (px 0) auto + display flex + alignItems center + justifyContent spaceBetween + flexWrap Flexbox.wrap + Stylesheet.key "gap" ("8px" :: Text) + ".nav-brand" ? do + fontSize (px 16) + fontWeight bold + color "#1f2937" + textDecoration none + ".nav-brand" # hover ? textDecoration none + ".nav-links" ? do + display flex + Stylesheet.key "gap" ("4px" :: Text) + flexWrap Flexbox.wrap + ".actions" ? do + display flex + flexDirection row + flexWrap Flexbox.wrap + Stylesheet.key "gap" ("6px" :: Text) + marginBottom (px 8) + +breadcrumbStyles :: Css +breadcrumbStyles = do + ".breadcrumb-container" ? do + backgroundColor transparent + padding (px 6) (px 0) (px 6) (px 0) + ".breadcrumb-list" ? do + display flex + alignItems center + flexWrap Flexbox.wrap + Stylesheet.key "gap" ("4px" :: Text) + margin (px 0) (px 0) (px 0) (px 0) + padding (px 0) (px 0) (px 0) (px 0) + listStyleType none + fontSize (px 12) + ".breadcrumb-item" ? do + display flex + alignItems center + Stylesheet.key "gap" ("4px" :: Text) + ".breadcrumb-sep" ? do + color "#9ca3af" + Stylesheet.key "user-select" ("none" :: Text) + ".breadcrumb-current" ? do + color "#6b7280" + fontWeight (weight 500) + (".breadcrumb-list" ** a) ? do + color "#0066cc" + textDecoration none + (".breadcrumb-list" ** a) # hover ? textDecoration underline + +cardStyles :: Css +cardStyles = do + ".card" + <> ".task-card" + <> ".stat-card" + <> ".task-detail" + <> ".task-summary" + <> ".filter-form" + <> ".status-form" + <> ".diff-section" + <> ".review-actions" + ? do + backgroundColor white + borderRadius (px 2) (px 2) (px 2) (px 2) + padding (px 8) (px 10) (px 8) (px 10) + border (px 1) solid "#d0d0d0" + ".review-actions" ? do + display flex + flexDirection row + flexWrap Flexbox.wrap + alignItems center + Stylesheet.key "gap" ("8px" :: Text) + ".stat-card" ? textAlign center + ".stat-count" ? do + fontSize (px 22) + fontWeight bold + ".stat-label" ? do + fontSize (px 11) + color "#6b7280" + marginTop (px 2) + ".stat-card.badge-open" ? do + borderLeft (px 4) solid "#f59e0b" + (".stat-card.badge-open" |> ".stat-count") ? color "#92400e" + ".stat-card.badge-inprogress" ? borderLeft (px 4) solid "#3b82f6" + (".stat-card.badge-inprogress" |> ".stat-count") ? color "#1e40af" + ".stat-card.badge-review" ? borderLeft (px 4) solid "#8b5cf6" + (".stat-card.badge-review" |> ".stat-count") ? color "#6b21a8" + ".stat-card.badge-approved" ? borderLeft (px 4) solid "#06b6d4" + (".stat-card.badge-approved" |> ".stat-count") ? color "#0e7490" + ".stat-card.badge-done" ? borderLeft (px 4) solid "#10b981" + (".stat-card.badge-done" |> ".stat-count") ? color "#065f46" + ".stat-card.badge-neutral" ? borderLeft (px 4) solid "#6b7280" + (".stat-card.badge-neutral" |> ".stat-count") ? color "#374151" + ".task-card" ? do + transition "border-color" (ms 150) ease (sec 0) + ".task-card" # hover ? do + borderColor "#999" + ".task-card-link" ? do + display block + textDecoration none + color inherit + cursor pointer + ".task-card-link" # hover ? textDecoration none + ".task-header" ? do + display flex + flexWrap Flexbox.wrap + alignItems center + Stylesheet.key "gap" ("6px" :: Text) + marginBottom (px 4) + ".task-id" ? do + fontFamily ["SF Mono", "Monaco", "monospace"] [monospace] + color "#0066cc" + textDecoration none + fontSize (px 12) + padding (px 2) (px 0) (px 2) (px 0) + ".task-id" # hover ? textDecoration underline + ".priority" ? do + fontSize (px 11) + color "#6b7280" + ".blocking-impact" ? do + fontSize (px 10) + color "#6b7280" + backgroundColor "#e5e7eb" + padding (px 1) (px 6) (px 1) (px 6) + borderRadius (px 8) (px 8) (px 8) (px 8) + marginLeft auto + ".task-title" ? do + fontSize (px 14) + margin (px 0) (px 0) (px 0) (px 0) + ".empty-msg" ? do + color "#6b7280" + fontStyle italic + ".info-msg" ? do + color "#6b7280" + marginBottom (px 12) + ".kb-preview" ? do + color "#6b7280" + fontSize (px 12) + marginTop (px 4) + overflow hidden + Stylesheet.key "text-overflow" ("ellipsis" :: Text) + ".ready-link" ? do + fontSize (px 13) + color "#0066cc" + ".count-badge" ? do + backgroundColor "#0066cc" + color white + padding (px 2) (px 8) (px 2) (px 8) + borderRadius (px 10) (px 10) (px 10) (px 10) + fontSize (px 12) + verticalAlign middle + ".description" ? do + backgroundColor "#f9fafb" + padding (px 8) (px 8) (px 8) (px 8) + borderRadius (px 2) (px 2) (px 2) (px 2) + margin (px 0) (px 0) (px 0) (px 0) + color "#374151" + fontSize (px 13) + ".description-block" ? do + pure () + ".description-header" ? do + display flex + justifyContent spaceBetween + alignItems center + marginBottom (px 8) + (".description-header" |> "h3") ? do + margin (px 0) (px 0) (px 0) (px 0) + ".edit-link" <> ".cancel-link" ? do + fontSize (px 12) + color "#0066cc" + "button.cancel-link" ? do + color "#dc2626" + backgroundColor transparent + border (px 0) solid transparent + padding (px 0) (px 0) (px 0) (px 0) + cursor pointer + textDecoration underline + ".diff-block" ? do + maxHeight (px 600) + overflowY auto + ".progress-bar" ? do + height (px 6) + backgroundColor "#e5e7eb" + borderRadius (px 2) (px 2) (px 2) (px 2) + overflow hidden + marginTop (px 6) + ".progress-fill" ? do + height (pct 100) + backgroundColor "#0066cc" + borderRadius (px 2) (px 2) (px 2) (px 2) + transition "width" (ms 300) ease (sec 0) + ".multi-progress-container" ? do + marginBottom (px 12) + ".multi-progress-bar" ? do + display flex + height (px 8) + backgroundColor "#e5e7eb" + borderRadius (px 4) (px 4) (px 4) (px 4) + overflow hidden + marginTop (px 6) + ".multi-progress-segment" ? do + height (pct 100) + transition "width" (ms 300) ease (sec 0) + ".progress-done" ? backgroundColor "#10b981" + ".progress-inprogress" ? backgroundColor "#f59e0b" + ".progress-open" ? backgroundColor "#3b82f6" + ".progress-legend" ? do + display flex + Stylesheet.key "gap" ("16px" :: Text) + marginTop (px 6) + fontSize (px 12) + color "#6b7280" + ".legend-item" ? do + display flex + alignItems center + Stylesheet.key "gap" ("4px" :: Text) + ".legend-dot" ? do + display inlineBlock + width (px 10) + height (px 10) + borderRadius (px 2) (px 2) (px 2) (px 2) + ".legend-done" ? backgroundColor "#10b981" + ".legend-inprogress" ? backgroundColor "#f59e0b" + ".legend-open" ? backgroundColor "#3b82f6" + ".stats-section" ? do + backgroundColor white + borderRadius (px 2) (px 2) (px 2) (px 2) + padding (px 8) (px 10) (px 8) (px 10) + border (px 1) solid "#d0d0d0" + ".stats-row" ? do + display flex + alignItems center + Stylesheet.key "gap" ("8px" :: Text) + padding (px 4) (px 0) (px 4) (px 0) + marginBottom (px 2) + ".stats-label" ? do + minWidth (px 80) + fontWeight (weight 500) + fontSize (px 13) + ".stats-bar-container" ? do + Stylesheet.key "flex" ("1" :: Text) + ".stats-count" ? do + minWidth (px 32) + textAlign (alignSide sideRight) + fontWeight (weight 500) + fontSize (px 13) + ".summary-section" ? do + backgroundColor white + borderRadius (px 2) (px 2) (px 2) (px 2) + padding (px 8) (px 10) (px 8) (px 10) + border (px 1) solid "#d0d0d0" + ".no-commit-msg" ? do + backgroundColor "#fff3cd" + border (px 1) solid "#ffc107" + borderRadius (px 2) (px 2) (px 2) (px 2) + padding (px 8) (px 10) (px 8) (px 10) + margin (px 8) (px 0) (px 8) (px 0) + ".conflict-warning" ? do + backgroundColor "#fee2e2" + border (px 1) solid "#ef4444" + borderRadius (px 2) (px 2) (px 2) (px 2) + padding (px 8) (px 10) (px 8) (px 10) + margin (px 8) (px 0) (px 8) (px 0) + +listGroupStyles :: Css +listGroupStyles = do + ".list-group" ? do + display flex + flexDirection column + backgroundColor white + borderRadius (px 2) (px 2) (px 2) (px 2) + border (px 1) solid "#d0d0d0" + overflow hidden + ".list-group-item" ? do + display flex + alignItems center + justifyContent spaceBetween + padding (px 8) (px 10) (px 8) (px 10) + borderBottom (px 1) solid "#e5e7eb" + textDecoration none + color inherit + transition "background-color" (ms 150) ease (sec 0) + ".list-group-item" # lastChild ? borderBottom (px 0) none transparent + ".list-group-item" # hover ? do + backgroundColor "#f9fafb" + textDecoration none + ".list-group-item-content" ? do + display flex + alignItems center + Stylesheet.key "gap" ("8px" :: Text) + Stylesheet.key "flex" ("1" :: Text) + minWidth (px 0) + overflow hidden + ".list-group-item-id" ? do + fontFamily ["SF Mono", "Monaco", "monospace"] [monospace] + color "#0066cc" + fontSize (px 12) + flexShrink 0 + ".list-group-item-title" ? do + fontSize (px 13) + color "#374151" + overflow hidden + Stylesheet.key "text-overflow" ("ellipsis" :: Text) + whiteSpace nowrap + ".list-group-item-meta" ? do + display flex + alignItems center + Stylesheet.key "gap" ("6px" :: Text) + flexShrink 0 + +statusBadges :: Css +statusBadges = do + ".badge" ? do + display inlineBlock + padding (px 2) (px 6) (px 2) (px 6) + borderRadius (px 2) (px 2) (px 2) (px 2) + fontSize (px 11) + fontWeight (weight 500) + whiteSpace nowrap + ".badge-open" ? do + backgroundColor "#fef3c7" + color "#92400e" + ".badge-inprogress" ? do + backgroundColor "#dbeafe" + color "#1e40af" + ".badge-review" ? do + backgroundColor "#ede9fe" + color "#6b21a8" + ".badge-approved" ? do + backgroundColor "#cffafe" + color "#0e7490" + ".badge-done" ? do + backgroundColor "#d1fae5" + color "#065f46" + ".status-badge-dropdown" ? do + position relative + display inlineBlock + ".status-badge-clickable" ? do + cursor pointer + Stylesheet.key "user-select" ("none" :: Text) + ".status-badge-clickable" # hover ? do + opacity 0.85 + ".dropdown-arrow" ? do + fontSize (px 8) + marginLeft (px 2) + opacity 0.7 + ".status-dropdown-menu" ? do + display none + position absolute + left (px 0) + top (pct 100) + marginTop (px 2) + backgroundColor white + borderRadius (px 4) (px 4) (px 4) (px 4) + Stylesheet.key "box-shadow" ("0 2px 8px rgba(0,0,0,0.15)" :: Text) + zIndex 100 + padding (px 4) (px 4) (px 4) (px 4) + minWidth (px 100) + ".status-badge-dropdown.open" |> ".status-dropdown-menu" ? do + display block + ".status-option-form" ? do + margin (px 0) (px 0) (px 0) (px 0) + padding (px 0) (px 0) (px 0) (px 0) + ".status-dropdown-option" ? do + display block + width (pct 100) + textAlign (alignSide sideLeft) + margin (px 2) (px 0) (px 2) (px 0) + border (px 0) none transparent + cursor pointer + transition "opacity" (ms 150) ease (sec 0) + ".status-dropdown-option" # hover ? do + opacity 0.7 + ".status-dropdown-option" # focus ? do + opacity 0.85 + Stylesheet.key "outline" ("2px solid #0066cc" :: Text) + Stylesheet.key "outline-offset" ("1px" :: Text) + ".status-dropdown-option.selected" ? do + Stylesheet.key "outline" ("2px solid #0066cc" :: Text) + Stylesheet.key "outline-offset" ("1px" :: Text) + ".status-badge-clickable" # focus ? do + Stylesheet.key "outline" ("2px solid #0066cc" :: Text) + Stylesheet.key "outline-offset" ("2px" :: Text) + ".badge-p0" ? do + backgroundColor "#fee2e2" + color "#991b1b" + ".badge-p1" ? do + backgroundColor "#fef3c7" + color "#92400e" + ".badge-p2" ? do + backgroundColor "#dbeafe" + color "#1e40af" + ".badge-p3" ? do + backgroundColor "#e5e7eb" + color "#4b5563" + ".badge-p4" ? do + backgroundColor "#f3f4f6" + color "#6b7280" + ".priority-badge-dropdown" ? do + position relative + display inlineBlock + ".priority-badge-clickable" ? do + cursor pointer + Stylesheet.key "user-select" ("none" :: Text) + ".priority-badge-clickable" # hover ? do + opacity 0.85 + ".priority-dropdown-menu" ? do + display none + position absolute + left (px 0) + top (pct 100) + marginTop (px 2) + backgroundColor white + borderRadius (px 4) (px 4) (px 4) (px 4) + Stylesheet.key "box-shadow" ("0 2px 8px rgba(0,0,0,0.15)" :: Text) + zIndex 100 + padding (px 4) (px 4) (px 4) (px 4) + minWidth (px 100) + ".priority-badge-dropdown.open" |> ".priority-dropdown-menu" ? do + display block + ".priority-option-form" ? do + margin (px 0) (px 0) (px 0) (px 0) + padding (px 0) (px 0) (px 0) (px 0) + ".priority-dropdown-option" ? do + display block + width (pct 100) + textAlign (alignSide sideLeft) + margin (px 2) (px 0) (px 2) (px 0) + border (px 0) none transparent + cursor pointer + transition "opacity" (ms 150) ease (sec 0) + ".priority-dropdown-option" # hover ? do + opacity 0.7 + ".priority-dropdown-option" # focus ? do + opacity 0.85 + Stylesheet.key "outline" ("2px solid #0066cc" :: Text) + Stylesheet.key "outline-offset" ("1px" :: Text) + ".priority-dropdown-option.selected" ? do + Stylesheet.key "outline" ("2px solid #0066cc" :: Text) + Stylesheet.key "outline-offset" ("1px" :: Text) + ".priority-badge-clickable" # focus ? do + Stylesheet.key "outline" ("2px solid #0066cc" :: Text) + Stylesheet.key "outline-offset" ("2px" :: Text) + +buttonStyles :: Css +buttonStyles = do + ".btn" + <> ".action-btn" + <> ".filter-btn" + <> ".submit-btn" + <> ".accept-btn" + <> ".reject-btn" + <> ".review-link-btn" + ? do + display inlineBlock + minHeight (px 32) + padding (px 6) (px 12) (px 6) (px 12) + borderRadius (px 2) (px 2) (px 2) (px 2) + border (px 0) none transparent + fontSize (px 13) + fontWeight (weight 500) + textDecoration none + cursor pointer + textAlign center + transition "all" (ms 150) ease (sec 0) + Stylesheet.key "touch-action" ("manipulation" :: Text) + ".action-btn" ? do + backgroundColor white + border (px 1) solid "#d1d5db" + color "#374151" + ".action-btn" # hover ? do + backgroundColor "#f9fafb" + borderColor "#9ca3af" + ".action-btn-primary" <> ".filter-btn" <> ".submit-btn" ? do + backgroundColor "#0066cc" + color white + borderColor "#0066cc" + ".action-btn-primary" + # hover + <> ".filter-btn" + # hover + <> ".submit-btn" + # hover + ? do + backgroundColor "#0052a3" + ".accept-btn" ? do + backgroundColor "#10b981" + color white + ".accept-btn" # hover ? backgroundColor "#059669" + ".reject-btn" ? do + backgroundColor "#ef4444" + color white + ".reject-btn" # hover ? backgroundColor "#dc2626" + ".clear-btn" ? do + display inlineBlock + minHeight (px 32) + padding (px 6) (px 10) (px 6) (px 10) + backgroundColor "#6b7280" + color white + borderRadius (px 2) (px 2) (px 2) (px 2) + textDecoration none + fontSize (px 13) + cursor pointer + ".clear-btn" # hover ? backgroundColor "#4b5563" + ".review-link-btn" ? do + backgroundColor "#8b5cf6" + color white + ".review-link-btn" # hover ? backgroundColor "#7c3aed" + ".review-link-section" ? margin (px 8) (px 0) (px 8) (px 0) + ".btn-secondary" <> ".load-more-btn" ? do + backgroundColor "#6b7280" + color white + width (pct 100) + marginTop (px 8) + ".btn-secondary" # hover <> ".load-more-btn" # hover ? backgroundColor "#4b5563" + +formStyles :: Css +formStyles = do + ".filter-row" ? do + display flex + flexWrap Flexbox.wrap + Stylesheet.key "gap" ("8px" :: Text) + alignItems flexEnd + ".filter-group" ? do + display flex + flexDirection row + alignItems center + Stylesheet.key "gap" ("4px" :: Text) + (".filter-group" |> label) ? do + fontSize (px 12) + color "#6b7280" + fontWeight (weight 500) + whiteSpace nowrap + ".filter-select" <> ".filter-input" <> ".status-select" ? do + minHeight (px 32) + padding (px 6) (px 10) (px 6) (px 10) + border (px 1) solid "#d1d5db" + borderRadius (px 2) (px 2) (px 2) (px 2) + fontSize (px 13) + minWidth (px 100) + ".filter-input" ? minWidth (px 120) + ".inline-form" ? display inlineBlock + ".reject-form" ? do + display flex + Stylesheet.key "gap" ("6px" :: Text) + Stylesheet.key "flex" ("1" :: Text) + minWidth (px 200) + flexWrap Flexbox.wrap + ".reject-notes" ? do + Stylesheet.key "flex" ("1" :: Text) + minWidth (px 160) + minHeight (px 32) + padding (px 6) (px 10) (px 6) (px 10) + border (px 1) solid "#d1d5db" + borderRadius (px 2) (px 2) (px 2) (px 2) + fontSize (px 13) + Stylesheet.key "resize" ("vertical" :: Text) + ".edit-description" ? do + marginTop (px 8) + padding (px 8) (px 0) (px 0) (px 0) + borderTop (px 1) solid "#e5e7eb" + (".edit-description" |> "summary") ? do + cursor pointer + color "#0066cc" + fontSize (px 13) + fontWeight (weight 500) + (".edit-description" |> "summary") # hover ? textDecoration underline + ".description-textarea" ? do + width (pct 100) + minHeight (px 250) + padding (px 8) (px 10) (px 8) (px 10) + border (px 1) solid "#d1d5db" + borderRadius (px 2) (px 2) (px 2) (px 2) + fontSize (px 13) + fontFamily ["SF Mono", "Monaco", "Consolas", "monospace"] [monospace] + lineHeight (em 1.5) + Stylesheet.key "resize" ("vertical" :: Text) + marginTop (px 8) + ".form-actions" ? do + display flex + flexDirection row + flexWrap Flexbox.wrap + Stylesheet.key "gap" ("8px" :: Text) + marginTop (px 8) + ".fact-edit-form" ? do + marginTop (px 8) + ".form-group" ? do + marginBottom (px 16) + (".form-group" |> label) ? do + display block + marginBottom (px 4) + fontSize (px 13) + fontWeight (weight 500) + color "#374151" + ".form-input" <> ".form-textarea" ? do + width (pct 100) + padding (px 8) (px 10) (px 8) (px 10) + border (px 1) solid "#d1d5db" + borderRadius (px 2) (px 2) (px 2) (px 2) + fontSize (px 14) + lineHeight (em 1.5) + ".form-input" # focus <> ".form-textarea" # focus ? do + borderColor "#0066cc" + Stylesheet.key "outline" ("none" :: Text) + Stylesheet.key "box-shadow" ("0 0 0 2px rgba(0, 102, 204, 0.2)" :: Text) + ".form-textarea" ? do + minHeight (px 120) + Stylesheet.key "resize" ("vertical" :: Text) + fontFamily + [ "-apple-system", + "BlinkMacSystemFont", + "Segoe UI", + "Roboto", + "Helvetica Neue", + "Arial", + "sans-serif" + ] + [sansSerif] + ".btn" ? do + display inlineBlock + padding (px 8) (px 16) (px 8) (px 16) + border (px 0) none transparent + borderRadius (px 3) (px 3) (px 3) (px 3) + fontSize (px 14) + fontWeight (weight 500) + textDecoration none + cursor pointer + transition "all" (ms 150) ease (sec 0) + ".btn-primary" ? do + backgroundColor "#0066cc" + color white + ".btn-primary" # hover ? backgroundColor "#0052a3" + ".btn-secondary" ? do + backgroundColor "#6b7280" + color white + ".btn-secondary" # hover ? backgroundColor "#4b5563" + ".btn-danger" ? do + backgroundColor "#dc2626" + color white + ".btn-danger" # hover ? backgroundColor "#b91c1c" + ".danger-zone" ? do + marginTop (px 24) + padding (px 16) (px 16) (px 16) (px 16) + backgroundColor "#fef2f2" + border (px 1) solid "#fecaca" + borderRadius (px 4) (px 4) (px 4) (px 4) + (".danger-zone" |> h2) ? do + color "#dc2626" + marginBottom (px 12) + ".back-link" ? do + marginTop (px 24) + paddingTop (px 16) + borderTop (px 1) solid "#e5e7eb" + (".back-link" |> a) ? do + color "#6b7280" + textDecoration none + (".back-link" |> a) # hover ? do + color "#374151" + textDecoration underline + ".task-link" ? do + color "#0066cc" + textDecoration none + fontWeight (weight 500) + ".task-link" # hover ? textDecoration underline + ".error-msg" ? do + color "#dc2626" + backgroundColor "#fef2f2" + padding (px 16) (px 16) (px 16) (px 16) + borderRadius (px 4) (px 4) (px 4) (px 4) + border (px 1) solid "#fecaca" + ".create-fact-section" ? do + marginBottom (px 16) + ".create-fact-toggle" ? do + cursor pointer + display inlineBlock + ".fact-create-form" ? do + marginTop (px 12) + padding (px 16) (px 16) (px 16) (px 16) + backgroundColor white + borderRadius (px 4) (px 4) (px 4) (px 4) + border (px 1) solid "#d1d5db" + +executionDetailsStyles :: Css +executionDetailsStyles = do + ".execution-section" ? do + marginTop (em 1) + backgroundColor white + borderRadius (px 2) (px 2) (px 2) (px 2) + padding (px 8) (px 10) (px 8) (px 10) + border (px 1) solid "#d0d0d0" + ".execution-details" ? do + marginTop (px 8) + ".metric-row" ? do + display flex + flexWrap Flexbox.wrap + padding (px 4) (px 0) (px 4) (px 0) + marginBottom (px 2) + ".metric-label" ? do + fontWeight (weight 600) + width (px 120) + color "#6b7280" + fontSize (px 13) + ".metric-value" ? do + Stylesheet.key "flex" ("1" :: Text) + fontSize (px 13) + ".amp-link" ? do + color "#0066cc" + textDecoration none + wordBreak breakAll + ".amp-link" # hover ? textDecoration underline + ".amp-thread-btn" ? do + display inlineBlock + padding (px 4) (px 10) (px 4) (px 10) + backgroundColor "#7c3aed" + color white + borderRadius (px 3) (px 3) (px 3) (px 3) + textDecoration none + fontSize (px 12) + fontWeight (weight 500) + transition "background-color" (ms 150) ease (sec 0) + ".amp-thread-btn" # hover ? do + backgroundColor "#6d28d9" + textDecoration none + ".retry-count" ? do + color "#f97316" + fontWeight (weight 600) + ".attempts-divider" ? do + margin (px 12) (px 0) (px 12) (px 0) + border (px 0) none transparent + borderTop (px 1) solid "#e5e7eb" + ".attempt-header" ? do + fontWeight (weight 600) + fontSize (px 13) + color "#374151" + marginTop (px 8) + marginBottom (px 4) + paddingBottom (px 4) + borderBottom (px 1) solid "#f3f4f6" + ".aggregated-metrics" ? do + marginTop (em 0.5) + paddingTop (em 0.75) + ".metrics-grid" ? do + display grid + Stylesheet.key "grid-template-columns" ("repeat(auto-fit, minmax(100px, 1fr))" :: Text) + Stylesheet.key "gap" ("10px" :: Text) + marginTop (px 8) + ".metric-card" ? do + backgroundColor "#f9fafb" + border (px 1) solid "#e5e7eb" + borderRadius (px 4) (px 4) (px 4) (px 4) + padding (px 10) (px 12) (px 10) (px 12) + textAlign center + (".metric-card" |> ".metric-value") ? do + fontSize (px 20) + fontWeight bold + color "#374151" + display block + marginBottom (px 2) + width auto + (".metric-card" |> ".metric-label") ? do + fontSize (px 11) + color "#6b7280" + fontWeight (weight 400) + width auto + +activityTimelineStyles :: Css +activityTimelineStyles = do + ".activity-section" ? do + marginTop (em 1) + backgroundColor white + borderRadius (px 2) (px 2) (px 2) (px 2) + padding (px 8) (px 10) (px 8) (px 10) + border (px 1) solid "#d0d0d0" + ".activity-timeline" ? do + position relative + paddingLeft (px 20) + marginTop (px 8) + ".activity-timeline" # before ? do + Stylesheet.key "content" ("''" :: Text) + position absolute + left (px 6) + top (px 0) + bottom (px 0) + width (px 2) + backgroundColor "#e5e7eb" + ".activity-item" ? do + position relative + display flex + Stylesheet.key "gap" ("8px" :: Text) + paddingBottom (px 10) + marginBottom (px 0) + ".activity-item" # lastChild ? paddingBottom (px 0) + ".activity-icon" ? do + position absolute + left (px (-16)) + width (px 14) + height (px 14) + borderRadius (pct 50) (pct 50) (pct 50) (pct 50) + display flex + alignItems center + justifyContent center + fontSize (px 8) + fontWeight bold + backgroundColor white + border (px 2) solid "#e5e7eb" + ".activity-content" ? do + Stylesheet.key "flex" ("1" :: Text) + ".activity-header" ? do + display flex + alignItems center + Stylesheet.key "gap" ("6px" :: Text) + marginBottom (px 2) + ".activity-stage" ? do + fontWeight (weight 600) + fontSize (px 12) + ".activity-time" ? do + fontSize (px 11) + color "#6b7280" + ".activity-message" ? do + margin (px 2) (px 0) (px 0) (px 0) + fontSize (px 12) + color "#374151" + ".activity-metadata" ? do + marginTop (px 4) + (".activity-metadata" |> "summary") ? do + fontSize (px 11) + color "#6b7280" + cursor pointer + ".metadata-json" ? do + fontSize (px 10) + backgroundColor "#f3f4f6" + padding (px 4) (px 6) (px 4) (px 6) + borderRadius (px 2) (px 2) (px 2) (px 2) + marginTop (px 2) + maxHeight (px 150) + overflow auto + ".stage-claiming" |> ".activity-icon" ? do + borderColor "#3b82f6" + color "#3b82f6" + ".stage-running" |> ".activity-icon" ? do + borderColor "#f59e0b" + color "#f59e0b" + ".stage-reviewing" |> ".activity-icon" ? do + borderColor "#8b5cf6" + color "#8b5cf6" + ".stage-retrying" |> ".activity-icon" ? do + borderColor "#f97316" + color "#f97316" + ".stage-completed" |> ".activity-icon" ? do + borderColor "#10b981" + color "#10b981" + ".stage-failed" |> ".activity-icon" ? do + borderColor "#ef4444" + color "#ef4444" + +commitStyles :: Css +commitStyles = do + ".commit-list" ? do + display flex + flexDirection column + Stylesheet.key "gap" ("4px" :: Text) + marginTop (px 8) + ".commit-item" ? do + padding (px 6) (px 8) (px 6) (px 8) + backgroundColor "#f9fafb" + borderRadius (px 2) (px 2) (px 2) (px 2) + border (px 1) solid "#e5e7eb" + ".commit-header" ? do + display flex + alignItems center + Stylesheet.key "gap" ("8px" :: Text) + marginBottom (px 2) + ".commit-hash" ? do + fontFamily ["SF Mono", "Monaco", "monospace"] [monospace] + fontSize (px 12) + color "#0066cc" + textDecoration none + backgroundColor "#e5e7eb" + padding (px 1) (px 4) (px 1) (px 4) + borderRadius (px 2) (px 2) (px 2) (px 2) + ".commit-hash" # hover ? textDecoration underline + ".commit-summary" ? do + fontSize (px 13) + color "#374151" + fontWeight (weight 500) + ".commit-meta" ? do + display flex + Stylesheet.key "gap" ("12px" :: Text) + fontSize (px 11) + color "#6b7280" + ".commit-author" ? fontWeight (weight 500) + ".commit-files" ? do + color "#9ca3af" + +markdownStyles :: Css +markdownStyles = do + ".markdown-content" ? do + width (pct 100) + lineHeight (em 1.6) + fontSize (px 14) + color "#374151" + ".md-h1" ? do + fontSize (px 18) + fontWeight bold + margin (em 1) (px 0) (em 0.5) (px 0) + paddingBottom (em 0.3) + borderBottom (px 1) solid "#e5e7eb" + ".md-h2" ? do + fontSize (px 16) + fontWeight (weight 600) + margin (em 0.8) (px 0) (em 0.4) (px 0) + ".md-h3" ? do + fontSize (px 14) + fontWeight (weight 600) + margin (em 0.6) (px 0) (em 0.3) (px 0) + ".md-para" ? do + margin (em 0.5) (px 0) (em 0.5) (px 0) + ".md-code" ? do + fontFamily ["SF Mono", "Monaco", "Consolas", "monospace"] [monospace] + fontSize (px 12) + backgroundColor "#1e1e1e" + color "#d4d4d4" + padding (px 10) (px 12) (px 10) (px 12) + borderRadius (px 4) (px 4) (px 4) (px 4) + overflow auto + whiteSpace preWrap + margin (em 0.5) (px 0) (em 0.5) (px 0) + ".md-list" ? do + margin (em 0.5) (px 0) (em 0.5) (px 0) + paddingLeft (px 24) + (".md-list" ** li) ? do + margin (px 4) (px 0) (px 4) (px 0) + ".md-inline-code" ? do + fontFamily ["SF Mono", "Monaco", "Consolas", "monospace"] [monospace] + fontSize (em 0.9) + backgroundColor "#f3f4f6" + padding (px 1) (px 4) (px 1) (px 4) + borderRadius (px 2) (px 2) (px 2) (px 2) + +retryBannerStyles :: Css +retryBannerStyles = do + ".retry-banner" ? do + borderRadius (px 4) (px 4) (px 4) (px 4) + padding (px 12) (px 16) (px 12) (px 16) + margin (px 0) (px 0) (px 16) (px 0) + ".retry-banner-warning" ? do + backgroundColor "#fef3c7" + border (px 1) solid "#f59e0b" + ".retry-banner-critical" ? do + backgroundColor "#fee2e2" + border (px 1) solid "#ef4444" + ".retry-banner-header" ? do + display flex + alignItems center + Stylesheet.key "gap" ("8px" :: Text) + marginBottom (px 8) + ".retry-icon" ? do + fontSize (px 18) + fontWeight bold + ".retry-attempt" ? do + fontSize (px 14) + fontWeight (weight 600) + color "#374151" + ".retry-warning-badge" ? do + backgroundColor "#dc2626" + color white + fontSize (px 11) + fontWeight (weight 600) + padding (px 2) (px 8) (px 2) (px 8) + borderRadius (px 2) (px 2) (px 2) (px 2) + marginLeft auto + ".retry-banner-details" ? do + fontSize (px 13) + color "#374151" + ".retry-detail-row" ? do + display flex + alignItems flexStart + Stylesheet.key "gap" ("8px" :: Text) + margin (px 4) (px 0) (px 4) (px 0) + ".retry-label" ? do + fontWeight (weight 500) + minWidth (px 110) + flexShrink 0 + ".retry-value" ? do + color "#4b5563" + ".retry-commit" ? do + fontFamily ["SF Mono", "Monaco", "Consolas", "monospace"] [monospace] + fontSize (em 0.9) + backgroundColor "#f3f4f6" + padding (px 1) (px 4) (px 1) (px 4) + borderRadius (px 2) (px 2) (px 2) (px 2) + ".retry-conflict-list" ? do + margin (px 0) (px 0) (px 0) (px 0) + padding (px 0) (px 0) (px 0) (px 16) + (".retry-conflict-list" ** li) ? do + fontFamily ["SF Mono", "Monaco", "Consolas", "monospace"] [monospace] + fontSize (px 12) + margin (px 2) (px 0) (px 2) (px 0) + ".retry-warning-message" ? do + marginTop (px 12) + padding (px 10) (px 12) (px 10) (px 12) + backgroundColor "#fecaca" + borderRadius (px 2) (px 2) (px 2) (px 2) + fontSize (px 12) + color "#991b1b" + fontWeight (weight 500) + ".retry-hint" ? do + marginTop (px 8) + fontSize (px 12) + color "#6b7280" + fontStyle italic + +commentStyles :: Css +commentStyles = do + ".comments-section" ? do + marginTop (px 12) + ".comment-card" ? do + backgroundColor "#f9fafb" + border (px 1) solid "#e5e7eb" + borderRadius (px 4) (px 4) (px 4) (px 4) + padding (px 10) (px 12) (px 10) (px 12) + marginBottom (px 8) + ".comment-text" ? do + margin (px 0) (px 0) (px 6) (px 0) + fontSize (px 13) + color "#374151" + whiteSpace preWrap + ".comment-time" ? do + fontSize (px 11) + color "#9ca3af" + ".comment-form" ? do + marginTop (px 12) + display flex + flexDirection column + Stylesheet.key "gap" ("8px" :: Text) + ".comment-textarea" ? do + width (pct 100) + padding (px 8) (px 10) (px 8) (px 10) + fontSize (px 13) + border (px 1) solid "#d0d0d0" + borderRadius (px 4) (px 4) (px 4) (px 4) + Stylesheet.key "resize" ("vertical" :: Text) + minHeight (px 60) + ".comment-textarea" # focus ? do + Stylesheet.key "outline" ("none" :: Text) + borderColor "#0066cc" + +timeFilterStyles :: Css +timeFilterStyles = do + ".time-filter" ? do + display flex + Stylesheet.key "gap" ("6px" :: Text) + marginBottom (px 12) + flexWrap Flexbox.wrap + ".time-filter-btn" ? do + display inlineBlock + padding (px 4) (px 12) (px 4) (px 12) + fontSize (px 12) + fontWeight (weight 500) + textDecoration none + borderRadius (px 12) (px 12) (px 12) (px 12) + border (px 1) solid "#d0d0d0" + backgroundColor white + color "#374151" + transition "all" (ms 150) ease (sec 0) + cursor pointer + ".time-filter-btn" # hover ? do + borderColor "#999" + backgroundColor "#f3f4f6" + textDecoration none + ".time-filter-btn.active" ? do + backgroundColor "#0066cc" + borderColor "#0066cc" + color white + ".time-filter-btn.active" # hover ? do + backgroundColor "#0055aa" + borderColor "#0055aa" + +sortDropdownStyles :: Css +sortDropdownStyles = do + ".page-header-row" ? do + display flex + alignItems center + justifyContent spaceBetween + flexWrap Flexbox.wrap + Stylesheet.key "gap" ("12px" :: Text) + marginBottom (px 8) + ".page-header-row" |> "h1" ? do + margin (px 0) (px 0) (px 0) (px 0) + ".sort-dropdown" ? do + display flex + alignItems center + Stylesheet.key "gap" ("6px" :: Text) + fontSize (px 13) + ".sort-label" ? do + color "#6b7280" + fontWeight (weight 500) + ".sort-dropdown-wrapper" ? do + position relative + ".sort-dropdown-btn" ? do + padding (px 4) (px 10) (px 4) (px 10) + fontSize (px 13) + fontWeight (weight 500) + border (px 1) solid "#d0d0d0" + borderRadius (px 4) (px 4) (px 4) (px 4) + backgroundColor white + color "#374151" + cursor pointer + transition "all" (ms 150) ease (sec 0) + whiteSpace nowrap + ".sort-dropdown-btn" # hover ? do + borderColor "#999" + backgroundColor "#f3f4f6" + ".sort-dropdown-content" ? do + minWidth (px 160) + right (px 0) + left auto + ".sort-dropdown-item" ? do + padding (px 8) (px 12) (px 8) (px 12) + fontSize (px 13) + ".sort-dropdown-item.active" ? do + backgroundColor "#e0f2fe" + fontWeight (weight 600) + +taskMetaStyles :: Css +taskMetaStyles = do + ".task-meta" ? do + marginBottom (px 12) + ".task-meta-primary" ? do + display flex + alignItems center + flexWrap Flexbox.wrap + Stylesheet.key "gap" ("6px" :: Text) + fontSize (px 14) + marginBottom (px 4) + ".task-meta-secondary" ? do + display flex + alignItems center + flexWrap Flexbox.wrap + Stylesheet.key "gap" ("6px" :: Text) + fontSize (px 12) + color "#6b7280" + ".task-meta-id" ? do + fontFamily ["SF Mono", "Monaco", "monospace"] [monospace] + fontSize (px 13) + backgroundColor "#f3f4f6" + padding (px 1) (px 4) (px 1) (px 4) + borderRadius (px 2) (px 2) (px 2) (px 2) + ".task-meta-label" ? do + color "#6b7280" + ".meta-sep" ? do + color "#d1d5db" + Stylesheet.key "user-select" ("none" :: Text) + +responsiveStyles :: Css +responsiveStyles = do + query Media.screen [Media.maxWidth (px 600)] <| do + body ? fontSize (px 13) + ".container" ? padding (px 6) (px 8) (px 6) (px 8) + ".navbar" ? do + padding (px 6) (px 8) (px 6) (px 8) + flexWrap Flexbox.wrap + ".navbar-hamburger" ? do + display flex + Stylesheet.key "order" ("2" :: Text) + ".navbar-links" ? do + display none + width (pct 100) + Stylesheet.key "order" ("3" :: Text) + flexDirection column + alignItems flexStart + paddingTop (px 8) + Stylesheet.key "gap" ("0" :: Text) + ".navbar-toggle-checkbox" # checked |+ ".navbar-hamburger" |+ ".navbar-links" ? do + display flex + ".navbar-link" ? do + padding (px 8) (px 6) (px 8) (px 6) + fontSize (px 13) + width (pct 100) + ".navbar-dropdown" ? do + width (pct 100) + ".navbar-dropdown-btn" ? do + padding (px 8) (px 6) (px 8) (px 6) + fontSize (px 13) + width (pct 100) + textAlign (alignSide sideLeft) + ".navbar-dropdown-content" ? do + position static + Stylesheet.key "box-shadow" ("none" :: Text) + paddingLeft (px 12) + backgroundColor transparent + ".navbar-dropdown-item" ? do + padding (px 6) (px 10) (px 6) (px 10) + fontSize (px 12) + ".nav-content" ? do + flexDirection column + alignItems flexStart + ".stats-grid" ? do + Stylesheet.key "grid-template-columns" ("repeat(2, 1fr)" :: Text) + ".detail-row" ? do + flexDirection column + Stylesheet.key "gap" ("2px" :: Text) + ".detail-label" ? width auto + ".filter-row" ? do + flexWrap Flexbox.wrap + ".filter-group" ? do + width auto + flexWrap Flexbox.nowrap + ".filter-select" <> ".filter-input" ? minWidth (px 80) + ".review-actions" ? do + flexDirection column + ".reject-form" ? do + width (pct 100) + flexDirection column + ".reject-notes" ? width (pct 100) + ".actions" ? flexDirection column + ".action-btn" ? width (pct 100) + +darkModeStyles :: Css +darkModeStyles = + query Media.screen [prefersDark] <| do + body ? do + backgroundColor "#111827" + color "#f3f4f6" + ".card" + <> ".task-card" + <> ".stat-card" + <> ".task-detail" + <> ".task-summary" + <> ".filter-form" + <> ".status-form" + <> ".diff-section" + <> ".review-actions" + <> ".list-group" + ? do + backgroundColor "#1f2937" + borderColor "#374151" + ".list-group-item" ? borderBottomColor "#374151" + ".list-group-item" # hover ? backgroundColor "#374151" + ".list-group-item-id" ? color "#60a5fa" + ".list-group-item-title" ? color "#d1d5db" + header ? do + backgroundColor "#1f2937" + borderColor "#374151" + ".navbar" ? do + backgroundColor "#1f2937" + borderColor "#374151" + ".navbar-brand" ? color "#60a5fa" + ".navbar-link" ? color "#d1d5db" + ".navbar-link" # hover ? backgroundColor "#374151" + ".navbar-dropdown-btn" ? color "#d1d5db" + ".navbar-dropdown-btn" # hover ? backgroundColor "#374151" + ".navbar-dropdown-content" ? do + backgroundColor "#1f2937" + Stylesheet.key "box-shadow" ("0 2px 8px rgba(0,0,0,0.3)" :: Text) + ".navbar-dropdown-item" ? color "#d1d5db" + ".navbar-dropdown-item" # hover ? backgroundColor "#374151" + ".status-dropdown-menu" ? do + backgroundColor "#1f2937" + Stylesheet.key "box-shadow" ("0 2px 8px rgba(0,0,0,0.3)" :: Text) + ".hamburger-line" ? backgroundColor "#d1d5db" + ".nav-brand" ? color "#f3f4f6" + "h2" <> "h3" ? color "#d1d5db" + a ? color "#60a5fa" + ".breadcrumb-container" ? backgroundColor transparent + ".breadcrumb-sep" ? color "#6b7280" + ".breadcrumb-current" ? color "#9ca3af" + + ".detail-label" + <> ".priority" + <> ".dep-type" + <> ".child-status" + <> ".empty-msg" + <> ".stat-label" + <> ".priority-desc" + ? color "#9ca3af" + ".child-title" ? color "#d1d5db" + code ? do + backgroundColor "#374151" + color "#f3f4f6" + ".task-meta-id" ? do + backgroundColor "#374151" + color "#e5e7eb" + ".task-meta-secondary" ? color "#9ca3af" + ".meta-sep" ? color "#4b5563" + ".task-meta-label" ? color "#9ca3af" + ".detail-section" ? borderTopColor "#374151" + ".description" ? do + backgroundColor "#374151" + color "#e5e7eb" + ".badge-open" ? do + backgroundColor "#78350f" + color "#fcd34d" + ".badge-inprogress" ? do + backgroundColor "#1e3a8a" + color "#93c5fd" + ".badge-review" ? do + backgroundColor "#4c1d95" + color "#c4b5fd" + ".badge-approved" ? do + backgroundColor "#164e63" + color "#67e8f9" + ".badge-done" ? do + backgroundColor "#064e3b" + color "#6ee7b7" + ".badge-p0" ? do + backgroundColor "#7f1d1d" + color "#fca5a5" + ".badge-p1" ? do + backgroundColor "#78350f" + color "#fcd34d" + ".badge-p2" ? do + backgroundColor "#1e3a8a" + color "#93c5fd" + ".badge-p3" ? do + backgroundColor "#374151" + color "#d1d5db" + ".badge-p4" ? do + backgroundColor "#1f2937" + color "#9ca3af" + ".blocking-impact" ? do + backgroundColor "#374151" + color "#9ca3af" + ".priority-dropdown-menu" ? do + backgroundColor "#1f2937" + Stylesheet.key "box-shadow" ("0 2px 8px rgba(0,0,0,0.3)" :: Text) + ".action-btn" ? do + backgroundColor "#374151" + borderColor "#4b5563" + color "#f3f4f6" + ".action-btn" # hover ? backgroundColor "#4b5563" + ".filter-select" <> ".filter-input" <> ".status-select" <> ".reject-notes" ? do + backgroundColor "#374151" + borderColor "#4b5563" + color "#f3f4f6" + ".stats-section" <> ".summary-section" ? do + backgroundColor "#1f2937" + borderColor "#374151" + + (".stat-card.badge-open" |> ".stat-count") ? color "#fbbf24" + (".stat-card.badge-inprogress" |> ".stat-count") ? color "#60a5fa" + (".stat-card.badge-review" |> ".stat-count") ? color "#a78bfa" + (".stat-card.badge-approved" |> ".stat-count") ? color "#22d3ee" + (".stat-card.badge-done" |> ".stat-count") ? color "#34d399" + (".stat-card.badge-neutral" |> ".stat-count") ? color "#9ca3af" + + ".progress-bar" ? backgroundColor "#374151" + ".progress-fill" ? backgroundColor "#60a5fa" + ".multi-progress-bar" ? backgroundColor "#374151" + ".progress-legend" ? color "#9ca3af" + ".activity-section" ? do + backgroundColor "#1f2937" + borderColor "#374151" + ".activity-timeline" # before ? backgroundColor "#374151" + ".activity-icon" ? do + backgroundColor "#1f2937" + borderColor "#374151" + ".activity-time" ? color "#9ca3af" + ".activity-message" ? color "#d1d5db" + (".activity-metadata" |> "summary") ? color "#9ca3af" + ".metadata-json" ? backgroundColor "#374151" + ".execution-section" ? do + backgroundColor "#1f2937" + borderColor "#374151" + + ".metric-label" ? color "#9ca3af" + ".metric-value" ? color "#d1d5db" + ".metric-card" ? do + backgroundColor "#374151" + borderColor "#4b5563" + (".metric-card" |> ".metric-value") ? color "#f3f4f6" + (".metric-card" |> ".metric-label") ? color "#9ca3af" + ".amp-link" ? color "#60a5fa" + ".amp-thread-btn" ? do + backgroundColor "#8b5cf6" + ".amp-thread-btn" # hover ? backgroundColor "#7c3aed" + ".markdown-content" ? color "#d1d5db" + ".commit-item" ? do + backgroundColor "#374151" + borderColor "#4b5563" + ".commit-hash" ? do + backgroundColor "#4b5563" + color "#60a5fa" + ".commit-summary" ? color "#d1d5db" + ".commit-meta" ? color "#9ca3af" + ".md-h1" ? borderBottomColor "#374151" + ".md-inline-code" ? do + backgroundColor "#374151" + color "#f3f4f6" + ".edit-description" ? borderTopColor "#374151" + (".edit-description" |> "summary") ? color "#60a5fa" + ".edit-link" ? color "#60a5fa" + "button.cancel-link" ? do + color "#f87171" + backgroundColor transparent + border (px 0) solid transparent + ".description-textarea" ? do + backgroundColor "#374151" + borderColor "#4b5563" + color "#f3f4f6" + ".fact-create-form" ? do + backgroundColor "#1f2937" + borderColor "#374151" + ".time-filter-btn" ? do + backgroundColor "#374151" + borderColor "#4b5563" + color "#d1d5db" + ".time-filter-btn" # hover ? do + backgroundColor "#4b5563" + borderColor "#6b7280" + ".time-filter-btn.active" ? do + backgroundColor "#3b82f6" + borderColor "#3b82f6" + color white + ".time-filter-btn.active" # hover ? do + backgroundColor "#2563eb" + borderColor "#2563eb" + ".sort-label" ? color "#9ca3af" + ".sort-dropdown-btn" ? do + backgroundColor "#374151" + borderColor "#4b5563" + color "#d1d5db" + ".sort-dropdown-btn" # hover ? do + backgroundColor "#4b5563" + borderColor "#6b7280" + ".sort-dropdown-item.active" ? do + backgroundColor "#1e3a5f" + ".comment-card" ? do + backgroundColor "#374151" + borderColor "#4b5563" + ".comment-text" ? color "#d1d5db" + ".comment-time" ? color "#9ca3af" + ".comment-textarea" ? do + backgroundColor "#374151" + borderColor "#4b5563" + color "#f3f4f6" + ".form-input" <> ".form-textarea" ? do + backgroundColor "#374151" + borderColor "#4b5563" + color "#f3f4f6" + (".form-group" |> label) ? color "#d1d5db" + ".danger-zone" ? do + backgroundColor "#450a0a" + borderColor "#991b1b" + (".danger-zone" |> h2) ? color "#f87171" + ".retry-banner-warning" ? do + backgroundColor "#451a03" + borderColor "#b45309" + ".retry-banner-critical" ? do + backgroundColor "#450a0a" + borderColor "#dc2626" + ".retry-attempt" ? color "#d1d5db" + ".retry-banner-details" ? color "#d1d5db" + ".retry-value" ? color "#9ca3af" + ".retry-commit" ? backgroundColor "#374151" + -- Responsive dark mode: dropdown content needs background on mobile + query Media.screen [Media.maxWidth (px 600)] <| do + ".navbar-dropdown-content" ? do + backgroundColor "#1f2937" + ".navbar-dropdown-item" # hover ? do + backgroundColor "#374151" + +prefersDark :: Stylesheet.Feature +prefersDark = + Stylesheet.Feature "prefers-color-scheme" (Just (Clay.value ("dark" :: Text))) + +statusBadgeClass :: Text -> Text +statusBadgeClass status = case status of + "Open" -> "badge badge-open" + "InProgress" -> "badge badge-inprogress" + "Review" -> "badge badge-review" + "Approved" -> "badge badge-approved" + "Done" -> "badge badge-done" + _ -> "badge" + +priorityBadgeClass :: Text -> Text +priorityBadgeClass priority = case priority of + "P0" -> "badge badge-p0" + "P1" -> "badge badge-p1" + "P2" -> "badge badge-p2" + "P3" -> "badge badge-p3" + "P4" -> "badge badge-p4" + _ -> "badge" diff --git a/Omni/Llamacpp.py b/Omni/Llamacpp.py index eac08fd..c7e9078 100755 --- a/Omni/Llamacpp.py +++ b/Omni/Llamacpp.py @@ -9,7 +9,10 @@ sure llama-cpp still works in case I need/want to switch at some point. # : out llamacpp-test # : run llama-cpp - +import logging +import Omni.App as App +import Omni.Log as Log +import Omni.Test as Test import os import sys import unittest @@ -23,18 +26,11 @@ class TestLlamaCpp(unittest.TestCase): self.assertIn("llama-cpp", os.environ.get("PATH", "")) -def test() -> None: - """Run this module's test suite.""" - suite = unittest.TestSuite() - suite.addTests( - unittest.defaultTestLoader.loadTestsFromTestCase(TestLlamaCpp), - ) - unittest.TextTestRunner().run(suite) - - def main() -> None: """Entrypoint.""" if sys.argv[1] == "test": - test() + logger = logging.getLogger(__name__) + Log.setup(logger) + Test.run(App.Area.Test, [TestLlamaCpp]) else: sys.exit(0) diff --git a/Omni/Log.py b/Omni/Log.py index ee4a050..5b3a618 100644 --- a/Omni/Log.py +++ b/Omni/Log.py @@ -13,7 +13,7 @@ class LowerFormatter(logging.Formatter): return super().format(record) -def setup(level: int = logging.INFO) -> logging.Logger: +def setup(logger: logging.Logger, level: int = logging.INFO) -> logging.Logger: """Run this in your `main()` function.""" logging.basicConfig( level=level, @@ -22,7 +22,6 @@ def setup(level: int = logging.INFO) -> logging.Logger: logging.addLevelName(logging.DEBUG, "dbug") logging.addLevelName(logging.ERROR, "fail") logging.addLevelName(logging.INFO, "info") - logger = logging.getLogger(__name__) formatter = LowerFormatter() handler = logging.StreamHandler() handler.setFormatter(formatter) @@ -32,5 +31,6 @@ def setup(level: int = logging.INFO) -> logging.Logger: def main() -> None: """Entrypoint to test that this kinda works.""" - logger = setup() + logger = logging.getLogger(__name__) + setup(logger) logger.debug("i am doing testing") diff --git a/Omni/Log/Concurrent.hs b/Omni/Log/Concurrent.hs new file mode 100644 index 0000000..77131ef --- /dev/null +++ b/Omni/Log/Concurrent.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Concurrent logging with multi-line output support +module Omni.Log.Concurrent + ( LineManager, + BuildState (..), + withLineManager, + initializeLines, + updateLine, + updateLineState, + ) +where + +import Alpha +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.Map as Map +import qualified Data.Text as Text +import Omni.Log.Terminal (OutputMode (..), TerminalInfo (..), detectTerminal, truncateToWidth) +import Omni.Namespace (Namespace) +import qualified Omni.Namespace as Namespace +import Rainbow (chunk, fore, green, red, white, yellow) +import qualified Rainbow +import qualified System.Console.ANSI as ANSI +import qualified System.IO as IO +import System.IO.Unsafe (unsafePerformIO) + +data BuildState = Analyzing | Pending | Building | Success | Failed | Skipped + deriving (Eq, Show) + +data LineManager = LineManager + { lmNamespaces :: [Namespace], + lmTermInfo :: TerminalInfo + } + +{-# NOINLINE currentLineManager #-} +currentLineManager :: IORef (Maybe LineManager) +currentLineManager = unsafePerformIO (newIORef Nothing) + +{-# NOINLINE namespaceLines #-} +namespaceLines :: IORef (Map Namespace Int) +namespaceLines = unsafePerformIO (newIORef Map.empty) + +-- | Tracks if the last output was transient (no newline printed) +-- When True, cleanup should not add a newline since next manager will overwrite +{-# NOINLINE lastOutputTransient #-} +lastOutputTransient :: IORef Bool +lastOutputTransient = unsafePerformIO (newIORef False) + +-- | Tracks if lines have been initialized (prevents duplicate initialization) +{-# NOINLINE linesInitialized #-} +linesInitialized :: IORef Bool +linesInitialized = unsafePerformIO (newIORef False) + +-- | Global lock for all terminal operations +-- ANSI terminal library (ncurses) is not thread-safe, so we must serialize all calls +-- to prevent segfaults during concurrent builds +{-# NOINLINE terminalLock #-} +terminalLock :: MVar () +terminalLock = unsafePerformIO (newMVar ()) + +withLineManager :: [Namespace] -> (LineManager -> IO a) -> IO a +withLineManager nss action = do + -- Check if a manager is already active (reentrant call) + existingMgr <- readIORef currentLineManager + maybe createNewManager action existingMgr + where + createNewManager = do + termInfo <- detectTerminal + + case tiMode termInfo of + SingleLine -> do + -- Single-line mode: no reservations, updates in place + let mgr = LineManager {lmNamespaces = nss, lmTermInfo = termInfo} + writeIORef currentLineManager (Just mgr) + writeIORef lastOutputTransient False + writeIORef linesInitialized False + result <- action mgr + -- Only print final newline if last output wasn't transient + -- (transient outputs expect to be overwritten by next manager) + wasTransient <- readIORef lastOutputTransient + unless wasTransient (IO.hPutStrLn IO.stderr "") + writeIORef currentLineManager Nothing + writeIORef namespaceLines Map.empty + writeIORef linesInitialized False + pure result + MultiLine -> do + -- Multi-line mode: reserve lines for each namespace + let numLines = min (length nss) (tiHeight termInfo - 2) + replicateM_ numLines (IO.hPutStrLn IO.stderr "") + withMVar terminalLock <| \_ -> ANSI.hCursorUp IO.stderr numLines + + let mgr = LineManager {lmNamespaces = nss, lmTermInfo = termInfo} + writeIORef currentLineManager (Just mgr) + writeIORef linesInitialized False + + -- Initialize the namespace -> line mapping + writeIORef namespaceLines (Map.fromList <| zip nss [0 ..]) + + result <- action mgr + + IO.hPutStrLn IO.stderr "" + writeIORef currentLineManager Nothing + writeIORef namespaceLines Map.empty + writeIORef linesInitialized False + pure result + +-- | Initialize all lines with pending status +-- Only initializes once per manager session (prevents duplicate output on reentrant calls) +initializeLines :: LineManager -> IO () +initializeLines LineManager {..} = do + alreadyInit <- readIORef linesInitialized + unless alreadyInit + <| case (tiMode lmTermInfo, tiSupportsANSI lmTermInfo) of + (_, False) -> pure () -- No ANSI support, skip initialization + (SingleLine, _) -> writeIORef linesInitialized True -- Mark as done even if no-op + (MultiLine, _) -> do + writeIORef linesInitialized True + nsMap <- readIORef namespaceLines + forM_ (Map.toList nsMap) <| \(ns, _) -> + withMVar terminalLock <| \_ -> do + ANSI.hSetCursorColumn IO.stderr 0 + ANSI.hClearLine IO.stderr + let nsText = Text.pack (Namespace.toPath ns) + let msg = "[.] " <> nsText -- Pending state before analysis starts + let truncated = truncateToWidth (tiWidth lmTermInfo - 1) msg + IO.hPutStrLn IO.stderr (Text.unpack truncated) + IO.hFlush IO.stderr + +updateLine :: Namespace -> Text -> IO () +updateLine ns output = do + mMgr <- readIORef currentLineManager + case mMgr of + Nothing -> do + IO.hPutStr IO.stderr (Text.unpack <| output <> "\r") + IO.hFlush IO.stderr + Just LineManager {..} -> + case tiMode lmTermInfo of + SingleLine -> + -- Single line: update in place + -- Lock all terminal output to prevent interleaved writes + withMVar terminalLock <| \_ -> do + let nsText = Text.pack (Namespace.toPath ns) + let msg = + if Text.null output + then "[~] " <> nsText + else "[~] " <> nsText <> ": " <> output + let truncated = truncateToWidth (tiWidth lmTermInfo - 1) msg + -- Clear line and write + IO.hPutStr IO.stderr "\r" + IO.hPutStr IO.stderr (Text.unpack truncated) + -- Pad to clear previous longer text + let padding = replicate (tiWidth lmTermInfo - Text.length truncated - 1) ' ' + IO.hPutStr IO.stderr padding + IO.hPutStr IO.stderr "\r" + IO.hPutStr IO.stderr (Text.unpack truncated) + IO.hFlush IO.stderr + MultiLine -> + -- Multi-line: use reserved lines with truncation + -- Lock covers IORef read + all terminal operations to prevent races + withMVar terminalLock <| \_ -> do + nsMap <- readIORef namespaceLines + case Map.lookup ns nsMap of + Nothing -> pure () + Just lineNum -> do + let numLines = length lmNamespaces + -- Move to the target line from bottom + ANSI.hCursorUp IO.stderr (numLines - lineNum) + ANSI.hSetCursorColumn IO.stderr 0 + ANSI.hClearLine IO.stderr + let nsText = Text.pack (Namespace.toPath ns) + let msg = + if Text.null output + then "[~] " <> nsText + else "[~] " <> nsText <> ": " <> output + let truncated = truncateToWidth (tiWidth lmTermInfo - 1) msg + IO.hPutStr IO.stderr (Text.unpack truncated) + IO.hFlush IO.stderr + -- Move back to bottom + ANSI.hCursorDown IO.stderr (numLines - lineNum) + +updateLineState :: Namespace -> BuildState -> IO () +updateLineState ns buildState = do + mMgr <- readIORef currentLineManager + case mMgr of + Nothing -> pure () + Just LineManager {..} -> + case tiMode lmTermInfo of + SingleLine -> + -- Single line: show completion, keep visible for success/failure + -- Lock all terminal output to prevent interleaved writes + withMVar terminalLock <| \_ -> do + let nsText = Text.pack (Namespace.toPath ns) + let (symbol, color) = case buildState of + Success -> ("✓", green) + Failed -> ("x", red) + Skipped -> ("_", yellow) + Analyzing -> ("+", white) + Pending -> (".", white) + Building -> ("~", white) + let msg = "[" <> symbol <> "] " <> nsText + let truncated = truncateToWidth (tiWidth lmTermInfo - 1) msg + + IO.hPutStr IO.stderr "\r" + Rainbow.hPutChunks IO.stderr [fore color <| chunk truncated] + case buildState of + Success -> do + IO.hPutStrLn IO.stderr "" -- Keep successes visible + writeIORef lastOutputTransient False + Failed -> do + IO.hPutStrLn IO.stderr "" -- Keep failures visible + writeIORef lastOutputTransient False + Skipped -> do + IO.hPutStrLn IO.stderr "" -- Keep skipped visible + writeIORef lastOutputTransient False + _ -> writeIORef lastOutputTransient True -- Transient states overwrite + IO.hFlush IO.stderr + MultiLine -> + -- Multi-line: use reserved lines with truncation + -- Lock covers IORef read + all terminal operations to prevent races + withMVar terminalLock <| \_ -> do + nsMap <- readIORef namespaceLines + case Map.lookup ns nsMap of + Nothing -> pure () + Just lineNum -> do + let numLines = length lmNamespaces + ANSI.hCursorUp IO.stderr (numLines - lineNum) + ANSI.hSetCursorColumn IO.stderr 0 + ANSI.hClearLine IO.stderr + let nsText = Text.pack (Namespace.toPath ns) + let (symbol, colorFn) = case buildState of + Success -> ("✓", fore green) + Failed -> ("x", fore red) + Skipped -> ("_", fore yellow) + Analyzing -> ("+", identity) + Pending -> (".", identity) + Building -> ("~", identity) + let msg = "[" <> symbol <> "] " <> nsText + let truncated = truncateToWidth (tiWidth lmTermInfo - 1) msg + Rainbow.hPutChunks IO.stderr [colorFn <| chunk truncated] + IO.hFlush IO.stderr + ANSI.hCursorDown IO.stderr (numLines - lineNum) diff --git a/Omni/Log/Terminal.hs b/Omni/Log/Terminal.hs new file mode 100644 index 0000000..1a4c717 --- /dev/null +++ b/Omni/Log/Terminal.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Terminal detection and output mode selection +module Omni.Log.Terminal + ( TerminalInfo (..), + OutputMode (..), + detectTerminal, + truncateToWidth, + ) +where + +import Alpha +import qualified Control.Exception as Exception +import qualified Data.Text as Text +import qualified System.Console.ANSI as ANSI +import qualified System.Environment as Env + +data OutputMode + = MultiLine -- Wide terminals (≥80 cols) - reserved lines per namespace + | SingleLine -- Narrow terminals (<80 cols) - rotating single line + deriving (Eq, Show) + +data TerminalInfo = TerminalInfo + { tiWidth :: Int, + tiHeight :: Int, + tiMode :: OutputMode, + tiSupportsANSI :: Bool + } + deriving (Eq, Show) + +detectTerminal :: IO TerminalInfo +detectTerminal = do + term <- Env.lookupEnv "TERM" + area <- Env.lookupEnv "AREA" + noColor <- Env.lookupEnv "NO_COLOR" + + -- Check if we support ANSI + let supportsANSI = case (term, area, noColor) of + (_, _, Just _) -> False -- NO_COLOR set + (Just "dumb", _, _) -> False + (_, Just "Live", _) -> False -- production logs + (Nothing, _, _) -> False + _ -> True + + -- Get terminal size, catching exceptions from stdin issues + -- When NO_COLOR is set or ANSI is not supported, skip terminal size detection + -- to avoid outputting escape codes + mSize <- + if supportsANSI + then Exception.catch ANSI.getTerminalSize <| \(_ :: Exception.IOException) -> pure Nothing + else pure Nothing -- Skip if no ANSI support + let (width, height) = case mSize of + Just (h, w) -> (w, h) + Nothing -> (80, 24) -- sensible default + + -- Determine mode based on ANSI support + let mode + | not supportsANSI = SingleLine -- Fallback to single line for dumb terminals + | otherwise = MultiLine + + pure + TerminalInfo + { tiWidth = width, + tiHeight = height, + tiMode = mode, + tiSupportsANSI = supportsANSI + } + +-- | Truncate text to fit width with ellipsis +truncateToWidth :: Int -> Text -> Text +truncateToWidth maxWidth text + | Text.length text <= maxWidth = text + | maxWidth <= 3 = Text.take maxWidth text + | otherwise = Text.take (maxWidth - 3) text <> "..." diff --git a/Omni/Namespace.hs b/Omni/Namespace.hs index 5884507..a0f8a8e 100644 --- a/Omni/Namespace.hs +++ b/Omni/Namespace.hs @@ -111,7 +111,10 @@ toHaskellModule :: Namespace -> String toHaskellModule = toModule fromHaskellModule :: String -> Namespace -fromHaskellModule s = Namespace (List.splitOn "." s) Hs +fromHaskellModule s = + let s' = if ".hs" `List.isSuffixOf` s then List.take (length s - 3) s else s + s'' = map (\c -> if c == '/' then '.' else c) s' + in Namespace (List.splitOn "." s'') Hs toSchemeModule :: Namespace -> String toSchemeModule = toModule diff --git a/Omni/Os/Base.nix b/Omni/Os/Base.nix index 3464af4..0489b1c 100644 --- a/Omni/Os/Base.nix +++ b/Omni/Os/Base.nix @@ -6,7 +6,8 @@ in { boot.tmp.cleanOnBoot = true; networking.firewall.allowPing = true; networking.firewall.allowedTCPPorts = [ports.et]; - nix.settings.substituters = ["https://cache.nixos.org"]; # "ssh://dev.bensima.com" ]; + nix.settings.substituters = ["https://cache.nixos.org" "https://nix-community.cachix.org"]; # "ssh://dev.bensima.com" ]; + nix.settings.trusted-public-keys = ["nix-community.cachix.org-1:mB9FSh9qf2dCimDSUo8Zy7bkq5CX+/rkCWyvRCYg3Fs="]; nix.gc.automatic = true; nix.gc.dates = "Sunday 02:15"; nix.optimise.automatic = true; diff --git a/Omni/Repl.py b/Omni/Repl.py index d7d2fb4..49b6c1e 100755 --- a/Omni/Repl.py +++ b/Omni/Repl.py @@ -20,8 +20,8 @@ additional files to load. import importlib import importlib.util import inspect +import logging import mypy.api -import Omni.Log as Log import os import pathlib import pydoc @@ -33,7 +33,7 @@ import types import typing import unittest -LOG = Log.setup() +LOG = logging.getLogger(__name__) class ReplError(Exception): @@ -246,7 +246,6 @@ def test() -> None: def move() -> None: """Actual entrypoint.""" - Log.setup() ns = sys.argv[1] path = sys.argv[2] editor = os.environ.get("EDITOR", "$EDITOR") diff --git a/Omni/Task.hs b/Omni/Task.hs new file mode 100644 index 0000000..c6e68ac --- /dev/null +++ b/Omni/Task.hs @@ -0,0 +1,1014 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- : dep sqlite-simple +module Omni.Task where + +import Alpha +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.Text as T +import qualified Omni.Cli as Cli +import qualified Omni.Namespace as Namespace +import Omni.Task.Core +import qualified Omni.Task.MigrationTest as MigrationTest +import qualified Omni.Task.RaceTest as RaceTest +import qualified Omni.Test as Test +import qualified System.Console.Docopt as Docopt +import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) +import System.Environment (setEnv) +import qualified Test.Tasty as Tasty +import Web.HttpApiData (parseQueryParam) +import Prelude (read) + +main :: IO () +main = Cli.main plan + +plan :: Cli.Plan () +plan = + Cli.Plan + { help = help, + move = move, + test = test, + tidy = \_ -> pure () + } + +help :: Cli.Docopt +help = + [Cli.docopt| +task + +Usage: + task init [--quiet] + task create <title> [options] + task edit <id> [options] + task delete <id> [--json] + task comment <id> <message> [--json] + task list [options] + task ready [--json] + task show <id> [--json] + task update <id> <status> [options] [--verified] + task deps <id> [--json] + task tree [<id>] [--json] + task progress <id> [--json] + task stats [--epic=<id>] [--json] + task export [-o <file>] + task import -i <file> + task test + task (-h | --help) + +Commands: + init Initialize task database + create Create a new task or epic + edit Edit an existing task + delete Delete a task + comment Add a comment to a task + list List all tasks + ready Show ready tasks (not blocked) + show Show detailed task information + update Update task status + deps Show dependency tree + tree Show task tree (epics with children, or all epics if no ID given) + progress Show progress for an epic + stats Show task statistics + export Export tasks to JSONL + import Import tasks from JSONL file + test Run tests + +Options: + -h --help Show this help + --title=<title> Task title + --type=<type> Task type: epic, task, or human (default: task) + --parent=<id> Parent epic ID + --priority=<p> Priority: 0-4 (0=critical, 4=backlog, default: 2) + --complexity=<c> Complexity: 1-5 for model selection (1=trivial, 5=expert) + --status=<status> Filter by status: draft, open, in-progress, review, approved, done + --epic=<id> Filter stats by epic (recursive) + --deps=<ids> Comma-separated list of dependency IDs + --dep-type=<type> Dependency type: blocks, discovered-from, parent-child, related + --discovered-from=<id> Shortcut for --deps=<id> --dep-type=discovered-from + --namespace=<ns> Optional namespace (e.g., Omni/Task, Biz/Cloud) + --description=<desc> Task description + --db=<file> Path to SQLite database (overrides TASK_DB_PATH) + --flush Force immediate export + --json Output in JSON format (for agent use) + --quiet Non-interactive mode (for agents) + --verified Mark task as verified (code compiles, tests pass, feature works) + -i <file> Input file for import + -o <file> Output file for export + +Arguments: + <title> Task title + <id> Task ID + <status> Task status (draft, open, in-progress, review, approved, done) + <message> Comment message + <file> JSONL file to import +|] + +-- Helper to check if JSON output is requested +isJsonMode :: Cli.Arguments -> Bool +isJsonMode args = args `Cli.has` Cli.longOption "json" + +-- Helper to output JSON +outputJson :: (Aeson.ToJSON a) => a -> IO () +outputJson val = BLC.putStrLn <| Aeson.encode val + +-- Helper for success message in JSON +outputSuccess :: Text -> IO () +outputSuccess msg = outputJson <| Aeson.object ["success" Aeson..= True, "message" Aeson..= msg] + +move :: Cli.Arguments -> IO () +move args = do + -- Handle --db flag globally + for_ + (Cli.getArg args (Cli.longOption "db")) + (setEnv "TASK_DB_PATH") + + move' args + +move' :: Cli.Arguments -> IO () +move' args + | args `Cli.has` Cli.command "init" = do + let quiet = args `Cli.has` Cli.longOption "quiet" + initTaskDb + unless quiet <| putText "Task database initialized. Use 'task create' to add tasks." + | args `Cli.has` Cli.command "create" = do + title <- getArgText args "title" + taskType <- case Cli.getArg args (Cli.longOption "type") of + Nothing -> pure WorkTask + Just "epic" -> pure Epic + Just "task" -> pure WorkTask + Just "human" -> pure HumanTask + Just other -> panic <| "Invalid task type: " <> T.pack other <> ". Use: epic, task, or human" + parent <- case Cli.getArg args (Cli.longOption "parent") of + Nothing -> pure Nothing + Just p -> pure <| Just (T.pack p) + + -- Handle --discovered-from as shortcut + (depIds, depType) <- case Cli.getArg args (Cli.longOption "discovered-from") of + Just discoveredId -> pure ([T.pack discoveredId], DiscoveredFrom) + Nothing -> do + -- Parse regular --deps and --dep-type + ids <- case Cli.getArg args (Cli.longOption "deps") of + Nothing -> pure [] + Just depStr -> pure <| T.splitOn "," (T.pack depStr) + dtype <- case Cli.getArg args (Cli.longOption "dep-type") of + Nothing -> pure Blocks + Just "blocks" -> pure Blocks + Just "discovered-from" -> pure DiscoveredFrom + Just "parent-child" -> pure ParentChild + Just "related" -> pure Related + Just other -> panic <| "Invalid dependency type: " <> T.pack other <> ". Use: blocks, discovered-from, parent-child, or related" + pure (ids, dtype) + + let deps = map (\did -> Dependency {depId = did, depType = depType}) depIds + + -- Parse priority (default to P2 = medium) + priority <- case Cli.getArg args (Cli.longOption "priority") of + Nothing -> pure P2 + Just "0" -> pure P0 + Just "1" -> pure P1 + Just "2" -> pure P2 + Just "3" -> pure P3 + Just "4" -> pure P4 + Just other -> panic <| "Invalid priority: " <> T.pack other <> ". Use: 0-4" + + -- Parse complexity (1-5 scale) + complexity <- case Cli.getArg args (Cli.longOption "complexity") of + Nothing -> pure Nothing + Just c -> case readMaybe c of + Just n | n >= 1 && n <= 5 -> pure (Just n) + _ -> panic <| "Invalid complexity: " <> T.pack c <> ". Use: 1-5" + + namespace <- case Cli.getArg args (Cli.longOption "namespace") of + Nothing -> pure Nothing + Just ns -> do + -- Validate it's a proper namespace by parsing it + let validNs = Namespace.fromHaskellModule ns + nsPath = T.pack <| Namespace.toPath validNs + pure <| Just nsPath + + description <- case Cli.getArg args (Cli.longOption "description") of + Nothing -> panic "--description is required for task create" + Just d -> pure (T.pack d) + + createdTask <- createTask title taskType parent namespace priority complexity deps description + if isJsonMode args + then outputJson createdTask + else putStrLn <| "Created task: " <> T.unpack (taskId createdTask) + | args `Cli.has` Cli.command "edit" = do + tid <- getArgText args "id" + + -- Parse optional edits + maybeTitle <- pure <| Cli.getArg args (Cli.longOption "title") + maybeType <- case Cli.getArg args (Cli.longOption "type") of + Nothing -> pure Nothing + Just "epic" -> pure <| Just Epic + Just "task" -> pure <| Just WorkTask + Just other -> panic <| "Invalid task type: " <> T.pack other <> ". Use: epic or task" + maybeParent <- pure <| fmap T.pack (Cli.getArg args (Cli.longOption "parent")) + maybePriority <- case Cli.getArg args (Cli.longOption "priority") of + Nothing -> pure Nothing + Just "0" -> pure <| Just P0 + Just "1" -> pure <| Just P1 + Just "2" -> pure <| Just P2 + Just "3" -> pure <| Just P3 + Just "4" -> pure <| Just P4 + Just other -> panic <| "Invalid priority: " <> T.pack other <> ". Use: 0-4" + maybeComplexity <- case Cli.getArg args (Cli.longOption "complexity") of + Nothing -> pure Nothing + Just c -> case readMaybe c of + Just n | n >= 1 && n <= 5 -> pure (Just (Just n)) + _ -> panic <| "Invalid complexity: " <> T.pack c <> ". Use: 1-5" + maybeStatus <- case Cli.getArg args (Cli.longOption "status") of + Nothing -> pure Nothing + Just "draft" -> pure <| Just Draft + Just "open" -> pure <| Just Open + Just "in-progress" -> pure <| Just InProgress + Just "review" -> pure <| Just Review + Just "done" -> pure <| Just Done + Just other -> panic <| "Invalid status: " <> T.pack other <> ". Use: draft, open, in-progress, review, or done" + maybeNamespace <- case Cli.getArg args (Cli.longOption "namespace") of + Nothing -> pure Nothing + Just ns -> do + let validNs = Namespace.fromHaskellModule ns + nsPath = T.pack <| Namespace.toPath validNs + pure <| Just nsPath + maybeDesc <- pure <| fmap T.pack (Cli.getArg args (Cli.longOption "description")) + + maybeDeps <- case Cli.getArg args (Cli.longOption "discovered-from") of + Just discoveredId -> pure <| Just [Dependency {depId = T.pack discoveredId, depType = DiscoveredFrom}] + Nothing -> case Cli.getArg args (Cli.longOption "deps") of + Nothing -> pure Nothing + Just depStr -> do + let ids = T.splitOn "," (T.pack depStr) + dtype <- case Cli.getArg args (Cli.longOption "dep-type") of + Nothing -> pure Blocks + Just "blocks" -> pure Blocks + Just "discovered-from" -> pure DiscoveredFrom + Just "parent-child" -> pure ParentChild + Just "related" -> pure Related + Just other -> panic <| "Invalid dependency type: " <> T.pack other + pure <| Just (map (\did -> Dependency {depId = did, depType = dtype}) ids) + + let modifyFn task = + task + { taskTitle = maybe (taskTitle task) T.pack maybeTitle, + taskType = fromMaybe (taskType task) maybeType, + taskParent = case maybeParent of Nothing -> taskParent task; Just p -> Just p, + taskNamespace = case maybeNamespace of Nothing -> taskNamespace task; Just ns -> Just ns, + taskStatus = fromMaybe (taskStatus task) maybeStatus, + taskPriority = fromMaybe (taskPriority task) maybePriority, + taskComplexity = fromMaybe (taskComplexity task) maybeComplexity, + taskDescription = fromMaybe (taskDescription task) maybeDesc, + taskDependencies = fromMaybe (taskDependencies task) maybeDeps + } + + updatedTask <- editTask tid modifyFn + if isJsonMode args + then outputJson updatedTask + else putStrLn <| "Updated task: " <> T.unpack (taskId updatedTask) + | args `Cli.has` Cli.command "delete" = do + tid <- getArgText args "id" + deleteTask tid + if isJsonMode args + then outputSuccess ("Deleted task " <> tid) + else putStrLn <| "Deleted task: " <> T.unpack tid + | args `Cli.has` Cli.command "comment" = do + tid <- getArgText args "id" + message <- getArgText args "message" + updatedTask <- addComment tid message + if isJsonMode args + then outputJson updatedTask + else putStrLn <| "Added comment to task: " <> T.unpack tid + | args `Cli.has` Cli.command "list" = do + maybeType <- case Cli.getArg args (Cli.longOption "type") of + Nothing -> pure Nothing + Just "epic" -> pure <| Just Epic + Just "task" -> pure <| Just WorkTask + Just "human" -> pure <| Just HumanTask + Just other -> panic <| "Invalid task type: " <> T.pack other + maybeParent <- case Cli.getArg args (Cli.longOption "parent") of + Nothing -> pure Nothing + Just p -> pure <| Just (T.pack p) + maybeStatus <- case Cli.getArg args (Cli.longOption "status") of + Nothing -> pure Nothing + Just "draft" -> pure <| Just Draft + Just "open" -> pure <| Just Open + Just "in-progress" -> pure <| Just InProgress + Just "review" -> pure <| Just Review + Just "approved" -> pure <| Just Approved + Just "done" -> pure <| Just Done + Just other -> panic <| "Invalid status: " <> T.pack other <> ". Use: draft, open, in-progress, review, approved, or done" + maybeNamespace <- case Cli.getArg args (Cli.longOption "namespace") of + Nothing -> pure Nothing + Just ns -> do + let validNs = Namespace.fromHaskellModule ns + nsPath = T.pack <| Namespace.toPath validNs + pure <| Just nsPath + tasks <- listTasks maybeType maybeParent maybeStatus maybeNamespace + if isJsonMode args + then outputJson tasks + else traverse_ printTask tasks + | args `Cli.has` Cli.command "ready" = do + tasks <- getReadyTasks + if isJsonMode args + then outputJson tasks + else do + putText "Ready tasks:" + traverse_ printTask tasks + | args `Cli.has` Cli.command "show" = do + tid <- getArgText args "id" + tasks <- loadTasks + case findTask tid tasks of + Nothing -> putText "Task not found" + Just task -> + if isJsonMode args + then outputJson task + else showTaskDetailed task + | args `Cli.has` Cli.command "update" = do + tid <- getArgText args "id" + statusStr <- getArgText args "status" + let isVerified = args `Cli.has` Cli.longOption "verified" + + -- Handle update dependencies + deps <- do + -- Parse --deps and --dep-type + ids <- case Cli.getArg args (Cli.longOption "deps") of + Nothing -> pure [] + Just depStr -> pure <| T.splitOn "," (T.pack depStr) + dtype <- case Cli.getArg args (Cli.longOption "dep-type") of + Nothing -> pure Blocks + Just "blocks" -> pure Blocks + Just "discovered-from" -> pure DiscoveredFrom + Just "parent-child" -> pure ParentChild + Just "related" -> pure Related + Just other -> panic <| "Invalid dependency type: " <> T.pack other <> ". Use: blocks, discovered-from, parent-child, or related" + pure (map (\d -> Dependency {depId = d, depType = dtype}) ids) + + let newStatus = case statusStr of + "draft" -> Draft + "open" -> Open + "in-progress" -> InProgress + "review" -> Review + "approved" -> Approved + "done" -> Done + _ -> panic "Invalid status. Use: draft, open, in-progress, review, approved, or done" + + -- Show verification checklist warning when marking Done without --verified + when (newStatus == Done && not isVerified && not (isJsonMode args)) <| do + putText "" + putText "⚠️ VERIFICATION CHECKLIST (use --verified to skip):" + putText " [ ] Code compiles (bild succeeds)" + putText " [ ] Tests pass (bild --test)" + putText " [ ] Feature works in production (manual verification)" + putText "" + + updateTaskStatus tid newStatus deps + + -- Record verification in activity log if verified + when (newStatus == Done && isVerified) + <| logActivity tid Completed (Just "{\"verified\":true}") + + if isJsonMode args + then + if newStatus == Done && isVerified + then outputJson <| Aeson.object ["success" Aeson..= True, "message" Aeson..= ("Updated task " <> tid), "verified" Aeson..= True] + else outputSuccess <| "Updated task " <> tid + else + if newStatus == Done && isVerified + then putStrLn <| "Updated task " <> T.unpack tid <> " (verified ✓)" + else putStrLn <| "Updated task " <> T.unpack tid + | args `Cli.has` Cli.command "deps" = do + tid <- getArgText args "id" + if isJsonMode args + then do + deps <- getDependencyTree tid + outputJson deps + else showDependencyTree tid + | args `Cli.has` Cli.command "tree" = do + maybeId <- case Cli.getArg args (Cli.argument "id") of + Nothing -> pure Nothing + Just idStr -> pure <| Just (T.pack idStr) + if isJsonMode args + then do + tree <- getTaskTree maybeId + outputJson tree + else showTaskTree maybeId + | args `Cli.has` Cli.command "progress" = do + tid <- getArgText args "id" + if isJsonMode args + then do + progress <- getTaskProgress tid + outputJson progress + else showTaskProgress tid + | args `Cli.has` Cli.command "stats" = do + maybeEpic <- case Cli.getArg args (Cli.longOption "epic") of + Nothing -> pure Nothing + Just e -> pure <| Just (T.pack e) + if isJsonMode args + then do + stats <- getTaskStats maybeEpic + outputJson stats + else showTaskStats maybeEpic + | args `Cli.has` Cli.command "export" = do + file <- case Cli.getArg args (Cli.shortOption 'o') of + Nothing -> pure Nothing + Just f -> pure (Just f) + exportTasks file + case file of + Just f -> putText <| "Exported tasks to " <> T.pack f + Nothing -> pure () + | args `Cli.has` Cli.command "import" = do + -- Note: -i <file> means the value is stored in option 'i', not argument "file" + file <- case Cli.getArg args (Cli.shortOption 'i') of + Nothing -> panic "import requires -i <file>" + Just f -> pure (T.pack f) + importTasks (T.unpack file) + putText <| "Imported tasks from " <> file + | otherwise = putText (T.pack <| Cli.usage help) + where + getArgText :: Cli.Arguments -> String -> IO Text + getArgText argz name = do + maybeArg <- pure <| Cli.getArg argz (Cli.argument name) + case maybeArg of + Nothing -> panic (T.pack name <> " required") + Just val -> pure (T.pack val) + +test :: Test.Tree +test = + Test.group + "Omni.Task" + [ unitTests, + cliTests, + Tasty.after Tasty.AllSucceed "Unit tests" RaceTest.test, + Tasty.after Tasty.AllSucceed "Unit tests" MigrationTest.test + ] + +unitTests :: Test.Tree +unitTests = + Test.group + "Unit tests" + [ Test.unit "setup test database" <| do + -- Set up test mode for all tests (uses _/tmp/tasks-test.db) + setEnv "TASK_TEST_MODE" "1" + + -- Clean up test database before all tests + let testFile = "_/tmp/tasks-test.db" + createDirectoryIfMissing True "_/tmp" + exists <- doesFileExist testFile + when exists <| removeFile testFile + initTaskDb + True Test.@?= True, + Test.unit "can create task" <| do + task <- createTask "Test task" WorkTask Nothing Nothing P2 Nothing [] "Test description" + taskTitle task Test.@?= "Test task" + taskType task Test.@?= WorkTask + taskStatus task Test.@?= Open + taskPriority task Test.@?= P2 + null (taskDependencies task) Test.@?= True, + Test.unit "can create human task" <| do + task <- createTask "Human Task" HumanTask Nothing Nothing P2 Nothing [] "Human task description" + taskType task Test.@?= HumanTask, + Test.unit "ready tasks exclude human tasks" <| do + task <- createTask "Human Task" HumanTask Nothing Nothing P2 Nothing [] "Human task" + ready <- getReadyTasks + (taskId task `notElem` map taskId ready) Test.@?= True, + Test.unit "ready tasks exclude draft tasks" <| do + task <- createTask "Draft Task" WorkTask Nothing Nothing P2 Nothing [] "Draft description" + updateTaskStatus (taskId task) Draft [] + ready <- getReadyTasks + (taskId task `notElem` map taskId ready) Test.@?= True, + Test.unit "can create task with description" <| do + task <- createTask "Test task" WorkTask Nothing Nothing P2 Nothing [] "My description" + taskDescription task Test.@?= "My description", + Test.unit "can create task with complexity" <| do + task <- createTask "Complex task" WorkTask Nothing Nothing P2 (Just 4) [] "High complexity task" + taskComplexity task Test.@?= Just 4, + Test.unit "complexity is persisted" <| do + task <- createTask "Persisted complexity" WorkTask Nothing Nothing P2 (Just 3) [] "Medium complexity" + tasks <- loadTasks + case findTask (taskId task) tasks of + Nothing -> Test.assertFailure "Could not reload task" + Just reloaded -> taskComplexity reloaded Test.@?= Just 3, + Test.unit "can list tasks" <| do + _ <- createTask "Test task for list" WorkTask Nothing Nothing P2 Nothing [] "List test" + tasks <- listTasks Nothing Nothing Nothing Nothing + not (null tasks) Test.@?= True, + Test.unit "ready tasks exclude blocked ones" <| do + task1 <- createTask "First task" WorkTask Nothing Nothing P2 Nothing [] "First description" + let blockingDep = Dependency {depId = taskId task1, depType = Blocks} + task2 <- createTask "Blocked task" WorkTask Nothing Nothing P2 Nothing [blockingDep] "Blocked description" + ready <- getReadyTasks + (taskId task1 `elem` map taskId ready) Test.@?= True + (taskId task2 `notElem` map taskId ready) Test.@?= True, + Test.unit "discovered-from dependencies don't block" <| do + task1 <- createTask "Original task" WorkTask Nothing Nothing P2 Nothing [] "Original" + let discDep = Dependency {depId = taskId task1, depType = DiscoveredFrom} + task2 <- createTask "Discovered work" WorkTask Nothing Nothing P2 Nothing [discDep] "Discovered" + ready <- getReadyTasks + -- Both should be ready since DiscoveredFrom doesn't block + (taskId task1 `elem` map taskId ready) Test.@?= True + (taskId task2 `elem` map taskId ready) Test.@?= True, + Test.unit "related dependencies don't block" <| do + task1 <- createTask "Task A" WorkTask Nothing Nothing P2 Nothing [] "Task A description" + let relDep = Dependency {depId = taskId task1, depType = Related} + task2 <- createTask "Task B" WorkTask Nothing Nothing P2 Nothing [relDep] "Task B description" + ready <- getReadyTasks + -- Both should be ready since Related doesn't block + (taskId task1 `elem` map taskId ready) Test.@?= True + (taskId task2 `elem` map taskId ready) Test.@?= True, + Test.unit "ready tasks exclude epics" <| do + epic <- createTask "Epic task" Epic Nothing Nothing P2 Nothing [] "Epic description" + ready <- getReadyTasks + (taskId epic `notElem` map taskId ready) Test.@?= True, + Test.unit "ready tasks exclude tasks needing intervention (retry >= 3)" <| do + task <- createTask "Failing task" WorkTask Nothing Nothing P2 Nothing [] "Failing description" + ready1 <- getReadyTasks + (taskId task `elem` map taskId ready1) Test.@?= True + setRetryContext + RetryContext + { retryTaskId = taskId task, + retryOriginalCommit = "abc123", + retryConflictFiles = [], + retryAttempt = 3, + retryReason = "test_failure", + retryNotes = Nothing + } + ready2 <- getReadyTasks + (taskId task `notElem` map taskId ready2) Test.@?= True, + Test.unit "child task gets sequential ID" <| do + parent <- createTask "Parent" Epic Nothing Nothing P2 Nothing [] "Parent epic" + child1 <- createTask "Child 1" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 1 description" + child2 <- createTask "Child 2" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 2 description" + taskId child1 Test.@?= taskId parent <> ".1" + taskId child2 Test.@?= taskId parent <> ".2", + Test.unit "grandchild task gets sequential ID" <| do + parent <- createTask "Grandparent" Epic Nothing Nothing P2 Nothing [] "Grandparent epic" + child <- createTask "Parent" Epic (Just (taskId parent)) Nothing P2 Nothing [] "Parent epic" + grandchild <- createTask "Grandchild" WorkTask (Just (taskId child)) Nothing P2 Nothing [] "Grandchild task" + taskId grandchild Test.@?= taskId parent <> ".1.1", + Test.unit "siblings of grandchild task get sequential ID" <| do + parent <- createTask "Grandparent" Epic Nothing Nothing P2 Nothing [] "Grandparent" + child <- createTask "Parent" Epic (Just (taskId parent)) Nothing P2 Nothing [] "Parent" + grandchild1 <- createTask "Grandchild 1" WorkTask (Just (taskId child)) Nothing P2 Nothing [] "Grandchild 1" + grandchild2 <- createTask "Grandchild 2" WorkTask (Just (taskId child)) Nothing P2 Nothing [] "Grandchild 2" + taskId grandchild1 Test.@?= taskId parent <> ".1.1" + taskId grandchild2 Test.@?= taskId parent <> ".1.2", + Test.unit "child ID generation skips gaps" <| do + parent <- createTask "Parent with gaps" Epic Nothing Nothing P2 Nothing [] "Parent with gaps" + child1 <- createTask "Child 1" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 1" + -- Manually create a task with .3 suffix to simulate a gap (or deleted task) + let child3Id = taskId parent <> ".3" + child3 = + Task + { taskId = child3Id, + taskTitle = "Child 3", + taskType = WorkTask, + taskParent = Just (taskId parent), + taskNamespace = Nothing, + taskStatus = Open, + taskPriority = P2, + taskComplexity = Nothing, + taskDependencies = [], + taskDescription = "Child 3", + taskComments = [], + taskCreatedAt = taskCreatedAt child1, + taskUpdatedAt = taskUpdatedAt child1 + } + saveTask child3 + + -- Create a new child, it should get .4, not .2 + child4 <- createTask "Child 4" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 4" + taskId child4 Test.@?= taskId parent <> ".4", + Test.unit "can edit task" <| do + task <- createTask "Original Title" WorkTask Nothing Nothing P2 Nothing [] "Original" + let modifyFn t = t {taskTitle = "New Title", taskPriority = P0} + updated <- editTask (taskId task) modifyFn + taskTitle updated Test.@?= "New Title" + taskPriority updated Test.@?= P0 + -- Check persistence + tasks <- loadTasks + case findTask (taskId task) tasks of + Nothing -> Test.assertFailure "Could not reload task" + Just reloaded -> do + taskTitle reloaded Test.@?= "New Title" + taskPriority reloaded Test.@?= P0, + Test.unit "task lookup is case insensitive" <| do + task <- createTask "Case sensitive" WorkTask Nothing Nothing P2 Nothing [] "Case sensitive description" + let tid = taskId task + upperTid = T.toUpper tid + tasks <- loadTasks + let found = findTask upperTid tasks + case found of + Just t -> taskId t Test.@?= tid + Nothing -> Test.assertFailure "Could not find task with upper case ID", + Test.unit "namespace normalization handles .hs suffix" <| do + let ns = "Omni/Task.hs" + validNs = Namespace.fromHaskellModule ns + Namespace.toPath validNs Test.@?= "Omni/Task.hs", + Test.unit "generated IDs are lowercase" <| do + task <- createTask "Lowercase check" WorkTask Nothing Nothing P2 Nothing [] "Lowercase description" + let tid = taskId task + tid Test.@?= T.toLower tid + -- check it matches regex for base36 (t-[0-9a-z]+) + let isLowerBase36 = T.all (\c -> c `elem` ['0' .. '9'] ++ ['a' .. 'z'] || c == 't' || c == '-') tid + isLowerBase36 Test.@?= True, + Test.unit "dependencies are case insensitive" <| do + task1 <- createTask "Blocker" WorkTask Nothing Nothing P2 Nothing [] "Blocker description" + let tid1 = taskId task1 + -- Use uppercase ID for dependency + upperTid1 = T.toUpper tid1 + dep = Dependency {depId = upperTid1, depType = Blocks} + task2 <- createTask "Blocked" WorkTask Nothing Nothing P2 Nothing [dep] "Blocked description" + + -- task1 is Open, so task2 should NOT be ready + ready <- getReadyTasks + (taskId task2 `notElem` map taskId ready) Test.@?= True + + updateTaskStatus tid1 Done [] + + -- task2 should now be ready because dependency check normalizes IDs + ready2 <- getReadyTasks + (taskId task2 `elem` map taskId ready2) Test.@?= True, + Test.unit "can create task with lowercase ID" <| do + -- This verifies that lowercase IDs are accepted and not rejected + let lowerId = "t-lowercase" + let task = Task lowerId "Lower" WorkTask Nothing Nothing Open P2 Nothing [] "Lower description" [] (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC") + saveTask task + tasks <- loadTasks + case findTask lowerId tasks of + Just t -> taskId t Test.@?= lowerId + Nothing -> Test.assertFailure "Should find task with lowercase ID", + Test.unit "generateId produces valid ID" <| do + tid <- generateId + let task = Task tid "Auto" WorkTask Nothing Nothing Open P2 Nothing [] "Auto description" [] (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC") + saveTask task + tasks <- loadTasks + case findTask tid tasks of + Just _ -> pure () + Nothing -> Test.assertFailure "Should find generated task", + Test.unit "generateId produces sequential IDs" <| do + tid1 <- generateId + tid2 <- generateId + tid3 <- generateId + T.isPrefixOf "t-" tid1 Test.@?= True + T.isPrefixOf "t-" tid2 Test.@?= True + T.isPrefixOf "t-" tid3 Test.@?= True + let num1 = readMaybe (T.unpack (T.drop 2 tid1)) :: Maybe Int + num2 = readMaybe (T.unpack (T.drop 2 tid2)) :: Maybe Int + num3 = readMaybe (T.unpack (T.drop 2 tid3)) :: Maybe Int + case (num1, num2, num3) of + (Just n1, Just n2, Just n3) -> do + (n2 == n1 + 1) Test.@?= True + (n3 == n2 + 1) Test.@?= True + _ -> Test.assertFailure "IDs should be sequential integers", + Test.unit "lowercase ID does not clash with existing uppercase ID" <| do + -- Setup: Create task with Uppercase ID + let upperId = "t-UPPER" + let task1 = Task upperId "Upper Task" WorkTask Nothing Nothing Open P2 Nothing [] "Upper description" [] (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC") + saveTask task1 + + -- Action: Try to create task with Lowercase ID (same letters) + -- Note: In the current implementation, saveTask blindly appends. + -- Ideally, we should be checking for existence if we want to avoid clash. + -- OR, we accept that they are the SAME task and this is an update? + -- But if they are different tasks (different titles, created at different times), + -- treating them as the same is dangerous. + + let lowerId = "t-upper" + let task2 = Task lowerId "Lower Task" WorkTask Nothing Nothing Open P2 Nothing [] "Lower description" [] (read "2025-01-01 00:00:01 UTC") (read "2025-01-01 00:00:01 UTC") + saveTask task2 + + tasks <- loadTasks + -- What do we expect? + -- If we expect them to be distinct: + -- let foundUpper = List.find (\t -> taskId t == upperId) tasks + -- let foundLower = List.find (\t -> taskId t == lowerId) tasks + -- foundUpper /= Nothing + -- foundLower /= Nothing + + -- BUT findTask uses case-insensitive search. + -- So findTask upperId returns task1 (probably, as it's first). + -- findTask lowerId returns task1. + -- task2 is effectively hidden/lost to findTask. + + -- So, "do not clash" implies we shouldn't end up in this state. + -- The test should probably fail if we have multiple tasks that match the same ID case-insensitively. + + let matches = filter (\t -> matchesId (taskId t) upperId) tasks + length matches Test.@?= 2, + Test.unit "FromHttpApiData Priority: empty string returns Left" <| do + let result = parseQueryParam "" :: Either Text Priority + case result of + Left _ -> pure () + Right _ -> Test.assertFailure "Empty string should return Left", + Test.unit "FromHttpApiData Priority: valid values parse correctly" <| do + (parseQueryParam "P0" :: Either Text Priority) Test.@?= Right P0 + (parseQueryParam "P1" :: Either Text Priority) Test.@?= Right P1 + (parseQueryParam "P2" :: Either Text Priority) Test.@?= Right P2 + (parseQueryParam "P3" :: Either Text Priority) Test.@?= Right P3 + (parseQueryParam "P4" :: Either Text Priority) Test.@?= Right P4, + Test.unit "FromHttpApiData Status: empty string returns Left" <| do + let result = parseQueryParam "" :: Either Text Status + case result of + Left _ -> pure () + Right _ -> Test.assertFailure "Empty string should return Left", + Test.unit "FromHttpApiData Status: valid values parse correctly" <| do + (parseQueryParam "Open" :: Either Text Status) Test.@?= Right Open + (parseQueryParam "InProgress" :: Either Text Status) Test.@?= Right InProgress + (parseQueryParam "Done" :: Either Text Status) Test.@?= Right Done, + Test.unit "can add comment to task" <| do + task <- createTask "Task with comment" WorkTask Nothing Nothing P2 Nothing [] "Description" + updatedTask <- addComment (taskId task) "This is a test comment" + length (taskComments updatedTask) Test.@?= 1 + case taskComments updatedTask of + (c : _) -> commentText c Test.@?= "This is a test comment" + [] -> Test.assertFailure "Expected at least one comment", + Test.unit "can add multiple comments to task" <| do + task <- createTask "Task with comments" WorkTask Nothing Nothing P2 Nothing [] "Description" + _ <- addComment (taskId task) "First comment" + updatedTask <- addComment (taskId task) "Second comment" + length (taskComments updatedTask) Test.@?= 2 + case taskComments updatedTask of + (c1 : c2 : _) -> do + commentText c1 Test.@?= "First comment" + commentText c2 Test.@?= "Second comment" + _ -> Test.assertFailure "Expected at least two comments", + Test.unit "comments are persisted" <| do + task <- createTask "Persistent comments" WorkTask Nothing Nothing P2 Nothing [] "Description" + _ <- addComment (taskId task) "Persisted comment" + tasks <- loadTasks + case findTask (taskId task) tasks of + Nothing -> Test.assertFailure "Could not reload task" + Just reloaded -> do + length (taskComments reloaded) Test.@?= 1 + case taskComments reloaded of + (c : _) -> commentText c Test.@?= "Persisted comment" + [] -> Test.assertFailure "Expected at least one comment" + ] + +-- | Test CLI argument parsing to ensure docopt string matches actual usage +cliTests :: Test.Tree +cliTests = + Test.group + "CLI argument parsing" + [ Test.unit "init command" <| do + let result = Docopt.parseArgs help ["init"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'init': " <> show err + Right args -> args `Cli.has` Cli.command "init" Test.@?= True, + Test.unit "init with --quiet flag" <| do + let result = Docopt.parseArgs help ["init", "--quiet"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'init --quiet': " <> show err + Right args -> do + args `Cli.has` Cli.command "init" Test.@?= True + args `Cli.has` Cli.longOption "quiet" Test.@?= True, + Test.unit "create with title" <| do + let result = Docopt.parseArgs help ["create", "Test task"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + Cli.getArg args (Cli.argument "title") Test.@?= Just "Test task", + Test.unit "create with --json flag" <| do + let result = Docopt.parseArgs help ["create", "Test", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "create with --namespace flag" <| do + let result = Docopt.parseArgs help ["create", "Test", "--namespace=Omni/Task"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create --namespace': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + Cli.getArg args (Cli.longOption "namespace") Test.@?= Just "Omni/Task", + Test.unit "create with --discovered-from flag" <| do + let result = Docopt.parseArgs help ["create", "Test", "--discovered-from=t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create --discovered-from': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + Cli.getArg args (Cli.longOption "discovered-from") Test.@?= Just "t-abc123", + Test.unit "create with --priority flag" <| do + let result = Docopt.parseArgs help ["create", "Test", "--priority=1"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create --priority': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + Cli.getArg args (Cli.longOption "priority") Test.@?= Just "1", + Test.unit "create with --complexity flag" <| do + let result = Docopt.parseArgs help ["create", "Test", "--complexity=3"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create --complexity': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + Cli.getArg args (Cli.longOption "complexity") Test.@?= Just "3", + Test.unit "edit with --complexity flag" <| do + let result = Docopt.parseArgs help ["edit", "t-abc123", "--complexity=4"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'edit --complexity': " <> show err + Right args -> do + args `Cli.has` Cli.command "edit" Test.@?= True + Cli.getArg args (Cli.longOption "complexity") Test.@?= Just "4", + Test.unit "edit command" <| do + let result = Docopt.parseArgs help ["edit", "t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'edit': " <> show err + Right args -> do + args `Cli.has` Cli.command "edit" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123", + Test.unit "edit with options" <| do + let result = Docopt.parseArgs help ["edit", "t-abc123", "--title=New Title", "--priority=0"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'edit' with options: " <> show err + Right args -> do + args `Cli.has` Cli.command "edit" Test.@?= True + Cli.getArg args (Cli.longOption "title") Test.@?= Just "New Title" + Cli.getArg args (Cli.longOption "priority") Test.@?= Just "0", + Test.unit "list command" <| do + let result = Docopt.parseArgs help ["list"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list': " <> show err + Right args -> args `Cli.has` Cli.command "list" Test.@?= True, + Test.unit "list with --json flag" <| do + let result = Docopt.parseArgs help ["list", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "list" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "list with --status filter" <| do + let result = Docopt.parseArgs help ["list", "--status=open"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list --status': " <> show err + Right args -> do + args `Cli.has` Cli.command "list" Test.@?= True + Cli.getArg args (Cli.longOption "status") Test.@?= Just "open", + Test.unit "list with --status=approved filter" <| do + let result = Docopt.parseArgs help ["list", "--status=approved"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list --status=approved': " <> show err + Right args -> do + args `Cli.has` Cli.command "list" Test.@?= True + Cli.getArg args (Cli.longOption "status") Test.@?= Just "approved", + Test.unit "list with --status=draft filter" <| do + let result = Docopt.parseArgs help ["list", "--status=draft"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list --status=draft': " <> show err + Right args -> do + args `Cli.has` Cli.command "list" Test.@?= True + Cli.getArg args (Cli.longOption "status") Test.@?= Just "draft", + Test.unit "ready command" <| do + let result = Docopt.parseArgs help ["ready"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'ready': " <> show err + Right args -> args `Cli.has` Cli.command "ready" Test.@?= True, + Test.unit "ready with --json flag" <| do + let result = Docopt.parseArgs help ["ready", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'ready --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "ready" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "update command" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "done"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123" + Cli.getArg args (Cli.argument "status") Test.@?= Just "done", + Test.unit "update command with approved" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "approved"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update ... approved': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123" + Cli.getArg args (Cli.argument "status") Test.@?= Just "approved", + Test.unit "update command with draft" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "draft"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update ... draft': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123" + Cli.getArg args (Cli.argument "status") Test.@?= Just "draft", + Test.unit "update with --json flag" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "done", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "update with --verified flag" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "done", "--verified"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update --verified': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + args `Cli.has` Cli.longOption "verified" Test.@?= True, + Test.unit "update with --verified and --json flags" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "done", "--verified", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update --verified --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + args `Cli.has` Cli.longOption "verified" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "deps command" <| do + let result = Docopt.parseArgs help ["deps", "t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'deps': " <> show err + Right args -> do + args `Cli.has` Cli.command "deps" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123", + Test.unit "tree command" <| do + let result = Docopt.parseArgs help ["tree"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'tree': " <> show err + Right args -> args `Cli.has` Cli.command "tree" Test.@?= True, + Test.unit "tree with id" <| do + let result = Docopt.parseArgs help ["tree", "t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'tree <id>': " <> show err + Right args -> do + args `Cli.has` Cli.command "tree" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123", + Test.unit "export command" <| do + let result = Docopt.parseArgs help ["export"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'export': " <> show err + Right args -> args `Cli.has` Cli.command "export" Test.@?= True, + Test.unit "import command" <| do + let result = Docopt.parseArgs help ["import", "-i", "tasks.jsonl"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'import': " <> show err + Right args -> do + args `Cli.has` Cli.command "import" Test.@?= True + -- Note: -i is a short option, not an argument + Cli.getArg args (Cli.shortOption 'i') Test.@?= Just "tasks.jsonl", + Test.unit "show command" <| do + let result = Docopt.parseArgs help ["show", "t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'show': " <> show err + Right args -> do + args `Cli.has` Cli.command "show" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123", + Test.unit "show with --json flag" <| do + let result = Docopt.parseArgs help ["show", "t-abc123", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'show --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "show" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "stats command" <| do + let result = Docopt.parseArgs help ["stats"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'stats': " <> show err + Right args -> args `Cli.has` Cli.command "stats" Test.@?= True, + Test.unit "stats with --json flag" <| do + let result = Docopt.parseArgs help ["stats", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'stats --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "stats" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "stats with --epic flag" <| do + let result = Docopt.parseArgs help ["stats", "--epic=t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'stats --epic': " <> show err + Right args -> do + args `Cli.has` Cli.command "stats" Test.@?= True + Cli.getArg args (Cli.longOption "epic") Test.@?= Just "t-abc123", + Test.unit "create with flags in different order" <| do + let result = Docopt.parseArgs help ["create", "Test", "--json", "--priority=1", "--namespace=Omni/Task"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create' with reordered flags: " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True + Cli.getArg args (Cli.longOption "priority") Test.@?= Just "1" + Cli.getArg args (Cli.longOption "namespace") Test.@?= Just "Omni/Task", + Test.unit "comment command" <| do + let result = Docopt.parseArgs help ["comment", "t-abc123", "This is a comment"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'comment': " <> show err + Right args -> do + args `Cli.has` Cli.command "comment" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123" + Cli.getArg args (Cli.argument "message") Test.@?= Just "This is a comment", + Test.unit "comment with --json flag" <| do + let result = Docopt.parseArgs help ["comment", "t-abc123", "Test comment", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'comment --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "comment" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True + ] diff --git a/Omni/Task/Core.hs b/Omni/Task/Core.hs new file mode 100644 index 0000000..c930b2c --- /dev/null +++ b/Omni/Task/Core.hs @@ -0,0 +1,1567 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- : dep http-api-data +module Omni.Task.Core where + +import Alpha +import Data.Aeson (FromJSON, ToJSON, decode, encode) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Time (UTCTime, diffUTCTime, getCurrentTime) +import qualified Database.SQLite.Simple as SQL +import qualified Database.SQLite.Simple.FromField as SQL +import qualified Database.SQLite.Simple.Ok as SQLOk +import qualified Database.SQLite.Simple.ToField as SQL +import GHC.Generics () +import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getXdgDirectory) +import System.Environment (lookupEnv) +import System.FilePath (takeDirectory, (</>)) +import System.IO.Unsafe (unsafePerformIO) +import Web.HttpApiData (FromHttpApiData (..)) + +-- Core data types +data Task = Task + { taskId :: Text, + taskTitle :: Text, + taskType :: TaskType, + taskParent :: Maybe Text, -- Parent epic ID + taskNamespace :: Maybe Text, -- Optional namespace (e.g., "Omni/Task", "Biz/Cloud") + taskStatus :: Status, + taskPriority :: Priority, -- Priority level (0-4) + taskComplexity :: Maybe Int, -- Complexity 1-5 for model selection + taskDependencies :: [Dependency], -- List of dependencies with types + taskDescription :: Text, -- Required description + taskComments :: [Comment], -- Timestamped comments for extra context + taskCreatedAt :: UTCTime, + taskUpdatedAt :: UTCTime + } + deriving (Show, Eq, Generic) + +data TaskType = Epic | WorkTask | HumanTask + deriving (Show, Eq, Read, Generic) + +data Status = Draft | Open | InProgress | Review | Approved | Done + deriving (Show, Eq, Read, Generic) + +-- Priority levels (matching beads convention) +data Priority = P0 | P1 | P2 | P3 | P4 + deriving (Show, Eq, Ord, Read, Generic) + +data Dependency = Dependency + { depId :: Text, -- ID of the task this depends on + depType :: DependencyType -- Type of dependency relationship + } + deriving (Show, Eq, Generic) + +data DependencyType + = Blocks -- Hard dependency, blocks ready work queue + | DiscoveredFrom -- Work discovered during other work + | ParentChild -- Epic/subtask relationship + | Related -- Soft relationship, doesn't block + deriving (Show, Eq, Read, Generic) + +data TaskProgress = TaskProgress + { progressTaskId :: Text, + progressTotal :: Int, + progressCompleted :: Int, + progressPercentage :: Int + } + deriving (Show, Eq, Generic) + +data EpicForReview = EpicForReview + { epicTask :: Task, + epicTotal :: Int, + epicCompleted :: Int + } + deriving (Show, Eq, Generic) + +data HumanActionItems = HumanActionItems + { failedTasks :: [Task], + epicsInReview :: [EpicForReview], + humanTasks :: [Task] + } + deriving (Show, Eq, Generic) + +data AggregatedMetrics = AggregatedMetrics + { aggTotalCostCents :: Int, + aggTotalDurationSeconds :: Int, + aggCompletedTasks :: Int, + aggTotalTokens :: Int + } + deriving (Show, Eq, Generic) + +-- Retry context for tasks that failed due to merge conflicts +data RetryContext = RetryContext + { retryTaskId :: Text, + retryOriginalCommit :: Text, + retryConflictFiles :: [Text], + retryAttempt :: Int, + retryReason :: Text, -- "merge_conflict" | "ci_failure" | "rejected" + retryNotes :: Maybe Text -- Human notes/guidance for intervention + } + deriving (Show, Eq, Generic) + +-- Activity stage for task_activity tracking +data ActivityStage = Claiming | Running | Reviewing | Retrying | Completed | Failed + deriving (Show, Eq, Read, Generic) + +-- Task activity log entry +data TaskActivity = TaskActivity + { activityId :: Maybe Int, -- NULL for new entries, set by DB + activityTaskId :: Text, + activityTimestamp :: UTCTime, + activityStage :: ActivityStage, + activityMessage :: Maybe Text, + activityMetadata :: Maybe Text, -- JSON for extra data + activityThreadUrl :: Maybe Text, -- Link to agent session (unused with native Engine) + activityStartedAt :: Maybe UTCTime, -- When work started + activityCompletedAt :: Maybe UTCTime, -- When work completed + activityCostCents :: Maybe Int, -- API cost in cents + activityTokensUsed :: Maybe Int -- Total tokens used + } + deriving (Show, Eq, Generic) + +-- Fact for knowledge base +data Fact = Fact + { factId :: Maybe Int, + factProject :: Text, + factContent :: Text, + factRelatedFiles :: [Text], + factSourceTask :: Maybe Text, + factConfidence :: Double, + factCreatedAt :: UTCTime + } + deriving (Show, Eq, Generic) + +-- Comment for task notes/context +data Comment = Comment + { commentText :: Text, + commentCreatedAt :: UTCTime + } + deriving (Show, Eq, Generic) + +instance ToJSON TaskType + +instance FromJSON TaskType + +instance ToJSON Status + +instance FromJSON Status + +instance ToJSON Priority + +instance FromJSON Priority + +instance ToJSON DependencyType + +instance FromJSON DependencyType + +instance ToJSON Dependency + +instance FromJSON Dependency + +instance ToJSON Task + +instance FromJSON Task + +instance ToJSON TaskProgress + +instance FromJSON TaskProgress + +instance ToJSON AggregatedMetrics + +instance FromJSON AggregatedMetrics + +instance ToJSON RetryContext + +instance FromJSON RetryContext + +instance ToJSON ActivityStage + +instance FromJSON ActivityStage + +instance ToJSON TaskActivity + +instance FromJSON TaskActivity + +instance ToJSON Fact + +instance FromJSON Fact + +instance ToJSON Comment + +instance FromJSON Comment + +-- HTTP API Instances (for Servant query params) + +instance FromHttpApiData Status where + parseQueryParam t + | T.null t = Left "No status provided" + | otherwise = case readMaybe (T.unpack t) of + Just s -> Right s + Nothing -> Left ("Invalid status: " <> t) + +instance FromHttpApiData Priority where + parseQueryParam t + | T.null t = Left "No priority provided" + | otherwise = case readMaybe (T.unpack t) of + Just p -> Right p + Nothing -> Left ("Invalid priority: " <> t) + +-- SQLite Instances + +instance SQL.FromField TaskType where + fromField f = do + t <- SQL.fromField f :: SQLOk.Ok String + case readMaybe t of + Just x -> pure x + Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid TaskType" + +instance SQL.ToField TaskType where + toField x = SQL.toField (show x :: String) + +instance SQL.FromField Status where + fromField f = do + t <- SQL.fromField f :: SQLOk.Ok String + case readMaybe t of + Just x -> pure x + Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid Status" + +instance SQL.ToField Status where + toField x = SQL.toField (show x :: String) + +instance SQL.FromField Priority where + fromField f = do + t <- SQL.fromField f :: SQLOk.Ok String + case readMaybe t of + Just x -> pure x + Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid Priority" + +instance SQL.ToField Priority where + toField x = SQL.toField (show x :: String) + +instance SQL.FromField ActivityStage where + fromField f = do + t <- SQL.fromField f :: SQLOk.Ok String + case readMaybe t of + Just x -> pure x + Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid ActivityStage" + +instance SQL.ToField ActivityStage where + toField x = SQL.toField (show x :: String) + +-- Store dependencies as JSON text +instance SQL.FromField [Dependency] where + fromField f = do + mt <- SQL.fromField f :: SQLOk.Ok (Maybe String) + case mt of + Nothing -> pure [] + Just t -> case Aeson.decode (BLC.pack t) of + Just x -> pure x + Nothing -> pure [] + +instance SQL.ToField [Dependency] where + toField deps = SQL.toField (BLC.unpack (encode deps)) + +-- Store comments as JSON text +instance SQL.FromField [Comment] where + fromField f = do + mt <- SQL.fromField f :: SQLOk.Ok (Maybe String) + case mt of + Nothing -> pure [] + Just t -> case Aeson.decode (BLC.pack t) of + Just x -> pure x + Nothing -> pure [] + +instance SQL.ToField [Comment] where + toField comments = SQL.toField (BLC.unpack (encode comments)) + +instance SQL.FromRow Task where + fromRow = + Task + </ SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field -- complexity + <*> SQL.field + <*> (fromMaybe "" </ SQL.field) -- Handle NULL description from legacy data + <*> SQL.field -- comments + <*> SQL.field + <*> SQL.field + +instance SQL.ToRow Task where + toRow t = + [ SQL.toField (taskId t), + SQL.toField (taskTitle t), + SQL.toField (taskType t), + SQL.toField (taskParent t), + SQL.toField (taskNamespace t), + SQL.toField (taskStatus t), + SQL.toField (taskPriority t), + SQL.toField (taskComplexity t), + SQL.toField (taskDependencies t), + SQL.toField (taskDescription t), + SQL.toField (taskComments t), + SQL.toField (taskCreatedAt t), + SQL.toField (taskUpdatedAt t) + ] + +instance SQL.FromRow TaskActivity where + fromRow = + TaskActivity + </ SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + +instance SQL.ToRow TaskActivity where + toRow a = + [ SQL.toField (activityId a), + SQL.toField (activityTaskId a), + SQL.toField (activityTimestamp a), + SQL.toField (activityStage a), + SQL.toField (activityMessage a), + SQL.toField (activityMetadata a), + SQL.toField (activityThreadUrl a), + SQL.toField (activityStartedAt a), + SQL.toField (activityCompletedAt a), + SQL.toField (activityCostCents a), + SQL.toField (activityTokensUsed a) + ] + +instance SQL.FromRow Fact where + fromRow = do + fid <- SQL.field + proj <- SQL.field + content <- SQL.field + (relatedFilesJson :: String) <- SQL.field + sourceTask <- SQL.field + confidence <- SQL.field + createdAt <- SQL.field + let relatedFiles = fromMaybe [] (decode (BLC.pack relatedFilesJson)) + pure + Fact + { factId = fid, + factProject = proj, + factContent = content, + factRelatedFiles = relatedFiles, + factSourceTask = sourceTask, + factConfidence = confidence, + factCreatedAt = createdAt + } + +instance SQL.ToRow Fact where + toRow f = + [ SQL.toField (factId f), + SQL.toField (factProject f), + SQL.toField (factContent f), + SQL.toField (BLC.unpack (encode (factRelatedFiles f))), + SQL.toField (factSourceTask f), + SQL.toField (factConfidence f), + SQL.toField (factCreatedAt f) + ] + +-- | Case-insensitive ID comparison +matchesId :: Text -> Text -> Bool +matchesId id1 id2 = normalizeId id1 == normalizeId id2 + +-- | Normalize ID to lowercase +normalizeId :: Text -> Text +normalizeId = T.toLower + +-- | Find a task by ID (case-insensitive) +findTask :: Text -> [Task] -> Maybe Task +findTask tid = List.find (\t -> matchesId (taskId t) tid) + +-- | Normalize task IDs (self, parent, dependencies) to lowercase +normalizeTask :: Task -> Task +normalizeTask t = + t + { taskId = normalizeId (taskId t), + taskParent = fmap normalizeId (taskParent t), + taskDependencies = map normalizeDependency (taskDependencies t) + } + +normalizeDependency :: Dependency -> Dependency +normalizeDependency d = d {depId = normalizeId (depId d)} + +-- Lock for application-level thread safety (Read-Calc-Write cycles) +taskLock :: MVar () +taskLock = unsafePerformIO (newMVar ()) +{-# NOINLINE taskLock #-} + +withTaskLock :: IO a -> IO a +withTaskLock action = withMVar taskLock (const action) + +-- Get the tasks database file path +getTasksDbPath :: IO FilePath +getTasksDbPath = do + customPath <- lookupEnv "TASK_DB_PATH" + testMode <- lookupEnv "TASK_TEST_MODE" + case (testMode, customPath) of + (Just "1", _) -> pure "_/tmp/tasks-test.db" + (_, Just p) -> pure p + _ -> do + xdgData <- getXdgDirectory XdgData "jr" + pure (xdgData </> "jr.db") + +-- DB Helper +withDb :: (SQL.Connection -> IO a) -> IO a +withDb action = do + dbPath <- getTasksDbPath + SQL.withConnection dbPath <| \conn -> do + SQL.execute_ conn "PRAGMA busy_timeout = 5000" + action conn + +-- Initialize the task database +initTaskDb :: IO () +initTaskDb = do + dbPath <- getTasksDbPath + createDirectoryIfMissing True (takeDirectory dbPath) + withDb <| \conn -> do + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS tasks (\ + \ id TEXT PRIMARY KEY, \ + \ title TEXT NOT NULL, \ + \ type TEXT NOT NULL, \ + \ parent TEXT, \ + \ namespace TEXT, \ + \ status TEXT NOT NULL, \ + \ priority TEXT NOT NULL, \ + \ complexity INTEGER, \ + \ dependencies TEXT NOT NULL, \ + \ description TEXT, \ + \ comments TEXT NOT NULL DEFAULT '[]', \ + \ created_at TIMESTAMP NOT NULL, \ + \ updated_at TIMESTAMP NOT NULL \ + \)" + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS id_counter (\ + \ id INTEGER PRIMARY KEY CHECK (id = 1), \ + \ counter INTEGER NOT NULL DEFAULT 0 \ + \)" + SQL.execute_ + conn + "INSERT OR IGNORE INTO id_counter (id, counter) VALUES (1, 0)" + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS retry_context (\ + \ task_id TEXT PRIMARY KEY, \ + \ original_commit TEXT NOT NULL, \ + \ conflict_files TEXT NOT NULL, \ + \ attempt INTEGER NOT NULL DEFAULT 1, \ + \ reason TEXT NOT NULL \ + \)" + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS task_activity (\ + \ id INTEGER PRIMARY KEY AUTOINCREMENT, \ + \ task_id TEXT NOT NULL, \ + \ timestamp DATETIME DEFAULT CURRENT_TIMESTAMP, \ + \ stage TEXT NOT NULL, \ + \ message TEXT, \ + \ metadata TEXT, \ + \ amp_thread_url TEXT, \ + \ started_at DATETIME, \ + \ completed_at DATETIME, \ + \ cost_cents INTEGER, \ + \ tokens_used INTEGER, \ + \ FOREIGN KEY (task_id) REFERENCES tasks(id) \ + \)" + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS facts (\ + \ id INTEGER PRIMARY KEY AUTOINCREMENT, \ + \ project TEXT NOT NULL, \ + \ fact TEXT NOT NULL, \ + \ related_files TEXT NOT NULL, \ + \ source_task TEXT, \ + \ confidence REAL NOT NULL, \ + \ created_at DATETIME DEFAULT CURRENT_TIMESTAMP \ + \)" + runMigrations conn + +-- | Run schema migrations to add missing columns to existing tables +runMigrations :: SQL.Connection -> IO () +runMigrations conn = do + migrateTable conn "task_activity" taskActivityColumns + migrateTable conn "tasks" tasksColumns + migrateTable conn "retry_context" retryContextColumns + migrateTable conn "facts" factsColumns + +-- | Expected columns for task_activity table (name, type, nullable) +taskActivityColumns :: [(Text, Text)] +taskActivityColumns = + [ ("id", "INTEGER"), + ("task_id", "TEXT"), + ("timestamp", "DATETIME"), + ("stage", "TEXT"), + ("message", "TEXT"), + ("metadata", "TEXT"), + ("amp_thread_url", "TEXT"), + ("started_at", "DATETIME"), + ("completed_at", "DATETIME"), + ("cost_cents", "INTEGER"), + ("tokens_used", "INTEGER") + ] + +-- | Expected columns for tasks table +tasksColumns :: [(Text, Text)] +tasksColumns = + [ ("id", "TEXT"), + ("title", "TEXT"), + ("type", "TEXT"), + ("parent", "TEXT"), + ("namespace", "TEXT"), + ("status", "TEXT"), + ("priority", "TEXT"), + ("complexity", "INTEGER"), + ("dependencies", "TEXT"), + ("description", "TEXT"), + ("comments", "TEXT"), + ("created_at", "TIMESTAMP"), + ("updated_at", "TIMESTAMP") + ] + +-- | Expected columns for retry_context table +retryContextColumns :: [(Text, Text)] +retryContextColumns = + [ ("task_id", "TEXT"), + ("original_commit", "TEXT"), + ("conflict_files", "TEXT"), + ("attempt", "INTEGER"), + ("reason", "TEXT"), + ("notes", "TEXT") + ] + +-- | Expected columns for facts table +factsColumns :: [(Text, Text)] +factsColumns = + [ ("id", "INTEGER"), + ("project", "TEXT"), + ("fact", "TEXT"), + ("related_files", "TEXT"), + ("source_task", "TEXT"), + ("confidence", "REAL"), + ("created_at", "DATETIME") + ] + +-- | Migrate a table by adding any missing columns +migrateTable :: SQL.Connection -> Text -> [(Text, Text)] -> IO () +migrateTable conn tableName expectedCols = do + existingCols <- getTableColumns conn tableName + let missingCols = filter (\(name, _) -> name `notElem` existingCols) expectedCols + traverse_ (addColumn conn tableName) missingCols + +-- | Get list of column names for a table using PRAGMA table_info +getTableColumns :: SQL.Connection -> Text -> IO [Text] +getTableColumns conn tableName = do + let query = SQL.Query <| "PRAGMA table_info(" <> tableName <> ")" + rows <- SQL.query_ conn query :: IO [(Int, Text, Text, Int, Maybe Text, Int)] + pure [colName | (_, colName, _, _, _, _) <- rows] + +-- | Add a column to a table +addColumn :: SQL.Connection -> Text -> (Text, Text) -> IO () +addColumn conn tableName (colName, colType) = do + let sql = "ALTER TABLE " <> tableName <> " ADD COLUMN " <> colName <> " " <> colType + SQL.execute_ conn (SQL.Query sql) + +-- Generate a sequential task ID (t-1, t-2, t-3, ...) +generateId :: IO Text +generateId = do + counter <- getNextCounter + pure <| "t-" <> T.pack (show counter) + +-- Get the next counter value (atomically increments) +getNextCounter :: IO Int +getNextCounter = + withDb <| \conn -> do + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS id_counter (\ + \ id INTEGER PRIMARY KEY CHECK (id = 1), \ + \ counter INTEGER NOT NULL DEFAULT 0 \ + \)" + SQL.execute_ conn "INSERT OR IGNORE INTO id_counter (id, counter) VALUES (1, 0)" + SQL.execute_ conn "UPDATE id_counter SET counter = counter + 1 WHERE id = 1" + [SQL.Only c] <- SQL.query_ conn "SELECT counter FROM id_counter WHERE id = 1" :: IO [SQL.Only Int] + pure c + +-- Generate a child ID based on parent ID +generateChildId :: Text -> IO Text +generateChildId parentId = do + tasks <- loadTasks + pure <| computeNextChildId tasks (normalizeId parentId) + +computeNextChildId :: [Task] -> Text -> Text +computeNextChildId tasks parentId = + let suffixes = mapMaybe (getSuffix parentId <. taskId) tasks + nextSuffix = case suffixes of + [] -> 1 + s -> maximum s + 1 + in parentId <> "." <> T.pack (show nextSuffix) + +getSuffix :: Text -> Text -> Maybe Int +getSuffix parent childId = + if parent `T.isPrefixOf` childId && T.length childId > T.length parent + then + let rest = T.drop (T.length parent) childId + in if T.head rest == '.' + then readMaybe (T.unpack (T.tail rest)) + else Nothing + else Nothing + +-- Load all tasks from DB +loadTasks :: IO [Task] +loadTasks = + withDb <| \conn -> do + SQL.query_ conn "SELECT id, title, type, parent, namespace, status, priority, complexity, dependencies, description, comments, created_at, updated_at FROM tasks" + +-- Save a single task (UPSERT) +saveTask :: Task -> IO () +saveTask task = + withDb <| \conn -> do + SQL.execute + conn + "INSERT OR REPLACE INTO tasks \ + \ (id, title, type, parent, namespace, status, priority, complexity, dependencies, description, comments, created_at, updated_at) \ + \ VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" + task + +-- Create a new task +createTask :: Text -> TaskType -> Maybe Text -> Maybe Text -> Priority -> Maybe Int -> [Dependency] -> Text -> IO Task +createTask title taskType parent namespace priority complexity deps description = + withTaskLock <| do + let parent' = fmap normalizeId parent + deps' = map normalizeDependency deps + + tid <- case parent' of + Nothing -> generateUniqueId + Just pid -> do + tasks <- loadTasks + pure <| computeNextChildId tasks pid + now <- getCurrentTime + let task = + Task + { taskId = normalizeId tid, + taskTitle = title, + taskType = taskType, + taskParent = parent', + taskNamespace = namespace, + taskStatus = Open, + taskPriority = priority, + taskComplexity = complexity, + taskDependencies = deps', + taskDescription = description, + taskComments = [], + taskCreatedAt = now, + taskUpdatedAt = now + } + saveTask task + pure task + +-- Generate a unique ID +generateUniqueId :: IO Text +generateUniqueId = do + -- We can query DB directly to check existence + go + where + go = do + tid <- generateId + exists <- + withDb <| \conn -> do + [SQL.Only c] <- SQL.query conn "SELECT COUNT(*) FROM tasks WHERE id = ?" (SQL.Only tid) :: IO [SQL.Only Int] + pure (c > 0) + if exists then go else pure tid + +-- Update task status +updateTaskStatus :: Text -> Status -> [Dependency] -> IO () +updateTaskStatus tid newStatus newDeps = + withTaskLock + <| withDb + <| \conn -> do + now <- getCurrentTime + -- If newDeps is empty, we need to preserve existing deps. + -- If newDeps is NOT empty, we replace them. + -- This logic is slightly tricky in SQL. We fetch first. + rows <- SQL.query conn "SELECT dependencies FROM tasks WHERE id = ?" (SQL.Only tid) :: IO [SQL.Only [Dependency]] + case rows of + [] -> pure () -- Task not found + (SQL.Only existingDeps : _) -> do + let finalDeps = if null newDeps then existingDeps else newDeps + SQL.execute + conn + "UPDATE tasks SET status = ?, updated_at = ?, dependencies = ? WHERE id = ?" + (newStatus, now, finalDeps, tid) + +-- Edit a task +editTask :: Text -> (Task -> Task) -> IO Task +editTask tid modifyFn = + withTaskLock <| do + tasks <- loadTasks + case findTask tid tasks of + Nothing -> panic "Task not found" + Just original -> do + now <- getCurrentTime + let modified = modifyFn original + finalTask = modified {taskUpdatedAt = now} + saveTask finalTask + pure finalTask + +-- Delete a task +deleteTask :: Text -> IO () +deleteTask tid = + withDb <| \conn -> + SQL.execute conn "DELETE FROM tasks WHERE id = ?" (SQL.Only tid) + +-- Add a comment to a task +addComment :: Text -> Text -> IO Task +addComment tid commentText = + withTaskLock <| do + tasks <- loadTasks + case findTask tid tasks of + Nothing -> panic "Task not found" + Just task -> do + now <- getCurrentTime + let newComment = Comment {commentText = commentText, commentCreatedAt = now} + updatedTask = task {taskComments = taskComments task ++ [newComment], taskUpdatedAt = now} + saveTask updatedTask + pure updatedTask + +-- List tasks +listTasks :: Maybe TaskType -> Maybe Text -> Maybe Status -> Maybe Text -> IO [Task] +listTasks maybeType maybeParent maybeStatus maybeNamespace = do + -- Implementing specific filters in SQL would be more efficient, but for MVP and API compat: + tasks <- loadTasks + let filtered = + tasks + |> filterByType maybeType + |> filterByParent maybeParent + |> filterByStatus maybeStatus + |> filterByNamespace maybeNamespace + pure filtered + where + filterByType Nothing ts = ts + filterByType (Just typ) ts = filter (\t -> taskType t == typ) ts + filterByParent Nothing ts = ts + filterByParent (Just pid) ts = filter (\t -> taskParent t == Just pid) ts + filterByStatus Nothing ts = ts + filterByStatus (Just status) ts = filter (\t -> taskStatus t == status) ts + filterByNamespace Nothing ts = ts + filterByNamespace (Just ns) ts = filter (\t -> taskNamespace t == Just ns) ts + +-- Get ready tasks +getReadyTasks :: IO [Task] +getReadyTasks = do + allTasks <- loadTasks + retryContexts <- getAllRetryContexts + let openTasks = filter (\t -> taskStatus t `elem` [Open, InProgress]) allTasks + doneIds = map taskId <| filter (\t -> taskStatus t == Done) allTasks + + parentIds = mapMaybe taskParent allTasks + isParent tid = tid `elem` parentIds + + -- Tasks with retry_attempt >= 3 need human intervention + needsInterventionIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3] + + blockingDepIds task = [depId dep | dep <- taskDependencies task, depType dep `elem` [Blocks, ParentChild]] + isReady task = + taskType task + /= Epic + && not (isParent (taskId task)) + && all (`elem` doneIds) (blockingDepIds task) + && taskType task + /= HumanTask + && taskId task + `notElem` needsInterventionIds + pure <| filter isReady openTasks + +-- Get dependency tree +getDependencyTree :: Text -> IO [Task] +getDependencyTree tid = do + tasks <- loadTasks + case findTask tid tasks of + Nothing -> pure [] + Just task -> pure <| collectDeps tasks task + where + collectDeps allTasks task = + let depIds = map depId (taskDependencies task) + deps = filter (\t -> any (matchesId (taskId t)) depIds) allTasks + in task : concatMap (collectDeps allTasks) deps + +-- Get task progress +getTaskProgress :: Text -> IO TaskProgress +getTaskProgress tidRaw = do + let tid = normalizeId tidRaw + -- Could be SQL optimized + tasks <- loadTasks + case findTask tid tasks of + Nothing -> panic "Task not found" + Just _ -> do + let children = filter (\child -> taskParent child == Just tid) tasks + total = length children + completed = length <| filter (\child -> taskStatus child == Done) children + percentage = if total == 0 then 0 else (completed * 100) `div` total + pure + TaskProgress + { progressTaskId = tid, + progressTotal = total, + progressCompleted = completed, + progressPercentage = percentage + } + +showTaskProgress :: Text -> IO () +showTaskProgress tid = do + progress <- getTaskProgress tid + putText <| "Progress for " <> tid <> ": " <> T.pack (show (progressCompleted progress)) <> "/" <> T.pack (show (progressTotal progress)) <> " (" <> T.pack (show (progressPercentage progress)) <> "%)" + +showDependencyTree :: Text -> IO () +showDependencyTree tid = do + tasks <- loadTasks + case findTask tid tasks of + Nothing -> putText "Task not found" + Just task -> printTree tasks task 0 + where + printTree :: [Task] -> Task -> Int -> IO () + printTree allTasks task indent = do + putText <| T.pack (replicate (indent * 2) ' ') <> taskId task <> ": " <> taskTitle task + let depIds = map depId (taskDependencies task) + deps = filter (\t -> any (matchesId (taskId t)) depIds) allTasks + traverse_ (\dep -> printTree allTasks dep (indent + 1)) deps + +getTaskTree :: Maybe Text -> IO [Task] +getTaskTree maybeId = do + tasks <- loadTasks + case maybeId of + Nothing -> do + let epics = filter (\t -> taskType t == Epic) tasks + in pure <| concatMap (collectChildren tasks) epics + Just tid -> do + case findTask tid tasks of + Nothing -> pure [] + Just task -> pure <| collectChildren tasks task + where + collectChildren allTasks task = + let children = filter (maybe False (`matchesId` taskId task) <. taskParent) allTasks + in task : concatMap (collectChildren allTasks) children + +showTaskTree :: Maybe Text -> IO () +showTaskTree maybeId = do + tasks <- loadTasks + case maybeId of + Nothing -> do + let epics = filter (\t -> taskType t == Epic) tasks + if null epics + then putText "No epics found" + else traverse_ (printEpicTree tasks) epics + Just tid -> do + case findTask tid tasks of + Nothing -> putText "Task not found" + Just task -> printEpicTree tasks task + where + printEpicTree allTasks task = printTreeNode allTasks task (0 :: Int) + + printTreeNode allTasks task indent = printTreeNode' allTasks task indent [] + + printTreeNode' allTasks task indent ancestry = do + let children = filter (maybe False (`matchesId` taskId task) <. taskParent) allTasks + prefix = + if indent == 0 + then "" + else + let ancestorPrefixes = map (\hasMore -> if hasMore then "│ " else " ") (List.init ancestry) + myPrefix = if List.last ancestry then "├── " else "└── " + in T.pack <| concat ancestorPrefixes ++ myPrefix + statusStr = case taskType task of + Epic -> + let total = length children + completed = length <| filter (\t -> taskStatus t == Done) children + in "[" <> T.pack (show completed) <> "/" <> T.pack (show total) <> "]" + _ -> case taskStatus task of + Draft -> "[.]" + Open -> "[ ]" + InProgress -> "[~]" + Review -> "[?]" + Approved -> "[+]" + Done -> "[✓]" + + coloredStatusStr = case taskType task of + Epic -> magenta statusStr + _ -> case taskStatus task of + Draft -> gray statusStr + Open -> bold statusStr + InProgress -> yellow statusStr + Review -> magenta statusStr + Approved -> green statusStr + Done -> green statusStr + + nsStr = case taskNamespace task of + Nothing -> "" + Just ns -> "[" <> ns <> "] " + + coloredNsStr = case taskNamespace task of + Nothing -> "" + Just _ -> gray nsStr + + usedWidth = T.length prefix + T.length (taskId task) + T.length statusStr + T.length nsStr + 2 + availableWidth = max 20 (80 - usedWidth) + truncatedTitle = + if T.length (taskTitle task) > availableWidth + then T.take (availableWidth - 3) (taskTitle task) <> "..." + else taskTitle task + + coloredTitle = if taskType task == Epic then bold truncatedTitle else truncatedTitle + + putText <| prefix <> cyan (taskId task) <> " " <> coloredStatusStr <> " " <> coloredNsStr <> coloredTitle + + let indexedChildren = zip [1 ..] children + totalChildren = length children + traverse_ + ( \(idx, child) -> + let hasMoreSiblings = idx < totalChildren + in printTreeNode' allTasks child (indent + 1) (ancestry ++ [hasMoreSiblings]) + ) + indexedChildren + +printTask :: Task -> IO () +printTask t = do + tasks <- loadTasks + let progressInfo = + if taskType t == Epic + then + let children = filter (maybe False (`matchesId` taskId t) <. taskParent) tasks + total = length children + completed = length <| filter (\child -> taskStatus child == Done) children + in " [" <> T.pack (show completed) <> "/" <> T.pack (show total) <> "]" + else "" + + parentInfo = case taskParent t of + Nothing -> "" + Just p -> " (parent: " <> p <> ")" + + namespaceInfo = case taskNamespace t of + Nothing -> "" + Just ns -> " [" <> ns <> "]" + + coloredStatus = + let s = "[" <> T.pack (show (taskStatus t)) <> "]" + in case taskStatus t of + Draft -> gray s + Open -> bold s + InProgress -> yellow s + Review -> magenta s + Approved -> green s + Done -> green s + + coloredTitle = if taskType t == Epic then bold (taskTitle t) else taskTitle t + coloredProgress = if taskType t == Epic then magenta progressInfo else progressInfo + coloredNamespace = case taskNamespace t of + Nothing -> "" + Just _ -> gray namespaceInfo + coloredParent = case taskParent t of + Nothing -> "" + Just _ -> gray parentInfo + + putText + <| cyan (taskId t) + <> " [" + <> T.pack (show (taskType t)) + <> "] " + <> coloredStatus + <> coloredProgress + <> " " + <> coloredTitle + <> coloredParent + <> coloredNamespace + +showTaskDetailed :: Task -> IO () +showTaskDetailed t = do + tasks <- loadTasks + putText "" + putText <| "Title: " <> taskTitle t <> " (ID: " <> taskId t <> ")" + putText <| "Type: " <> T.pack (show (taskType t)) + putText <| "Status: " <> T.pack (show (taskStatus t)) + putText <| "Priority: " <> T.pack (show (taskPriority t)) <> priorityDesc + + when (taskType t == Epic) <| do + let children = filter (maybe False (`matchesId` taskId t) <. taskParent) tasks + total = length children + completed = length <| filter (\child -> taskStatus child == Done) children + percentage = if total == 0 then 0 else (completed * 100) `div` total + putText <| "Progress: " <> T.pack (show completed) <> "/" <> T.pack (show total) <> " (" <> T.pack (show percentage) <> "%)" + + case taskParent t of + Nothing -> pure () + Just p -> putText <| "Parent: " <> p + case taskNamespace t of + Nothing -> pure () + Just ns -> putText <| "Namespace: " <> ns + putText <| "Created: " <> T.pack (show (taskCreatedAt t)) + putText <| "Updated: " <> T.pack (show (taskUpdatedAt t)) + + unless (null (taskDependencies t)) <| do + putText "" + putText "Dependencies:" + traverse_ printDependency (taskDependencies t) + + unless (T.null (taskDescription t)) <| do + putText "" + putText "Description:" + let indented = T.unlines <| map (" " <>) (T.lines (taskDescription t)) + putText indented + + unless (null (taskComments t)) <| do + putText "" + putText "Comments:" + traverse_ printComment (taskComments t) + + putText "" + where + priorityDesc = case taskPriority t of + P0 -> " (Critical)" + P1 -> " (High)" + P2 -> " (Medium)" + P3 -> " (Low)" + P4 -> " (Backlog)" + + printDependency dep = + putText <| " - " <> depId dep <> " [" <> T.pack (show (depType dep)) <> "]" + + printComment c = + putText <| " [" <> T.pack (show (commentCreatedAt c)) <> "] " <> commentText c + +red, green, yellow, blue, magenta, cyan, gray, bold :: Text -> Text +red t = "\ESC[31m" <> t <> "\ESC[0m" +green t = "\ESC[32m" <> t <> "\ESC[0m" +yellow t = "\ESC[33m" <> t <> "\ESC[0m" +blue t = "\ESC[34m" <> t <> "\ESC[0m" +magenta t = "\ESC[35m" <> t <> "\ESC[0m" +cyan t = "\ESC[36m" <> t <> "\ESC[0m" +gray t = "\ESC[90m" <> t <> "\ESC[0m" +bold t = "\ESC[1m" <> t <> "\ESC[0m" + +-- Export tasks: Dump SQLite to JSONL +exportTasks :: Maybe FilePath -> IO () +exportTasks maybePath = do + tasks <- loadTasks + case maybePath of + Just path -> do + TIO.writeFile path "" + traverse_ (saveTaskToJsonl path) tasks + Nothing -> + -- Stream to stdout + traverse_ (BLC.putStrLn <. encode) tasks + +saveTaskToJsonl :: FilePath -> Task -> IO () +saveTaskToJsonl path task = do + let json = encode task + BLC.appendFile path (json <> "\n") + +data TaskStats = TaskStats + { totalTasks :: Int, + draftTasks :: Int, + openTasks :: Int, + inProgressTasks :: Int, + reviewTasks :: Int, + approvedTasks :: Int, + doneTasks :: Int, + totalEpics :: Int, + readyTasks :: Int, + blockedTasks :: Int, + tasksByPriority :: [(Priority, Int)], + tasksByNamespace :: [(Text, Int)] + } + deriving (Show, Eq, Generic) + +instance ToJSON TaskStats + +instance FromJSON TaskStats + +getTaskStats :: Maybe Text -> IO TaskStats +getTaskStats maybeEpicId = do + allTasks <- loadTasks + + targetTasks <- case maybeEpicId of + Nothing -> pure allTasks + Just epicId -> + case findTask epicId allTasks of + Nothing -> panic "Epic not found" + Just task -> pure <| getAllDescendants allTasks (taskId task) + + globalReady <- getReadyTasks + let readyIds = map taskId globalReady + readyCount = length <| filter (\t -> taskId t `elem` readyIds) targetTasks + + tasks = targetTasks + total = length tasks + draft = length <| filter (\t -> taskStatus t == Draft) tasks + open = length <| filter (\t -> taskStatus t == Open) tasks + inProg = length <| filter (\t -> taskStatus t == InProgress) tasks + review = length <| filter (\t -> taskStatus t == Review) tasks + approved = length <| filter (\t -> taskStatus t == Approved) tasks + done = length <| filter (\t -> taskStatus t == Done) tasks + epics = length <| filter (\t -> taskType t == Epic) tasks + readyCount' = readyCount + blockedCount = total - readyCount' - done - draft + byPriority = + [ (P0, length <| filter (\t -> taskPriority t == P0) tasks), + (P1, length <| filter (\t -> taskPriority t == P1) tasks), + (P2, length <| filter (\t -> taskPriority t == P2) tasks), + (P3, length <| filter (\t -> taskPriority t == P3) tasks), + (P4, length <| filter (\t -> taskPriority t == P4) tasks) + ] + namespaces = mapMaybe taskNamespace tasks + uniqueNs = List.nub namespaces + byNamespace = map (\ns -> (ns, length <| filter (\t -> taskNamespace t == Just ns) tasks)) uniqueNs + pure + TaskStats + { totalTasks = total, + draftTasks = draft, + openTasks = open, + inProgressTasks = inProg, + reviewTasks = review, + approvedTasks = approved, + doneTasks = done, + totalEpics = epics, + readyTasks = readyCount', + blockedTasks = blockedCount, + tasksByPriority = byPriority, + tasksByNamespace = byNamespace + } + +getAllDescendants :: [Task] -> Text -> [Task] +getAllDescendants allTasks parentId = + let children = filter (maybe False (`matchesId` parentId) <. taskParent) allTasks + in children ++ concatMap (getAllDescendants allTasks <. taskId) children + +computeTaskStatsFromList :: [Task] -> TaskStats +computeTaskStatsFromList tasks = + let total = length tasks + draft = length [t | t <- tasks, taskStatus t == Draft] + open = length [t | t <- tasks, taskStatus t == Open] + inProg = length [t | t <- tasks, taskStatus t == InProgress] + review = length [t | t <- tasks, taskStatus t == Review] + approved = length [t | t <- tasks, taskStatus t == Approved] + done = length [t | t <- tasks, taskStatus t == Done] + epics = length [t | t <- tasks, taskType t == Epic] + readyCount = open + inProg + blockedCount = 0 + byPriority = + [ (P0, length [t | t <- tasks, taskPriority t == P0]), + (P1, length [t | t <- tasks, taskPriority t == P1]), + (P2, length [t | t <- tasks, taskPriority t == P2]), + (P3, length [t | t <- tasks, taskPriority t == P3]), + (P4, length [t | t <- tasks, taskPriority t == P4]) + ] + namespaces = mapMaybe taskNamespace tasks + uniqueNs = List.nub namespaces + byNamespace = [(ns, length [t | t <- tasks, taskNamespace t == Just ns]) | ns <- uniqueNs] + in TaskStats + { totalTasks = total, + draftTasks = draft, + openTasks = open, + inProgressTasks = inProg, + reviewTasks = review, + approvedTasks = approved, + doneTasks = done, + totalEpics = epics, + readyTasks = readyCount, + blockedTasks = blockedCount, + tasksByPriority = byPriority, + tasksByNamespace = byNamespace + } + +showTaskStats :: Maybe Text -> IO () +showTaskStats maybeEpicId = do + stats <- getTaskStats maybeEpicId + putText "" + case maybeEpicId of + Nothing -> putText "Task Statistics" + Just epicId -> putText <| "Task Statistics for Epic " <> epicId + putText "" + putText <| "Total tasks: " <> T.pack (show (totalTasks stats)) + putText <| " Draft: " <> T.pack (show (draftTasks stats)) + putText <| " Open: " <> T.pack (show (openTasks stats)) + putText <| " In Progress: " <> T.pack (show (inProgressTasks stats)) + putText <| " Review: " <> T.pack (show (reviewTasks stats)) + putText <| " Approved: " <> T.pack (show (approvedTasks stats)) + putText <| " Done: " <> T.pack (show (doneTasks stats)) + putText "" + putText <| "Epics: " <> T.pack (show (totalEpics stats)) + putText "" + putText <| "Ready to work: " <> T.pack (show (readyTasks stats)) + putText <| "Blocked: " <> T.pack (show (blockedTasks stats)) + putText "" + putText "By Priority:" + traverse_ printPriority (tasksByPriority stats) + unless (null (tasksByNamespace stats)) <| do + putText "" + putText "By Namespace:" + traverse_ printNamespace (tasksByNamespace stats) + putText "" + where + printPriority (p, count) = + let label = case p of + P0 -> "P0 (Critical)" + P1 -> "P1 (High)" + P2 -> "P2 (Medium)" + P3 -> "P3 (Low)" + P4 -> "P4 (Backlog)" + in putText <| " " <> T.pack (show count) <> " " <> label + printNamespace (ns, count) = + putText <| " " <> T.pack (show count) <> " " <> ns + +-- Import tasks: Read from JSONL and insert/update DB +importTasks :: FilePath -> IO () +importTasks filePath = do + exists <- doesFileExist filePath + unless exists <| panic (T.pack filePath <> " does not exist") + + content <- TIO.readFile filePath + let importLines = T.lines content + importedTasks = map normalizeTask (mapMaybe decodeTask importLines) + + -- Save all imported tasks (UPSERT logic handles updates) + traverse_ saveTask importedTasks + where + decodeTask :: Text -> Maybe Task + decodeTask line = + if T.null line + then Nothing + else decode (BLC.pack <| T.unpack line) + +-- Retry context management + +-- | Get retry context for a task (if any) +getRetryContext :: Text -> IO (Maybe RetryContext) +getRetryContext tid = + withDb <| \conn -> do + rows <- + SQL.query + conn + "SELECT task_id, original_commit, conflict_files, attempt, reason, notes FROM retry_context WHERE task_id = ?" + (SQL.Only tid) :: + IO [(Text, Text, Text, Int, Text, Maybe Text)] + case rows of + [] -> pure Nothing + ((taskId', commit, filesJson, attempt, reason, notes) : _) -> + let files = fromMaybe [] (decode (BLC.pack <| T.unpack filesJson)) + in pure + <| Just + RetryContext + { retryTaskId = taskId', + retryOriginalCommit = commit, + retryConflictFiles = files, + retryAttempt = attempt, + retryReason = reason, + retryNotes = notes + } + +-- | Set retry context for a task (upsert) +setRetryContext :: RetryContext -> IO () +setRetryContext ctx = + withDb <| \conn -> do + let filesJson = T.pack <| BLC.unpack <| encode (retryConflictFiles ctx) + SQL.execute + conn + "INSERT OR REPLACE INTO retry_context (task_id, original_commit, conflict_files, attempt, reason, notes) VALUES (?, ?, ?, ?, ?, ?)" + (retryTaskId ctx, retryOriginalCommit ctx, filesJson, retryAttempt ctx, retryReason ctx, retryNotes ctx) + +-- | Clear retry context for a task (on successful merge) +clearRetryContext :: Text -> IO () +clearRetryContext tid = + withDb <| \conn -> + SQL.execute conn "DELETE FROM retry_context WHERE task_id = ?" (SQL.Only tid) + +-- | Increment retry attempt and return new count +incrementRetryAttempt :: Text -> IO Int +incrementRetryAttempt tid = do + maybeCtx <- getRetryContext tid + case maybeCtx of + Nothing -> pure 1 + Just ctx -> do + let newAttempt = retryAttempt ctx + 1 + setRetryContext ctx {retryAttempt = newAttempt} + pure newAttempt + +-- | Log activity to the task_activity table +logActivity :: Text -> ActivityStage -> Maybe Text -> IO () +logActivity tid stage metadata = + withDb <| \conn -> + SQL.execute + conn + "INSERT INTO task_activity (task_id, stage, message, metadata) VALUES (?, ?, ?, ?)" + (tid, show stage :: String, Nothing :: Maybe Text, metadata) + +-- | Log activity with worker metrics (amp thread URL, timing, cost) +logActivityWithMetrics :: Text -> ActivityStage -> Maybe Text -> Maybe Text -> Maybe UTCTime -> Maybe UTCTime -> Maybe Int -> Maybe Int -> IO Int +logActivityWithMetrics tid stage metadata ampUrl startedAt completedAt costCents tokens = + withDb <| \conn -> do + SQL.execute + conn + "INSERT INTO task_activity (task_id, stage, message, metadata, amp_thread_url, started_at, completed_at, cost_cents, tokens_used) \ + \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)" + (tid, show stage :: String, Nothing :: Maybe Text, metadata, ampUrl, startedAt, completedAt, costCents, tokens) + [SQL.Only actId] <- SQL.query_ conn "SELECT last_insert_rowid()" :: IO [SQL.Only Int] + pure actId + +-- | Update an existing activity record with metrics +updateActivityMetrics :: Int -> Maybe Text -> Maybe UTCTime -> Maybe Int -> Maybe Int -> IO () +updateActivityMetrics actId ampUrl completedAt costCents tokens = + withDb <| \conn -> + SQL.execute + conn + "UPDATE task_activity SET amp_thread_url = COALESCE(?, amp_thread_url), \ + \completed_at = COALESCE(?, completed_at), \ + \cost_cents = COALESCE(?, cost_cents), \ + \tokens_used = COALESCE(?, tokens_used) \ + \WHERE id = ?" + (ampUrl, completedAt, costCents, tokens, actId) + +-- | Get all activities for a task, ordered by timestamp descending +getActivitiesForTask :: Text -> IO [TaskActivity] +getActivitiesForTask tid = + withDb <| \conn -> + SQL.query + conn + "SELECT id, task_id, timestamp, stage, message, metadata, \ + \amp_thread_url, started_at, completed_at, cost_cents, tokens_used \ + \FROM task_activity WHERE task_id = ? ORDER BY timestamp DESC" + (SQL.Only tid) + +-- | Get the most recent running activity for a task (for metrics display) +getLatestRunningActivity :: Text -> IO (Maybe TaskActivity) +getLatestRunningActivity tid = do + activities <- getActivitiesForTask tid + pure <| List.find (\a -> activityStage a == Running) activities + +-- | Get aggregated metrics for all descendants of an epic +getAggregatedMetrics :: Text -> IO AggregatedMetrics +getAggregatedMetrics epicId = do + allTasks <- loadTasks + let descendants = getAllDescendants allTasks epicId + descendantIds = map taskId descendants + completedCount = length [t | t <- descendants, taskStatus t == Done] + activities <- concat </ traverse getActivitiesForTask descendantIds + let totalCost = sum [c | act <- activities, Just c <- [activityCostCents act]] + totalTokens = sum [t | act <- activities, Just t <- [activityTokensUsed act]] + totalDuration = sum [calcDuration act | act <- activities] + pure + AggregatedMetrics + { aggTotalCostCents = totalCost, + aggTotalDurationSeconds = totalDuration, + aggCompletedTasks = completedCount, + aggTotalTokens = totalTokens + } + where + calcDuration act = case (activityStartedAt act, activityCompletedAt act) of + (Just start, Just end) -> floor (diffUTCTime end start) + _ -> 0 + +-- | Get aggregated metrics for all tasks globally (not scoped to an epic) +getGlobalAggregatedMetrics :: IO AggregatedMetrics +getGlobalAggregatedMetrics = do + allTasks <- loadTasks + let completedCount = length [t | t <- allTasks, taskStatus t == Done] + taskIds = map taskId allTasks + activities <- concat </ traverse getActivitiesForTask taskIds + let totalCost = sum [c | act <- activities, Just c <- [activityCostCents act]] + totalTokens = sum [t | act <- activities, Just t <- [activityTokensUsed act]] + totalDuration = sum [calcDuration act | act <- activities] + pure + AggregatedMetrics + { aggTotalCostCents = totalCost, + aggTotalDurationSeconds = totalDuration, + aggCompletedTasks = completedCount, + aggTotalTokens = totalTokens + } + where + calcDuration act = case (activityStartedAt act, activityCompletedAt act) of + (Just start, Just end) -> floor (diffUTCTime end start) + _ -> 0 + +-- | Get tasks with unmet blocking dependencies (not ready, not done) +getBlockedTasks :: IO [Task] +getBlockedTasks = do + allTasks <- loadTasks + readyTasks <- getReadyTasks + let readyIds = map taskId readyTasks + doneIds = [taskId t | t <- allTasks, taskStatus t == Done] + isBlocked task = + taskStatus task + `elem` [Open, InProgress] + && taskId task + `notElem` readyIds + && taskId task + `notElem` doneIds + pure [t | t <- allTasks, isBlocked t] + +-- | Count how many tasks are transitively blocked by this task +getBlockingImpact :: [Task] -> Task -> Int +getBlockingImpact allTasks task = + length (getTransitiveDependents allTasks (taskId task)) + +-- | Get all tasks that depend on this task (directly or transitively) +-- Uses a Set to track visited nodes and avoid infinite loops from circular deps +getTransitiveDependents :: [Task] -> Text -> [Task] +getTransitiveDependents allTasks tid = go Set.empty [tid] + where + go :: Set.Set Text -> [Text] -> [Task] + go _ [] = [] + go visited (current : rest) + | Set.member current visited = go visited rest + | otherwise = + let directDeps = [t | t <- allTasks, dependsOnTask current t] + newIds = [taskId t | t <- directDeps, not (Set.member (taskId t) visited)] + visited' = Set.insert current visited + in directDeps ++ go visited' (newIds ++ rest) + +-- | Check if task depends on given ID with Blocks dependency type +dependsOnTask :: Text -> Task -> Bool +dependsOnTask tid task = + any (\d -> matchesId (depId d) tid && depType d == Blocks) (taskDependencies task) + +-- | Get tasks that have failed 3+ times and need human intervention +getInterventionTasks :: IO [Task] +getInterventionTasks = do + allTasks <- loadTasks + retryContexts <- getAllRetryContexts + let highRetryIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3] + pure [t | t <- allTasks, taskId t `elem` highRetryIds] + +-- | Get all items needing human action +getHumanActionItems :: IO HumanActionItems +getHumanActionItems = do + allTasks <- loadTasks + retryContexts <- getAllRetryContexts + let highRetryIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3] + failed = [t | t <- allTasks, taskId t `elem` highRetryIds] + epics = [t | t <- allTasks, taskType t == Epic, taskStatus t /= Done] + epicsReady = + [ EpicForReview + { epicTask = e, + epicTotal = total, + epicCompleted = completed + } + | e <- epics, + let children = [c | c <- allTasks, taskParent c == Just (taskId e)], + let total = length children, + total > 0, + let completed = length [c | c <- children, taskStatus c == Done], + completed == total + ] + human = [t | t <- allTasks, taskType t == HumanTask, taskStatus t == Open] + pure + HumanActionItems + { failedTasks = failed, + epicsInReview = epicsReady, + humanTasks = human + } + +-- | Get all retry contexts from the database +getAllRetryContexts :: IO [RetryContext] +getAllRetryContexts = + withDb <| \conn -> do + rows <- + SQL.query_ + conn + "SELECT task_id, original_commit, conflict_files, attempt, reason, notes FROM retry_context" :: + IO [(Text, Text, Text, Int, Text, Maybe Text)] + pure + [ RetryContext + { retryTaskId = tid, + retryOriginalCommit = commit, + retryConflictFiles = fromMaybe [] (decode (BLC.pack (T.unpack filesJson))), + retryAttempt = attempt, + retryReason = reason, + retryNotes = notes + } + | (tid, commit, filesJson, attempt, reason, notes) <- rows + ] + +-- | Update just the notes field for a retry context +updateRetryNotes :: Text -> Text -> IO () +updateRetryNotes tid notes = do + maybeCtx <- getRetryContext tid + case maybeCtx of + Nothing -> + setRetryContext + RetryContext + { retryTaskId = tid, + retryOriginalCommit = "", + retryConflictFiles = [], + retryAttempt = 0, + retryReason = "", + retryNotes = Just notes + } + Just ctx -> + setRetryContext ctx {retryNotes = Just notes} + +-- Fact management + +-- | Save a fact to the database +saveFact :: Fact -> IO Int +saveFact f = + withDb <| \conn -> do + let filesJson = T.pack <| BLC.unpack <| encode (factRelatedFiles f) + SQL.execute + conn + "INSERT INTO facts (project, fact, related_files, source_task, confidence, created_at) \ + \VALUES (?, ?, ?, ?, ?, ?)" + (factProject f, factContent f, filesJson, factSourceTask f, factConfidence f, factCreatedAt f) + [SQL.Only factIdVal] <- SQL.query_ conn "SELECT last_insert_rowid()" :: IO [SQL.Only Int] + pure factIdVal + +-- | Load all facts from the database +loadFacts :: IO [Fact] +loadFacts = + withDb <| \conn -> + SQL.query_ + conn + "SELECT id, project, fact, related_files, source_task, confidence, created_at FROM facts" + +-- | Get facts for a specific project +getFactsForProject :: Text -> IO [Fact] +getFactsForProject proj = + withDb <| \conn -> + SQL.query + conn + "SELECT id, project, fact, related_files, source_task, confidence, created_at \ + \FROM facts WHERE project = ? ORDER BY confidence DESC" + (SQL.Only proj) + +-- | Get facts related to a specific file +getFactsForFile :: Text -> IO [Fact] +getFactsForFile filePath = + withDb <| \conn -> + SQL.query + conn + "SELECT id, project, fact, related_files, source_task, confidence, created_at \ + \FROM facts WHERE related_files LIKE ? ORDER BY confidence DESC" + (SQL.Only ("%" <> filePath <> "%")) + +-- | Delete a fact by ID +deleteFact :: Int -> IO () +deleteFact fid = + withDb <| \conn -> + SQL.execute conn "DELETE FROM facts WHERE id = ?" (SQL.Only fid) diff --git a/Omni/Task/DESIGN.md b/Omni/Task/DESIGN.md new file mode 100644 index 0000000..0dbf3b5 --- /dev/null +++ b/Omni/Task/DESIGN.md @@ -0,0 +1,232 @@ +# Task Manager Improvement Plan + +Based on beads project planning patterns, here are proposed improvements for Omni/Task.hs. + +## Current State + +**What we have:** +- ✅ Basic CRUD operations (create, list, update, ready) +- ✅ Dependency tracking (--deps for blocking) +- ✅ JSONL storage with git sync +- ✅ Short base62 task IDs +- ✅ Optional namespace field +- ✅ Project field for grouping +- ✅ Three status levels (open, in-progress, done) + +**What we're missing:** +- ❌ Multiple dependency types (blocks, discovered-from, parent-child, related) +- ❌ Hierarchical task IDs (parent.1, parent.2) +- ❌ Task types (epic vs task) - epics will replace "project" +- ❌ Dependency tree visualization +- ❌ Work discovery tracking +- ❌ Epic/child task relationships + +## Proposed Improvements (Priority Order) + +### Phase 1: Core Features (High Priority) + +#### 1.1 Add Task Types (Epic vs Task) +```haskell +data TaskType = Epic | Task + deriving (Show, Eq, Generic) +``` + +**Benefits:** +- Epics are containers for related tasks (replace "project" concept) +- Tasks are the actual work items +- Simple two-level hierarchy +- Epic-based planning support + +**Schema Changes:** +- Replace `taskProject :: Text` with `taskType :: TaskType` +- Add `taskParent :: Maybe Text` for parent epic +- Epics can contain tasks or other epics (for nested structure) + +**Commands:** +```bash +# Create an epic (container) +task create "User Authentication System" --type=epic + +# Create tasks within an epic +task create "Design API" --type=task --parent=t-abc123 +task create "Implement JWT" --type=task --parent=t-abc123 + +# Create a sub-epic (optional, for complex projects) +task create "OAuth Integration" --type=epic --parent=t-abc123 +``` + +#### 1.2 Enhanced Dependency Types +```haskell +data DependencyType = Blocks | DiscoveredFrom | ParentChild | Related + deriving (Show, Eq, Generic) +``` + +**Benefits:** +- Track work discovery context +- Maintain audit trail +- Support epic hierarchies + +**Commands:** +```bash +task create "Fix bug" project --discovered-from=t-abc123 +task create "Subtask 1" project --parent=t-epic-id +task dep add t-123 t-124 --type=related +``` + +### Phase 2: Hierarchical Tasks (Medium Priority) + +#### 2.1 Parent-Child Task IDs +**Pattern:** `t-abc123.1`, `t-abc123.2`, `t-abc123.3` + +**Benefits:** +- Human-friendly sequential IDs under epic +- Natural work breakdown +- Up to 3 levels of nesting + +**Schema Changes:** +```haskell +data Task = Task + { ... + taskParent :: Maybe Text -- Parent task ID + ... + } + +-- New table for child counters +CREATE TABLE child_counters ( + parent_id TEXT PRIMARY KEY, + last_child INTEGER NOT NULL DEFAULT 0, + FOREIGN KEY (parent_id) REFERENCES tasks(id) ON DELETE CASCADE +); +``` + +**Commands:** +```bash +task create "Design auth API" project --parent=t-abc123 +# Creates: t-abc123.1 + +task create "Implement JWT" project --parent=t-abc123 +# Creates: t-abc123.2 +``` + +#### 2.2 Dependency Tree Visualization +```bash +task tree t-epic-id +# Shows: +# t-abc123 [Epic] User Authentication System +# t-abc123.1 [Task] Design auth API +# t-abc123.2 [Task] Implement JWT +# t-abc123.2.1 [Task] Add token generation +# t-abc123.2.2 [Task] Add token validation +# t-abc123.3 [Task] Add password hashing +``` + +### Phase 3: Project Management (Lower Priority) + +#### 3.1 Task Filtering and Queries +```bash +task list --type=epic +task list --status=open +task list --parent=t-epic-id # List all children +``` + +#### 3.2 Epic Statistics +```bash +task stats # Overall stats +task stats --epic=t-abc123 # Epic-specific +task progress t-epic-id # Epic completion % +``` + +#### 3.3 Discovered Work Tracking +```bash +task create "Found memory leak" project --discovered-from=t-abc123 +# Automatically links context +# Shows in dependency tree as "discovered during t-abc123" +``` + +## Implementation Strategy + +### Milestone 1: Type System Foundations +- [ ] Add TaskType enum (Epic | Task) +- [ ] Add DependencyType enum +- [ ] Update Task data structure (replace project with type and parent) +- [ ] Update CLI commands +- [ ] Update tests +- [ ] Update AGENTS.md +- [ ] Migration: existing tasks default to type=Task, project becomes epic name + +### Milestone 2: Enhanced Dependencies +- [ ] Add `discovered-from` support +- [ ] Add `related` dependency type +- [ ] Track dependency metadata (who, when, why) +- [ ] Update ready work algorithm to respect dependency types + +### Milestone 3: Hierarchical Structure +- [ ] Add parent field to Task +- [ ] Implement child ID generation (t-abc123.1) +- [ ] Add child_counters table/storage +- [ ] Update createTask to handle --parent flag +- [ ] Implement parent-child dependency creation + +### Milestone 4: Visualization & Reporting +- [ ] Implement `task tree` command +- [ ] Implement `task stats` command +- [ ] Implement `task progress` for epics +- [ ] Add filtering by type, priority +- [ ] Improve task list display with colors/formatting + +## Open Questions + +1. **Storage Format**: Should we keep JSONL or move to SQLite like beads? + - JSONL: Simple, git-friendly, human-readable + - SQLite: Fast queries, complex relationships, beads-compatible + - **Recommendation**: Start with JSONL, can add SQLite later for caching + +2. **Child Counter Storage**: Where to store child counters? + - Option A: Separate .tasks/counters.jsonl file + - Option B: In-memory during session, persist to JSONL + - Option C: Add SQLite just for this + - **Recommendation**: Option A - separate JSONL file + +3. **Dependency Storage**: How to store complex dependencies? + - Current: List of text IDs in task + - Beads: Separate dependencies table + - **Recommendation**: Add dependencies field with type info: + ```haskell + data Dependency = Dependency + { depId :: Text + , depType :: DependencyType + } + ``` + +4. **Backward Compatibility**: How to handle existing tasks? + - Add sensible defaults (type=Task, priority=Medium) + - Migration script or auto-upgrade on load? + - **Recommendation**: Auto-upgrade with defaults on import + +## Benefits Summary + +**For AI Agents:** +- Better work discovery and context tracking +- Clearer project structure +- Easier to understand what work is related +- Natural way to break down large tasks + +**For Humans:** +- Epic-based planning for large features +- Priority-driven work queue +- Visual dependency trees +- Better project tracking and reporting + +**For Collaboration:** +- Discovered work maintains context +- Related work is easily found +- Epic structure provides clear organization +- Dependency tracking prevents duplicate work + +## Next Steps + +1. Create tasks for each milestone +2. Start with Milestone 1 (Type System Foundations) +3. Get feedback on hierarchical ID format +4. Implement incrementally, test thoroughly +5. Update AGENTS.md with new patterns diff --git a/Omni/Task/MigrationTest.hs b/Omni/Task/MigrationTest.hs new file mode 100644 index 0000000..f16f782 --- /dev/null +++ b/Omni/Task/MigrationTest.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Omni.Task.MigrationTest where + +import Alpha +import qualified Data.Set as Set +import Omni.Task.Core +import qualified Omni.Test as Test +import System.Directory (doesFileExist, removeFile) +import System.Environment (setEnv) + +test :: Test.Tree +test = Test.group "Omni.Task.Migration" [migrationStartupTest] + +migrationStartupTest :: Test.Tree +migrationStartupTest = + Test.unit "database initializes with schema migrations" <| do + setEnv "TASK_TEST_MODE" "1" + + let testFile = "_/tmp/tasks-test.db" + exists <- doesFileExist testFile + when exists <| removeFile testFile + + initTaskDb + + withDb <| \conn -> do + tasksCols <- getTableColumns conn "tasks" + activityCols <- getTableColumns conn "task_activity" + retryCols <- getTableColumns conn "retry_context" + + Set.fromList ["id", "title", "status"] + `Set.isSubsetOf` Set.fromList tasksCols + Test.@?= True + Set.fromList ["id", "task_id", "stage"] + `Set.isSubsetOf` Set.fromList activityCols + Test.@?= True + Set.fromList ["task_id", "attempt", "reason"] + `Set.isSubsetOf` Set.fromList retryCols + Test.@?= True + + removeFile testFile diff --git a/Omni/Task/README.md b/Omni/Task/README.md new file mode 100644 index 0000000..463c9e5 --- /dev/null +++ b/Omni/Task/README.md @@ -0,0 +1,376 @@ +# Task Manager for AI Agents + +The task manager is a dependency-aware issue tracker inspired by beads. It uses: +- **Storage**: SQLite database (`~/.cache/omni/tasks/tasks.db`) +- **Dependencies**: Tasks can block other tasks +- **Ready work detection**: Automatically finds unblocked tasks + +**IMPORTANT**: You MUST use `task` for ALL issue tracking. NEVER use markdown TODOs, todo_write, task lists, or any other tracking methods. + +## Human Setup vs Agent Usage + +**If you see "database not found" or similar errors:** +```bash +task init --quiet # Non-interactive, auto-setup, no prompts +``` + +**Why `--quiet`?** The regular `task init` may have interactive prompts. The `--quiet` flag makes it fully non-interactive and safe for agent-driven setup. + +**If `task init --quiet` fails:** Ask the human to run `task init` manually, then continue. + +## Create a Task +```bash +task create "<title>" [--type=<type>] [--parent=<id>] [--deps=<ids>] [--dep-type=<type>] [--discovered-from=<id>] [--namespace=<ns>] +``` + +Examples: +```bash +# Create an epic (container for tasks) +task create "User Authentication System" --type=epic + +# Create a task within an epic +task create "Design auth API" --parent=t-abc123 + +# Create a task with blocking dependency +task create "Write tests" --deps=t-a1b2c3 --dep-type=blocks + +# Create work discovered during implementation (shortcut) +task create "Fix memory leak" --discovered-from=t-abc123 + +# Create related work (doesn't block) +task create "Update documentation" --deps=t-abc123 --dep-type=related + +# Associate with a namespace +task create "Fix type errors" --namespace="Omni/Task" +``` + +**Task Types:** +- `epic` - Container for related tasks +- `task` - Individual work item (default) +- `human` - Task specifically for human operators (excluded from agent work queues) + +**Dependency Types:** +- `blocks` - Hard dependency, blocks ready work queue (default) +- `discovered-from` - Work discovered during other work, doesn't block +- `parent-child` - Epic/subtask relationship, blocks ready work +- `related` - Soft relationship, doesn't block + +The `--namespace` option associates the task with a specific namespace in the monorepo (e.g., `Omni/Task`, `Biz/Cloud`). This helps organize tasks by the code they relate to. + +## List Tasks +```bash +task list [options] # Flags can be in any order +``` + +Examples: +```bash +task list # All tasks +task list --type=epic # All epics +task list --parent=t-abc123 # All tasks in an epic +task list --status=open # All open tasks +task list --status=done # All completed tasks +task list --namespace="Omni/Task" # All tasks for a namespace +task list --parent=t-abc123 --status=open # Combine filters: open tasks in epic +``` + +## Get Ready Work +```bash +task ready +``` + +Shows all tasks that are: +- Not closed +- Not blocked by incomplete dependencies + +## Update Task Status +```bash +task update <id> <status> +``` + +Status values: `open`, `in-progress`, `done` + +Examples: +```bash +task update t-20241108120000 in-progress +task update t-20241108120000 done +``` + +**Note**: Task updates are immediately saved to the SQLite database. + +## View Dependencies +```bash +task deps <id> +``` + +Shows the dependency tree for a task. + +## View Task Tree +```bash +task tree [<id>] +``` + +Shows task hierarchy with visual status indicators: +- `[ ]` - Open +- `[~]` - In Progress +- `[✓]` - Done + +Examples: +```bash +task tree # Show all epics with their children +task tree t-abc123 # Show specific epic/task with its children +``` + +## Export Tasks +```bash +task export [-o <file>] +``` + +Exports tasks to JSONL format (stdout by default, or to a file with `-o`). + +## Import Tasks +```bash +task import -i <file> +``` + +Imports tasks from a JSONL file, merging with existing tasks. Newer tasks (based on `updatedAt` timestamp) take precedence. + +Examples: +```bash +task import -i /path/to/backup.jsonl +``` + +## Initialize (First Time) +```bash +task init +``` + +Creates the SQLite database at `~/.cache/omni/tasks/tasks.db`. + +## Common Workflows + +### Starting New Work + +1. **Find what's ready to work on:** + ```bash + task ready + ``` + +2. **Pick a task and mark it in progress:** + ```bash + task update t-20241108120000 in-progress + ``` + +3. **When done, mark it complete:** + ```bash + task update t-20241108120000 done + ``` + +### Creating Dependent Tasks + +When you discover work that depends on other work: + +```bash +# Create the blocking task first +task create "Design API" --type=task + +# Note the ID (e.g., t-20241108120000) + +# Create dependent task with blocking dependency +task create "Implement API client" --deps=t-20241108120000 --dep-type=blocks +``` + +The dependent task won't show up in `task ready` until the blocker is marked `done`. + +### Discovered Work Pattern + +When you find work during implementation, use the `--discovered-from` flag: + +```bash +# While working on t-abc123, you discover a bug +task create "Fix memory leak in parser" --discovered-from=t-abc123 + +# This is equivalent to: +task create "Fix memory leak in parser" --deps=t-abc123 --dep-type=discovered-from +``` + +The `discovered-from` dependency type maintains context but **doesn't block** the ready work queue. This allows AI agents to track what work was found during other work while still being able to work on it immediately. + +### Working with Epics + +```bash +# Create an epic for a larger feature +task create "User Authentication System" --type=epic +# Note ID: t-abc123 + +# Create child tasks within the epic +task create "Design login flow" --parent=t-abc123 +task create "Implement OAuth" --parent=t-abc123 +task create "Add password reset" --parent=t-abc123 + +# List all tasks in an epic +task list --parent=t-abc123 + +# List all epics +task list --type=epic +``` + +## Agent Best Practices + +### 1. ALWAYS Check Ready Work First +Before asking what to do, you MUST check `task ready --json` to see unblocked tasks. + +### 2. ALWAYS Create Tasks for Discovered Work +When you encounter work during implementation, you MUST create linked tasks: +```bash +task create "Fix type error in auth module" --discovered-from=t-abc123 --json +task create "Add missing test coverage" --discovered-from=t-abc123 --json +``` + +**Bug Discovery Pattern** + +When you discover a bug or unexpected behavior: +```bash +# CORRECT: Immediately file a task +task create "Command X fails when Y" --discovered-from=<current-task-id> --json + +# WRONG: Ignoring it and moving on +# WRONG: Leaving a TODO comment +# WRONG: Mentioning it but not filing a task +``` + +**Examples of bugs you MUST file:** +- "Expected `--flag value` to work but only `--flag=value` works" +- "Documentation says X but actual behavior is Y" +- "Combining two flags causes parsing error" +- "Feature is missing that would be useful" + +**CRITICAL: File bugs immediately when you discover them:** +- If a command doesn't work as documented → create a task +- If a command doesn't work as you expected → create a task +- If behavior is inconsistent or confusing → create a task +- If documentation is wrong or misleading → create a task +- If you find yourself working around a limitation → create a task + +**NEVER leave TODO comments in code.** Create a task instead. + +**NEVER ignore bugs or unexpected behavior.** File a task for it immediately. + +### 3. Forbidden Patterns + +**Markdown checklist (NEVER do this):** +```markdown +❌ Wrong: +- [ ] Refactor auth module +- [ ] Add tests +- [ ] Update docs + +✅ Correct: +task create "Refactor auth module" -p 2 --json +task create "Add tests for auth" -p 2 --json +task create "Update auth docs" -p 3 --json +``` + +**todo_write tool (NEVER do this):** +``` +❌ Wrong: todo_write({todos: [{content: "Fix bug", ...}]}) +✅ Correct: task create "Fix bug in parser" -p 1 --json +``` + +**Inline code comments (NEVER do this):** +```python +❌ Wrong: +# TODO: write tests for this function +# FIXME: handle edge case + +✅ Correct: +# Create task instead: +task create "Write tests for parse_config" -p 2 --namespace="Omni/Config" --json +task create "Handle edge case in parser" -p 1 --discovered-from=<current-id> --json +``` + +### 4. Track Dependencies +If work depends on other work, use `--deps`: +```bash +# Can't write tests until implementation is done +task create "Test auth flow" --deps=t-20241108120000 --dep-type=blocks --json +``` + +### 5. Use Descriptive Titles +Good: `"Add JWT token validation to auth middleware"` +Bad: `"Fix auth"` + +### 6. Use Epics for Organization +Organize related work using epics: +- Create an epic for larger features: `task create "Feature Name" --type=epic --json` +- Add tasks to the epic using `--parent=<epic-id>` +- Use `--discovered-from` to track work found during implementation + +### 7. ALWAYS Store AI Planning Docs in `_/llm` Directory +AI assistants often create planning and design documents during development: +- PLAN.md, DESIGN.md, TESTING_GUIDE.md, tmp, and similar files +- **You MUST use a dedicated directory for these ephemeral files** +- Store ALL AI-generated planning/design docs in `_/llm` +- The `_` directory is ignored by git and all of our temporary files related to the omnirepo go there +- NEVER commit planning docs to the repo root + +## Dependency Rules + +- A task is **blocked** if any of its dependencies are not `done` +- A task is **ready** if all its dependencies are `done` (or it has no dependencies) +- `task ready` only shows tasks with status `open` or `in-progress` that are not blocked + +## Storage + +Tasks are stored in a SQLite database at `~/.cache/omni/tasks/tasks.db`. This is a local database, not git-tracked. + +To back up or transfer tasks, use `task export` and `task import`. + +## Testing and Development + +**CRITICAL**: When manually testing task functionality, use the test database: + +```bash +# Set test mode to protect production database +export TASK_TEST_MODE=1 + +# Now all task operations use _/tmp/tasks-test.db +task create "Test task" --type=task +task list +task tree + +# Unset when done +unset TASK_TEST_MODE +``` + +**The test suite automatically uses test mode** - you don't need to set it manually when running `task test` or `bild --test Omni/Task.hs`. + +## Troubleshooting + +### "Task not found" +- Check the task ID is correct with `task list` +- Ensure you've run `task init` + +### "Database not initialized" +Run: `task init` + +### Dependencies not working +- Verify dependency IDs exist: `task list` +- Check dependency tree: `task deps <id>` + +## Reinforcement: Critical Rules + +Remember these non-negotiable rules: + +- ✅ Use `task` for ALL task tracking (with `--json` flag) +- ✅ Link discovered work with `--discovered-from` dependencies +- ✅ File bugs IMMEDIATELY when you discover unexpected behavior +- ✅ Check `task ready --json` before asking "what should I work on?" +- ✅ Store AI planning docs in `_/llm` directory +- ❌ NEVER use `todo_write` tool +- ❌ NEVER create markdown TODO lists or task checklists +- ❌ NEVER put TODOs or FIXMEs in code comments +- ❌ NEVER use external issue trackers +- ❌ NEVER duplicate tracking systems +- ❌ NEVER clutter repo root with planning documents + +**If you find yourself about to use todo_write or create a markdown checklist, STOP and use `task create` instead.** diff --git a/Omni/Task/RaceTest.hs b/Omni/Task/RaceTest.hs new file mode 100644 index 0000000..8ab797a --- /dev/null +++ b/Omni/Task/RaceTest.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Omni.Task.RaceTest where + +import Alpha +import Control.Concurrent.Async (mapConcurrently) +import Data.List (nub) +import qualified Data.Text as T +import Omni.Task.Core +import qualified Omni.Test as Test +import System.Directory (doesFileExist, removeFile) +import System.Environment (setEnv) + +test :: Test.Tree +test = Test.group "Omni.Task.Race" [raceTest] + +raceTest :: Test.Tree +raceTest = + Test.unit "concurrent child creation (race condition)" <| do + -- Set up test mode (uses _/tmp/tasks-test.db) + setEnv "TASK_TEST_MODE" "1" + + -- Clean up test database + let testFile = "_/tmp/tasks-test.db" + exists <- doesFileExist testFile + when exists <| removeFile testFile + initTaskDb + + -- Create a parent epic + parent <- createTask "Parent Epic" Epic Nothing Nothing P2 Nothing [] "Parent Epic description" + let parentId = taskId parent + + -- Create multiple children concurrently + -- We'll create 10 children in parallel + let childCount = 10 + indices = [1 .. childCount] + + -- Run concurrent creations + children <- + mapConcurrently + (\i -> createTask ("Child " <> tshow i) WorkTask (Just parentId) Nothing P2 Nothing [] ("Child " <> tshow i <> " description")) + indices + + -- Check for duplicates in generated IDs + let ids = map taskId children + uniqueIds = nub ids + + -- If there was a race condition, we'd have fewer unique IDs than children + length uniqueIds Test.@?= length children + length uniqueIds Test.@?= childCount + + -- Verify IDs follow the pattern parentId.N + for_ ids <| \tid -> do + (parentId `T.isPrefixOf` tid) Test.@?= True + + -- Cleanup + removeFile testFile diff --git a/Omni/Test.py b/Omni/Test.py index 495334a..71ac32a 100644 --- a/Omni/Test.py +++ b/Omni/Test.py @@ -6,10 +6,17 @@ import Omni.Log as Log import typing import unittest +TestCase = unittest.TestCase + + +class TestError(Exception): + """When the test environment or harness encounters a problem.""" + def run(area: App.Area, tests: list[typing.Any]) -> None: """Run the given tests with loglevel determined by area.""" - Log.setup(logging.DEBUG if area == App.Area.Test else logging.ERROR) + logger = logging.getLogger(__name__) + Log.setup(logger, logging.DEBUG if area == App.Area.Test else logging.ERROR) suite = unittest.TestSuite() suite.addTests([ unittest.defaultTestLoader.loadTestsFromTestCase(tc) for tc in tests diff --git a/Omni/Users.nix b/Omni/Users.nix index 043c5fd..3de5712 100644 --- a/Omni/Users.nix +++ b/Omni/Users.nix @@ -40,7 +40,7 @@ in { isNormalUser = true; home = "/home/ben"; openssh.authorizedKeys.keys = readKeys ./Keys/Ben.pub; - extraGroups = ["wheel" "docker" "bitcoind-mainnet" "git"]; + extraGroups = ["wheel" "docker" "bitcoind-mainnet" "git" "audio" "video"]; hashedPassword = "$6$SGhdoRB6DhWe$elW8RQE1ebe8JKf1ALW8jGZTPCyn2rpq/0J8MV/A9y8qFMEhA.Z2eiexMgptohZAK5kcGOc6HIUgNzJqnDUvY."; }; dre = { |