diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,17 @@ ## [Unreleased] +## [0.1.1.0] - 2026-09-01 + +### Changed + +- `tricorder-mcp` no longer requires the agent to pass the directory of the + project in question, and will instead infer it from the current working + directory or use the directory passed from the agent harness. +- Added more accurate and detailed descriptions for each tool. + +## [0.1.0.0] - 2026-08-19 + ### Added - Initial release. diff --git a/src/Tricorder/MCP/Main.hs b/src/Tricorder/MCP/Main.hs --- a/src/Tricorder/MCP/Main.hs +++ b/src/Tricorder/MCP/Main.hs @@ -7,7 +7,7 @@ , noHandlers , runMcpServerStdio ) -import MCP.Server.Derive (deriveToolHandlerWithDescription) +import MCP.Server.Derive (deriveToolHandlerWithOptions) import Paths_tricorder_mcp (version) import Tricorder.MCP.Tools (Tool, handleTool, toolDescriptions) @@ -20,7 +20,7 @@ handlers :: McpServerHandlers handlers = noHandlers - { tools = Just $(deriveToolHandlerWithDescription ''Tool 'handleTool toolDescriptions) + { tools = Just $(deriveToolHandlerWithOptions ''Tool 'handleTool toolDescriptions) } diff --git a/src/Tricorder/MCP/Tools.hs b/src/Tricorder/MCP/Tools.hs --- a/src/Tricorder/MCP/Tools.hs +++ b/src/Tricorder/MCP/Tools.hs @@ -1,14 +1,11 @@ module Tricorder.MCP.Tools ( Tool (..) - , StartOptions (..) , StopOptions (..) , RestartOptions (..) , StatusOptions (..) , TestResultsOptions (..) , SourceOptions (..) , EvalCommentsOptions (..) - , LogPathOptions (..) - , LogContentsOptions (..) , handleTool , toolCommand , toolDescriptions @@ -18,98 +15,146 @@ import Control.Exception (IOException, try) import MCP.Server (ClientContext, Content (..), ToolResult, toolError, toolResult) +import MCP.Server.Derive (DefinitionOptions (..), defaultDefinitionOptions) +import System.Directory (listDirectory) +import System.Environment (lookupEnv) import System.Exit (ExitCode (..)) +import System.Posix (getWorkingDirectory) import System.Process.Typed (proc, readProcess, setWorkingDir) import Tricorder.SourceLookup.SourceQuery (parseSourceQuery) import Data.ByteString.Lazy qualified as BSL +import Data.List qualified as List import Tricorder.CLI.Command qualified as CLI data Tool - = Start StartOptions + = Start | Stop StopOptions | Restart RestartOptions | Status StatusOptions | TestResults TestResultsOptions | Source SourceOptions | EvalComments EvalCommentsOptions - | LogPath LogPathOptions - | LogContents LogContentsOptions - - -newtype StartOptions = StartOptions {directory :: Text} + | LogPath + | LogContents -data StopOptions = StopOptions - { directory :: Text - , force :: Maybe Bool - } +newtype StopOptions = StopOptions {force :: Maybe Bool} -data RestartOptions = RestartOptions - { directory :: Text - , force :: Maybe Bool - } +newtype RestartOptions = RestartOptions {force :: Maybe Bool} data StatusOptions = StatusOptions - { directory :: Text - , wait :: Maybe Bool - , json :: Maybe Bool + { wait :: Maybe Bool , verbose :: Maybe Bool , expand :: Maybe Int } data TestResultsOptions = TestResultsOptions - { directory :: Text - , failed :: Maybe Bool + { failed :: Maybe Bool , wait :: Maybe Bool } -data SourceOptions = SourceOptions - { directory :: Text - , modules :: [Text] - } +newtype SourceOptions = SourceOptions {modules :: [Text]} -data EvalCommentsOptions = EvalCommentsOptions - { directory :: Text - , wait :: Maybe Bool - , json :: Maybe Bool +newtype EvalCommentsOptions = EvalCommentsOptions + { wait :: Maybe Bool } -newtype LogPathOptions = LogPathOptions {directory :: Text} - - -newtype LogContentsOptions = LogContentsOptions {directory :: Text} - - -toolDescriptions :: [(String, String)] +toolDescriptions :: [(String, DefinitionOptions)] toolDescriptions = - [ ("Start", "Start the tricorder daemon for a project (no-op if already running)") - , ("Stop", "Stop the tricorder daemon for a project") - , ("Restart", "Restart the tricorder daemon for a project") - , ("Status", "Get the current GHCi build status: diagnostics, errors and warnings") - , ("TestResults", "Show output from the latest test run") - , ("Source", "Print the Haskell source of one or more installed modules") - , ("EvalComments", "Show eval comments and their evaluated results from the latest build") - , ("LogPath", "Print the path to the daemon's log file") - , ("LogContents", "Print the daemon's log output") + [ + ( "Start" + , defaultDefinitionOptions + { optDescription = Just "Start the tricorder daemon (no-op if already running)." + , optTitle = Just "Start daemon" + } + ) , - ( "directory" - , "Absolute path to the project's working directory (the tricorder daemon is scoped per-directory)" + ( "Stop" + , defaultDefinitionOptions + { optDescription = Just "Stop the tricorder daemon." + , optTitle = Just "Stop daemon" + , optFieldDescriptions = + [ ("force", "Ignore pending queries instead of waiting for them to finish.") + ] + } ) - , ("force", "Ignore pending queries instead of waiting for them to finish") - , ("wait", "Block until the current build cycle finishes before returning") - , ("json", "Return machine-readable JSON instead of the default text output") - , ("verbose", "Include the full GHC message body under each diagnostic") - , ("expand", "Only show the summary line and full message body for diagnostic #N") - , ("failed", "Only show output from failed test suites") - , ("modules", "Module names to look up, e.g. Data.Map.Strict or Data.Map.Strict#insert") + , + ( "Restart" + , defaultDefinitionOptions + { optDescription = Just "Restart the tricorder daemon." + , optTitle = Just "Restart daemon" + , optFieldDescriptions = + [ ("force", "Ignore pending queries instead of waiting for them to finish.") + ] + } + ) + , + ( "Status" + , defaultDefinitionOptions + { optDescription = Just "Get the current GHCi build status: diagnostics, errors and warnings." + , optTitle = Just "View built status" + , optFieldDescriptions = + [ ("wait", "Block until the current build cycle finishes before returning.") + , ("verbose", "Include the full GHC message body under each diagnostic.") + , ("expand", "Only show the summary line and full message body for diagnostic #N.") + ] + } + ) + , + ( "TestResults" + , defaultDefinitionOptions + { optDescription = Just "Show output from the latest test suite runs." + , optTitle = Just "View test results" + , optFieldDescriptions = + [ ("wait", "Block until the current build cycle finishes before returning.") + , ("failed", "Only show output from failed test suites.") + ] + } + ) + , + ( "Source" + , defaultDefinitionOptions + { optDescription = + Just + "Print the Haskell source of one or more installed modules. Prefer this over downloading tarballs." + , optTitle = Just "Lookup source" + , optFieldDescriptions = + [ ("modules", "Module names to look up, e.g. Data.Map.Strict or Data.Map.Strict#insert.") + ] + } + ) + , + ( "EvalComments" + , defaultDefinitionOptions + { optDescription = Just "Show eval comments and their evaluated results from the latest build." + , optTitle = Just "View eval comments" + , optFieldDescriptions = + [ ("wait", "Block until the current build cycle finishes before returning.") + ] + } + ) + , + ( "LogPath" + , defaultDefinitionOptions + { optDescription = Just "Print the path to the daemon's log file." + , optTitle = Just "View log path" + } + ) + , + ( "LogContents" + , defaultDefinitionOptions + { optDescription = Just "Print the daemon's log output." + , optTitle = Just "View log contents" + } + ) ] @@ -117,53 +162,41 @@ -- it in, and the subcommand plus flags to pass. Builds the shared 'CLI.Command' -- and renders it via 'CLI.commandToArgs' so the flags stay in sync with -- "Tricorder.CLI.Arguments" instead of being duplicated here. -toolCommand :: Tool -> (Text, [String]) -toolCommand = \case - (Start (StartOptions {directory})) -> - ( directory - , CLI.commandToArgs CLI.Start - ) - (Stop (StopOptions {directory, force = doForce})) -> - ( directory - , CLI.commandToArgs (CLI.Stop (toForce doForce)) - ) - (Restart (RestartOptions {directory, force = doForce})) -> - ( directory - , CLI.commandToArgs (CLI.Restart (toForce doForce)) - ) - (Status (StatusOptions {directory, wait, json, verbose, expand})) -> - ( directory - , CLI.commandToArgs - $ CLI.Status +toolCommand :: Tool -> [String] +toolCommand = + CLI.commandToArgs . \case + Start -> + CLI.Start + (Stop (StopOptions {force = doForce})) -> + CLI.Stop $ toForce doForce + (Restart (RestartOptions {force = doForce})) -> + CLI.Restart $ toForce doForce + (Status (StatusOptions {wait, verbose, expand})) -> + CLI.Status CLI.StatusOptions { wait = toWaitMode wait - , format = toFormat json + , format = CLI.JsonOutput , verbosity = toVerbosity verbose , expand } - ) - (TestResults (TestResultsOptions {directory, failed, wait})) -> - ( directory - , CLI.commandToArgs - $ CLI.Test CLI.TestOptions {failedOnly = fromMaybe False failed, wait = toWaitMode wait} - ) - (Source (SourceOptions {directory, modules})) -> - ( directory - , CLI.commandToArgs (CLI.Source (map parseSourceQuery modules)) - ) - (EvalComments (EvalCommentsOptions {directory, wait, json})) -> - ( directory - , CLI.commandToArgs - $ CLI.EvalComments CLI.EvalCommentsOptions {wait = toWaitMode wait, format = toFormat json} - ) - (LogPath (LogPathOptions {directory})) -> - ( directory - , CLI.commandToArgs (CLI.Log CLI.ShowLogPath) - ) - (LogContents (LogContentsOptions {directory})) -> - ( directory - , CLI.commandToArgs (CLI.Log (CLI.ShowLog CLI.NoFollow)) - ) + (TestResults (TestResultsOptions {failed, wait})) -> + CLI.Test + CLI.TestOptions + { failedOnly = fromMaybe False failed + , wait = toWaitMode wait + } + (Source (SourceOptions {modules})) -> + CLI.Source $ parseSourceQuery <$> modules + (EvalComments (EvalCommentsOptions {wait})) -> + CLI.EvalComments + CLI.EvalCommentsOptions + { wait = toWaitMode wait + , format = CLI.JsonOutput + } + LogPath -> + CLI.Log CLI.ShowLogPath + LogContents -> + CLI.Log $ CLI.ShowLog CLI.NoFollow toForce :: Maybe Bool -> CLI.Force @@ -174,10 +207,6 @@ toWaitMode = maybe CLI.ShowCurrent (\enabled -> if enabled then CLI.WaitForBuild else CLI.ShowCurrent) -toFormat :: Maybe Bool -> CLI.OutputFormat -toFormat = maybe CLI.TextOutput (\enabled -> if enabled then CLI.JsonOutput else CLI.TextOutput) - - toVerbosity :: Maybe Bool -> CLI.Verbosity toVerbosity = maybe CLI.Concise (\enabled -> if enabled then CLI.Verbose else CLI.Concise) @@ -202,12 +231,35 @@ -- request. handleTool :: ClientContext -> Tool -> IO ToolResult handleTool _ tool = do - let (directory, args) = toolCommand tool - outcome <- - try @IOException $ readProcess $ setWorkingDir (toString directory) $ proc "tricorder" args - pure $ case outcome of - Left ex -> toolError $ "Failed to run tricorder: " <> show ex - Right (ExitSuccess, out, _) -> toolResult [ContentText (decodeUtf8 out)] - Right (ExitFailure _, out, _) | reportsBuildOutcome tool -> toolResult [ContentText (decodeUtf8 out)] - Right (ExitFailure _, out, err) -> - toolError $ "tricorder failed: " <> decodeUtf8 (if BSL.null err then out else err) + mDir <- projectRoot + case mDir of + Left err -> + pure $ toolError $ "Failed to run tricorder: " <> err + Right directory -> do + outcome <- + try @IOException + $ readProcess + $ setWorkingDir directory + $ proc "tricorder" args + pure $ case outcome of + Left ex -> toolError $ "Failed to run tricorder: " <> show ex + Right (ExitSuccess, out, _) -> toolResult [ContentText (decodeUtf8 out)] + Right (ExitFailure _, out, _) | reportsBuildOutcome tool -> toolResult [ContentText (decodeUtf8 out)] + Right (ExitFailure _, out, err) -> + toolError $ "tricorder failed: " <> decodeUtf8 (if BSL.null err then out else err) + where + args = toolCommand tool + + +projectRoot :: IO (Either Text FilePath) +projectRoot = do + claudeDir <- lookupEnv "CLAUDE_PROJECT_DIR" + copilotDir <- lookupEnv "COPILOT_CWD" + workingDir <- getWorkingDirectory + let dir = fromMaybe workingDir $ claudeDir <|> copilotDir + files <- listDirectory dir + if not (any (\f -> ".cabal" `List.isSuffixOf` f || "cabal.project" `List.isPrefixOf` f) files) + then + pure $ Left $ "Could not find a `.cabal` file in the resolved project directory: " <> toText dir + else + pure $ Right dir diff --git a/test/Unit/Tricorder/MCP/ToolsSpec.hs b/test/Unit/Tricorder/MCP/ToolsSpec.hs --- a/test/Unit/Tricorder/MCP/ToolsSpec.hs +++ b/test/Unit/Tricorder/MCP/ToolsSpec.hs @@ -9,57 +9,55 @@ spec_Tools = do describe "toolCommand" do it "starts with just the directory" do - toolCommand (Start (StartOptions {directory = "/proj"})) - `shouldBe` ("/proj", ["start"]) + toolCommand Start + `shouldBe` ["start"] it "omits --force when unset" do - toolCommand (Stop (StopOptions {directory = "/proj", force = Nothing})) - `shouldBe` ("/proj", ["stop"]) + toolCommand (Stop (StopOptions {force = Nothing})) + `shouldBe` ["stop"] it "omits --force when explicitly false" do - toolCommand (Restart (RestartOptions {directory = "/proj", force = Just False})) - `shouldBe` ("/proj", ["restart"]) + toolCommand (Restart (RestartOptions {force = Just False})) + `shouldBe` ["restart"] it "includes --force when true" do - toolCommand (Stop (StopOptions {directory = "/proj", force = Just True})) - `shouldBe` ("/proj", ["stop", "--force"]) + toolCommand (Stop (StopOptions {force = Just True})) + `shouldBe` ["stop", "--force"] it "combines status flags in order, with --expand carrying its argument" do toolCommand ( Status StatusOptions - { directory = "/proj" - , wait = Just True - , json = Just True + { wait = Just True , verbose = Nothing , expand = Just 3 } ) - `shouldBe` ("/proj", ["status", "--wait", "--json", "--expand", "3"]) + `shouldBe` ["status", "--wait", "--json", "--expand", "3"] it "turns modules into positional arguments" do toolCommand - (Source (SourceOptions {directory = "/proj", modules = ["Data.Map.Strict", "Foo#bar"]})) - `shouldBe` ("/proj", ["source", "Data.Map.Strict", "Foo#bar"]) + (Source (SourceOptions {modules = ["Data.Map.Strict", "Foo#bar"]})) + `shouldBe` ["source", "Data.Map.Strict", "Foo#bar"] it "maps log_path to --print-path" do - toolCommand (LogPath (LogPathOptions {directory = "/proj"})) - `shouldBe` ("/proj", ["log", "--print-path"]) + toolCommand LogPath + `shouldBe` ["log", "--print-path"] it "maps log_contents to plain log" do - toolCommand (LogContents (LogContentsOptions {directory = "/proj"})) - `shouldBe` ("/proj", ["log"]) + toolCommand LogContents + `shouldBe` ["log"] describe "reportsBuildOutcome" do it "is true for status, test_results and eval_comments" do - reportsBuildOutcome (Status (StatusOptions "/p" Nothing Nothing Nothing Nothing)) `shouldBe` True - reportsBuildOutcome (TestResults (TestResultsOptions "/p" Nothing Nothing)) `shouldBe` True - reportsBuildOutcome (EvalComments (EvalCommentsOptions "/p" Nothing Nothing)) `shouldBe` True + reportsBuildOutcome (Status (StatusOptions Nothing Nothing Nothing)) `shouldBe` True + reportsBuildOutcome (TestResults (TestResultsOptions Nothing Nothing)) `shouldBe` True + reportsBuildOutcome (EvalComments (EvalCommentsOptions Nothing)) `shouldBe` True it "is false for commands whose exit code reflects process failure" do - reportsBuildOutcome (Start (StartOptions "/p")) `shouldBe` False - reportsBuildOutcome (Stop (StopOptions "/p" Nothing)) `shouldBe` False - reportsBuildOutcome (Restart (RestartOptions "/p" Nothing)) `shouldBe` False - reportsBuildOutcome (Source (SourceOptions "/p" [])) `shouldBe` False - reportsBuildOutcome (LogPath (LogPathOptions "/p")) `shouldBe` False - reportsBuildOutcome (LogContents (LogContentsOptions "/p")) `shouldBe` False + reportsBuildOutcome Start `shouldBe` False + reportsBuildOutcome (Stop (StopOptions Nothing)) `shouldBe` False + reportsBuildOutcome (Restart (RestartOptions Nothing)) `shouldBe` False + reportsBuildOutcome (Source (SourceOptions [])) `shouldBe` False + reportsBuildOutcome LogPath `shouldBe` False + reportsBuildOutcome LogContents `shouldBe` False diff --git a/tricorder-mcp.cabal b/tricorder-mcp.cabal --- a/tricorder-mcp.cabal +++ b/tricorder-mcp.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tricorder-mcp -version: 0.1.0.0 +version: 0.1.1.0 synopsis: MCP server for Tricorder description: Model Context Protocol server for Tricorder. category: AI, @@ -58,12 +58,14 @@ , atelier-prelude >=0.1 && <0.3 , base >=4.18 && <4.23 , bytestring >=0.11 && <0.13 + , directory ==1.3.* , effectful-core ==2.6.* , effectful-plugin >=2.0 && <2.2 , mcp-server ==0.2.* , process ==1.6.* , tricorder-types ==0.1.* , typed-process ==0.2.* + , unix ==2.8.* mixins: base hiding (Prelude) default-language: GHC2021