diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog + +All notable changes to `tricorder-mcp` will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to the [PVP](https://pvp.haskell.org/). + +## [Unreleased] + +### Added + +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Tweag + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,71 @@ +# tricorder-mcp + +Model Context Protocol server for [Tricorder](../tricorder/README.md). + +## Installation + +`tricorder-mcp` needs to be downloaded or installed onto your machine before Claude or Copilot can use it. + +### Hackage + +Download or install from [Hackage](https://hackage.haskell.org/package/tricorder-mcp): + +```bash +cabal install tricorder-mcp +# or +stack install tricorder-mcp +``` + +### GitHub release + +Download and install from [GitHub releases](https://github.com/tweag/tricorder/releases), and place the binary in your `PATH`. + +## Add MCP server to your agent + +### With Claude + +If you put `tricorder-mcp` in your `PATH`: + +```bash +claude mcp add tricorder -- tricorder-mcp +``` + +Alternatively, if you want to refer to `tricorder-mcp` by an absolute path: + +```bash +claude mcp add tricorder -- /path/to/tricorder-mcp +``` + +### With Copilot + +Use the `/mcp add` command within Copilot, or use the CLI directly: + +```bash +copilot mcp add tricorder -- tricorder-mcp +``` + +Alternatively, if you want to refer to `tricorder-mcp` by an absolute path: + +```bash +copilot mcp add tricorder -- /path/to/tricorder-mcp +``` + +## Usage + +Prompt your agent to use the `tricorder` MCP server whenever you want it to +perform some work. Alternatively, you can add it to your repo's `AGENT.md` to +ensure your agent always knows that the MCP server is available. + +## Built on atelier + +`tricorder-mcp` is built on the **atelier** toolkit, also developed in this repository: + +- [`atelier-prelude`](https://github.com/tweag/tricorder/tree/main/atelier-prelude) — relude-based prelude with Effectful conventions +- [`atelier-core`](https://github.com/tweag/tricorder/tree/main/atelier-core) — foundational effects and utilities +- [`atelier-db`](https://github.com/tweag/tricorder/tree/main/atelier-db) — relational database effect (Hasql/Rel8) +- [`atelier-testing`](https://github.com/tweag/tricorder/tree/main/atelier-testing) — database-backed test utilities +- [`atelier-monitoring`](https://github.com/tweag/tricorder/tree/main/atelier-monitoring) - observability and monitoring effects and utilities + +## License + +MIT — see [LICENSE](LICENSE). diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Tricorder.MCP.Main qualified as MCP + + +main :: IO () +main = MCP.main diff --git a/src/Tricorder/MCP/Main.hs b/src/Tricorder/MCP/Main.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/MCP/Main.hs @@ -0,0 +1,33 @@ +module Tricorder.MCP.Main (main) where + +import Data.Version (showVersion) +import MCP.Server + ( McpServerHandlers (..) + , McpServerInfo (..) + , noHandlers + , runMcpServerStdio + ) +import MCP.Server.Derive (deriveToolHandlerWithDescription) + +import Paths_tricorder_mcp (version) +import Tricorder.MCP.Tools (Tool, handleTool, toolDescriptions) + + +main :: IO () +main = runMcpServerStdio serverInfo handlers + + +handlers :: McpServerHandlers +handlers = + noHandlers + { tools = Just $(deriveToolHandlerWithDescription ''Tool 'handleTool toolDescriptions) + } + + +serverInfo :: McpServerInfo +serverInfo = + McpServerInfo + { serverName = "Tricorder MCP Server" + , serverVersion = toText (showVersion version) + , serverInstructions = "A server to manage and use Tricorder for development purposes." + } diff --git a/src/Tricorder/MCP/Tools.hs b/src/Tricorder/MCP/Tools.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/MCP/Tools.hs @@ -0,0 +1,213 @@ +module Tricorder.MCP.Tools + ( Tool (..) + , StartOptions (..) + , StopOptions (..) + , RestartOptions (..) + , StatusOptions (..) + , TestResultsOptions (..) + , SourceOptions (..) + , EvalCommentsOptions (..) + , LogPathOptions (..) + , LogContentsOptions (..) + , handleTool + , toolCommand + , toolDescriptions + , reportsBuildOutcome + ) +where + +import Control.Exception (IOException, try) +import MCP.Server (ClientContext, Content (..), ToolResult, toolError, toolResult) +import System.Exit (ExitCode (..)) +import System.Process.Typed (proc, readProcess, setWorkingDir) +import Tricorder.SourceLookup.SourceQuery (parseSourceQuery) + +import Data.ByteString.Lazy qualified as BSL +import Tricorder.CLI.Command qualified as CLI + + +data Tool + = Start StartOptions + | Stop StopOptions + | Restart RestartOptions + | Status StatusOptions + | TestResults TestResultsOptions + | Source SourceOptions + | EvalComments EvalCommentsOptions + | LogPath LogPathOptions + | LogContents LogContentsOptions + + +newtype StartOptions = StartOptions {directory :: Text} + + +data StopOptions = StopOptions + { directory :: Text + , force :: Maybe Bool + } + + +data RestartOptions = RestartOptions + { directory :: Text + , force :: Maybe Bool + } + + +data StatusOptions = StatusOptions + { directory :: Text + , wait :: Maybe Bool + , json :: Maybe Bool + , verbose :: Maybe Bool + , expand :: Maybe Int + } + + +data TestResultsOptions = TestResultsOptions + { directory :: Text + , failed :: Maybe Bool + , wait :: Maybe Bool + } + + +data SourceOptions = SourceOptions + { directory :: Text + , modules :: [Text] + } + + +data EvalCommentsOptions = EvalCommentsOptions + { directory :: Text + , wait :: Maybe Bool + , json :: Maybe Bool + } + + +newtype LogPathOptions = LogPathOptions {directory :: Text} + + +newtype LogContentsOptions = LogContentsOptions {directory :: Text} + + +toolDescriptions :: [(String, String)] +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") + , + ( "directory" + , "Absolute path to the project's working directory (the tricorder daemon is scoped per-directory)" + ) + , ("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") + ] + + +-- | The @tricorder@ invocation for a tool call: the project directory to run +-- 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 + CLI.StatusOptions + { wait = toWaitMode wait + , format = toFormat json + , 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)) + ) + + +toForce :: Maybe Bool -> CLI.Force +toForce = maybe CLI.NoForce (\enabled -> if enabled then CLI.Force else CLI.NoForce) + + +toWaitMode :: Maybe Bool -> CLI.WaitMode +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) + + +-- | Whether a tool's exit code reports a build/test outcome (errors present, +-- tests failed) rather than the CLI process itself failing. @tricorder +-- status@, @test-results@ and @eval-comments@ exit non-zero to signal what +-- they found, not that the command failed, so their output is trusted +-- regardless of exit code; every other command only exits non-zero on a +-- genuine execution failure. +reportsBuildOutcome :: Tool -> Bool +reportsBuildOutcome (Status _) = True +reportsBuildOutcome (TestResults _) = True +reportsBuildOutcome (EvalComments _) = True +reportsBuildOutcome _ = False + + +-- | Spawning @tricorder@ can fail before it ever runs (e.g. the given +-- directory does not exist, or the binary is not on @PATH@): 'readProcess' +-- reports that as an 'IOException' rather than an 'ExitCode', and left +-- uncaught it would take the whole server down with it, not just this +-- 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) diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 --- /dev/null +++ b/test/Driver.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} + diff --git a/test/Unit/Tricorder/MCP/ToolsSpec.hs b/test/Unit/Tricorder/MCP/ToolsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Tricorder/MCP/ToolsSpec.hs @@ -0,0 +1,65 @@ +module Unit.Tricorder.MCP.ToolsSpec (spec_Tools) where + +import Test.Hspec (Spec, describe, it, shouldBe) + +import Tricorder.MCP.Tools + + +spec_Tools :: Spec +spec_Tools = do + describe "toolCommand" do + it "starts with just the directory" do + toolCommand (Start (StartOptions {directory = "/proj"})) + `shouldBe` ("/proj", ["start"]) + + it "omits --force when unset" do + toolCommand (Stop (StopOptions {directory = "/proj", force = Nothing})) + `shouldBe` ("/proj", ["stop"]) + + it "omits --force when explicitly false" do + toolCommand (Restart (RestartOptions {directory = "/proj", force = Just False})) + `shouldBe` ("/proj", ["restart"]) + + it "includes --force when true" do + toolCommand (Stop (StopOptions {directory = "/proj", force = Just True})) + `shouldBe` ("/proj", ["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 + , verbose = Nothing + , expand = Just 3 + } + ) + `shouldBe` ("/proj", ["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"]) + + it "maps log_path to --print-path" do + toolCommand (LogPath (LogPathOptions {directory = "/proj"})) + `shouldBe` ("/proj", ["log", "--print-path"]) + + it "maps log_contents to plain log" do + toolCommand (LogContents (LogContentsOptions {directory = "/proj"})) + `shouldBe` ("/proj", ["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 + + 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 diff --git a/tricorder-mcp.cabal b/tricorder-mcp.cabal new file mode 100644 --- /dev/null +++ b/tricorder-mcp.cabal @@ -0,0 +1,155 @@ +cabal-version: 2.0 + +-- This file has been generated from package.yaml by hpack version 0.38.3. +-- +-- see: https://github.com/sol/hpack + +name: tricorder-mcp +version: 0.1.0.0 +synopsis: MCP server for Tricorder +description: Model Context Protocol server for Tricorder. +category: AI, + Development +homepage: https://github.com/tweag/tricorder#readme +bug-reports: https://github.com/tweag/tricorder/issues +author: Victor Nascimento Bakke +maintainer: victor.bakke@tweag.io +license: MIT +license-file: LICENSE +build-type: Simple +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/tweag/tricorder + +library tricorder-mcp-internal + exposed-modules: + Tricorder.MCP.Main + Tricorder.MCP.Tools + other-modules: + Paths_tricorder_mcp + autogen-modules: + Paths_tricorder_mcp + hs-source-dirs: + src + default-extensions: + BlockArguments + DataKinds + DeriveAnyClass + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + GADTs + LambdaCase + MultiWayIf + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + StrictData + TemplateHaskell + TypeFamilies + ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded + build-depends: + atelier-core >=0.3 && <0.5 + , atelier-prelude >=0.1 && <0.3 + , base >=4.18 && <4.23 + , bytestring >=0.11 && <0.13 + , 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.* + mixins: + base hiding (Prelude) + default-language: GHC2021 + if impl(GHC >= 9.8) + ghc-options: -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations + +executable tricorder-mcp + main-is: Main.hs + other-modules: + Paths_tricorder_mcp + autogen-modules: + Paths_tricorder_mcp + hs-source-dirs: + app + default-extensions: + BlockArguments + DataKinds + DeriveAnyClass + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + GADTs + LambdaCase + MultiWayIf + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + StrictData + TemplateHaskell + TypeFamilies + ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded "-with-rtsopts=-N -T" + build-depends: + atelier-prelude >=0.1 && <0.3 + , base >=4.18 && <4.23 + , effectful-core ==2.6.* + , effectful-plugin >=2.0 && <2.2 + , tricorder-mcp-internal + mixins: + base hiding (Prelude) + default-language: GHC2021 + if impl(GHC >= 9.8) + ghc-options: -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations + +test-suite tricorder-mcp-test + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + Unit.Tricorder.MCP.ToolsSpec + Paths_tricorder_mcp + autogen-modules: + Paths_tricorder_mcp + hs-source-dirs: + test + default-extensions: + BlockArguments + DataKinds + DeriveAnyClass + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + GADTs + LambdaCase + MultiWayIf + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + StrictData + TemplateHaskell + TypeFamilies + ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded -Wno-prepositive-qualified-module + build-tool-depends: + tasty-discover:tasty-discover + build-depends: + atelier-core >=0.3 && <0.5 + , atelier-prelude >=0.1 && <0.3 + , base >=4.18 && <4.23 + , effectful-core ==2.6.* + , effectful-plugin >=2.0 && <2.2 + , hspec ==2.11.* + , tasty ==1.5.* + , tasty-hspec ==1.2.* + , tricorder-mcp-internal + mixins: + base hiding (Prelude) + default-language: GHC2021 + if impl(GHC >= 9.8) + ghc-options: -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations