diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,800 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Synapse CLI - Algebraic Implementation +-- +-- This executable uses the categorical machinery: +-- - Effect stack (SynapseM) with caching and cycle detection +-- - Reified algebras for navigation, rendering, completion +-- - Proper error handling +-- +-- CLI Structure: +-- synapse [OPTIONS] [--param value ...] +-- +-- Options must appear BEFORE the backend. Everything after the backend +-- is passed through for method invocation. +module Main where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (asks) +import Data.Aeson +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Data.Text.Encoding as TE +import Options.Applicative +import Data.Version (showVersion) +import qualified Paths_plexus_synapse as Meta +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStrLn, stderr, hFlush, stdout) + + +import Synapse.Schema.Types +import Synapse.Monad (SynapseM, SynapseEnv(..), SynapseError(..), BackendErrorType(..), TransportContext(..), TransportErrorCategory(..), initEnv, runSynapseM, throwNav, throwTransport, throwParse, throwBackend) +import Synapse.Algebra.Navigate +import Synapse.Algebra.Render (renderSchema) +import Synapse.CLI.Help (renderMethodHelp) +import Synapse.CLI.Parse (parseParams) +import qualified Synapse.CLI.Parse as Parse +import Synapse.IR.Types (IR, irMethods, MethodDef) +import qualified Data.Map.Strict as Map +import qualified Synapse.CLI.Template as TemplateIR +import Synapse.Transport +import Synapse.Bidir (BidirMode(..), parseBidirMode, detectBidirMode, handleBidirRequest) +import Plexus.Types (Response(..)) +import Synapse.CLI.Transform (mkTransformEnv, transformParams, defaultTransformers, injectBooleanDefaults, injectSmartDefaults) +import Synapse.IR.Builder (buildIR) +import Synapse.Renderer (RendererConfig, defaultRendererConfig, renderItem, prettyValue, withMethodPath) +import System.Directory (createDirectoryIfMissing, getHomeDirectory) +import System.FilePath (()) +import qualified Synapse.Self.Commands as Self +import Synapse.Backend.Discovery (Backend(..), BackendDiscovery(..), registryDiscovery, pingBackends, getBackendAt) + +-- ============================================================================ +-- Types +-- ============================================================================ + +-- | Synapse-level options (must appear before backend) +-- Controls connection settings and output format +data SynapseOpts = SynapseOpts + { soHost :: Text -- ^ Registry host for discovery + , soPort :: Int -- ^ Registry port for discovery + , soJson :: Bool -- ^ Output raw JSON stream items + , soRaw :: Bool -- ^ Output raw content (no templates) + , soDryRun :: Bool -- ^ Show request without sending + , soSchema :: Bool -- ^ Fetch raw schema JSON + , soGenerate :: Bool -- ^ Generate templates from IR + , soEmitIR :: Bool -- ^ Emit IR for code generation + , soParams :: Maybe Text -- ^ JSON params via -p + , soRpc :: Maybe Text -- ^ Raw JSON-RPC passthrough + , soGeneratorInfo :: [Text] -- ^ Generator tool info (tool:version pairs) + , soBidirMode :: Maybe Text -- ^ Bidirectional mode override + , soBidirCmd :: Maybe Text -- ^ Bidirectional subprocess command (--bidir-cmd) + } + deriving Show + +-- | Full CLI arguments after two-phase parsing +data Args = Args + { argOpts :: SynapseOpts -- ^ Synapse-level options + , argBackend :: Maybe Text -- ^ Backend name (first positional) + , argPath :: [Text] -- ^ Path segments and --key value params (raw) + } + deriving Show + + +-- ============================================================================ +-- Constants +-- ============================================================================ + +defaultHost :: Text +defaultHost = "127.0.0.1" + +defaultPort :: Int +defaultPort = 4444 + +-- ============================================================================ +-- Argument Splitting +-- ============================================================================ +-- Main +-- ============================================================================ + +main :: IO () +main = do + args <- execParser argsInfo + let opts = argOpts args + -- Use specified host/port for registry discovery + let discovery = registryDiscovery (soHost opts) (soPort opts) + + -- Get the backend at the connection point (host:port) + -- If it has a registry plugin, that's used for discovering other backends + maybeBackend <- getBackendAt (soHost opts) (soPort opts) + let hostBackend = maybe "plexus" id maybeBackend + + case argBackend args of + Nothing + -- Suppress banner for data output modes + | soEmitIR opts || soSchema opts || soJson opts || soRaw opts -> + runWithDiscovery discovery hostBackend args + | otherwise -> do + -- No backend specified, show available backends + TIO.putStr cliHeader + backends <- discoverBackends discovery + -- Ping backends to check if they're reachable + backendsWithStatus <- pingBackends backends + TIO.putStrLn "\nAvailable backends:" + mapM_ printBackend backendsWithStatus + TIO.putStrLn "\nUsage: synapse [command...]" + Just backend + -- Handle --help/-h if it somehow ends up as the backend + | backend `elem` ["--help", "-h"] -> TIO.putStr cliHeader + -- Handle _self meta-commands (use discovered primary backend) + | backend == "_self" -> runWithDiscovery discovery hostBackend args + | otherwise -> runWithDiscovery discovery backend args + +-- | Print a backend in the list +printBackend :: Backend -> IO () +printBackend b = do + let nameField = T.justifyLeft 15 ' ' (backendName b) + let hostPort = backendHost b <> ":" <> T.pack (show (backendPort b)) + let status = case backendReachable b of + Just True -> " [OK]" + Just False -> " [UNREACHABLE]" + Nothing -> "" + let desc = if T.null (backendDescription b) + then "" + else " - " <> backendDescription b + TIO.putStrLn $ " " <> nameField <> hostPort <> status <> desc + +-- | Run a Hub command with backend discovery +runWithDiscovery :: BackendDiscovery -> Text -> Args -> IO () +runWithDiscovery discovery backendName args = do + let opts = argOpts args + -- Try to discover backend info + maybeBackend <- getBackendInfo discovery backendName + + case maybeBackend of + Just backend -> do + -- Always use discovered host/port from registry + -- The -H/-P flags specify where to find the registry, not the target backend + run backendName (backendHost backend) (backendPort backend) args + Nothing -> do + -- Backend not found in registry - gather available backends and show error + backends <- discoverBackends discovery + backendsWithStatus <- pingBackends backends + env <- initEnv (soHost opts) (soPort opts) backendName + result <- runSynapseM env (throwBackend (BackendNotFound backendName) backendsWithStatus) + case result of + Left err -> do + hPutStrLn stderr $ renderError err + exitFailure + Right () -> exitSuccess + +-- | Run a Hub command with specified backend and connection details +run :: Text -> Text -> Int -> Args -> IO () +run backend host port args = do + env <- initEnv host port backend + rendererCfg <- defaultRendererConfig + result <- runSynapseM env (dispatch args rendererCfg) + case result of + Left err -> do + hPutStrLn stderr $ renderError err + exitFailure + Right () -> exitSuccess + +-- | Dispatch based on navigation result +dispatch :: Args -> RendererConfig -> SynapseM () +dispatch Args{argOpts = SynapseOpts{..}, argBackend, argPath} rendererCfg = do + -- Check for _self commands first (before anything else) + case argBackend of + Just "_self" -> do + -- _self meta-command: parse subcommand and rest from argPath + let (pathSegs, rawParams, _) = parsePathAndParams argPath + case pathSegs of + (subcommand : rest) -> do + Self.dispatch subcommand rest rawParams + return () + [] -> do + -- No subcommand provided, show help + Self.showHelp + return () + + -- Normal dispatch + _ -> do + -- Mode 1: Raw JSON-RPC passthrough + case soRpc of + Just rpcJson -> do + case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 rpcJson) of + Left err -> throwParse $ T.pack err + Right rpcReq -> do + items <- invokeRawRpc rpcReq + liftIO $ mapM_ (printResult soJson soRaw rendererCfg) items + return () + + Nothing -> do + -- Parse path and inline params (--key value pairs) + let (pathSegs, rawParams, helpRequested) = parsePathAndParams argPath + + -- Normal Plexus RPC routing + -- Apply parameter transformations (path expansion, env vars) + transformEnv <- liftIO mkTransformEnv + inlineParams <- liftIO $ transformParams transformEnv defaultTransformers rawParams + + -- Mode 1.5: Respond subcommand (agent sends a response to a pending bidir request) + if not (null pathSegs) && head pathSegs == "respond" + then handleRespondCommand rawParams + + -- Mode 2: Schema request + else if soSchema + then do + -- Try to navigate and determine if last segment is a method + schemaResult <- fetchSchemaForPath pathSegs + case schemaResult of + Left err -> throwNav $ FetchError err pathSegs + Right val -> liftIO $ LBS.putStrLn $ encode val + + -- Mode 3: Generate templates (IR-driven approach) + else if soGenerate + then do + homeDir <- liftIO getHomeDirectory + let baseDir = homeDir ".config" "synapse" "templates" + writeAndLog gt = do + writeGeneratedTemplateIR baseDir gt + TIO.putStrLn $ " " <> T.pack (TemplateIR.gtPath gt) + liftIO $ TIO.putStrLn $ "Generating templates in " <> T.pack baseDir <> "..." + count <- TemplateIR.generateAllTemplatesWithCallback writeAndLog pathSegs + liftIO $ TIO.putStrLn $ "Generated " <> T.pack (show count) <> " templates" + + -- Mode 4: Emit IR for code generation + else if soEmitIR + then do + ir <- buildIR soGeneratorInfo pathSegs + liftIO $ LBS.putStrLn $ encode ir + + else do + -- Mode 5: Normal navigation + if null pathSegs + then do + rootSchema <- navigate [] + case rootSchema of + ViewPlugin schema _ -> liftIO $ do + TIO.putStr cliHeader + TIO.putStr "\n\n" + TIO.putStr $ renderSchema schema + _ -> pure () + else do + -- Navigate to target + view <- navigate pathSegs + case view of + -- Landed on a plugin: show help + ViewPlugin schema _ -> + liftIO $ TIO.putStr $ renderSchema schema + + -- Landed on a method: invoke or show help + ViewMethod method path -> do + -- Build IR for this method's namespace + ir <- buildIR soGeneratorInfo (init path) + let fullPath = T.intercalate "." path + + -- If --help was explicitly requested, show help and exit + if helpRequested + then do + case Map.lookup fullPath (irMethods ir) of + Just methodDef -> + liftIO $ TIO.putStr $ renderMethodHelp ir methodDef + Nothing -> + liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method + else do + -- Build params: use IR-driven parsing for inline params + let schemaDefaults = extractSchemaDefaults method + userParams <- case soParams of + -- -p JSON: parse as raw JSON (bypass IR parsing) + Just jsonStr -> + case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 jsonStr) of + Left err -> throwParse $ T.pack err + Right p -> pure p + Nothing + | not (null inlineParams) -> + -- Use IR-driven parsing for inline params + case Map.lookup fullPath (irMethods ir) of + Just methodDef -> do + -- Inject boolean defaults for flags without values + let paramsWithBools = injectBooleanDefaults ir methodDef inlineParams + -- Inject smart defaults for missing required params (e.g., --path defaults to cwd) + paramsWithDefaults <- liftIO $ injectSmartDefaults transformEnv ir methodDef paramsWithBools + case parseParams ir methodDef paramsWithDefaults of + Right p -> pure p + Left errs -> do + liftIO $ mapM_ (hPutStrLn stderr . renderParseError) errs + throwParse "Parameter parsing failed" + Nothing -> + -- Fallback to flat object if method not in IR + pure $ buildParamsObject inlineParams + | otherwise -> pure $ object [] + -- Merge: user params override schema defaults + let params = mergeParams schemaDefaults userParams + + if soDryRun + then do + backend <- asks seBackend + liftIO $ LBS.putStrLn $ encodeDryRun backend (init path) (last path) params + -- Show help when: method has required params AND user provided no params + else if hasRequiredParams method && userParams == object [] && null inlineParams + then do + -- Render help from IR + case Map.lookup fullPath (irMethods ir) of + Just methodDef -> + liftIO $ TIO.putStr $ renderMethodHelp ir methodDef + Nothing -> + -- Fallback: method not in IR, use basic info + liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method + else invokeMethod path params + where + handleRespondCommand :: [(Text, Text)] -> SynapseM () + handleRespondCommand params = do + let mRequestId = lookup "request_id" params + mResponseStr = lookup "response" params + case (mRequestId, mResponseStr) of + (Nothing, _) -> throwParse "Missing --request-id for respond subcommand" + (_, Nothing) -> throwParse "Missing --response for respond subcommand" + (Just requestId, Just responseStr) -> + case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 responseStr) of + Left err -> throwParse $ "Invalid --response JSON: " <> T.pack err + Right (resp :: Response Value) -> sendResponse requestId resp + + invokeMethod path params = do + let namespacePath = init path -- path without method name + let methodName' = last path + -- Set method path hint for template resolution + let rendererCfg' = withMethodPath rendererCfg path + -- Determine bidirectional mode (--bidir-cmd takes precedence) + bidirMode <- liftIO $ case soBidirCmd of + Just cmd -> pure $ BidirCmd cmd + Nothing -> case soBidirMode of + Just modeStr -> case parseBidirMode modeStr of + Just mode -> pure mode + Nothing -> do + TIO.hPutStrLn stderr $ "[synapse] Unknown --bidir-mode: " <> modeStr <> ", using auto-detect" + detectBidirMode + Nothing -> detectBidirMode + -- Use bidirectional streaming handler + invokeStreamingWithBidir + namespacePath + methodName' + params + (printResult soJson soRaw rendererCfg') + (handleBidirRequest bidirMode) + + -- Extract default values from JSON Schema properties + -- Schema format: {"properties": {"key": {"default": value, ...}, ...}, ...} + extractSchemaDefaults :: MethodSchema -> Value + extractSchemaDefaults m = case methodParams m of + Nothing -> object [] + Just (Object o) -> case KM.lookup "properties" o of + Just (Object props) -> object + [ (k, defaultVal) + | (k, propSchema) <- KM.toList props + , Object propObj <- [propSchema] + , Just defaultVal <- [KM.lookup "default" propObj] + ] + _ -> object [] + Just _ -> object [] + + -- Merge two JSON objects: right takes precedence over left + mergeParams :: Value -> Value -> Value + mergeParams (Object defaults) (Object user) = + Object (KM.union user defaults) -- union prefers first arg on conflict + mergeParams _ user = user -- if defaults aren't an object, just use user params + + -- Check if method has required parameters + hasRequiredParams :: MethodSchema -> Bool + hasRequiredParams m = case methodParams m of + Nothing -> False + Just (Object o) -> case KM.lookup "required" o of + Just (Array arr) -> not (null arr) + _ -> False + Just _ -> False + + -- Fetch schema for a path, detecting if last segment is a method + -- Uses navigate to determine what type of schema to fetch + fetchSchemaForPath :: [Text] -> SynapseM (Either Text Value) + fetchSchemaForPath segs = do + view <- navigate segs + case view of + ViewPlugin schema _ -> pure $ Right $ toJSON schema + ViewMethod method path -> do + -- Use method-specific schema query for detailed method info + let parentPath = init path + methodName' = last path + detailedMethod <- fetchMethodSchema parentPath methodName' + pure $ Right $ toJSON detailedMethod + + -- Invoke raw JSON-RPC request + invokeRawRpc :: Value -> SynapseM [HubStreamItem] + invokeRawRpc rpcReq = do + case rpcReq of + Object o -> case (KM.lookup "method" o, KM.lookup "params" o) of + (Just (String method), Just params) -> invokeRaw method params + (Just (String method), Nothing) -> invokeRaw method (object []) + _ -> throwParse "JSON-RPC must have 'method' field" + _ -> throwParse "JSON-RPC must be an object" + +-- | Parse path segments and --key value params +-- Returns (path segments, [(key, value)] params, help requested) +-- Example: ["echo", "once", "--message", "hello", "--count", "3"] +-- -> (["echo", "once"], [("message", "hello"), ("count", "3")], False) +-- Example: ["echo", "once", "--help"] +-- -> (["echo", "once"], [], True) +parsePathAndParams :: [Text] -> ([Text], [(Text, Text)], Bool) +parsePathAndParams = go [] [] False + where + go path params helpReq [] = (reverse path, reverse params, helpReq) + go path params helpReq (x:xs) + -- --help flag: mark help requested, don't add as param + | x == "--help" || x == "-h" = + go path params True xs + -- --key value pair (value must not start with --) + | Just key <- T.stripPrefix "--" x + , not (T.null key) + , (val:rest) <- xs + , not (T.isPrefixOf "--" val) = + let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case + in go path ((normalizedKey, val) : params) helpReq rest + -- --key with no value or next arg is another flag (boolean flag) + | Just key <- T.stripPrefix "--" x + , not (T.null key) = + let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case + in go path ((normalizedKey, "") : params) helpReq xs + -- Regular path segment - split on dots to support Plexus RPC path syntax (e.g., cone.chat) + | otherwise = + let segments = map (T.replace "-" "_") $ filter (not . T.null) $ T.splitOn "." x + in go (reverse segments ++ path) params helpReq xs + +-- | Build JSON object from key-value pairs +buildParamsObject :: [(Text, Text)] -> Value +buildParamsObject pairs = object + [ (K.fromText k, inferValue v) | (k, v) <- pairs ] + where + -- Try to infer the JSON type from the string value + inferValue :: Text -> Value + inferValue t + | t == "true" = Bool True + | t == "false" = Bool False + | Just n <- readMaybe (T.unpack t) :: Maybe Integer = Number (fromInteger n) + | Just n <- readMaybe (T.unpack t) :: Maybe Double = Number (realToFrac n) + | otherwise = String t + +readMaybe :: Read a => String -> Maybe a +readMaybe s = case reads s of + [(x, "")] -> Just x + _ -> Nothing + +-- | ASCII splash logo +splash :: Text +splash = T.unlines + [ "" + , "███████╗██╗ ██╗███╗ ██╗ █████╗ ██████╗ ███████╗███████╗" + , "██╔════╝╚██╗ ██╔╝████╗ ██║██╔══██╗██╔══██╗██╔════╝██╔════╝" + , "███████╗ ╚████╔╝ ██╔██╗ ██║███████║██████╔╝███████╗█████╗ " + , "╚════██║ ╚██╔╝ ██║╚██╗██║██╔══██║██╔═══╝ ╚════██║██╔══╝ " + , "███████║ ██║ ██║ ╚████║██║ ██║██║ ███████║███████╗" + , "╚══════╝ ╚═╝ ╚═╝ ╚═══╝╚═╝ ╚═╝╚═╝ ╚══════╝╚══════╝" + , "" + ] + +-- | Get CLI help text from optparse-applicative +cliHeader :: Text +cliHeader = splash <> T.pack (fst $ renderFailure failure "synapse") <> selfHelp + where + failure = parserFailure defaultPrefs argsInfo (ShowHelpText Nothing) mempty + selfHelp = T.unlines + [ "" + , "Meta-commands (local, no RPC):" + , "" + , " synapse _self template" + , " Manage Mustache templates (CRUD operations)" + , "" + , " Subcommands:" + , " list [pattern] - List existing templates" + , " show - Display template content" + , " generate [pattern] - Generate new templates from IR" + , " delete - Delete templates" + , " reload - Clear template cache" + , "" + , " Examples:" + , " synapse _self template list" + , " synapse _self template show cone.chat" + , " synapse _self template generate 'plexus.cone.*'" + , "" + ] + +-- | Render an error for display +renderError :: SynapseError -> String +renderError = \case + NavError (NotFound seg path maybeSchema) -> + let baseMsg = "Command not found: '" <> T.unpack seg <> "' at " <> showPath path + in case maybeSchema of + Nothing -> baseMsg + Just schema -> + let methods = psMethods schema + children = pluginChildren schema + suggestions = if null methods && null children + then "" + else "\n\nAvailable commands:" + <> renderMethods methods + <> renderChildren children + in baseMsg <> suggestions + NavError (MethodNotTerminal seg path) -> + "Method '" <> T.unpack seg <> "' cannot have subcommands at " <> showPath path + NavError (Cycle hash path) -> + "Cycle detected: hash " <> T.unpack hash <> " at " <> showPath path + NavError (FetchError msg path) -> + "Fetch error at " <> showPath path <> ": " <> T.unpack msg + TransportError msg -> + "Transport error: " <> T.unpack msg + TransportErrorContext ctx -> + renderTransportError ctx + ParseError msg -> + "Parse error: " <> T.unpack msg + ValidationError msg -> + "Validation error: " <> T.unpack msg + BackendError errorType backends -> + case errorType of + BackendNotFound name -> + "Backend not found: '" <> T.unpack name <> "'" + <> renderBackendList backends + BackendUnreachable name -> + "Backend unreachable: '" <> T.unpack name <> "'" + <> renderBackendList backends + NoBackendsAvailable -> + "No backends available" + <> renderBackendList backends + where + showPath [] = "root" + showPath p = T.unpack $ T.intercalate "." p + + renderMethods [] = "" + renderMethods methods = + let header = "\n\n Methods:" + methodLines = map renderMethod methods + in header <> concat methodLines + + renderMethod method = + let name = T.unpack $ methodName method + desc = T.unpack $ methodDescription method + padding = 20 + namePadded = name <> replicate (max 1 (padding - length name)) ' ' + in "\n " <> namePadded <> desc + + renderChildren [] = "" + renderChildren children = + let header = "\n\n Child plugins:" + childLines = map renderChild children + in header <> concat childLines + + renderChild child = + let name = T.unpack $ csNamespace child + desc = T.unpack $ csDescription child + padding = 20 + namePadded = name <> replicate (max 1 (padding - length name)) ' ' + in "\n " <> namePadded <> desc + + renderBackendList [] = "\n\nNo backends available." + renderBackendList backends = + let header = "\n\nAvailable backends:" + backendLines = map renderBackendLine backends + usageHint = "\n\nUsage: synapse [command...]" + in header <> concat backendLines <> usageHint + + renderBackendLine backend = + let name = T.unpack $ backendName backend + nameField = name <> replicate (max 1 (15 - length name)) ' ' + hostPort = T.unpack $ backendHost backend <> ":" <> T.pack (show (backendPort backend)) + status = case backendReachable backend of + Just True -> " [OK]" + Just False -> " [UNREACHABLE]" + Nothing -> "" + desc = if T.null (backendDescription backend) + then "" + else " - " <> T.unpack (backendDescription backend) + in "\n " <> nameField <> hostPort <> status <> desc + +-- | Render transport error with context +renderTransportError :: TransportContext -> String +renderTransportError TransportContext{..} = case tcCategory of + ConnectionRefused -> + "Connection refused\n\n" <> + "Backend: " <> T.unpack tcBackend <> "\n" <> + "Address: " <> T.unpack tcHost <> ":" <> show tcPort <> "\n" <> + "Path: " <> showPath tcPath <> "\n\n" <> + "Troubleshooting:\n" <> + " - Check if the backend is running\n" <> + " - Verify host (-H) and port (-P) settings\n" <> + " - Run 'synapse' (no args) to list backends" + + ConnectionTimeout -> + "Connection timeout\n\n" <> + "Backend: " <> T.unpack tcBackend <> " @ " <> + T.unpack tcHost <> ":" <> show tcPort <> "\n\n" <> + "The server may be overloaded or network latency is high\n" <> + "Error: " <> T.unpack tcMessage + + ProtocolError -> + "Protocol error\n\n" <> + "Backend: " <> T.unpack tcBackend <> "\n" <> + "This may indicate a version mismatch\n\n" <> + "Error: " <> T.unpack tcMessage + + UnknownTransportError -> + "Transport error: " <> T.unpack tcMessage <> "\n\n" <> + "Backend: " <> T.unpack tcBackend <> " @ " <> + T.unpack tcHost <> ":" <> show tcPort + where + showPath [] = "root" + showPath p = T.unpack $ T.intercalate "." p + +-- | Render a parse error for display +renderParseError :: Parse.ParseError -> String +renderParseError = \case + Parse.UnknownParam name suggestions -> + "Unknown parameter: --" <> T.unpack name <> + case suggestions of + [] -> "" + [s] -> "\n\nDid you mean: --" <> T.unpack s <> "?" + ss -> "\n\nDid you mean one of:\n" <> + unlines [" --" <> T.unpack s | s <- ss] + Parse.MissingRequired name -> + "Missing required parameter: --" <> T.unpack name + Parse.InvalidValue name reason -> + "Invalid value for --" <> T.unpack name <> ": " <> T.unpack reason + Parse.AmbiguousVariant name variants -> + "Ambiguous variant for --" <> T.unpack name <> ": could be one of " <> show (map T.unpack variants) + Parse.MissingDiscriminator param field -> + "Missing discriminator for --" <> T.unpack param <> ": need --" <> T.unpack param <> "." <> T.unpack field + Parse.UnknownVariant param value valid suggestions -> + "Unknown variant '" <> T.unpack value <> "' for --" <> T.unpack param <> + "\n\nValid variants: " <> T.unpack (T.intercalate ", " valid) <> + case suggestions of + [] -> "" + [s] -> "\n\nDid you mean: " <> T.unpack s <> "?" + ss -> "\n\nDid you mean one of: " <> T.unpack (T.intercalate ", " ss) <> "?" + Parse.TypeNotFound name -> + "Type not found in IR: " <> T.unpack name + + +-- | Write a generated template to disk (no logging) +writeGeneratedTemplateIR :: FilePath -> TemplateIR.GeneratedTemplate -> IO () +writeGeneratedTemplateIR baseDir gt = do + let fullPath = baseDir TemplateIR.gtPath gt + createDirectoryIfMissing True (baseDir T.unpack (TemplateIR.gtNamespace gt)) + TIO.writeFile fullPath (TemplateIR.gtTemplate gt) + +-- | Encode a dry-run request +encodeDryRun :: Text -> [Text] -> Text -> Value -> LBS.ByteString +encodeDryRun backend namespacePath method params = + let fullPath = if null namespacePath then [backend] else namespacePath + dotPath = T.intercalate "." (fullPath ++ [method]) + in encode $ object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (1 :: Int) + , "method" .= (backend <> ".call") + , "params" .= object + [ "method" .= dotPath + , "params" .= params + ] + ] + +-- | Print a stream result +-- soJson: output raw JSON stream items +-- soRaw: skip template rendering, just output content JSON +-- otherwise: try template rendering, fall back to content JSON +printResult :: Bool -> Bool -> RendererConfig -> HubStreamItem -> IO () +printResult True _ _ item = LBS.putStrLn $ encode item +printResult _ True _ item = case item of + -- Raw mode: just output the content + HubData _ _ _ dat -> do + LBS.putStrLn $ encode dat + hFlush stdout + HubProgress _ _ msg _ -> do + TIO.putStr msg + TIO.putStr "\r" + hFlush stdout + HubError _ _ err _ -> + hPutStrLn stderr $ "Error: " <> T.unpack err + _ -> pure () +printResult _ _ cfg item = do + -- Template mode: try to render with template + mRendered <- renderItem cfg item + case mRendered of + Just text + | T.null (T.strip text) -> pure () + | otherwise -> do + TIO.putStr text + hFlush stdout + Nothing -> case item of + -- Fallback to pretty-printed content + HubData _ _ _ dat -> do + TIO.putStrLn $ prettyValue dat + hFlush stdout + HubProgress _ _ msg _ -> do + TIO.putStr msg + TIO.putStr "\r" + hFlush stdout + HubError _ _ err _ -> + hPutStrLn stderr $ "Error: " <> T.unpack err + _ -> pure () + +-- ============================================================================ +-- Argument Parsing (Synapse Options Only) +-- ============================================================================ + +-- | Parser for synapse-level options only +-- Backend and path are handled separately after arg splitting +argsInfo :: ParserInfo Args +argsInfo = info (argsParser <**> versionOption <**> helper) + ( fullDesc + <> header "synapse - Algebraic CLI for Hub" + <> progDesc "synapse [OPTIONS] [--param value ...]" + <> noIntersperse -- Stop option parsing at first positional arg + ) + where + versionOption = infoOption (showVersion Meta.version) + ( long "version" <> short 'V' <> help "Show version" ) + +argsParser :: Parser Args +argsParser = Args <$> optsParser <*> backendParser <*> restParser + where + backendParser = optional $ T.pack <$> argument str + ( metavar "BACKEND" + <> help "Backend name (e.g., plexus, registry-hub)" ) + + restParser = many $ T.pack <$> argument str + ( metavar "PATH... [--param value ...]" + <> help "Path and method parameters (passed through)" ) + +optsParser :: Parser SynapseOpts +optsParser = do + soHost <- T.pack <$> strOption + ( long "host" <> short 'H' <> metavar "HOST" + <> value (T.unpack defaultHost) + <> help "Registry/discovery host (default: 127.0.0.1)" ) + soPort <- option auto + ( long "port" <> short 'P' <> metavar "PORT" + <> value defaultPort + <> help "Registry/discovery port (default: 4444)" ) + soJson <- switch + ( long "json" <> short 'j' + <> help "Output raw JSON stream items" ) + soRaw <- switch + ( long "raw" + <> help "Output raw content JSON (skip templates)" ) + soDryRun <- switch + ( long "dry-run" <> short 'n' + <> help "Show JSON-RPC request without sending" ) + soSchema <- switch + ( long "schema" <> short 's' + <> help "Fetch raw schema JSON for path" ) + soGenerate <- switch + ( long "generate-templates" <> short 'g' + <> help "Generate mustache templates from IR" ) + soEmitIR <- switch + ( long "emit-ir" <> short 'i' + <> help "Emit IR for code generation (JSON)" ) + soParams <- optional $ T.pack <$> strOption + ( long "params" <> short 'p' <> metavar "JSON" + <> help "Method parameters as JSON object" ) + soRpc <- optional $ T.pack <$> strOption + ( long "rpc" <> short 'r' <> metavar "JSON" + <> help "Raw JSON-RPC request (bypass navigation)" ) + soGeneratorInfo <- many $ T.pack <$> strOption + ( long "generator-info" <> metavar "TOOL:VERSION" + <> help "Generator tool version info (can be specified multiple times)" ) + soBidirMode <- optional $ T.pack <$> strOption + ( long "bidir-mode" <> short 'b' <> metavar "MODE" + <> help "Bidirectional mode: interactive (TTY), json (pipe protocol), auto-cancel, defaults, respond" ) + soBidirCmd <- optional $ T.pack <$> strOption + ( long "bidir-cmd" <> metavar "CMD" + <> help "Shell command to handle bidir requests (stdin=JSON request, stdout=JSON response)" ) + pure SynapseOpts{..} diff --git a/examples/SchemaDiscovery.hs b/examples/SchemaDiscovery.hs new file mode 100644 --- /dev/null +++ b/examples/SchemaDiscovery.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Demonstrates the two-call schema discovery pattern +-- +-- 1. Call substrate.schema → get list of activations +-- 2. For each activation, call substrate.activation_schema → get method schemas +-- +-- The ActivationInfo structure drives both: +-- - CLI subcommand generation (arbor, cone, health) +-- - Schema enrichment requests (fetch enriched schema for each namespace) + +module Main where + +import Data.Aeson (Value, encode, toJSON) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Streaming.Prelude as S + +import Plexus (connect, disconnect, defaultConfig) +import Substrate.Client (SubstrateConnection, substrateRpc) +import Plexus.Schema + ( PlexusSchema(..) + , PlexusSchemaEvent(..) + , ActivationInfo(..) + , EnrichedSchema(..) + , ActivationSchemaEvent(..) + , extractSchemaEvent + , extractActivationSchemaEvent + ) + +main :: IO () +main = do + putStrLn "=== Schema Discovery Demo ===" + putStrLn "" + + conn <- connect defaultConfig + + -- STEP 1: Discover all activations + putStrLn "Step 1: Calling substrate.schema to discover activations..." + mSchema <- S.head_ $ S.mapMaybe extractSchemaEvent $ + substrateRpc conn "substrate.schema" (toJSON ([] :: [Value])) + + case mSchema of + Nothing -> putStrLn "Failed to get schema" + Just (SchemaError err) -> T.putStrLn $ "Schema error: " <> err + Just (SchemaData schema) -> do + putStrLn $ "Found " <> show (length (schemaActivations schema)) <> " activations" + putStrLn "" + + -- For each activation, show what we'd do + mapM_ (demonstrateActivation conn) (schemaActivations schema) + + disconnect conn + +-- | Demonstrate how an ActivationInfo drives both CLI and schema requests +demonstrateActivation :: SubstrateConnection -> ActivationInfo -> IO () +demonstrateActivation plexusConn act = do + let ns = activationNamespace act + methods = activationMethods act + + putStrLn $ "Activation: " <> T.unpack ns + putStrLn $ " Description: " <> T.unpack (activationDescription act) + putStrLn $ " Methods: " <> show (length methods) + + -- STEP 2: Use the namespace to request enriched schema + putStrLn $ " → Requesting enriched schema for '" <> T.unpack ns <> "'..." + + mEnriched <- S.head_ $ S.mapMaybe extractActivationSchemaEvent $ + substrateRpc plexusConn "substrate.activation_schema" (toJSON [ns]) + + case mEnriched of + Nothing -> putStrLn " Failed to get enriched schema" + Just (ActivationSchemaError err) -> + T.putStrLn $ " Schema error: " <> err + Just (ActivationSchemaData enriched) -> do + let variantCount = maybe 0 length (schemaOneOf enriched) + putStrLn $ " ✓ Got enriched schema with " <> show variantCount <> " method variants" + + -- Show the mapping: methods[i] corresponds to oneOf[i] + putStrLn " Mapping (index-based):" + mapM_ (\(idx, method) -> + putStrLn $ " [" <> show idx <> "] " <> T.unpack method) + (zip [0..] methods) + + putStrLn "" + + -- This demonstrates: + -- 1. ActivationInfo.namespace → used for substrate.activation_schema RPC + -- 2. ActivationInfo.methods → used to know which method corresponds to which oneOf variant + -- 3. Same structure drives CLI: "symbols-dyn " + +-- | The key insight: ActivationInfo is the source of truth for both +-- +-- For CLI generation: +-- - activationNamespace → subcommand name ("arbor") +-- - activationMethods → sub-subcommand names ("tree-create", "tree-list") +-- +-- For schema enrichment: +-- - activationNamespace → RPC parameter: substrate.activation_schema("arbor") +-- - activationMethods[i] → maps to enrichedSchema.oneOf[i] +-- +-- This creates a direct correspondence: +-- +-- CLI Command | Schema Lookup +-- -------------------------|---------------------------------- +-- arbor tree-create | enriched["arbor"].oneOf[0] +-- arbor tree-get | enriched["arbor"].oneOf[1] +-- arbor tree-list | enriched["arbor"].oneOf[3] +-- cone list | enriched["cone"].oneOf[1] +-- +-- The mapping is guaranteed by the order in ActivationInfo.methods +-- matching the order in the enriched schema's oneOf array. diff --git a/plexus-synapse.cabal b/plexus-synapse.cabal new file mode 100644 --- /dev/null +++ b/plexus-synapse.cabal @@ -0,0 +1,196 @@ +cabal-version: 3.0 +name: plexus-synapse +version: 0.3.0.0 +synopsis: Schema-driven CLI for Plexus RPC servers +license: MIT +author: +maintainer: +build-type: Simple + +flag build-examples + description: Build example programs (schema-discovery) + default: False + manual: True + +library + exposed-modules: + Synapse.Schema.Types + Synapse.Schema.Functor + Synapse.Monad + Synapse.Algebra.Navigate + Synapse.Algebra.Render + Synapse.Algebra.Walk + Synapse.Algebra.Recursion + Synapse.Transport + Synapse.Cache + Synapse.Renderer + Synapse.IR.Types + Synapse.IR.Builder + Synapse.Bidir + Synapse.CLI.Help + Synapse.CLI.Parse + Synapse.CLI.Support + Synapse.CLI.Template + Synapse.CLI.Transform + Synapse.CLI.Similarity + Synapse.Backend.Discovery + Synapse.Self.Commands + Synapse.Self.Template + Synapse.Self.Pattern + Synapse.Self.Examples + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + aeson >= 2.0 && < 2.3, + text >= 2.0 && < 2.2, + bytestring >= 0.11 && < 0.13, + websockets >= 0.13 && < 0.14, + network >= 3.1 && < 3.3, + async >= 2.2 && < 2.3, + stm >= 2.5 && < 2.6, + streaming >= 0.2 && < 0.3, + mtl >= 2.3 && < 2.4, + transformers >= 0.6 && < 0.7, + containers >= 0.6 && < 0.8, + unordered-containers >= 0.2 && < 0.3, + hashable >= 1.4 && < 1.6, + prettyprinter >= 1.7 && < 1.8, + mustache >= 2.4 && < 2.5, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6, + yaml >= 0.11 && < 0.12, + vector >= 0.12 && < 0.14, + scientific >= 0.3 && < 0.4, + regex-tdfa >= 1.3 && < 1.4, + time >= 1.12 && < 1.15, + array >= 0.5 && < 0.6, + process >= 1.6 && < 1.7 + hs-source-dirs: src + default-language: GHC2021 + default-extensions: + OverloadedStrings + DeriveGeneric + DeriveAnyClass + DerivingStrategies + GeneralizedNewtypeDeriving + LambdaCase + RecordWildCards + +executable synapse + main-is: Main.hs + autogen-modules: Paths_plexus_synapse + other-modules: Paths_plexus_synapse + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + plexus-synapse, + aeson >= 2.0 && < 2.3, + text >= 2.0 && < 2.2, + bytestring >= 0.11 && < 0.13, + mtl >= 2.3 && < 2.4, + containers >= 0.6 && < 0.8, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6, + optparse-applicative >= 0.18 && < 0.19, + prettyprinter >= 1.7 && < 1.8 + hs-source-dirs: app + default-language: GHC2021 + default-extensions: + OverloadedStrings + RecordWildCards + LambdaCase + +executable schema-discovery + main-is: SchemaDiscovery.hs + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + plexus-synapse, + aeson >= 2.0 && < 2.3, + text >= 2.0 && < 2.2, + streaming >= 0.2 && < 0.3 + hs-source-dirs: examples + default-language: GHC2021 + default-extensions: + OverloadedStrings + if !flag(build-examples) + buildable: False + +test-suite cli-test + type: exitcode-stdio-1.0 + main-is: CLISpec.hs + build-depends: + base >= 4.17 && < 5, + text >= 2.0 && < 2.2, + process >= 1.6 && < 1.7, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + +test-suite ir-test + type: exitcode-stdio-1.0 + main-is: IRSpec.hs + build-depends: + base >= 4.17 && < 5, + plexus-synapse, + text >= 2.0 && < 2.2, + containers >= 0.6 && < 0.8, + hspec >= 2.10 && < 2.12, + aeson >= 2.2 && < 2.3, + bytestring >= 0.11 && < 0.13 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + LambdaCase + RecordWildCards + ghc-options: -threaded + +test-suite typeref-json + type: exitcode-stdio-1.0 + main-is: TypeRefJson.hs + build-depends: + base >= 4.17 && < 5, + plexus-synapse, + text >= 2.0 && < 2.2, + aeson >= 2.2 && < 2.3, + aeson-pretty >= 0.8 && < 0.9, + bytestring >= 0.11 && < 0.13 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + +test-suite parse-test + type: exitcode-stdio-1.0 + main-is: ParseSpec.hs + build-depends: + base >= 4.17 && < 5, + plexus-synapse, + text >= 2.0 && < 2.2, + aeson >= 2.2 && < 2.3, + containers >= 0.6 && < 0.8, + vector >= 0.12 && < 0.14, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + +test-suite path-normalization-test + type: exitcode-stdio-1.0 + main-is: PathNormalizationSpec.hs + build-depends: + base >= 4.17 && < 5, + text >= 2.0 && < 2.2, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded diff --git a/src/Synapse/Algebra/Navigate.hs b/src/Synapse/Algebra/Navigate.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Algebra/Navigate.hs @@ -0,0 +1,102 @@ +-- | Navigation algebra (paramorphism) +-- +-- = Why Paramorphism +-- +-- Navigation requires inspecting child namespaces to match path segments. +-- A catamorphism only gives us the folded result — we lose the original structure. +-- A paramorphism gives us both: F(μF × A) → A +-- +-- At each layer, we receive (original subtree, already-computed result) pairs. +-- We inspect the original to check namespaces, then recurse. +-- +-- = Effectful Navigation +-- +-- Since resolution requires network calls (fetch child schema), we can't use +-- pure 'para'. Instead, we implement navigation directly in SynapseM, +-- following the same pattern but with effects. +module Synapse.Algebra.Navigate + ( -- * Navigation + navigate + , navigateFrom + + -- * Algebra Types + , NavAlg + , NavResult + + -- * Helpers + , findChild + , findMethod + ) where + +import Data.Text (Text) +import Data.List (find) + +import Synapse.Schema.Types +import Synapse.Monad +import Synapse.Transport (fetchSchemaAt) +import Synapse.Cache (fetchCached) + +-- | The navigation algebra type (conceptual) +-- +-- In a pure setting with recursive schemas: +-- @ +-- type NavAlg = PluginSchemaF (ChildSummary, NavResult) -> NavResult +-- @ +-- +-- With effectful resolution: +-- @ +-- type NavAlg = PluginSchema -> Path -> Path -> SynapseM SchemaView +-- @ +type NavAlg = PluginSchema -> Path -> Path -> SynapseM SchemaView + +-- | Result of navigation: either a schema view or an error +type NavResult = SynapseM SchemaView + +-- | Navigate to a target from root +-- Fetches root schema and navigates from there +-- Note: If path starts with root namespace (e.g., "plexus"), it's stripped +-- so that "synapse plexus cone" works the same as "synapse cone" +navigate :: Path -> SynapseM SchemaView +navigate target = do + root <- fetchSchemaAt [] + -- Normalize path: strip leading root namespace if present + let normalizedTarget = case target of + (seg:rest) | seg == psNamespace root -> rest + _ -> target + withFreshVisited $ navigateFrom root [] normalizedTarget + +-- | Navigate from a given schema +-- visited: path taken so far +-- target: remaining path to navigate +navigateFrom :: PluginSchema -> Path -> Path -> SynapseM SchemaView +navigateFrom schema visited = \case + -- Empty target: we've arrived + [] -> pure $ ViewPlugin schema visited + + -- Non-empty target: try to navigate + (seg:rest) -> + -- First check if seg is a child namespace + case findChild seg schema of + Just child -> do + -- Check for cycle before descending + checkCycle (csHash child) (visited ++ [seg]) + -- Fetch child schema (with caching) + childSchema <- fetchCached (csHash child) (fetchSchemaAt (visited ++ [seg])) + -- Recurse into child + navigateFrom childSchema (visited ++ [seg]) rest + + Nothing -> + -- Not a child — check if it's a method + case findMethod seg schema of + Just method + | null rest -> pure $ ViewMethod method (visited ++ [seg]) + | otherwise -> throwNav $ MethodNotTerminal seg visited + Nothing -> throwNav $ NotFound seg visited (Just schema) + +-- | Find a child by namespace +findChild :: Text -> PluginSchema -> Maybe ChildSummary +findChild seg schema = find ((== seg) . csNamespace) (pluginChildren schema) + +-- | Find a method by name +findMethod :: Text -> PluginSchema -> Maybe MethodSchema +findMethod seg schema = find ((== seg) . methodName) (psMethods schema) diff --git a/src/Synapse/Algebra/Recursion.hs b/src/Synapse/Algebra/Recursion.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Algebra/Recursion.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Recursion schemes for schema trees +-- +-- This module provides proper categorical recursion schemes: +-- +-- = Anamorphism (unfold) +-- +-- An anamorphism builds a recursive structure from a seed using a coalgebra: +-- +-- @ +-- coalgebra :: a -> f a -- one step of unfolding +-- ana :: Functor f => (a -> f a) -> a -> Fix f +-- ana coalg = Fix . fmap (ana coalg) . coalg +-- @ +-- +-- For effectful unfolding, we use 'anaM': +-- +-- @ +-- anaM :: (Monad m, Traversable f) => (a -> m (f a)) -> a -> m (Fix f) +-- @ +-- +-- = Catamorphism (fold) +-- +-- A catamorphism collapses a recursive structure using an algebra: +-- +-- @ +-- algebra :: f a -> a -- one step of folding +-- cata :: Functor f => (f a -> a) -> Fix f -> a +-- cata alg = alg . fmap (cata alg) . unFix +-- @ +-- +-- = Hylomorphism (unfold then fold) +-- +-- A hylomorphism composes an anamorphism with a catamorphism: +-- +-- @ +-- hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b +-- hylo alg coalg = cata alg . ana coalg +-- = alg . fmap (hylo alg coalg) . coalg -- fused +-- @ +-- +-- The fused version never builds the intermediate structure! +module Synapse.Algebra.Recursion + ( -- * Pure recursion schemes + cata + , ana + , hylo + , para + , apo + + -- * Monadic recursion schemes + , cataM + , anaM + , hyloM + + -- * Schema-specific operations + , unfoldSchema + , foldSchema + , walkSchema + + -- * Re-exports + , Fix(..) + ) where + +import Control.Monad (forM) +import Data.Text (Text) + +import Synapse.Schema.Types (Path, PluginSchema(..), MethodSchema(..), ChildSummary(..)) +import Synapse.Schema.Functor (SchemaF(..), Fix(..), SchemaTree) +import Synapse.Monad +import Synapse.Transport (fetchSchemaAt) + +-- ============================================================================ +-- Pure Recursion Schemes +-- ============================================================================ + +-- | Catamorphism: fold a recursive structure +-- +-- @ +-- cata alg = alg . fmap (cata alg) . unFix +-- @ +cata :: Functor f => (f a -> a) -> Fix f -> a +cata alg = go + where + go (Fix fa) = alg (fmap go fa) + +-- | Anamorphism: unfold to build a recursive structure +-- +-- @ +-- ana coalg = Fix . fmap (ana coalg) . coalg +-- @ +ana :: Functor f => (a -> f a) -> a -> Fix f +ana coalg = go + where + go a = Fix (fmap go (coalg a)) + +-- | Hylomorphism: unfold then fold (fused - no intermediate structure) +-- +-- @ +-- hylo alg coalg = cata alg . ana coalg -- unfused +-- = alg . fmap (hylo alg coalg) . coalg -- fused +-- @ +hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b +hylo alg coalg = go + where + go a = alg (fmap go (coalg a)) + +-- | Paramorphism: fold with access to original substructures +-- +-- Like cata but the algebra also receives the original subtree +para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a +para alg = go + where + go (Fix fa) = alg (fmap (\x -> (x, go x)) fa) + +-- | Apomorphism: unfold with early termination +-- +-- Like ana but can short-circuit by returning Right with final value +apo :: Functor f => (a -> f (Either (Fix f) a)) -> a -> Fix f +apo coalg = go + where + go a = Fix (fmap (either id go) (coalg a)) + +-- ============================================================================ +-- Monadic Recursion Schemes +-- ============================================================================ + +-- | Monadic catamorphism +-- +-- Fold with effects at each step +cataM :: (Monad m, Traversable f) => (f a -> m a) -> Fix f -> m a +cataM alg = go + where + go (Fix fa) = do + fa' <- traverse go fa -- recursively process children + alg fa' -- apply algebra to results + +-- | Monadic anamorphism +-- +-- Unfold with effects at each step. This is what we need for +-- schema tree building since fetching is effectful. +anaM :: (Monad m, Traversable f) => (a -> m (f a)) -> a -> m (Fix f) +anaM coalg = go + where + go a = do + fa <- coalg a -- one step of unfolding (effectful) + fa' <- traverse go fa -- recursively unfold children + pure (Fix fa') + +-- | Monadic hylomorphism +-- +-- Unfold then fold, both with effects. Fused version. +hyloM :: (Monad m, Traversable f) => (f b -> m b) -> (a -> m (f a)) -> a -> m b +hyloM alg coalg = go + where + go a = do + fa <- coalg a -- unfold one step + fb <- traverse go fa -- recursively process + alg fb -- fold one step + +-- ============================================================================ +-- Schema-Specific Operations +-- ============================================================================ + +-- | Coalgebra for unfolding schema trees +-- +-- Given a path, fetch the schema and produce one layer of SchemaF +-- with child paths in the recursive positions. +schemaCoalgebra :: Path -> SynapseM (SchemaF Path) +schemaCoalgebra path = do + schema <- fetchSchemaAt path + let childPaths = case psChildren schema of + Nothing -> [] + Just children -> [path ++ [csNamespace c] | c <- children] + pure $ PluginF schema path childPaths + +-- | Unfold a complete schema tree from a path +-- +-- This is anaM applied to our schema coalgebra. +-- Builds the full tree structure by fetching all schemas. +unfoldSchema :: Path -> SynapseM SchemaTree +unfoldSchema = anaM schemaCoalgebra + +-- | Fold a schema tree with an algebra +-- +-- Pure fold - use this when you've already built the tree. +foldSchema :: (SchemaF a -> a) -> SchemaTree -> a +foldSchema = cata + +-- | Walk the schema tree with a monadic hylomorphism +-- +-- This is the main operation: unfold from a path, fold with an algebra. +-- Fused, so doesn't build intermediate tree in memory. +walkSchema :: (SchemaF a -> SynapseM a) -> Path -> SynapseM a +walkSchema alg = hyloM alg schemaCoalgebra diff --git a/src/Synapse/Algebra/Render.hs b/src/Synapse/Algebra/Render.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Algebra/Render.hs @@ -0,0 +1,207 @@ +-- | Render algebra for PluginSchema +module Synapse.Algebra.Render + ( -- * Rendering Functions + renderSchema + , renderSchemaWith + , renderMethod + , renderMethodFull + , renderChild + , renderParams + + -- * Configuration + , RenderStyle(..) + , defaultStyle + , compactStyle + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Aeson (Value(..)) +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import Data.List (intersperse, sortOn) +import Prettyprinter +import Prettyprinter.Render.Text (renderStrict) + +import Synapse.Schema.Types + +-- | Rendering style configuration +data RenderStyle = RenderStyle + { rsIndent :: !Int -- ^ Spaces per indent level + , rsShowHash :: !Bool -- ^ Show plugin/method hashes + , rsShowTypes :: !Bool -- ^ Show parameter types + , rsCompact :: !Bool -- ^ Compact single-line format + } + deriving stock (Show, Eq) + +-- | Default style: readable multi-line output +defaultStyle :: RenderStyle +defaultStyle = RenderStyle + { rsIndent = 2 + , rsShowHash = False + , rsShowTypes = True + , rsCompact = False + } + +-- | Compact style: single-line descriptions +compactStyle :: RenderStyle +compactStyle = defaultStyle { rsCompact = True } + +-- | Render a PluginSchema +renderSchema :: PluginSchema -> Text +renderSchema = renderSchemaWith defaultStyle + +-- | Render with custom style +renderSchemaWith :: RenderStyle -> PluginSchema -> Text +renderSchemaWith _style PluginSchema{..} + | null psMethods && maybe True null psChildren = headerText + | otherwise = renderStrict $ layoutPretty layoutOpts doc + where + layoutOpts = LayoutOptions (AvailablePerLine 80 1.0) + + headerText = psNamespace <> " v" <> psVersion <> "\n" <> psDescription <> "\n" + + doc :: Doc ann + doc = vsep + [ pretty psNamespace <+> pretty ("v" <> psVersion) + , emptyDoc + , indent 2 $ align $ fillSep $ map pretty $ T.words psDescription + , emptyDoc + , childrenDoc + , methodsDoc + ] + + childrenDoc = case psChildren of + Nothing -> emptyDoc + Just [] -> emptyDoc + Just children -> vsep + [ pretty ("activations" :: Text) + , emptyDoc + , indent 2 $ vsep $ map renderChildDoc (sortOn csNamespace children) + , emptyDoc + ] + + methodsDoc + | null psMethods = emptyDoc + | otherwise = vsep + [ pretty ("methods" :: Text) + , emptyDoc + , indent 2 $ vsep $ intersperse emptyDoc $ map renderMethodDoc (sortOn methodName psMethods) + ] + + renderChildDoc child = fillBreak 12 (pretty $ csNamespace child) + <+> align (fillSep $ map pretty $ T.words $ csDescription child) + + renderMethodDoc method = vsep $ + [ fillBreak 12 (pretty $ methodName method) + <+> align (fillSep $ map pretty $ T.words $ methodDescription method) + ] ++ paramsDocs (methodParams method) + + paramsDocs Nothing = [] + paramsDocs (Just (Object o)) = case KM.lookup "properties" o of + Just (Object props) -> + let reqList = case KM.lookup "required" o of + Just (Array arr) -> [t | String t <- foldr (:) [] arr] + _ -> [] + propList = KM.toList props + sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList + in [indent 12 $ vsep $ map (renderParamDoc reqList) sorted] + _ -> [] + paramsDocs _ = [] + + renderParamDoc :: [Text] -> (K.Key, Value) -> Doc ann + renderParamDoc required (name, propSchema) = + let nameText = K.toText name + isReq = nameText `elem` required + (typ, desc) = extractTypeDesc propSchema + flag = "--" <> T.replace "_" "-" nameText + typStr = " <" <> typ <> ">" <> if isReq then "" else "?" + descWords = if T.null desc then [] else map pretty (T.words desc) + in fillBreak 20 (pretty flag <> pretty typStr) + <+> align (fillSep descWords) + +-- | Render a method (short form) +renderMethod :: MethodSchema -> Text +renderMethod = renderMethodWith defaultStyle + +-- | Render a method with style +renderMethodWith :: RenderStyle -> MethodSchema -> Text +renderMethodWith RenderStyle{..} m = + " " <> padRight 16 (methodName m) <> methodDescription m + <> if rsShowTypes then renderParams (methodParams m) else "" + +-- | Render a method (full form with all params) +renderMethodFull :: MethodSchema -> Text +renderMethodFull m = T.unlines $ + [ methodName m <> " - " <> methodDescription m + , "" + ] <> paramLines + where + paramLines = case methodParams m of + Nothing -> [" (no parameters)"] + Just schema -> renderParamsFull schema + +-- | Render a child summary +renderChild :: ChildSummary -> Text +renderChild child = + " " <> padRight 16 (csNamespace child) <> csDescription child + +-- | Render parameters inline +renderParams :: Maybe Value -> Text +renderParams Nothing = "" +renderParams (Just (Object o)) = case KM.lookup "properties" o of + Just (Object props) -> + let reqList = case KM.lookup "required" o of + Just (Array arr) -> [t | String t <- foldr (:) [] arr] + _ -> [] + propList = KM.toList props + sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList + rendered = map (renderParam reqList) sorted + in if null rendered then "" else "\n" <> T.intercalate "\n" rendered + _ -> "" +renderParams _ = "" + +-- | Render a single parameter +renderParam :: [Text] -> (K.Key, Value) -> Text +renderParam required (name, propSchema) = + let nameText = K.toText name + isReq = nameText `elem` required + flagName = T.replace "_" "-" nameText + (typ, desc) = extractTypeDesc propSchema + reqMarker = if isReq then "" else "?" + in " --" <> flagName <> " <" <> typ <> ">" <> reqMarker <> " " <> desc + +-- | Render parameters in full (for method help) +renderParamsFull :: Value -> [Text] +renderParamsFull (Object o) = case KM.lookup "properties" o of + Just (Object props) -> + let reqList = case KM.lookup "required" o of + Just (Array arr) -> [t | String t <- foldr (:) [] arr] + _ -> [] + propList = KM.toList props + sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList + in map (renderParamFull reqList) sorted + _ -> [] +renderParamsFull _ = [] + +renderParamFull :: [Text] -> (K.Key, Value) -> Text +renderParamFull required (name, propSchema) = + let nameText = K.toText name + isReq = nameText `elem` required + (typ, desc) = extractTypeDesc propSchema + reqText = if isReq then " (required)" else " (optional)" + in " --" <> nameText <> " <" <> typ <> ">" <> reqText <> "\n " <> desc + +-- | Extract type and description from property schema +extractTypeDesc :: Value -> (Text, Text) +extractTypeDesc (Object po) = + ( case KM.lookup "type" po of { Just (String t) -> t; _ -> "any" } + , case KM.lookup "description" po of { Just (String d) -> d; _ -> "" } + ) +extractTypeDesc _ = ("any", "") + +-- | Pad text to a minimum width +padRight :: Int -> Text -> Text +padRight n t + | T.length t >= n = t <> " " + | otherwise = t <> T.replicate (n - T.length t) " " diff --git a/src/Synapse/Algebra/Walk.hs b/src/Synapse/Algebra/Walk.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Algebra/Walk.hs @@ -0,0 +1,149 @@ +-- | Schema tree walking via recursion schemes +-- +-- This module provides schema traversal using proper categorical machinery: +-- +-- = Anamorphism (Unfold) +-- +-- The schema tree is built via anamorphism - we have a coalgebra that +-- produces one layer of 'SchemaF' from a path seed: +-- +-- @ +-- coalgebra :: Path -> SynapseM (SchemaF Path) +-- @ +-- +-- Iterating this coalgebra builds the full tree: +-- +-- @ +-- unfoldSchema :: Path -> SynapseM SchemaTree +-- unfoldSchema = anaM coalgebra +-- @ +-- +-- = Catamorphism (Fold) +-- +-- To process the tree, we use algebras. A method-collecting algebra: +-- +-- @ +-- methodAlgebra :: SchemaF [MethodInfo] -> [MethodInfo] +-- methodAlgebra (PluginF schema path children) = +-- localMethods ++ concat children +-- methodAlgebra (MethodF method ns path) = +-- [MethodInfo method path ns] +-- @ +-- +-- = Hylomorphism (Unfold then Fold) +-- +-- Most operations combine unfold and fold. Using 'hyloM' we get fusion: +-- +-- @ +-- walkMethods :: Path -> SynapseM [MethodInfo] +-- walkMethods = hyloM methodAlgebra schemaCoalgebra +-- @ +-- +-- The fused version never materializes the intermediate tree! +module Synapse.Algebra.Walk + ( -- * Recursion Schemes + walkMethods + , walkSchema + , foldMethods + + -- * Building Trees + , unfoldSchema + , foldSchema + + -- * Types + , MethodInfo(..) + , SchemaF(..) + , SchemaTree + + -- * Re-exports for algebras + , Fix(..) + ) where + +import Data.Text (Text) + +import Synapse.Schema.Types (Path, PluginSchema(..), MethodSchema(..), ChildSummary(..)) +import Synapse.Schema.Functor (SchemaF(..), Fix(..), SchemaTree) +import Synapse.Monad +import Synapse.Algebra.Recursion (hyloM, unfoldSchema, foldSchema) +import Synapse.Transport (fetchSchemaAt) + +-- | Information about a method in context +data MethodInfo = MethodInfo + { miMethod :: MethodSchema -- ^ The method schema + , miPath :: Path -- ^ Full path to this method + , miNamespace :: Text -- ^ Parent namespace + } + deriving stock (Show, Eq) + +-- ============================================================================ +-- Algebras +-- ============================================================================ + +-- | Algebra for collecting methods +-- +-- This is a proper F-algebra: SchemaF [MethodInfo] -> [MethodInfo] +-- It shows how to combine child results with local data. +methodAlgebra :: SchemaF [MethodInfo] -> [MethodInfo] +methodAlgebra (PluginF schema path childResults) = + -- Local methods from this plugin + let localMethods = + [ MethodInfo m (path ++ [methodName m]) (psNamespace schema) + | m <- psMethods schema + ] + -- Combine with results from children (already processed) + in localMethods ++ concat childResults +methodAlgebra (MethodF method ns path) = + -- Method nodes are leaves - just wrap in list + [MethodInfo method path ns] + +-- | Monadic algebra for collecting methods (for hyloM) +methodAlgebraM :: SchemaF [MethodInfo] -> SynapseM [MethodInfo] +methodAlgebraM = pure . methodAlgebra + +-- ============================================================================ +-- Coalgebras +-- ============================================================================ + +-- | Coalgebra for unfolding schema trees +-- +-- This is a proper F-coalgebra: Path -> SynapseM (SchemaF Path) +-- It shows how to produce one layer from a seed. +schemaCoalgebra :: Path -> SynapseM (SchemaF Path) +schemaCoalgebra path = do + schema <- fetchSchemaAt path + let childPaths = case psChildren schema of + Nothing -> [] + Just children -> [path ++ [csNamespace c] | c <- children] + pure $ PluginF schema path childPaths + +-- ============================================================================ +-- Walking Operations +-- ============================================================================ + +-- | Walk the schema tree, collecting all methods +-- +-- This is a hylomorphism: unfold from path, fold with method algebra. +-- Uses hyloM for the fused monadic version - no intermediate tree built! +-- +-- @ +-- walkMethods = hyloM methodAlgebraM schemaCoalgebra +-- @ +walkMethods :: Path -> SynapseM [MethodInfo] +walkMethods = hyloM methodAlgebraM schemaCoalgebra + +-- | Walk schema tree with a custom monadic algebra +-- +-- General version - provide your own algebra. +walkSchema :: (SchemaF a -> SynapseM a) -> Path -> SynapseM a +walkSchema alg = hyloM alg schemaCoalgebra + +-- | Fold over methods with pure transformations +-- +-- Convenience wrapper: walk to collect methods, then map and combine. +foldMethods :: (MethodInfo -> a) -- ^ Transform each method + -> ([a] -> b) -- ^ Combine results + -> Path -- ^ Starting path + -> SynapseM b +foldMethods f combine path = do + methods <- walkMethods path + pure $ combine $ map f methods diff --git a/src/Synapse/Backend/Discovery.hs b/src/Synapse/Backend/Discovery.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Backend/Discovery.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Backend Discovery Abstraction +-- +-- This module provides an abstraction layer for discovering Plexus RPC servers. +-- Currently implements a stub that returns hardcoded localhost:4444, but the +-- interface is designed to support future dynamic discovery via a directory +-- service. +-- +-- = Future Vision +-- +-- @ +-- ┌─────────────┐ ┌──────────────────┐ ┌─────────────────┐ +-- │ synapse │────▶│ Hub Directory │────▶│ Backend Hubs │ +-- │ (CLI) │ │ (port 4444) │ │ (discovered) │ +-- └─────────────┘ └──────────────────┘ └─────────────────┘ +-- │ +-- ▼ +-- Returns list of: +-- - Hub name +-- - Connection info (host:port or https URL) +-- - Description +-- - Schema hash +-- @ +-- +-- = Usage +-- +-- @ +-- main :: IO () +-- main = do +-- let discovery = stubDiscovery +-- backends <- discoverBackends discovery +-- -- Use backends to build CLI subcommands +-- @ +module Synapse.Backend.Discovery + ( -- * Backend Type + Backend(..) + + -- * Discovery Interface + , BackendDiscovery(..) + + -- * Implementations + , stubDiscovery + , registryDiscovery + + -- * Backend Discovery + , getBackendAt + + -- * Health Checks + , pingBackend + , pingBackends + ) where + +import Data.Aeson (ToJSON, FromJSON, (.:), (.:?), withObject) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Control.Exception (catch, SomeException) +import Data.Either (isRight) +import Control.Concurrent.Async (mapConcurrently, race, async, wait) +import Control.Concurrent (threadDelay) +import Data.IORef (newIORef, writeIORef, readIORef) +import Control.Monad (void) +import Plexus.Client (SubstrateConfig(..)) +import qualified Plexus.Transport as ST +import Plexus.Types (PlexusStreamItem(..), TransportError(..)) + +-- ============================================================================ +-- Backend Type +-- ============================================================================ + +-- | A discovered backend hub +data Backend = Backend + { backendName :: Text -- ^ e.g., "plexus" + , backendDescription :: Text -- ^ Human-readable description + , backendHost :: Text -- ^ Host to connect to + , backendPort :: Int -- ^ Port + , backendVersion :: Maybe Text -- ^ Version if known + , backendReachable :: Maybe Bool -- ^ Whether backend is reachable (Nothing = not checked) + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +-- ============================================================================ +-- Discovery Interface +-- ============================================================================ + +-- | Backend discovery interface +-- +-- This is a record-of-functions pattern that allows swapping discovery +-- implementations without changing calling code. In the future, this could +-- become a typeclass if we need more sophisticated dispatch. +data BackendDiscovery = BackendDiscovery + { discoverBackends :: IO [Backend] + -- ^ Query for all available backends + , getBackendInfo :: Text -> IO (Maybe Backend) + -- ^ Get info for a specific backend by name + } + +-- ============================================================================ +-- Stub Implementation +-- ============================================================================ + +-- | Stub discovery that returns empty list +-- +-- Used as fallback when connection fails completely. +stubDiscovery :: BackendDiscovery +stubDiscovery = BackendDiscovery + { discoverBackends = pure [] + , getBackendInfo = \_ -> pure Nothing + } + +-- ============================================================================ +-- Registry Types +-- ============================================================================ + +-- | Registry backend info (from registry activation) +data RegistryBackendInfo = RegistryBackendInfo + { rbiName :: Text + , rbiHost :: Text + , rbiPort :: Int + , rbiProtocol :: Text + , rbiDescription :: Maybe Text + , rbiIsActive :: Bool + } + deriving (Show, Generic) + +instance FromJSON RegistryBackendInfo where + parseJSON = withObject "RegistryBackendInfo" $ \o -> do + name <- o .: "name" + host <- o .: "host" + port <- o .: "port" + protocol <- o .: "protocol" + desc <- o .:? "description" + active <- o .: "is_active" + pure $ RegistryBackendInfo name host port protocol desc active + +-- | Registry event wrapper +data RegistryEvent + = BackendsEvent { backends :: [RegistryBackendInfo] } + | BackendEvent { backend :: Maybe RegistryBackendInfo } + deriving (Show, Generic) + +instance FromJSON RegistryEvent where + parseJSON = withObject "RegistryEvent" $ \o -> do + eventType <- o .: "type" -- Rust uses #[serde(tag = "type")] + case eventType :: Text of + "backends" -> BackendsEvent <$> o .: "backends" + "backend" -> BackendEvent <$> o .: "backend" + _ -> fail $ "Unknown registry event type: " ++ T.unpack eventType + +-- | Backend info response from _info endpoint +data BackendInfoResponse = BackendInfoResponse + { birBackend :: Text + } + deriving (Show, Generic) + +instance FromJSON BackendInfoResponse where + parseJSON = withObject "BackendInfoResponse" $ \o -> do + backendName <- o .: "backend" + pure $ BackendInfoResponse backendName + +-- ============================================================================ +-- Registry-based Discovery +-- ============================================================================ + +-- | Query the registry activation for available backends +-- +-- Connects to the registry service and queries for registered backends. +-- Falls back to stubDiscovery if registry is unavailable. +registryDiscovery :: Text -> Int -> BackendDiscovery +registryDiscovery registryHost registryPort = BackendDiscovery + { discoverBackends = do + -- First, discover the backend name using _info + maybeBackendName <- discoverBackendName registryHost registryPort + case maybeBackendName of + Just discoveredName -> do + -- Create a Backend entry for the discovered backend + let discoveredBackend = Backend + { backendName = discoveredName + , backendDescription = "Backend discovered via _info" + , backendHost = registryHost + , backendPort = registryPort + , backendVersion = Nothing + , backendReachable = Nothing + } + + -- Try to get additional backends from registry (if it exists) + registryBackends <- queryRegistry registryHost registryPort discoveredName + + -- Only include discovered backend if not already in registry + -- (prefer registry entry since it has more details) + let matchesDiscovered b = backendName b == discoveredName + && backendHost b == registryHost + && backendPort b == registryPort + isDuplicate = any matchesDiscovered registryBackends + backends = if isDuplicate + then registryBackends + else [discoveredBackend] ++ registryBackends + + pure backends + Nothing -> + -- Connection failed completely + discoverBackends stubDiscovery + , getBackendInfo = queryBackend registryHost registryPort + } + +-- | Get the backend name at a given host/port via _info +-- Returns whatever backend is running there (e.g., "registry-hub", "plexus") +-- If that backend has a registry plugin, it can be used to discover other backends +getBackendAt :: Text -> Int -> IO (Maybe Text) +getBackendAt = discoverBackendName + +-- | Discover the backend name by calling _info +discoverBackendName :: Text -> Int -> IO (Maybe Text) +discoverBackendName host port = do + let cfg = SubstrateConfig + { substrateHost = T.unpack host + , substratePort = port + , substratePath = "/" + , substrateBackend = "" -- Not used for _info + } + result <- ST.rpcCallWith cfg "_info" Aeson.Null + `catch` \(_e :: SomeException) -> pure (Left $ NetworkError "Connection failed") + + case result of + Left _err -> pure Nothing + Right items -> do + -- Extract the backend name from subscription response + case [Aeson.fromJSON content | StreamData _ _ _ content <- items] of + (Aeson.Success (Aeson.Object obj):_) | Just (Aeson.String name) <- KM.lookup "backend" obj -> + pure (Just name) + _ -> pure Nothing + +-- | Query the registry for all backends +queryRegistry :: Text -> Int -> Text -> IO [Backend] +queryRegistry host port backendName = do + -- Try registry query first + queryRegistryImpl host port backendName `catch` \(_e :: SomeException) -> + -- Return empty list on error - caller will handle fallback + pure [] + +-- | Implementation of registry query +queryRegistryImpl :: Text -> Int -> Text -> IO [Backend] +queryRegistryImpl host port backendName = do + let cfg = SubstrateConfig + { substrateHost = T.unpack host + , substratePort = port + , substratePath = "/" + , substrateBackend = backendName + } + -- Call registry.list through the backend + result <- ST.invokeMethod cfg ["registry"] "list" (Aeson.object []) + case result of + Left _err -> pure [] + Right items -> do + -- Extract content from stream items + let contents = [c | StreamData _ _ _ c <- items] + let events = [e | Aeson.Success e <- map Aeson.fromJSON contents] + let backendInfos = concat [bs | BackendsEvent bs <- events] + pure $ map convertBackend backendInfos + +-- | Query for a specific backend by name +queryBackend :: Text -> Int -> Text -> IO (Maybe Backend) +queryBackend host port name = do + -- First discover the backend name + maybeBackendName <- discoverBackendName host port + case maybeBackendName of + Just discoveredName -> do + -- Check if the requested name matches the discovered backend + if name == discoveredName + then pure $ Just Backend + { backendName = discoveredName + , backendDescription = "Backend discovered via _info" + , backendHost = host + , backendPort = port + , backendVersion = Nothing + , backendReachable = Nothing + } + else do + -- Try to find it in the registry + result <- catch + (queryBackendImpl host port discoveredName name) + (\(_e :: SomeException) -> pure Nothing) + pure result + Nothing -> getBackendInfo stubDiscovery name + +-- | Implementation of backend get query +queryBackendImpl :: Text -> Int -> Text -> Text -> IO (Maybe Backend) +queryBackendImpl host port backendName name = do + let cfg = SubstrateConfig + { substrateHost = T.unpack host + , substratePort = port + , substratePath = "/" + , substrateBackend = backendName + } + params = Aeson.object ["name" Aeson..= name] + result <- ST.invokeMethod cfg ["registry"] "get" params + case result of + Left _err -> pure Nothing + Right items -> do + -- Extract content from stream items + let contents = [c | StreamData _ _ _ c <- items] + let events = [e | Aeson.Success e <- map Aeson.fromJSON contents] + case [b | BackendEvent (Just b) <- events] of + (info:_) -> pure $ Just (convertBackend info) + [] -> pure Nothing + +-- | Convert registry backend info to discovery backend +convertBackend :: RegistryBackendInfo -> Backend +convertBackend info = Backend + { backendName = rbiName info + , backendDescription = maybe "" id (rbiDescription info) + , backendHost = rbiHost info + , backendPort = rbiPort info + , backendVersion = Nothing + , backendReachable = Nothing -- Will be checked separately + } + +-- | Ping a backend to check if it's reachable (with 300ms timeout) +-- 300ms allows for WebSocket connection establishment overhead (~150-200ms) +-- plus actual RPC round-trip time +pingBackend :: Backend -> IO Backend +pingBackend backend = do + let cfg = SubstrateConfig + { substrateHost = T.unpack (backendHost backend) + , substratePort = backendPort backend + , substratePath = "/" + , substrateBackend = "" -- _info has no namespace prefix + } + timeout = threadDelay 300000 >> pure (Left $ ConnectionTimeout (backendHost backend) (backendPort backend)) + rpcCall = ST.rpcCallWith cfg "_info" Aeson.Null + `catch` \(_e :: SomeException) -> pure (Left $ NetworkError "Connection failed") + + -- Race the RPC call against a 300ms timeout + result <- race timeout rpcCall + let reachable = case result of + Left _ -> False -- Timeout + Right (Right _) -> True -- Success + Right (Left _) -> False -- RPC error + + pure $ backend { backendReachable = Just reachable } + +-- | Ping all backends in parallel +pingBackends :: [Backend] -> IO [Backend] +pingBackends backends = mapConcurrently pingBackend backends diff --git a/src/Synapse/Bidir.hs b/src/Synapse/Bidir.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Bidir.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Bidirectional communication support for Synapse +-- +-- This module handles bidirectional requests (confirm, prompt, select) from +-- the backend, supporting multiple modes for both human and agent users. +-- +-- = Modes +-- +-- - @interactive@: Uses TTY prompts (requires terminal) +-- - @json@: Outputs request as JSON to stdout, reads response from stdin +-- - @auto-cancel@: Automatically cancels all requests with a warning +-- - @defaults@: Uses default values from requests if available +-- - @--bidir-cmd CMD@: Spawns a subprocess per request (stdin=JSON, stdout=JSON) +-- - @--bidir-respond@: Prints request to stdout as JSON, returns Nothing so the +-- agent can respond via a separate @synapse \ respond@ invocation +-- +-- = Protocol +-- +-- When a @StreamRequest@ arrives, the handler: +-- 1. Processes it according to the current mode +-- 2. If a response is produced, sends it via @{backend}.respond@ RPC method +-- 3. If Nothing is returned (BidirRespond), the caller skips sending a response +module Synapse.Bidir + ( -- * Types + BidirMode(..) + , parseBidirMode + , defaultBidirMode + + -- * TTY Detection + , isTTY + , detectBidirMode + + -- * Request Handling + , handleBidirRequest + , BidirHandler + ) where + +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as TIO +import System.IO (hClose, hFlush, hIsTerminalDevice, stderr, stdin, stdout) +import System.Process (createProcess, proc, std_in, std_out, StdStream(..), waitForProcess) +import System.Exit (ExitCode(..)) + +import Plexus.Types + ( Request(..) + , Response(..) + , SelectOption(..) + ) + +-- | Bidirectional communication mode +data BidirMode + = BidirInteractive -- ^ Use TTY prompts (requires terminal) + | BidirJson -- ^ Output request as JSON, read response from stdin + | BidirAutoCancel -- ^ Automatically cancel all requests + | BidirDefaults -- ^ Use default values from requests + | BidirCmd Text -- ^ Spawn subprocess per request (stdin=JSON request, stdout=JSON response) + | BidirRespond -- ^ Print request to stdout as JSON; agent responds via separate process call + deriving (Show, Eq) + +-- | Parse bidirectional mode from string +parseBidirMode :: Text -> Maybe BidirMode +parseBidirMode = \case + "interactive" -> Just BidirInteractive + "json" -> Just BidirJson + "auto-cancel" -> Just BidirAutoCancel + "defaults" -> Just BidirDefaults + "respond" -> Just BidirRespond + _ -> Nothing + +-- | Default mode when running in TTY +defaultBidirMode :: BidirMode +defaultBidirMode = BidirInteractive + +-- | Check if stdin is a terminal +isTTY :: IO Bool +isTTY = hIsTerminalDevice stdin + +-- | Detect the appropriate bidirectional mode based on environment +-- Returns Interactive for TTY, AutoCancel for piped mode +detectBidirMode :: IO BidirMode +detectBidirMode = do + tty <- isTTY + pure $ if tty then BidirInteractive else BidirAutoCancel + +-- | Handler type for bidirectional requests +-- Takes request ID, request data, and returns an optional response. +-- Nothing means no immediate response (e.g., BidirRespond mode; agent responds separately). +type BidirHandler = Text -> Request Value -> IO (Maybe (Response Value)) + +-- | Handle a bidirectional request according to the mode +handleBidirRequest :: BidirMode -> Text -> Request Value -> IO (Maybe (Response Value)) +handleBidirRequest mode requestId req = case mode of + BidirInteractive -> Just <$> handleInteractive requestId req + BidirJson -> Just <$> handleJson requestId req + BidirAutoCancel -> Just <$> handleAutoCancel requestId req + BidirDefaults -> Just <$> handleDefaults requestId req + BidirCmd cmd -> Just <$> handleCmd cmd requestId req + BidirRespond -> handleRespond requestId req + +-- | Interactive TTY handling +handleInteractive :: Text -> Request Value -> IO (Response Value) +handleInteractive _requestId req = case req of + Confirm{..} -> do + let defaultHint = case confirmDefault of + Just True -> " [Y/n]" + Just False -> " [y/N]" + Nothing -> " [y/n]" + TIO.putStr $ confirmMessage <> defaultHint <> ": " + hFlush stdout + input <- TIO.getLine + let confirmed = case T.toLower (T.strip input) of + "" -> case confirmDefault of + Just d -> d + Nothing -> False + "y" -> True + "yes" -> True + _ -> False + pure $ Confirmed confirmed + + Prompt{..} -> do + let hint = case promptPlaceholder of + Just ph -> " (" <> ph <> ")" + Nothing -> "" + TIO.putStr $ promptMessage <> hint <> ": " + hFlush stdout + input <- TIO.getLine + let response = if T.null input + then case promptDefault of + Just d -> d + Nothing -> String input + else String input + pure $ Value response + + Select{..} -> do + TIO.putStrLn selectMessage + mapM_ printOption (zip [1..] selectOptions) + TIO.putStr "Select (enter number): " + hFlush stdout + input <- TIO.getLine + case reads (T.unpack input) of + [(n, "")] | n >= 1 && n <= length selectOptions -> + let selected = optionValue (selectOptions !! (n - 1)) + in pure $ Selected [selected] + _ -> pure Cancelled + + CustomRequest{} -> pure Cancelled + where + printOption :: (Int, SelectOption Value) -> IO () + printOption (idx, SelectOption{..}) = do + let desc = case optionDescription of + Just d -> " - " <> d + Nothing -> "" + TIO.putStrLn $ " " <> T.pack (show idx) <> ") " <> optionLabel <> desc + +-- | JSON protocol handling for piped mode +-- Outputs request as a JSON line to stdout, reads a JSON response line from stdin +handleJson :: Text -> Request Value -> IO (Response Value) +handleJson requestId req = do + let jsonReq = encode $ object + [ "type" .= ("bidir_request" :: Text) + , "request_id" .= requestId + , "request" .= req + ] + LBS.putStrLn jsonReq + hFlush stdout + inputLine <- TIO.getLine + case eitherDecode (LBS.fromStrict $ T.encodeUtf8 inputLine) of + Left err -> do + TIO.hPutStrLn stderr $ "[synapse] Failed to parse bidir response: " <> T.pack err + pure Cancelled + Right resp -> pure resp + +-- | Auto-cancel mode: cancels all requests with a warning +handleAutoCancel :: Text -> Request Value -> IO (Response Value) +handleAutoCancel requestId req = do + TIO.hPutStrLn stderr $ "[synapse] Auto-cancelling " <> requestTypeName req + <> " request (id: " <> requestId <> ") - not in interactive mode" + TIO.hPutStrLn stderr "[synapse] Use --bidir-mode to change: json, defaults, interactive" + TIO.hPutStrLn stderr "[synapse] Or use --bidir-cmd CMD / --bidir-respond for agent mode" + pure Cancelled + +-- | Defaults mode: uses default values from requests if available +handleDefaults :: Text -> Request Value -> IO (Response Value) +handleDefaults requestId req = case req of + Confirm{..} -> case confirmDefault of + Just d -> do + TIO.hPutStrLn stderr $ "[synapse] Using default for confirm (id: " + <> requestId <> "): " <> if d then "yes" else "no" + pure $ Confirmed d + Nothing -> do + TIO.hPutStrLn stderr $ "[synapse] No default for confirm (id: " + <> requestId <> "), cancelling" + pure Cancelled + + Prompt{..} -> case promptDefault of + Just d -> do + TIO.hPutStrLn stderr $ "[synapse] Using default for prompt (id: " <> requestId <> ")" + pure $ Value d + Nothing -> do + TIO.hPutStrLn stderr $ "[synapse] No default for prompt (id: " + <> requestId <> "), cancelling" + pure Cancelled + + Select{..} -> do + TIO.hPutStrLn stderr $ "[synapse] No default for select (id: " + <> requestId <> "), cancelling" + pure Cancelled + + CustomRequest{} -> pure Cancelled + +-- | Command mode: spawn a subprocess per request +-- The subprocess receives a JSON object on stdin: +-- {"request_id": "...", "request": {...}} +-- And must write a JSON Response object to stdout: +-- {"type": "confirmed", "value": true} +handleCmd :: Text -> Text -> Request Value -> IO (Response Value) +handleCmd cmd requestId req = do + let reqJson = encode $ object + [ "request_id" .= requestId + , "request" .= req + ] + (Just hIn, Just hOut, _, ph) <- createProcess (proc "sh" ["-c", T.unpack cmd]) + { std_in = CreatePipe + , std_out = CreatePipe + } + LBS.hPutStr hIn reqJson + hClose hIn + outputBytes <- LBS.hGetContents hOut + exitCode <- waitForProcess ph + case exitCode of + ExitFailure code -> do + TIO.hPutStrLn stderr $ "[synapse] --bidir-cmd subprocess exited with code " + <> T.pack (show code) <> " (id: " <> requestId <> ")" + pure Cancelled + ExitSuccess -> case eitherDecode outputBytes of + Left err -> do + TIO.hPutStrLn stderr $ "[synapse] Failed to parse --bidir-cmd response: " <> T.pack err + pure Cancelled + Right resp -> pure resp + +-- | Respond mode: print request to stdout as JSON, return Nothing +-- The caller (invokeStreamingWithBidir) will skip sending a response. +-- The agent is expected to call: synapse respond --request-id --response +handleRespond :: Text -> Request Value -> IO (Maybe (Response Value)) +handleRespond requestId req = do + let jsonReq = encode $ object + [ "type" .= ("bidir_request" :: Text) + , "request_id" .= requestId + , "request" .= req + ] + LBS.putStrLn jsonReq + hFlush stdout + pure Nothing + +-- | Get a human-readable name for the request type +requestTypeName :: Request t -> Text +requestTypeName = \case + Confirm{} -> "confirm" + Prompt{} -> "prompt" + Select{} -> "select" + CustomRequest{} -> "custom" diff --git a/src/Synapse/CLI/Help.hs b/src/Synapse/CLI/Help.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/CLI/Help.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} + +-- | IR-based help rendering for CLI +-- +-- Renders method and parameter help directly from the IR, providing +-- structured type information including discriminated union expansion. +-- +-- = Design +-- +-- Instead of parsing JSON Schema ad-hoc, we use the pre-built IR: +-- +-- @ +-- IR (types, methods) +-- | +-- +-> renderMethodHelp -> full method documentation +-- +-> renderParamHelp -> parameter with type expansion +-- +-> expandType -> discriminated union variants +-- +-> renderTypeRef -> type signature string +-- @ +-- +-- = Example Output +-- +-- @ +-- cone.chat - Chat with a cone +-- +-- Parameters: +-- --identifier (required) +-- Cone name or UUID +-- Either: +-- --identifier.type by_name --identifier.name +-- --identifier.type by_id --identifier.id +-- +-- --prompt (required) +-- User message / prompt to send +-- +-- --ephemeral (optional) +-- If true, doesn't advance head +-- @ +module Synapse.CLI.Help + ( -- * Method Help + renderMethodHelp + , renderMethodHelpWith + + -- * Parameter Help + , renderParamHelp + , renderParamHelpWith + + -- * Type Rendering + , renderTypeRef + , expandType + + -- * Configuration + , HelpStyle(..) + , defaultHelpStyle + ) where + +import Data.List (intersperse) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, maybeToList) +import Data.Text (Text) +import qualified Data.Text as T + +import Synapse.IR.Types + +-- ============================================================================ +-- Configuration +-- ============================================================================ + +-- | Style configuration for help rendering +data HelpStyle = HelpStyle + { hsIndent :: !Int -- ^ Spaces per indent level + , hsParamWidth :: !Int -- ^ Width for parameter column + , hsShowFormats :: !Bool -- ^ Show format hints (uuid, int64, etc.) + , hsExpandEnums :: !Bool -- ^ Expand enum variants inline + } + deriving stock (Show, Eq) + +-- | Default help style +defaultHelpStyle :: HelpStyle +defaultHelpStyle = HelpStyle + { hsIndent = 2 + , hsParamWidth = 30 + , hsShowFormats = True + , hsExpandEnums = True + } + +-- ============================================================================ +-- Method Help +-- ============================================================================ + +-- | Render complete help for a method +renderMethodHelp :: IR -> MethodDef -> Text +renderMethodHelp = renderMethodHelpWith defaultHelpStyle + +-- | Render method help with custom style +renderMethodHelpWith :: HelpStyle -> IR -> MethodDef -> Text +renderMethodHelpWith style ir method = T.unlines $ + [ header + , "" + ] ++ descSection ++ paramSection + where + header = mdFullPath method <> streamingIndicator + + streamingIndicator + | mdStreaming method = " [streaming]" + | otherwise = "" + + descSection = case mdDescription method of + Just desc -> [desc, ""] + Nothing -> [] + + paramSection + | null (mdParams method) = ["(no parameters)"] + | otherwise = + ["Parameters:"] ++ + concatMap (renderParamBlock style ir) (mdParams method) + +-- | Render a parameter as a block (may be multi-line for complex types) +renderParamBlock :: HelpStyle -> IR -> ParamDef -> [Text] +renderParamBlock style ir param = + let indent' = T.replicate (hsIndent style) " " + indent2 = T.replicate (hsIndent style * 2) " " + + -- Parameter header line + flagName = "--" <> T.replace "_" "-" (pdName param) -- Display as kebab-case + typeStr = renderTypeRef ir (pdType param) + reqText = if pdRequired param then "(required)" else "(optional)" + headerLine = indent' <> flagName <> " <" <> typeStr <> "> " <> reqText + + -- Description line + descLines = case pdDescription param of + Just desc -> [indent2 <> desc] + Nothing -> [] + + -- Type expansion (for enums/unions) + expansionLines = if hsExpandEnums style + then map (indent2 <>) (expandType ir (pdName param) (pdType param)) + else [] + + in [""] ++ [headerLine] ++ descLines ++ expansionLines + +-- ============================================================================ +-- Parameter Help +-- ============================================================================ + +-- | Render help for a single parameter +renderParamHelp :: IR -> ParamDef -> [Text] +renderParamHelp = renderParamHelpWith defaultHelpStyle + +-- | Render parameter help with custom style +renderParamHelpWith :: HelpStyle -> IR -> ParamDef -> [Text] +renderParamHelpWith style ir param = renderParamBlock style ir param + +-- ============================================================================ +-- Type Rendering +-- ============================================================================ + +-- | Render a type reference as a type signature string +-- +-- Examples: +-- RefPrimitive "string" Nothing -> "string" +-- RefPrimitive "string" (Just "uuid") -> "uuid" +-- RefArray (RefPrimitive "string" Nothing) -> "string[]" +-- RefOptional (RefNamed "Foo") -> "Foo?" +-- RefNamed "ConeIdentifier" -> "ConeIdentifier" +renderTypeRef :: IR -> TypeRef -> Text +renderTypeRef ir = \case + RefNamed qn -> qualifiedNameFull qn + + RefPrimitive typ mFormat + | Just fmt <- mFormat -> fmt -- Use format as type (uuid, int64, etc.) + | otherwise -> typ + + RefArray inner -> renderTypeRef ir inner <> "[]" + + RefOptional inner -> renderTypeRef ir inner <> "?" + + RefAny -> "any" + + RefUnknown -> "unknown" + +-- | Expand a type into CLI flag examples +-- +-- For discriminated unions, shows each variant with its fields. +-- Returns empty list for simple types. +-- +-- Example for ConeIdentifier: +-- @ +-- ["Either:" +-- ," --identifier.type by_name --identifier.name " +-- ," --identifier.type by_id --identifier.id " +-- ] +-- @ +expandType :: IR -> Text -> TypeRef -> [Text] +expandType ir prefix = \case + RefNamed qn -> expandNamedType ir prefix (qualifiedNameFull qn) + RefOptional inner -> expandType ir prefix inner + _ -> [] -- Primitives and arrays don't expand + +-- | Expand a named type by looking it up in the IR +expandNamedType :: IR -> Text -> Text -> [Text] +expandNamedType ir prefix typeName = + case Map.lookup typeName (irTypes ir) of + Nothing -> [] -- Type not found, no expansion + Just typeDef -> expandTypeDef ir prefix typeDef + +-- | Expand a type definition +expandTypeDef :: IR -> Text -> TypeDef -> [Text] +expandTypeDef ir prefix TypeDef{..} = case tdKind of + -- Discriminated union: show each variant + KindEnum discriminator variants + | length variants > 1 -> expandEnum ir prefix discriminator variants + | otherwise -> [] + + -- Struct: could expand fields, but typically too verbose + KindStruct _fields -> [] + + -- Alias: expand the target + KindAlias target -> expandType ir prefix target + + -- Primitives don't expand + KindPrimitive _ _ -> [] + + -- String enums don't expand (just string literals) + KindStringEnum _ -> [] + +-- | Expand an enum (discriminated union) into variant examples +expandEnum :: IR -> Text -> Text -> [VariantDef] -> [Text] +expandEnum ir prefix discriminator variants = + ["Either:"] ++ map ((" " <>) . renderVariantExample ir prefix discriminator) variants + +-- | Render a single variant as a CLI example +-- +-- Example: "--identifier.type by_name --identifier.name " +renderVariantExample :: IR -> Text -> Text -> VariantDef -> Text +renderVariantExample ir prefix discriminator VariantDef{..} = + let prefix' = T.replace "_" "-" prefix -- Display as kebab-case + disc' = T.replace "_" "-" discriminator -- Display as kebab-case + discFlag = "--" <> prefix' <> "." <> disc' <> " " <> vdName + fieldFlags = map (renderFieldFlag ir prefix') vdFields + in T.intercalate " " (discFlag : fieldFlags) + +-- | Render a field as a CLI flag +-- +-- Example: "--identifier.name " +renderFieldFlag :: IR -> Text -> FieldDef -> Text +renderFieldFlag ir prefix FieldDef{..} = + let name' = T.replace "_" "-" fdName -- Display as kebab-case + in "--" <> prefix <> "." <> name' <> " <" <> renderTypeRef ir fdType <> ">" + +-- ============================================================================ +-- String Enum Helpers +-- ============================================================================ + +-- | Check if a type is a string enum and get its values +getStringEnumValues :: IR -> TypeRef -> Maybe [Text] +getStringEnumValues ir (RefNamed qn) = + let name = qualifiedNameFull qn + in case Map.lookup name (irTypes ir) of + Just TypeDef{tdKind = KindEnum "value" variants} -> + Just $ map vdName variants + _ -> Nothing +getStringEnumValues _ _ = Nothing + +-- | Render string enum values inline +-- Example: "One of: pending, in_progress, completed" +renderStringEnumHint :: [Text] -> Text +renderStringEnumHint values = "One of: " <> T.intercalate ", " values diff --git a/src/Synapse/CLI/Parse.hs b/src/Synapse/CLI/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/CLI/Parse.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} + +-- | IR-driven parameter parsing for CLI +-- +-- Transforms flat --key value pairs into properly nested JSON using IR type information. +-- +-- = Problem +-- +-- CLI flags are flat: @--identifier.type by_name --identifier.name foo@ +-- Server expects nested: @{"identifier": {"type": "by_name", "name": "foo"}}@ +-- +-- = Solution +-- +-- Use IR type definitions to understand the structure: +-- +-- @ +-- IR lookup: identifier -> RefNamed "ConeIdentifier" +-- IR lookup: ConeIdentifier -> KindEnum "type" [VariantDef "by_name" [...], ...] +-- Result: {"identifier": {"type": "by_name", "name": "foo"}} +-- @ +-- +-- = Design +-- +-- Dotted keys are grouped by their first segment: +-- +-- @ +-- [("identifier.type", "by_name"), ("identifier.name", "foo"), ("prompt", "hi")] +-- -> Map.fromList [("identifier", [("type", "by_name"), ("name", "foo")]), +-- ("prompt", [("", "hi")])] +-- @ +-- +-- Each group is then built according to its parameter's TypeRef. +-- +-- = Arrays +-- +-- Repeated flags are collected into arrays: +-- +-- @ +-- --tags backend --tags critical --tags urgent +-- -> [("tags", [("", "backend"), ("", "critical"), ("", "urgent")])] +-- -> {"tags": ["backend", "critical", "urgent"]} +-- @ +module Synapse.CLI.Parse + ( -- * Parsing + parseParams + , ParseError(..) + + -- * Helpers (exposed for testing) + , groupByPrefix + , buildParamValue + ) where + +import Data.Aeson (Value(..), object) +import qualified Data.Aeson.Key as K +import Data.List (find) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Scientific (Scientific) +import qualified Data.Vector as V +import Text.Read (readMaybe) + +import Synapse.IR.Types +import Synapse.CLI.Similarity (suggestCorrections) + +-- ============================================================================ +-- Error Types +-- ============================================================================ + +-- | Errors that can occur during parameter parsing +data ParseError + = UnknownParam Text [Text] + -- ^ Flag doesn't match any known parameter (param name, suggestions) + | MissingRequired Text + -- ^ Required parameter was not provided + | InvalidValue Text Text + -- ^ Invalid value for parameter (param name, reason) + | AmbiguousVariant Text [Text] + -- ^ Multiple variants could match (discriminator, variant names) + | MissingDiscriminator Text Text + -- ^ Enum type missing discriminator value (param name, discriminator field) + | UnknownVariant Text Text [Text] [Text] + -- ^ Unknown variant name (param name, provided value, valid variants, suggestions) + | TypeNotFound Text + -- ^ Referenced type not found in IR + deriving (Show, Eq) + +-- ============================================================================ +-- Main Parsing Function +-- ============================================================================ + +-- | Parse flat key-value pairs into nested JSON using IR structure +-- +-- Example: +-- @ +-- parseParams ir method [("identifier.type", "by_name"), ("identifier.name", "foo"), ("prompt", "hi")] +-- = Right (object [("identifier", object [("type", "by_name"), ("name", "foo")]), +-- ("prompt", "hi")]) +-- @ +parseParams :: IR -> MethodDef -> [(Text, Text)] -> Either [ParseError] Value +parseParams ir method kvPairs = do + -- Group keys by their top-level prefix + let grouped = groupByPrefix kvPairs + + -- Build each parameter value + let paramDefs = mdParams method + let paramMap = Map.fromList [(pdName p, p) | p <- paramDefs] + + -- Process each group and collect results/errors + let results = map (processGroup ir paramMap) (Map.toList grouped) + + -- Check for missing required params + let providedParams = Map.keys grouped + let missingRequired = + [ MissingRequired (pdName p) + | p <- paramDefs + , pdRequired p + , pdName p `notElem` providedParams + , pdDefault p == Nothing -- Has no default value + ] + + -- Collect all errors and results + let (errors, values) = partitionResults results + let allErrors = errors ++ missingRequired + + if null allErrors + then Right $ object values + else Left allErrors + +-- | Process a single parameter group +processGroup :: IR -> Map Text ParamDef -> (Text, [(Text, Text)]) -> Either ParseError (K.Key, Value) +processGroup ir paramMap (paramName, subKeys) = + case Map.lookup paramName paramMap of + Nothing -> + let validParams = Map.keys paramMap + suggestions = suggestCorrections paramName validParams + in Left $ UnknownParam paramName suggestions + Just paramDef -> do + val <- buildParamValue ir paramDef subKeys + Right (K.fromText paramName, val) + +-- | Partition results into errors and successes +partitionResults :: [Either ParseError (K.Key, Value)] -> ([ParseError], [(K.Key, Value)]) +partitionResults = foldr partition ([], []) + where + partition (Left e) (errs, vals) = (e : errs, vals) + partition (Right v) (errs, vals) = (errs, v : vals) + +-- ============================================================================ +-- Key Grouping +-- ============================================================================ + +-- | Group dotted keys by their first segment +-- +-- Keys without dots get empty suffix: +-- @ +-- [("identifier.type", "by_name"), ("identifier.name", "foo"), ("prompt", "hi")] +-- -> Map.fromList [("identifier", [("type", "by_name"), ("name", "foo")]), +-- ("prompt", [("", "hi")])] +-- @ +groupByPrefix :: [(Text, Text)] -> Map Text [(Text, Text)] +groupByPrefix = foldr addPair Map.empty + where + addPair (key, val) acc = + let (prefix, suffix) = splitKey key + in Map.insertWith (++) prefix [(suffix, val)] acc + + splitKey key = case T.breakOn "." key of + (pre, rest) + | T.null rest -> (pre, "") -- No dot, empty suffix + | otherwise -> (pre, T.drop 1 rest) -- Drop the dot + +-- ============================================================================ +-- Value Building +-- ============================================================================ + +-- | Build value for a single param using its TypeRef +buildParamValue :: IR -> ParamDef -> [(Text, Text)] -> Either ParseError Value +buildParamValue ir param kvs = case pdType param of + RefPrimitive typ mFmt -> + -- Simple value, expect single kv with empty suffix + case lookup "" kvs of + Just val -> Right $ inferTypedValue typ mFmt val + Nothing -> Left $ InvalidValue (pdName param) "expected simple value" + + RefNamed qn -> + let typeName = qualifiedNameFull qn + in case Map.lookup typeName (irTypes ir) of + Just typeDef -> buildFromTypeDef ir (pdName param) typeDef kvs + Nothing -> + -- Type not in IR, treat as simple value + case lookup "" kvs of + Just val -> Right $ String val + Nothing -> Left $ TypeNotFound typeName + + RefOptional inner -> + -- For optional, if we have values, parse the inner type + if null kvs + then Right Null + else buildParamValue ir param{pdType = inner} kvs + + RefArray innerType -> + -- Collect all repeated --key value entries + let values = [val | ("", val) <- kvs] + in if null values + then Left $ InvalidValue (pdName param) "array requires at least one value" + else Right $ Array $ V.fromList $ map (buildTypedValue ir innerType) values + + RefAny -> + -- Dynamic type, try to parse as JSON or use as string + case lookup "" kvs of + Just val -> Right $ inferValue val + Nothing -> Left $ InvalidValue (pdName param) "dynamic type needs value" + + RefUnknown -> + -- Unknown type, best effort + case lookup "" kvs of + Just val -> Right $ inferValue val + Nothing -> Left $ InvalidValue (pdName param) "unknown type needs value" + +-- | Build value from a TypeDef +buildFromTypeDef :: IR -> Text -> TypeDef -> [(Text, Text)] -> Either ParseError Value +buildFromTypeDef ir paramName TypeDef{..} kvs = case tdKind of + KindEnum discriminator variants -> + -- Find which variant based on discriminator value + case lookup discriminator kvs of + Just variantName -> + case find (\v -> vdName v == variantName) variants of + Just variant -> buildVariant ir paramName discriminator variant kvs + Nothing -> + let validVariants = map vdName variants + suggestions = suggestCorrections variantName validVariants + in Left $ UnknownVariant paramName variantName validVariants suggestions + Nothing -> Left $ MissingDiscriminator paramName discriminator + + KindStruct fields -> + -- Build object from fields + buildStruct ir paramName fields kvs + + KindAlias target -> + -- Follow the alias + buildParamValue ir ParamDef{pdName = paramName, pdType = target, pdDescription = Nothing, pdRequired = True, pdDefault = Nothing} kvs + + KindStringEnum allowedValues -> + -- Expect single string value from allowed set + case lookup "" kvs of + Just val + | val `elem` allowedValues -> Right $ String val + | otherwise -> Left $ InvalidValue paramName $ + "must be one of: " <> T.intercalate ", " allowedValues + Nothing -> Left $ InvalidValue paramName "expected enum value" + + KindPrimitive typ mFmt -> + -- Expect single value + case lookup "" kvs of + Just val -> Right $ inferTypedValue typ mFmt val + Nothing -> Left $ InvalidValue paramName "expected primitive value" + +-- | Build a variant value (discriminator + variant fields) +buildVariant :: IR -> Text -> Text -> VariantDef -> [(Text, Text)] -> Either ParseError Value +buildVariant ir paramName discriminator VariantDef{..} kvs = + let discPair = (K.fromText discriminator, String vdName) + in case buildFieldPairs ir paramName vdFields kvs of + Right fieldPairs -> Right $ object (discPair : fieldPairs) + Left err -> Left err + +-- | Build field pairs from a list of field definitions +buildFieldPairs :: IR -> Text -> [FieldDef] -> [(Text, Text)] -> Either ParseError [(K.Key, Value)] +buildFieldPairs ir paramName fields kvs = do + let results = map (buildFieldPair ir paramName kvs) fields + let (errors, pairs) = partitionResults results + if null errors + then Right pairs + else Left (head errors) -- Return first error + +-- | Build a single field pair +buildFieldPair :: IR -> Text -> [(Text, Text)] -> FieldDef -> Either ParseError (K.Key, Value) +buildFieldPair ir paramName kvs FieldDef{..} = + case lookup fdName kvs of + Just val -> Right (K.fromText fdName, buildTypedValue ir fdType val) + Nothing + | fdRequired -> Left $ MissingRequired (paramName <> "." <> fdName) + | Just def <- fdDefault -> Right (K.fromText fdName, def) + | otherwise -> Right (K.fromText fdName, Null) + +-- | Build a struct value from fields +buildStruct :: IR -> Text -> [FieldDef] -> [(Text, Text)] -> Either ParseError Value +buildStruct ir paramName fields kvs = do + pairs <- buildFieldPairs ir paramName fields kvs + Right $ object pairs + +-- | Build a typed value from a TypeRef +buildTypedValue :: IR -> TypeRef -> Text -> Value +buildTypedValue ir ref val = case ref of + RefPrimitive typ mFmt -> inferTypedValue typ mFmt val + RefNamed qn -> + let typeName = qualifiedNameFull qn + in case Map.lookup typeName (irTypes ir) of + Just TypeDef{tdKind = KindPrimitive typ mFmt} -> inferTypedValue typ mFmt val + _ -> String val + RefOptional inner -> buildTypedValue ir inner val + RefArray _ -> inferValue val -- Best effort for arrays + RefAny -> inferValue val + RefUnknown -> String val + +-- ============================================================================ +-- Value Inference +-- ============================================================================ + +-- | Infer JSON value from string using type hints +inferTypedValue :: Text -> Maybe Text -> Text -> Value +inferTypedValue typ mFmt val = case typ of + "string" -> String val + "integer" -> case readMaybe (T.unpack val) :: Maybe Integer of + Just n -> Number (fromInteger n) + Nothing -> String val + "number" -> case readMaybe (T.unpack val) :: Maybe Double of + Just n -> Number (realToFrac n) + Nothing -> String val + "boolean" -> case T.toLower val of + "true" -> Bool True + "false" -> Bool False + "1" -> Bool True + "0" -> Bool False + _ -> String val + _ -> String val -- Default to string for unknown types + +-- | Infer JSON value from string without type hints +inferValue :: Text -> Value +inferValue t + | t == "true" = Bool True + | t == "false" = Bool False + | t == "null" = Null + | Just n <- readMaybe (T.unpack t) :: Maybe Integer = Number (fromInteger n) + | Just n <- readMaybe (T.unpack t) :: Maybe Double = Number (realToFrac n) + | otherwise = String t + +-- | Parse a string as JSON +parseJsonValue :: Text -> Either ParseError Value +parseJsonValue t = + -- Try to parse as JSON, fall back to string + Right $ inferValue t diff --git a/src/Synapse/CLI/Similarity.hs b/src/Synapse/CLI/Similarity.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/CLI/Similarity.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | String similarity utilities for typo suggestions +-- +-- Provides Levenshtein distance computation and correction suggestions +-- for CLI parameter names and variant values. +module Synapse.CLI.Similarity + ( levenshteinDistance + , suggestCorrections + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Data.List (sortOn) +import Data.Array + +-- | Compute Levenshtein distance between two strings +-- +-- Uses the Wagner-Fischer dynamic programming algorithm. +-- Time complexity: O(m*n) where m, n are string lengths. +-- +-- Examples: +-- >>> levenshteinDistance "kitten" "sitting" +-- 3 +-- >>> levenshteinDistance "message" "mesage" +-- 1 +levenshteinDistance :: Text -> Text -> Int +levenshteinDistance s1 s2 = dp ! (m, n) + where + m = T.length s1 + n = T.length s2 + + -- Dynamic programming array bounds: (0,0) to (m,n) + bounds = ((0, 0), (m, n)) + + -- DP table: dp!(i,j) = distance between first i chars of s1 and first j chars of s2 + dp = array bounds [(ij, dist ij) | ij <- range bounds] + + dist (0, j) = j -- s1 is empty, need j insertions + dist (i, 0) = i -- s2 is empty, need i deletions + dist (i, j) = minimum + [ dp ! (i-1, j) + 1 -- deletion + , dp ! (i, j-1) + 1 -- insertion + , dp ! (i-1, j-1) + cost -- substitution + ] + where + cost = if T.index s1 (i-1) == T.index s2 (j-1) then 0 else 1 + +-- | Find similar strings from a list of valid options +-- +-- Returns up to 3 suggestions sorted by edit distance. +-- Only suggests strings within a reasonable edit distance threshold: +-- - Threshold = max(2, length/3) +-- - This filters out dissimilar strings +-- +-- Examples: +-- >>> suggestCorrections "mesage" ["message", "massage", "passage"] +-- ["message"] +-- >>> suggestCorrections "cnt" ["count", "content", "constant"] +-- ["count", "content"] +suggestCorrections :: Text -> [Text] -> [Text] +suggestCorrections typo validOptions = + let threshold = max 2 (T.length typo `div` 3) + withDist = [(opt, levenshteinDistance typo opt) | opt <- validOptions] + -- Filter: distance > 0 (not exact match) and <= threshold + filtered = filter (\(_, d) -> d <= threshold && d > 0) withDist + sorted = sortOn snd filtered + in take 3 (map fst sorted) diff --git a/src/Synapse/CLI/Support.hs b/src/Synapse/CLI/Support.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/CLI/Support.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} + +-- | CLI representability checks for IR types +-- +-- Determines whether types from the IR can be represented as CLI flags. +-- This enables: +-- +-- 1. Showing appropriate help (simple flags vs JSON input required) +-- 2. Tab completion for types that can be enumerated +-- 3. Validation before attempting CLI invocation +-- +-- = Representability Rules +-- +-- A type is CLI-representable if it can be expressed as --flag value pairs: +-- +-- - Primitives: string, integer, number, boolean (always representable) +-- - UUID/formatted strings: representable as strings +-- - Optional T: representable if T is representable (flag is omittable) +-- - Arrays: representable via repeated flags (--key val1 --key val2 --key val3) +-- - Structs: representable if all required fields are representable +-- - Enums (discriminated): representable via --field.type variant --field.x ... +-- - String enums: representable (finite set of string values) +-- - Any/Unknown: NOT representable (need JSON input) +-- +-- = Example +-- +-- @ +-- data SupportLevel +-- = FullSupport -- All params work as CLI flags +-- | PartialSupport -- Some params need JSON +-- | NoSupport -- Method requires JSON input +-- @ +module Synapse.CLI.Support + ( -- * Support Levels + SupportLevel(..) + , SupportReason(..) + + -- * Method Support + , methodSupport + , methodSupportDetails + + -- * Type Checks + , canCLIRepresent + , canCLIRepresentVariant + , canCLIRepresentField + + -- * Utilities + , unsupportedParams + , requiredJsonParams + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T + +import Synapse.IR.Types + +-- ============================================================================ +-- Support Levels +-- ============================================================================ + +-- | Level of CLI support for a method +data SupportLevel + = FullSupport + -- ^ All parameters can be expressed as CLI flags + | PartialSupport [Text] + -- ^ Some parameters require JSON input (listed by name) + | NoSupport [Text] + -- ^ Method requires JSON input for critical parameters + deriving stock (Show, Eq) + +-- | Reason why a type is not CLI representable +data SupportReason + = ReasonArray + -- ^ Arrays need JSON or special handling + | ReasonNested + -- ^ Deeply nested structure + | ReasonAny + -- ^ Type is dynamic (any) + | ReasonUnknown + -- ^ Type information missing + | ReasonComplexUnion + -- ^ Union with non-representable variants + deriving stock (Show, Eq) + +-- ============================================================================ +-- Method Support +-- ============================================================================ + +-- | Check the CLI support level for a method +methodSupport :: IR -> MethodDef -> SupportLevel +methodSupport ir method = + let unsupported = unsupportedParams ir method + required = filter (isRequired method) unsupported + in case (null unsupported, null required) of + (True, _) -> FullSupport + (False, True) -> PartialSupport unsupported + (False, False) -> NoSupport required + where + isRequired m name = any (\p -> pdName p == name && pdRequired p) (mdParams m) + +-- | Get detailed support information for a method +methodSupportDetails :: IR -> MethodDef -> [(Text, Either SupportReason ())] +methodSupportDetails ir method = + [ (pdName p, checkParam p) + | p <- mdParams method + ] + where + checkParam p = case canCLIRepresentWithReason ir (pdType p) of + Left reason -> Left reason + Right () -> Right () + +-- ============================================================================ +-- Type Representability +-- ============================================================================ + +-- | Check if a type can be represented as CLI flags +canCLIRepresent :: IR -> TypeRef -> Bool +canCLIRepresent ir typeRef = case canCLIRepresentWithReason ir typeRef of + Right () -> True + Left _ -> False + +-- | Check representability with reason +canCLIRepresentWithReason :: IR -> TypeRef -> Either SupportReason () +canCLIRepresentWithReason ir = \case + -- Primitives are always representable + RefPrimitive _ _ -> Right () + + -- Optional types: representable if inner type is + RefOptional inner -> canCLIRepresentWithReason ir inner + + -- Arrays are representable via repeated flags if the element type is representable + RefArray innerType -> canCLIRepresentWithReason ir innerType + + -- Any/Unknown require JSON + RefAny -> Left ReasonAny + RefUnknown -> Left ReasonUnknown + + -- Named types: look up and check + RefNamed qn -> canCLIRepresentNamed ir (qualifiedNameFull qn) + +-- | Check if a named type is CLI representable +canCLIRepresentNamed :: IR -> Text -> Either SupportReason () +canCLIRepresentNamed ir name = + case Map.lookup name (irTypes ir) of + Nothing -> Left ReasonUnknown + Just typeDef -> canCLIRepresentTypeDef ir typeDef + +-- | Check if a type definition is CLI representable +canCLIRepresentTypeDef :: IR -> TypeDef -> Either SupportReason () +canCLIRepresentTypeDef ir TypeDef{..} = case tdKind of + -- Primitives are representable + KindPrimitive _ _ -> Right () + + -- Alias: check the target + KindAlias target -> canCLIRepresentWithReason ir target + + -- Structs: all fields must be representable + KindStruct fields -> + let checks = map (canCLIRepresentField ir) fields + in case filter isLeftE checks of + [] -> Right () + _ -> Left ReasonNested + + -- Enums: check based on discriminator type + KindEnum discriminator variants + -- String enums (discriminator is "value") are representable + | discriminator == "value" -> Right () + -- Discriminated unions: all variants must be representable + | otherwise -> + let checks = map (canCLIRepresentVariantWithReason ir) variants + in case filter isLeftE checks of + [] -> Right () + _ -> Left ReasonComplexUnion + + -- String enums are representable (simple string literals) + KindStringEnum _ -> Right () + +isLeftE :: Either a b -> Bool +isLeftE (Left _) = True +isLeftE (Right _) = False + +-- | Check if a variant is CLI representable +canCLIRepresentVariant :: IR -> VariantDef -> Bool +canCLIRepresentVariant ir VariantDef{..} = + all (canCLIRepresentField' ir) vdFields + +-- | Check if a variant is representable (with reason) +canCLIRepresentVariantWithReason :: IR -> VariantDef -> Either SupportReason () +canCLIRepresentVariantWithReason ir VariantDef{..} = + let checks = map (canCLIRepresentField ir) vdFields + in case filter isLeftE checks of + [] -> Right () + _ -> Left ReasonNested + +-- | Check if a field is CLI representable +canCLIRepresentField :: IR -> FieldDef -> Either SupportReason () +canCLIRepresentField ir FieldDef{..} = + canCLIRepresentWithReason ir fdType + +-- | Check if a field is representable (Bool version) +canCLIRepresentField' :: IR -> FieldDef -> Bool +canCLIRepresentField' ir field = case canCLIRepresentField ir field of + Right () -> True + Left _ -> False + +-- ============================================================================ +-- Utilities +-- ============================================================================ + +-- | Get list of parameters that cannot be represented as CLI flags +unsupportedParams :: IR -> MethodDef -> [Text] +unsupportedParams ir method = + [ pdName p + | p <- mdParams method + , not (canCLIRepresent ir (pdType p)) + ] + +-- | Get parameters that require JSON input (non-representable + required) +requiredJsonParams :: IR -> MethodDef -> [Text] +requiredJsonParams ir method = + [ pdName p + | p <- mdParams method + , pdRequired p + , not (canCLIRepresent ir (pdType p)) + ] + +-- ============================================================================ +-- Depth Checking (for recursive/deeply nested types) +-- ============================================================================ + +-- | Maximum nesting depth for CLI representability +maxNestingDepth :: Int +maxNestingDepth = 3 + +-- | Check if a type is representable within a depth limit +canCLIRepresentWithDepth :: IR -> Int -> TypeRef -> Bool +canCLIRepresentWithDepth _ depth _ + | depth <= 0 = False +canCLIRepresentWithDepth ir depth typeRef = case typeRef of + RefPrimitive _ _ -> True + RefOptional inner -> canCLIRepresentWithDepth ir depth inner + RefArray innerType -> canCLIRepresentWithDepth ir depth innerType + RefAny -> False + RefUnknown -> False + RefNamed qn -> canCLIRepresentNamedWithDepth ir (depth - 1) (qualifiedNameFull qn) + +-- | Check named type with depth +canCLIRepresentNamedWithDepth :: IR -> Int -> Text -> Bool +canCLIRepresentNamedWithDepth ir depth name + | depth <= 0 = False + | otherwise = case Map.lookup name (irTypes ir) of + Nothing -> False + Just TypeDef{..} -> case tdKind of + KindPrimitive _ _ -> True + KindAlias target -> canCLIRepresentWithDepth ir depth target + KindStruct fields -> all (canCLIRepresentFieldWithDepth ir (depth - 1)) fields + KindEnum "value" _ -> True -- String enum + KindEnum _ variants -> all (canCLIRepresentVariantWithDepth ir (depth - 1)) variants + +-- | Check field with depth +canCLIRepresentFieldWithDepth :: IR -> Int -> FieldDef -> Bool +canCLIRepresentFieldWithDepth ir depth FieldDef{..} = + canCLIRepresentWithDepth ir depth fdType + +-- | Check variant with depth +canCLIRepresentVariantWithDepth :: IR -> Int -> VariantDef -> Bool +canCLIRepresentVariantWithDepth ir depth VariantDef{..} = + all (canCLIRepresentFieldWithDepth ir depth) vdFields diff --git a/src/Synapse/CLI/Template.hs b/src/Synapse/CLI/Template.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/CLI/Template.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} + +-- | IR-driven Mustache template generation +-- +-- Generates structured Mustache templates directly from the IR, providing: +-- +-- - Discriminated union handling with ALL variants in one template +-- - Exhaustive variant coverage (every variant gets a section) +-- - Structured output with labeled fields +-- +-- = Design +-- +-- Templates are generated per-method with all return type variants visible: +-- +-- @ +-- IR (types, methods) +-- | +-- +-> generateTemplate -> unified template for a method (all variants) +-- +-> generateAllTemplates -> all templates for a path +-- +-> generateTemplatesFor -> subset of templates (filtered) +-- @ +-- +-- = Example Output +-- +-- For `cone.chat` (streaming enum with variants): +-- +-- @ +-- {{! cone.chat - returns: ConeEvent }} +-- {{! Variants: start, content, thinking, tool_use, tool_result, complete, error, passthrough }} +-- +-- {{#start}} +-- id: {{id}} +-- user_position: {{user_position}} +-- {{/start}} +-- +-- {{#content}}{{text}}{{/content}} +-- +-- {{#thinking}}{{thinking}}{{/thinking}} +-- +-- {{#tool_use}} +-- tool_name: {{tool_name}} +-- tool_use_id: {{tool_use_id}} +-- input: {{input}} +-- {{/tool_use}} +-- +-- {{#tool_result}} +-- tool_use_id: {{tool_use_id}} +-- output: {{output}} +-- is_error: {{is_error}} +-- {{/tool_result}} +-- +-- {{#complete}} +-- new_head: {{new_head}} +-- usage: {{usage}} +-- {{/complete}} +-- +-- {{#error}}{{message}}{{/error}} +-- +-- {{#passthrough}} +-- event_type: {{event_type}} +-- data: {{data}} +-- {{/passthrough}} +-- @ +module Synapse.CLI.Template + ( -- * Template Generation + generateTemplate + , generateAllTemplates + , generateTemplatesFor + , generateAllTemplatesWithCallback + + -- * Type Conversion (exposed for testing/reuse) + , typeRefToMustache + , typeDefToMustache + , variantToMustache + + -- * Types + , GeneratedTemplate(..) + , TemplateFilter(..) + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import System.FilePath ((), (<.>)) + +import Synapse.IR.Types +import Synapse.IR.Builder (buildIR) +import Synapse.Monad (SynapseM) +import Synapse.Schema.Types (Path) + +-- ============================================================================ +-- Types +-- ============================================================================ + +-- | A generated template with metadata +data GeneratedTemplate = GeneratedTemplate + { gtNamespace :: Text -- ^ Plugin namespace (e.g., "cone") + , gtMethod :: Text -- ^ Method name (e.g., "chat") + , gtTemplate :: Text -- ^ Mustache template content + , gtPath :: FilePath -- ^ Relative path for template file + , gtVariants :: [Text] -- ^ List of variant names this template handles + , gtReturnType :: Maybe Text -- ^ Return type name if named + } + deriving stock (Show, Eq) + +-- | Filter for selective template generation +data TemplateFilter + = AllTemplates -- ^ Generate all templates + | NamespaceFilter [Text] -- ^ Only these namespaces + | MethodFilter [(Text, Text)] -- ^ Only these (namespace, method) pairs + | ExcludeFilter [Text] -- ^ Exclude these namespaces + deriving stock (Show, Eq) + +-- ============================================================================ +-- High-Level Generation +-- ============================================================================ + +-- | Generate a unified template for a method's return type +-- +-- All variants are included in a single template file. +-- The template is named by method: {namespace}/{method}.mustache +generateTemplate :: IR -> MethodDef -> GeneratedTemplate +generateTemplate ir method = + let (body, variants, typeName) = generateMethodBody ir method + header = generateHeader method typeName variants + template = header <> "\n" <> body + in GeneratedTemplate + { gtNamespace = mdNamespace method + , gtMethod = mdName method + , gtTemplate = template + , gtPath = T.unpack (mdNamespace method) T.unpack (mdName method) <.> "mustache" + , gtVariants = variants + , gtReturnType = typeName + } + +-- | Generate header comment with method info and variant list +generateHeader :: MethodDef -> Maybe Text -> [Text] -> Text +generateHeader method mTypeName variants = + let typeInfo = maybe "" (\t -> " - returns: " <> t) mTypeName + variantList = if null variants + then "" + else "\n{{! Variants: " <> T.intercalate ", " variants <> " }}" + in "{{! " <> mdFullPath method <> typeInfo <> " }}" <> variantList + +-- | Generate template body for a method, returning (body, variants, typeName) +generateMethodBody :: IR -> MethodDef -> (Text, [Text], Maybe Text) +generateMethodBody ir method = case mdReturns method of + RefNamed qn -> + let name = qualifiedNameFull qn + in case Map.lookup name (irTypes ir) of + Just typeDef@TypeDef{tdKind = KindEnum _ variants} -> + -- Union type: generate sections for ALL variants (exhaustive) + -- No blank lines between sections to avoid whitespace in output + let variantNames = map vdName variants + body = T.intercalate "\n" (map (variantToMustache ir 0) variants) <> "\n" + in (body, variantNames, Just name) + Just typeDef -> + -- Non-union named type + (typeDefToMustache ir 0 typeDef, [], Just name) + Nothing -> + -- Type not found + ("{{.}}", [], Just name) + other -> + -- Primitive or other + (typeRefToMustache ir 0 other, [], Nothing) + +-- | Generate all templates by building IR and iterating methods +generateAllTemplates :: Path -> SynapseM [GeneratedTemplate] +generateAllTemplates = generateTemplatesFor AllTemplates + +-- | Generate templates with filtering +generateTemplatesFor :: TemplateFilter -> Path -> SynapseM [GeneratedTemplate] +generateTemplatesFor filt path = do + ir <- buildIR [] path -- No generator info for internal template generation + let methods = Map.elems (irMethods ir) + filtered = filterMethods filt methods + templates = map (generateTemplate ir) filtered + -- Filter out trivial templates that just render {{.}} + nonTrivial = filter (not . isTrivialTemplate) templates + pure nonTrivial + +-- | Filter methods based on TemplateFilter +filterMethods :: TemplateFilter -> [MethodDef] -> [MethodDef] +filterMethods AllTemplates methods = methods +filterMethods (NamespaceFilter nss) methods = + filter (\m -> mdNamespace m `elem` nss) methods +filterMethods (MethodFilter pairs) methods = + filter (\m -> (mdNamespace m, mdName m) `elem` pairs) methods +filterMethods (ExcludeFilter nss) methods = + filter (\m -> mdNamespace m `notElem` nss) methods + +-- | Generate templates with callback for streaming output +generateAllTemplatesWithCallback + :: (GeneratedTemplate -> IO ()) -- ^ Called for each template + -> Path + -> SynapseM Int -- ^ Returns count +generateAllTemplatesWithCallback callback path = do + templates <- generateAllTemplates path + liftIO $ mapM_ callback templates + pure $ length templates + +-- | Check if a template is trivial (just {{.}}) +isTrivialTemplate :: GeneratedTemplate -> Bool +isTrivialTemplate gt = + let body = T.drop 1 $ T.dropWhile (/= '\n') (gtTemplate gt) + -- Also drop the variants comment line if present + bodyWithoutComments = T.unlines $ filter (not . isComment) $ T.lines body + in T.strip bodyWithoutComments == "{{.}}" + where + isComment line = "{{!" `T.isPrefixOf` T.strip line + +-- ============================================================================ +-- Variant to Mustache (Exhaustive) +-- ============================================================================ + +-- | Convert a variant to a Mustache section +-- +-- This ensures EVERY variant gets a section, making the mapping exhaustive. +variantToMustache :: IR -> Int -> VariantDef -> Text +variantToMustache ir indent VariantDef{..} = + let ind = indentText indent + sectionName = vdName + displayFields = filter (not . isInternalField) vdFields + in case displayFields of + -- No displayable fields: empty section (still present for exhaustiveness) + [] -> ind <> "{{#" <> sectionName <> "}}{{/" <> sectionName <> "}}" + + -- Single content-like field: inline rendering (triple braces to avoid HTML escaping) + [field] | isContentField field -> + ind <> "{{#" <> sectionName <> "}}{{{" <> fdName field <> "}}}{{/" <> sectionName <> "}}" + + -- Multiple fields: render as labeled lines (no trailing newline) + fields -> + let fieldLines = map (generateFieldLine ir (indent + 1)) fields + openTag = ind <> "{{#" <> sectionName <> "}}" + closeTag = ind <> "{{/" <> sectionName <> "}}" + in T.intercalate "\n" $ [openTag] ++ fieldLines ++ [closeTag] + +-- ============================================================================ +-- Type Reference to Mustache +-- ============================================================================ + +-- | Convert a TypeRef to Mustache template text +typeRefToMustache :: IR -> Int -> TypeRef -> Text +typeRefToMustache ir indent = \case + -- Primitives render as the current value + RefPrimitive _ _ -> "{{.}}" + + -- Named types: look up the definition + RefNamed qn -> + let name = qualifiedNameFull qn + in case Map.lookup name (irTypes ir) of + Just typeDef -> typeDefToMustache ir indent typeDef + Nothing -> "{{.}}" -- Fallback if type not found + + -- Arrays: iterate with section + RefArray inner -> + let itemTemplate = typeRefToMustache ir (indent + 1) inner + ind = indentText indent + in T.unlines + [ ind <> "{{#.}}" + , itemTemplate + , ind <> "{{/.}}" + ] + + -- Optionals: just render the inner type (mustache handles missing) + RefOptional inner -> typeRefToMustache ir indent inner + + -- Any/Unknown: fall back to current value + RefAny -> "{{.}}" + RefUnknown -> "{{.}}" + +-- ============================================================================ +-- Type Definition to Mustache +-- ============================================================================ + +-- | Convert a TypeDef to Mustache template text +typeDefToMustache :: IR -> Int -> TypeDef -> Text +typeDefToMustache ir indent TypeDef{..} = case tdKind of + -- Discriminated union: render ALL variants as sections (exhaustive) + KindEnum _discriminator variants -> + T.intercalate "\n" $ map (variantToMustache ir indent) variants + + -- Struct: render each field + KindStruct fields -> + generateStructTemplate ir indent fields + + -- Primitive: just the value + KindPrimitive _ _ -> "{{.}}" + + -- Alias: follow to target + KindAlias target -> typeRefToMustache ir indent target + +-- ============================================================================ +-- Struct Template Generation +-- ============================================================================ + +-- | Generate template for a struct +generateStructTemplate :: IR -> Int -> [FieldDef] -> Text +generateStructTemplate ir indent fields = + let displayFields = filter (not . isInternalField) fields + fieldLines = map (generateFieldLine ir indent) displayFields + in T.unlines fieldLines + +-- ============================================================================ +-- Field Generation +-- ============================================================================ + +-- | Generate a labeled line for a field +generateFieldLine :: IR -> Int -> FieldDef -> Text +generateFieldLine ir indent field@FieldDef{..} = + let ind = indentText indent + label = fdName <> ": " + in case fdType of + -- For optional fields, show value or explicit "null" + RefOptional inner -> + let innerValue = generateOptionalInnerValue ir inner + in ind <> label <> "{{#" <> fdName <> "}}" <> innerValue <> "{{/" <> fdName <> "}}{{^" <> fdName <> "}}null{{/" <> fdName <> "}}" + _ -> + let value = generateFieldValue ir fdType fdName field + in ind <> label <> value + +-- | Generate value for inside an optional section (no outer wrapper needed) +generateOptionalInnerValue :: IR -> TypeRef -> Text +generateOptionalInnerValue ir typeRef = case typeRef of + RefNamed qn -> + let name = qualifiedNameFull qn + in case Map.lookup name (irTypes ir) of + Just TypeDef{tdKind = KindStruct fields} -> + let displayFields = filter (not . isInternalField) fields + fieldRefs = map (\f -> fdName f <> "={{" <> fdName f <> "}}") displayFields + in T.intercalate " " fieldRefs + _ -> "{{.}}" + RefPrimitive _ _ -> "{{.}}" + _ -> "{{.}}" + +-- | Generate the value portion of a field +generateFieldValue :: IR -> TypeRef -> Text -> FieldDef -> Text +generateFieldValue ir typeRef fieldName field = case typeRef of + -- Primitives: use triple braces for content fields to avoid HTML escaping + RefPrimitive _ _ -> + if isContentField field + then "{{{" <> fieldName <> "}}}" + else "{{" <> fieldName <> "}}" + + -- Arrays: iterate + RefArray inner -> case inner of + RefPrimitive _ _ -> + "{{#" <> fieldName <> "}}{{.}} {{/" <> fieldName <> "}}" + RefNamed qn -> + let name = qualifiedNameFull qn + in case Map.lookup name (irTypes ir) of + Just TypeDef{tdKind = KindStruct fields} -> + -- For arrays of structs, expand each item's fields on its own line + let displayFields = filter (not . isInternalField) fields + fieldRefs = map (generateFieldRefInContext ir "") displayFields + in "{{#" <> fieldName <> "}}\n " <> T.intercalate " " fieldRefs <> "{{/" <> fieldName <> "}}" + _ -> + "{{#" <> fieldName <> "}}{{.}}{{/" <> fieldName <> "}}" + _ -> + "{{#" <> fieldName <> "}}{{.}}{{/" <> fieldName <> "}}" + + -- Named types: depends on what they are + RefNamed qn -> + let name = qualifiedNameFull qn + in case Map.lookup name (irTypes ir) of + Just TypeDef{tdKind = KindPrimitive _ _} -> + "{{" <> fieldName <> "}}" + Just TypeDef{tdKind = KindStruct fields} -> + -- Expand struct fields with dot notation to avoid Haskell Show output + let displayFields = filter (not . isInternalField) fields + fieldRefs = map (\f -> fdName f <> "={{" <> fieldName <> "." <> fdName f <> "}}") displayFields + in T.intercalate " " fieldRefs + Just TypeDef{tdKind = KindEnum _ _} -> + "{{{" <> fieldName <> "}}}" -- Nested union: use triple braces for unescaped JSON + _ -> + "{{" <> fieldName <> "}}" + + -- Optional: wrap in section so null renders nothing + RefOptional inner -> case inner of + -- For optional structs, wrap expansion in a section + RefNamed qn -> + let name = qualifiedNameFull qn + in case Map.lookup name (irTypes ir) of + Just TypeDef{tdKind = KindStruct fields} -> + let displayFields = filter (not . isInternalField) fields + fieldRefs = map (\f -> fdName f <> "={{" <> fdName f <> "}}") displayFields + in "{{#" <> fieldName <> "}}" <> T.intercalate " " fieldRefs <> "{{/" <> fieldName <> "}}" + _ -> "{{#" <> fieldName <> "}}{{.}}{{/" <> fieldName <> "}}" + -- For optional primitives, simple section + _ -> "{{#" <> fieldName <> "}}{{.}}{{/" <> fieldName <> "}}" + + -- Fallback: use triple braces for content fields + RefAny -> + if isContentField field + then "{{{" <> fieldName <> "}}}" + else "{{" <> fieldName <> "}}" + RefUnknown -> + if isContentField field + then "{{{" <> fieldName <> "}}}" + else "{{" <> fieldName <> "}}" + +-- ============================================================================ +-- Field Reference Generation (for array contexts) +-- ============================================================================ + +-- | Generate a field reference in the context of an array iteration +-- Recursively expands struct fields using dot notation +-- prefix is the path prefix (empty for top-level array items) +generateFieldRefInContext :: IR -> Text -> FieldDef -> Text +generateFieldRefInContext ir prefix field = + let name = fdName field + fullPath = if T.null prefix then name else prefix <> "." <> name + in case fdType field of + -- Primitives: simple reference + RefPrimitive _ _ -> + name <> "={{" <> fullPath <> "}}" + + -- Named types: check if it's a struct that needs expansion + RefNamed qn -> + let typeName = qualifiedNameFull qn + in case Map.lookup typeName (irTypes ir) of + Just TypeDef{tdKind = KindStruct fields} -> + -- Flatten nested struct fields using dot notation (no wrapper) + let displayFields = filter (not . isInternalField) fields + dotRefs = map (\f -> fdName f <> "={{" <> fullPath <> "." <> fdName f <> "}}") displayFields + in T.intercalate " " dotRefs + Just TypeDef{tdKind = KindPrimitive _ _} -> + name <> "={{" <> fullPath <> "}}" + _ -> + -- Enum or unknown: just reference it + name <> "={{" <> fullPath <> "}}" + + -- Arrays: indicate it's an array + RefArray _ -> + name <> "=[...]" + + -- Optional: same as inner type but may be null + RefOptional inner -> case inner of + RefNamed qn -> + let typeName = qualifiedNameFull qn + in case Map.lookup typeName (irTypes ir) of + Just TypeDef{tdKind = KindStruct fields} -> + -- Flatten nested struct fields using dot notation (no wrapper) + let displayFields = filter (not . isInternalField) fields + dotRefs = map (\f -> fdName f <> "={{" <> fullPath <> "." <> fdName f <> "}}") displayFields + in T.intercalate " " dotRefs + _ -> name <> "={{" <> fullPath <> "}}" + _ -> name <> "={{" <> fullPath <> "}}" + + -- Fallback + _ -> name <> "={{" <> fullPath <> "}}" + +-- ============================================================================ +-- Field Classification +-- ============================================================================ + +-- | Check if a field is a "content" field (for inline rendering) +isContentField :: FieldDef -> Bool +isContentField FieldDef{..} = fdName `elem` ["content", "message", "text", "data"] + +-- | Check if a field is internal (shouldn't be displayed) +isInternalField :: FieldDef -> Bool +isInternalField FieldDef{..} = fdName `elem` ["type", "event"] + +-- ============================================================================ +-- Helpers +-- ============================================================================ + +-- | Generate indentation text +indentText :: Int -> Text +indentText n = T.replicate (n * 2) " " diff --git a/src/Synapse/CLI/Transform.hs b/src/Synapse/CLI/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/CLI/Transform.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Parameter transformation layer for CLI +-- +-- Provides programmable transformations for command-line parameters before +-- they're parsed by the IR-driven parser. This allows context-aware expansions +-- like path resolution and environment variable substitution. +-- +-- = Architecture +-- +-- @ +-- Command line args +-- ↓ +-- parsePathAndParams (extract --key value pairs) +-- ↓ +-- [(Text, Text)] raw params +-- ↓ +-- transformParams (THIS MODULE - middleware chain) +-- ↓ +-- [(Text, Text)] transformed params +-- ↓ +-- parseParams (IR-driven type parsing) +-- ↓ +-- Value (JSON sent to backend) +-- @ +-- +-- = Example +-- +-- @ +-- -- User runs: synapse claudecode create --name test --working_dir . +-- -- Input: [("name", "test"), ("working_dir", ".")] +-- env <- mkTransformEnv +-- transformed <- transformParams env defaultTransformers params +-- -- Output: [("name", "test"), ("working_dir", "/absolute/cwd")] +-- @ +module Synapse.CLI.Transform + ( -- * Transformation Pipeline + TransformEnv(..) + , Transformer + , transformParams + , mkTransformEnv + + -- * Built-in Transformers + , pathExpansion + , envExpansion + , defaultTransformers + + -- * Smart Defaults (Type-Aware) + , injectSmartDefaults + , injectBooleanDefaults + , isPathParamByType + , getSmartDefault + + -- * Utilities + , expandPath + , isPathParam + ) where + +import Control.Exception (catch, IOException) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory (getCurrentDirectory, makeAbsolute, getHomeDirectory) +import System.Environment (getEnvironment) +import System.FilePath (isRelative, ()) + +-- For type-aware smart defaults +import Synapse.IR.Types (IR, MethodDef(..), ParamDef(..), TypeRef(..)) + +-- ============================================================================ +-- Types +-- ============================================================================ + +-- | Environment available to transformers +data TransformEnv = TransformEnv + { teCwd :: FilePath -- ^ Current working directory + , teHome :: Maybe FilePath -- ^ Home directory + , teEnv :: [(String, String)] -- ^ Environment variables + } + deriving (Show, Eq) + +-- | A transformer: inspects/modifies parameter pairs +-- +-- Transformers are fail-safe: if transformation fails, return original value. +-- The server has authoritative validation, so it's better to pass through +-- potentially-wrong values than to fail CLI invocation. +type Transformer = TransformEnv -> (Text, Text) -> IO (Text, Text) + +-- ============================================================================ +-- Transformation Pipeline +-- ============================================================================ + +-- | Apply a chain of transformers to parameter pairs +-- +-- Each transformer in the list runs sequentially. Transformers can: +-- - Modify values based on keys +-- - Leave unmatched parameters unchanged +-- - Handle errors gracefully by returning original values +transformParams :: TransformEnv -> [Transformer] -> [(Text, Text)] -> IO [(Text, Text)] +transformParams env transformers params = + foldl applyTransformer (pure params) transformers + where + applyTransformer :: IO [(Text, Text)] -> Transformer -> IO [(Text, Text)] + applyTransformer mParams transformer = do + ps <- mParams + mapM (transformer env) ps + +-- | Create transformation environment from system state +mkTransformEnv :: IO TransformEnv +mkTransformEnv = do + cwd <- getCurrentDirectory + home <- (Just <$> getHomeDirectory) `catch` \(_ :: IOException) -> pure Nothing + env <- getEnvironment + pure TransformEnv + { teCwd = cwd + , teHome = home + , teEnv = env + } + +-- | Default transformer chain +-- +-- Applied to all CLI invocations unless disabled. +-- Order matters: earlier transformers run first. +defaultTransformers :: [Transformer] +defaultTransformers = + [ pathExpansion + , envExpansion + ] + +-- ============================================================================ +-- Path Expansion Transformer +-- ============================================================================ + +-- | Transform path parameters to absolute paths +-- +-- Handles: +-- - @--path .@ → @--path \/absolute\/cwd@ +-- - @--path ~\/foo@ → @--path \/home\/user\/foo@ +-- - @--working_dir relative@ → @--working_dir \/absolute\/path@ +-- - Leaves absolute paths unchanged +-- +-- Fail-safe: Returns original value if expansion fails. +pathExpansion :: Transformer +pathExpansion env@TransformEnv{..} (key, val) + | isPathParam key = do + expanded <- expandPath teCwd teHome val + pure (key, expanded) + | otherwise = pure (key, val) + +-- | Check if a parameter name represents a filesystem path +-- +-- Add parameter names to this list to enable path expansion for them. +isPathParam :: Text -> Bool +isPathParam k = k `elem` + [ "path" + , "working_dir" + , "output_dir" + , "file_path" + , "dir" + , "directory" + , "workdir" + ] + +-- | Expand a path string to absolute form +-- +-- Handles: +-- - @.@ → current working directory +-- - @~\/foo@ → home directory + foo +-- - @relative\/path@ → cwd + relative\/path +-- - @\/absolute@ → unchanged +-- +-- Fail-safe: Returns original path text if expansion fails. +expandPath :: FilePath -> Maybe FilePath -> Text -> IO Text +expandPath cwd mHome pathText = do + let path = T.unpack pathText + expanded <- tryExpand path `catch` \(_ :: IOException) -> pure path + pure $ T.pack expanded + where + tryExpand :: FilePath -> IO FilePath + tryExpand "." = makeAbsolute cwd + tryExpand ('~':'/':rest) = case mHome of + Just home -> makeAbsolute (home rest) + Nothing -> pure ('~':'/':rest) -- Can't expand, return as-is + tryExpand t@('~':_) = pure t -- ~user form not supported + tryExpand p + | isRelative p = makeAbsolute (cwd p) + | otherwise = pure p -- Already absolute + +-- ============================================================================ +-- Environment Variable Expansion +-- ============================================================================ + +-- | Expand environment variables in parameter values +-- +-- Handles: +-- - @--value $VAR@ → @--value \@ +-- - @--message \"Hello $USER\"@ → @--message \"Hello alice\"@ +-- +-- Simple implementation: only expands $VARNAME format (not ${VAR}). +-- Fail-safe: Returns original value if variable not found. +envExpansion :: Transformer +envExpansion TransformEnv{..} (key, val) + | T.any (== '$') val = do + let expanded = expandEnvVars teEnv val + pure (key, expanded) + | otherwise = pure (key, val) + +-- | Expand $VAR references in text +-- +-- Uses simple string replacement. Does not handle: +-- - ${VAR} syntax +-- - Default values (${VAR:-default}) +-- - Command substitution +-- +-- Fail-safe: Leaves $VAR unchanged if not found in environment. +expandEnvVars :: [(String, String)] -> Text -> Text +expandEnvVars env text = + -- Split on '$' and process each potential variable reference + let parts = T.splitOn "$" text + in case parts of + [] -> text + (first:rest) -> first <> T.concat (map expandPart rest) + where + -- Try to expand a part that comes after '$' + expandPart :: Text -> Text + expandPart part = + let (varName, suffix) = T.span isVarChar part + in if T.null varName + then "$" <> part -- No valid var name, keep $ + else case lookup (T.unpack varName) env of + Just value -> T.pack value <> suffix + Nothing -> "$" <> part -- Var not found, keep as-is + + -- Characters allowed in environment variable names + isVarChar :: Char -> Bool + isVarChar c = c `elem` (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_") + +-- ============================================================================ +-- Smart Defaults (Type-Aware) +-- ============================================================================ + +-- | Inject smart defaults for missing required parameters +-- +-- This is type-aware: it inspects the method's parameter definitions +-- to determine which params are required and what types need defaults. +-- +-- Currently supports: +-- - Path parameters (working_dir, path, etc.): Default to current working directory +-- +-- Only injects defaults for parameters that are: +-- 1. Required (not optional) +-- 2. Not provided by the user +-- 3. Have a known smart default for their type +-- +-- = Example +-- +-- @ +-- -- User runs: synapse claudecode create --name test --model opus +-- -- Method requires: name, working_dir, model +-- -- User provided: name, model +-- -- Missing: working_dir +-- +-- injectSmartDefaults env ir methodDef [(\"name\", \"test\"), (\"model\", \"opus\")] +-- -- Returns: [(\"name\", \"test\"), (\"model\", \"opus\"), (\"working_dir\", \"\/cwd\")] +-- @ +injectSmartDefaults :: TransformEnv -> IR -> MethodDef -> [(Text, Text)] -> IO [(Text, Text)] +injectSmartDefaults env _ir methodDef existingParams = do + let providedKeys = map fst existingParams + requiredParams = filter pdRequired (mdParams methodDef) + missingRequired = filter (\p -> pdName p `notElem` providedKeys) requiredParams + + -- For each missing required param, try to inject a smart default + defaults <- mapM (tryInjectDefault env) missingRequired + pure $ existingParams ++ catMaybes defaults + where + tryInjectDefault :: TransformEnv -> ParamDef -> IO (Maybe (Text, Text)) + tryInjectDefault e param = do + mDefault <- getSmartDefault e param + case mDefault of + Just val -> pure $ Just (pdName param, val) + Nothing -> pure Nothing + +-- | Inject "true" for boolean flags that were present but had no value +-- +-- When a user writes @--force@ without a value, parsePathAndParams marks it +-- as @("force", "")@. This function looks at the method definition to determine +-- which empty-value params are actually booleans, and fills them with "true". +-- +-- Non-boolean params with empty values are left as-is and will fail validation +-- later with a clear error message. +-- +-- = Example +-- +-- @ +-- -- User runs: synapse cone delete --identifier.type by_name --identifier.name test --force +-- -- Parsed: [("identifier.type", "by_name"), ("identifier.name", "test"), ("force", "")] +-- injectBooleanDefaults ir methodDef params +-- -- Returns: [("identifier.type", "by_name"), ("identifier.name", "test"), ("force", "true")] +-- @ +injectBooleanDefaults :: IR -> MethodDef -> [(Text, Text)] -> [(Text, Text)] +injectBooleanDefaults _ir methodDef params = + map fillBooleanDefault params + where + -- Create a map of param names to their definitions for quick lookup + paramDefMap = [(pdName p, p) | p <- mdParams methodDef] + + fillBooleanDefault :: (Text, Text) -> (Text, Text) + fillBooleanDefault (key, val) + -- If value is empty (flag with no value) and param is boolean, fill with "true" + | val == "", Just paramDef <- lookup key paramDefMap, isBooleanParam paramDef = + (key, "true") + -- Otherwise keep as-is + | otherwise = (key, val) + + -- Check if a parameter is a boolean type (including optional booleans) + isBooleanParam :: ParamDef -> Bool + isBooleanParam param = isBooleanType (pdType param) + + isBooleanType :: TypeRef -> Bool + isBooleanType (RefPrimitive "boolean" _) = True + isBooleanType (RefOptional inner) = isBooleanType inner + isBooleanType _ = False + +-- | Check if a parameter represents a filesystem path based on type info +-- +-- Uses both name heuristics AND type information: +-- - Name matches known path params (working_dir, path, etc.) +-- - Type is string (not UUID, not enum, etc.) +-- +-- This is more robust than just checking names, as it avoids false positives +-- like a parameter named \"path\" that's actually a URL or other non-filesystem type. +isPathParamByType :: ParamDef -> Bool +isPathParamByType param = + let nameMatches = pdName param `elem` pathParamNames + typeIsString = case pdType param of + RefPrimitive "string" _ -> True + RefOptional (RefPrimitive "string" _) -> True + _ -> False + in nameMatches && typeIsString + where + pathParamNames = + [ "path" + , "working_dir" + , "output_dir" + , "file_path" + , "dir" + , "directory" + , "workdir" + ] + +-- | Get smart default value for a parameter based on its type +-- +-- Returns Nothing if no smart default is available. +-- This is the extensibility point for adding new smart defaults. +-- +-- = Current Defaults +-- +-- - Path parameters → current working directory +-- +-- = Future Extensions +-- +-- Could add: +-- - UUID parameters → generated UUID +-- - Timestamp parameters → current time +-- - User name parameters → $USER from environment +getSmartDefault :: TransformEnv -> ParamDef -> IO (Maybe Text) +getSmartDefault env param + -- Path parameters: use current working directory + | isPathParamByType param = + pure $ Just (T.pack $ teCwd env) + + -- Future: UUID parameters could generate fresh UUIDs + -- | isUuidParam param = Just <$> generateUUID + + -- Future: Timestamp parameters could use current time + -- | isTimestampParam param = Just <$> getCurrentTimestamp + + -- No smart default available + | otherwise = pure Nothing diff --git a/src/Synapse/Cache.hs b/src/Synapse/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Cache.hs @@ -0,0 +1,27 @@ +-- | Schema caching by content hash +-- +-- Schemas are cached by their hash. Same hash = same content. +-- This enables safe caching: if the hash matches, use cached value. +module Synapse.Cache + ( -- * Cache Operations (re-exported from Monad) + lookupCache + , insertCache + + -- * Cache-aware fetching + , fetchCached + ) where + +import Synapse.Schema.Types +import Synapse.Monad + +-- | Fetch a schema, using cache if available +-- The fetcher function is only called if not in cache +fetchCached :: PluginHash -> SynapseM PluginSchema -> SynapseM PluginSchema +fetchCached hash fetcher = do + cached <- lookupCache hash + case cached of + Just schema -> pure schema + Nothing -> do + schema <- fetcher + insertCache (psHash schema) schema + pure schema diff --git a/src/Synapse/IR/Builder.hs b/src/Synapse/IR/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/IR/Builder.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | IR Builder - walks schema tree and constructs the IR +-- +-- Uses the existing schema walker with a custom algebra that: +-- 1. Extracts types from $defs in methodParams and methodReturns +-- 2. Deduplicates types by content hash (prefer parent namespace, then shortest) +-- 3. Infers streaming from return type structure +-- 4. Builds method definitions with type references +module Synapse.IR.Builder + ( -- * Building IR + buildIR + + -- * Extraction (for testing) + , extractTypesFromSchema + , extractMethodDef + , schemaToTypeRef + ) where + +import Control.Monad (forM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (asks) +import Data.Aeson (Value(..)) +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import Data.List (minimumBy) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe, catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format (formatTime, defaultTimeLocale) + +import Synapse.Schema.Types +import Synapse.Schema.Functor (SchemaF(..)) +import Synapse.Algebra.Walk (walkSchema) +import Synapse.Monad +import Synapse.IR.Types hiding (QualifiedName(..), qualifiedNameFull) +import Synapse.IR.Types (QualifiedName(..), qualifiedNameFull, synapseVersion) + +-- ============================================================================ +-- Building IR +-- ============================================================================ + +-- | Parse a generator info string "tool:version" into GeneratorInfo +-- Returns Nothing if the format is invalid +parseGeneratorInfo :: Text -> Maybe GeneratorInfo +parseGeneratorInfo s = case T.splitOn ":" s of + [tool, version] | not (T.null tool) && not (T.null version) -> + Just $ GeneratorInfo tool version + _ -> Nothing + +-- | Extract V2 hash information from a plugin schema +-- Since Plexus currently only provides a composite 'hash' field, +-- we use it for all three hash fields (backward compatible V1 mode) +extractPluginHashInfo :: PluginSchema -> PluginHashInfo +extractPluginHashInfo schema = PluginHashInfo + { phiHash = psHash schema + , phiSelfHash = psHash schema -- V1 fallback: use composite hash + , phiChildrenHash = psHash schema -- V1 fallback: use composite hash + } + +-- | Build IR by walking the schema tree from a given path +-- After walking, deduplicate types that have identical structure +-- Accepts generator info strings in "tool:version" format +buildIR :: [Text] -> Path -> SynapseM IR +buildIR generatorInfoStrs path = do + backend <- asks seBackend + raw <- walkSchema irAlgebra path + + -- Parse generator info and add synapse itself + let parsedGens = mapMaybe parseGeneratorInfo generatorInfoStrs + allGens = parsedGens ++ [GeneratorInfo "synapse" synapseVersion] + + -- Get current timestamp in ISO 8601 format + currentTime <- liftIO getCurrentTime + let timestamp = T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" currentTime + + -- Create generation metadata + let metadata = GenerationMetadata + { gmGenerators = allGens + , gmTimestamp = timestamp + , gmIrVersion = irVersion emptyIR + } + + pure $ deduplicateTypes raw + { irBackend = backend + , irMetadata = Just metadata + } + +-- | Algebra for building IR from schema tree +-- +-- At each node: +-- - Extract types from all methods' params and returns +-- - Build method definitions +-- - Merge with child results +irAlgebra :: SchemaF IR -> SynapseM IR +irAlgebra (PluginF schema path childIRs) = do + -- Use full path as namespace to avoid collisions + -- e.g., "hyperforge.workspace.repos" instead of just "repos" + let namespace = T.intercalate "." path + pathPrefix = namespace -- Same as namespace + + -- Extract types and methods from this plugin + let (localTypes, localMethods) = extractFromPlugin namespace pathPrefix schema + + -- Merge with children + let childIR = foldr mergeIR emptyIR childIRs + let pluginMethods = map mdName (Map.elems localMethods) + + -- Use this plugin's hash if at root (path is empty) + let thisHash = if null path + then Just (psHash schema) + else irHash childIR + + -- Extract V2 hash information for this plugin + let hashInfo = extractPluginHashInfo schema + childHashes = fromMaybe Map.empty (irPluginHashes childIR) + allHashes = Map.insert namespace hashInfo childHashes + + pure $ IR + { irVersion = irVersion emptyIR -- Use version from emptyIR + , irBackend = irBackend emptyIR -- Will be set by buildIR + , irHash = thisHash + , irMetadata = irMetadata childIR -- Preserve metadata from child + , irTypes = Map.union localTypes (irTypes childIR) -- Local wins on conflict + , irMethods = Map.union localMethods (irMethods childIR) + , irPlugins = Map.insert namespace pluginMethods (irPlugins childIR) + , irPluginHashes = Just allHashes -- V2: Store hash info per plugin + } + +irAlgebra (MethodF method namespace path) = do + -- Single method node (shouldn't happen in normal walk, but handle it) + let fullPath = T.intercalate "." path + let (types, mdef) = extractMethodDef namespace fullPath method + pure $ IR + { irVersion = irVersion emptyIR -- Use version from emptyIR + , irBackend = irBackend emptyIR -- Will be set by buildIR + , irHash = Nothing -- Methods don't carry hash + , irMetadata = Nothing -- Will be set by buildIR + , irTypes = types + , irMethods = Map.singleton fullPath mdef + , irPlugins = Map.singleton namespace [methodName method] + , irPluginHashes = Nothing -- Methods don't have plugin-level hashes + } + +-- ============================================================================ +-- Type Deduplication +-- ============================================================================ + +-- | Deduplicate types by content hash +-- +-- When multiple namespaces define identical types (e.g., solar.SolarEvent and +-- jupiter.SolarEvent), we deduplicate them by keeping one canonical version. +-- +-- Strategy: +-- 1. Hash each TypeDef by its structure (name + kind, ignoring namespace) +-- 2. Group duplicates +-- 3. Pick canonical: prefer parent namespace, then shortest namespace +-- 4. Update all RefNamed references to point to canonical qualified name +deduplicateTypes :: IR -> IR +deduplicateTypes ir = + let -- Group types by their content hash + typesByHash = Map.fromListWith (++) + [ (hashTypeStructure td, [(fullName, td)]) + | (fullName, td) <- Map.toList (irTypes ir) + ] + + -- Pick canonical version for each group + canonical = Map.fromList + [ (hash, selectCanonical group) + | (hash, group) <- Map.toList typesByHash + ] + + -- Build redirect map: old qualified name -> canonical qualified name + redirects = Map.fromList + [ (oldName, canonicalName) + | group <- Map.elems typesByHash + , let canonicalName = fst (selectCanonical group) + , (oldName, _) <- group + , oldName /= canonicalName + ] + + -- Keep only canonical types and update their internal type references + canonicalPairs = [canon | canon <- Map.elems canonical] + dedupedTypesWithUpdatedRefs = Map.fromList + [ (qualName, updateTypeDefRefs redirects td) + | (qualName, td) <- canonicalPairs + ] + + -- Update all method references + dedupedMethods = Map.map (updateMethodRefs redirects) (irMethods ir) + + in ir { irTypes = dedupedTypesWithUpdatedRefs, irMethods = dedupedMethods } + +-- | Hash a TypeDef by its structure (ignoring namespace and description) +-- Types are considered identical if they have the same name and kind +-- We normalize TypeRefs (strip namespaces) before hashing to detect structural identity +hashTypeStructure :: TypeDef -> Text +hashTypeStructure TypeDef{..} = + tdName <> "::" <> T.pack (show (normalizeTypeKind tdKind)) + where + -- Normalize a TypeKind by stripping namespaces from all RefNamed types + normalizeTypeKind :: TypeKind -> TypeKind + normalizeTypeKind = \case + KindStruct fields -> KindStruct (map normalizeField fields) + KindEnum disc variants -> KindEnum disc (map normalizeVariant variants) + KindStringEnum vals -> KindStringEnum vals + KindAlias target -> KindAlias (normalizeTypeRef target) + KindPrimitive t f -> KindPrimitive t f + + normalizeField :: FieldDef -> FieldDef + normalizeField fd = fd { fdType = normalizeTypeRef (fdType fd) } + + normalizeVariant :: VariantDef -> VariantDef + normalizeVariant vd = vd { vdFields = map normalizeField (vdFields vd) } + + normalizeTypeRef :: TypeRef -> TypeRef + normalizeTypeRef = \case + RefNamed qn -> + -- Strip namespace: keep only local name + RefNamed qn { qnNamespace = "" } + RefArray inner -> RefArray (normalizeTypeRef inner) + RefOptional inner -> RefOptional (normalizeTypeRef inner) + other -> other + +-- | Select the canonical version from a group of duplicate types +-- Strategy: prefer parent namespace, then shortest namespace +selectCanonical :: [(Text, TypeDef)] -> (Text, TypeDef) +selectCanonical dups = + case dups of + [] -> error "selectCanonical: empty list" + [single] -> single + multiple -> minimumBy compareNamespacePreference multiple + where + -- Compare two (fullName, typedef) pairs + compareNamespacePreference (_, td1) (_, td2) = + let ns1 = tdNamespace td1 + ns2 = tdNamespace td2 + -- Check if one is parent of the other + isParent n1 n2 = n2 `T.isPrefixOf` n1 && T.length n1 > T.length n2 + in case (isParent ns1 ns2, isParent ns2 ns1) of + (True, False) -> GT -- ns2 is parent of ns1, prefer ns2 + (False, True) -> LT -- ns1 is parent of ns2, prefer ns1 + _ -> compare (T.length ns1) (T.length ns2) -- Fallback: shortest wins + +-- | Parse a qualified name from a full name string (e.g., "cone.UUID" -> QualifiedName "cone" "UUID") +parseQualifiedName :: Text -> Maybe QualifiedName +parseQualifiedName t = + case T.breakOnEnd "." t of + ("", _) -> Nothing -- No dot found + (ns, local) | T.null local -> Nothing -- Ends with dot + | otherwise -> Just QualifiedName + { qnNamespace = T.dropEnd 1 ns -- Remove trailing dot + , qnLocalName = local + } + +-- | Update all RefNamed references in a method using redirect map +updateMethodRefs :: Map Text Text -> MethodDef -> MethodDef +updateMethodRefs redirects md = md + { mdParams = map (updateParamRefs redirects) (mdParams md) + , mdReturns = updateTypeRef redirects (mdReturns md) + , mdBidirType = fmap (updateTypeRef redirects) (mdBidirType md) + } + +-- | Update type references in a parameter +updateParamRefs :: Map Text Text -> ParamDef -> ParamDef +updateParamRefs redirects pd = pd + { pdType = updateTypeRef redirects (pdType pd) + } + +-- | Recursively update a TypeRef to use canonical names +updateTypeRef :: Map Text Text -> TypeRef -> TypeRef +updateTypeRef redirects = \case + RefNamed qn -> + let fullName = qualifiedNameFull qn + canonicalName = Map.findWithDefault fullName fullName redirects + in case parseQualifiedName canonicalName of + Just qn' -> RefNamed qn' + Nothing -> RefNamed qn -- Fallback if parse fails + RefArray inner -> + RefArray (updateTypeRef redirects inner) + RefOptional inner -> + RefOptional (updateTypeRef redirects inner) + other -> other + +-- | Update all type references in a TypeDef +updateTypeDefRefs :: Map Text Text -> TypeDef -> TypeDef +updateTypeDefRefs redirects td = td { tdKind = updateTypeKind (tdKind td) } + where + updateTypeKind :: TypeKind -> TypeKind + updateTypeKind = \case + KindStruct fields -> + KindStruct (map updateField fields) + KindEnum disc variants -> + KindEnum disc (map updateVariant variants) + KindAlias target -> + KindAlias (updateTypeRef redirects target) + KindStringEnum vals -> + KindStringEnum vals + KindPrimitive t f -> + KindPrimitive t f + + updateField :: FieldDef -> FieldDef + updateField fd = fd { fdType = updateTypeRef redirects (fdType fd) } + + updateVariant :: VariantDef -> VariantDef + updateVariant vd = vd { vdFields = map updateField (vdFields vd) } + +-- ============================================================================ +-- Extraction from Plugin +-- ============================================================================ + +-- | Extract all types and methods from a plugin schema +-- Types are namespace-qualified to avoid collisions (e.g., "cone.ListResult") +extractFromPlugin :: Text -> Text -> PluginSchema -> (Map Text TypeDef, Map Text MethodDef) +extractFromPlugin namespace pathPrefix schema = + let methods = psMethods schema + results = map (extractMethodDef namespace pathPrefix) methods + allTypes = Map.unions (map fst results) + allMethods = Map.fromList + [ (mdFullPath m, m) + | (_, m) <- results + ] + in (allTypes, allMethods) + +-- | Extract types and method def from a single method +extractMethodDef :: Text -> Text -> MethodSchema -> (Map Text TypeDef, MethodDef) +extractMethodDef namespace pathPrefix method = + let name = methodName method + fullPath = if T.null pathPrefix + then namespace <> "." <> name + else pathPrefix <> "." <> name + + -- Extract types from params (namespace-qualified) + (paramTypes, params) = extractParams namespace (methodParams method) + + -- Extract types from returns (namespace-qualified) + (returnTypes, returnRef, streaming) = extractReturns namespace name (methodReturns method) + + -- Combine all types + allTypes = Map.union paramTypes returnTypes + + -- Detect bidirectional type parameter T. + -- + -- When the schema reports bidirectional: true we know the method uses a + -- BidirChannel. The 'request_type' field (if present) holds the JSON + -- Schema for T. We currently emit: + -- - Nothing → not bidirectional + -- - Just RefAny → bidirectional with T=Value (StandardBidirChannel, + -- the default case; request_type is the StandardRequest schema) + -- - Just (RefNamed …) → bidirectional with a specific named T + -- (future: when request_type references a named type) + -- + -- NOTE: The substrate schema as of this implementation always uses + -- StandardBidirChannel (T=Value), so mdBidirType is always Nothing or + -- Just RefAny. A future change to MethodSchema / hub-macro that emits a + -- structured "bidir_type" field (distinct from the full request_type schema) + -- should be handled here. + bidirTypeRef = inferBidirType method + + mdef = MethodDef + { mdName = name + , mdFullPath = fullPath + , mdNamespace = namespace + , mdDescription = Just (methodDescription method) + , mdStreaming = streaming + , mdParams = params + , mdReturns = returnRef + , mdBidirType = bidirTypeRef + } + in (allTypes, mdef) + +-- | Infer the bidirectional type parameter from a MethodSchema. +-- +-- Returns: +-- Nothing – method is not bidirectional +-- Just RefAny – method is bidirectional with default T=Value (StandardBidirChannel) +-- Just tr – method is bidirectional with specific T type (future) +inferBidirType :: MethodSchema -> Maybe TypeRef +inferBidirType method + | not (methodBidirectional method) = Nothing + -- Method is bidirectional. Inspect request_type to determine T. + | otherwise = case methodRequestType method of + Nothing -> + -- bidirectional: true but no request_type schema → treat as T=Value + Just RefAny + Just _ -> + -- request_type is present. For now we always emit RefAny (T=Value) + -- because the schema emits the full StandardRequest schema rather than + -- a dedicated "bidir_type" field identifying T. + -- + -- TODO: When the hub-macro is extended to emit a structured + -- "bidir_type": { "$ref": "#/$defs/MyType" } field in the schema JSON, + -- parse it here with schemaToTypeRef and return the resulting TypeRef. + Just RefAny + +-- ============================================================================ +-- Parameter Extraction +-- ============================================================================ + +-- | Extract types and param defs from method params schema +-- Types are namespace-qualified to avoid collisions +extractParams :: Text -> Maybe Value -> (Map Text TypeDef, [ParamDef]) +extractParams _ Nothing = (Map.empty, []) +extractParams namespace (Just val) = case val of + Object o -> extractParamsFromObject namespace o + _ -> (Map.empty, []) + +extractParamsFromObject :: Text -> KM.KeyMap Value -> (Map Text TypeDef, [ParamDef]) +extractParamsFromObject namespace o = + let -- Extract $defs (namespace-qualified) + defs = extractDefs namespace o + + -- Extract properties + props = case KM.lookup "properties" o of + Just (Object p) -> KM.toList p + _ -> [] + + -- Get required list + required = case KM.lookup "required" o of + Just (Array arr) -> [t | String t <- V.toList arr] + _ -> [] + + -- Build param defs + params = + [ ParamDef + { pdName = K.toText k + , pdType = schemaToTypeRef namespace v + , pdDescription = extractDescription v + , pdRequired = K.toText k `elem` required + , pdDefault = extractDefault v + } + | (k, v) <- props + ] + in (defs, params) + +-- ============================================================================ +-- Return Type Extraction +-- ============================================================================ + +-- | Extract types, return ref, and streaming flag from returns schema +extractReturns :: Text -> Text -> Maybe Value -> (Map Text TypeDef, TypeRef, Bool) +extractReturns _ _ Nothing = (Map.empty, RefUnknown, False) +extractReturns namespace methodName (Just val) = case val of + Object o -> + let -- Extract $defs + defs = extractDefs namespace o + + -- Get the type name from title or generate from method name + typeName = case KM.lookup "title" o of + Just (String t) -> t + _ -> methodName <> "Result" + + -- Check for oneOf (discriminated union) + (typeDef, streaming) = case KM.lookup "oneOf" o of + Just (Array variants) -> + let variantDefs = mapMaybe (extractVariant namespace) (V.toList variants) + discriminator = inferDiscriminator variantDefs + nonErrorVariants = filter (\v -> vdName v /= "error") variantDefs + isStream = length nonErrorVariants > 1 + in ( Just $ TypeDef + { tdName = typeName + , tdNamespace = namespace + , tdDescription = extractDescription val + , tdKind = KindEnum discriminator variantDefs + } + , isStream + ) + _ -> + -- Not a union, just a regular type + (Nothing, False) + + -- Add the return type to defs if it's a union + allDefs = case typeDef of + Just td -> Map.insert (tdFullName td) td defs + Nothing -> defs + + -- Return type reference uses QualifiedName + typeRef = RefNamed QualifiedName + { qnNamespace = namespace + , qnLocalName = typeName + } + + in (allDefs, typeRef, streaming) + _ -> (Map.empty, RefUnknown, False) + +-- | Extract a variant from a oneOf element +extractVariant :: Text -> Value -> Maybe VariantDef +extractVariant namespace (Object o) = case KM.lookup "properties" o of + Just (Object props) -> + -- Find the discriminator value (look for "type" with const) + let discriminatorValue = case KM.lookup "type" props of + Just (Object typeObj) -> case KM.lookup "const" typeObj of + Just (String s) -> Just s + _ -> Nothing + _ -> Nothing + + -- Extract fields (excluding the discriminator) + fields = + [ FieldDef + { fdName = K.toText k + , fdType = schemaToTypeRef namespace v + , fdDescription = extractDescription v + , fdRequired = True -- In variants, fields are typically required + , fdDefault = Nothing + } + | (k, v) <- KM.toList props + , K.toText k /= "type" -- Exclude discriminator + ] + in case discriminatorValue of + Just dv -> Just $ VariantDef + { vdName = dv + , vdDescription = extractDescription (Object o) + , vdFields = fields + } + Nothing -> Nothing + _ -> Nothing +extractVariant _ _ = Nothing + +-- | Infer the discriminator field name from variants +inferDiscriminator :: [VariantDef] -> Text +inferDiscriminator _ = "type" -- Convention: always "type" + +-- | Extract const value from a simple string variant +-- Matches schema like: { "const": "pending", "type": "string", "description": "..." } +extractStringConst :: Value -> Maybe Text +extractStringConst (Object o) = + case (KM.lookup "const" o, KM.lookup "type" o) of + (Just (String c), Just (String "string")) -> Just c + _ -> Nothing +extractStringConst _ = Nothing + +-- ============================================================================ +-- Type Extraction from $defs +-- ============================================================================ + +-- | Extract type definitions from $defs or definitions (draft-07 compatibility) +-- Types are namespace-qualified to avoid collisions +extractDefs :: Text -> KM.KeyMap Value -> Map Text TypeDef +extractDefs namespace o = + let defs = case KM.lookup "$defs" o of + Just (Object d) -> d + _ -> case KM.lookup "definitions" o of + Just (Object d) -> d + _ -> KM.empty + in Map.fromList $ mapMaybe (extractTypeDef namespace) (KM.toList defs) + +-- | Extract a type definition from a $defs entry +extractTypeDef :: Text -> (K.Key, Value) -> Maybe (Text, TypeDef) +extractTypeDef namespace (k, v) = case v of + Object o -> + let name = K.toText k + desc = extractDescription v + kind = inferTypeKind namespace o + td = TypeDef name namespace desc kind + in Just (tdFullName td, td) + _ -> Nothing + +-- | Infer the kind of a type from its JSON Schema +inferTypeKind :: Text -> KM.KeyMap Value -> TypeKind +inferTypeKind namespace o + -- Check for oneOf (enum) + | Just (Array variants) <- KM.lookup "oneOf" o = + -- First check if this is a simple string enum (all variants are {const: X, type: "string"}) + let maybeStringValues = mapMaybe extractStringConst (V.toList variants) + in if length maybeStringValues == V.length variants && not (null maybeStringValues) + then KindStringEnum maybeStringValues + else let variantDefs = mapMaybe (extractVariant namespace) (V.toList variants) + in KindEnum "type" variantDefs + + -- Check for enum (simple string enum) + | Just (Array values) <- KM.lookup "enum" o = + let stringValues = [ asText v | v <- V.toList values ] + in KindStringEnum stringValues + + -- Check for object with properties (struct) + | Just (Object props) <- KM.lookup "properties" o = + let required = case KM.lookup "required" o of + Just (Array arr) -> [t | String t <- V.toList arr] + _ -> [] + fields = + [ FieldDef + { fdName = K.toText k + , fdType = schemaToTypeRef namespace v + , fdDescription = extractDescription v + , fdRequired = K.toText k `elem` required + , fdDefault = extractDefault v + } + | (k, v) <- KM.toList props + ] + in KindStruct fields + + -- Check for primitive types + | Just typeVal <- KM.lookup "type" o = + case typeVal of + String t -> KindPrimitive t (extractFormat o) + Array ts -> + -- Nullable type like ["string", "null"] + let nonNull = [t | String t <- V.toList ts, t /= "null"] + in case nonNull of + [t] -> KindPrimitive t (extractFormat o) + _ -> KindPrimitive "any" Nothing + _ -> KindPrimitive "any" Nothing + + -- Default to unknown + | otherwise = KindPrimitive "any" Nothing + + where + asText (String s) = s + asText _ = "unknown" + +-- ============================================================================ +-- Schema to TypeRef Conversion +-- ============================================================================ + +-- | Convert a JSON Schema value to a TypeRef +-- +-- Distinguishes between: +-- - RefAny: Schema present but no type constraints (intentionally dynamic, e.g. serde_json::Value) +-- - RefUnknown: No schema at all (schema gap, should warn) +-- +-- Type references via $ref are namespace-qualified (e.g., "cone.ConeInfo") +schemaToTypeRef :: Text -> Value -> TypeRef +schemaToTypeRef namespace (Object o) + -- Check for $ref - namespace-qualify the reference + | Just (String ref) <- KM.lookup "$ref" o = + RefNamed QualifiedName + { qnNamespace = namespace + , qnLocalName = extractRefName ref + } + + -- Check for array + | Just (String "array") <- KM.lookup "type" o = + case KM.lookup "items" o of + Just items -> RefArray (schemaToTypeRef namespace items) + Nothing -> RefArray RefAny -- array without items = any[] + + -- Check for nullable + | Just (Array types) <- KM.lookup "type" o = + let nonNull = [t | t@(String s) <- V.toList types, s /= "null"] + hasNull = any (\case String "null" -> True; _ -> False) (V.toList types) + in case nonNull of + [String t] -> + let base = RefPrimitive t (extractFormat o) + in if hasNull then RefOptional base else base + _ -> RefAny -- Multiple non-null types = any + + -- Check for anyOf (often used for optional refs) - namespace-qualify refs + | Just (Array options) <- KM.lookup "anyOf" o = + let refs = mapMaybe extractRefFromOption (V.toList options) + in case refs of + [r] -> RefOptional (RefNamed QualifiedName + { qnNamespace = namespace + , qnLocalName = r + }) + _ -> RefAny -- Complex anyOf = any + + -- Check for primitive type + | Just (String t) <- KM.lookup "type" o = + RefPrimitive t (extractFormat o) + + -- Schema object present but no type constraint = intentionally dynamic (RefAny) + -- This happens with serde_json::Value which emits {"description": "...", "default": null} + | otherwise = RefAny + +-- JSON Schema `true` is the "accept anything" schema - intentionally dynamic +-- This is used when schemars emits a field like `input: true` for serde_json::Value +schemaToTypeRef _ (Bool True) = RefAny + +-- Null, false, or non-JSON-Schema values = schema gap (should warn) +schemaToTypeRef _ _ = RefUnknown + +-- | Extract ref name from a $ref string like "#/$defs/Position" +extractRefName :: Text -> Text +extractRefName ref = case T.splitOn "/" ref of + parts | not (null parts) -> last parts + _ -> ref + +-- | Extract ref from anyOf option (for optional types) +extractRefFromOption :: Value -> Maybe Text +extractRefFromOption (Object o) = case KM.lookup "$ref" o of + Just (String ref) -> Just (extractRefName ref) + _ -> Nothing +extractRefFromOption _ = Nothing + +-- ============================================================================ +-- Helpers +-- ============================================================================ + +-- | Extract description from a schema +extractDescription :: Value -> Maybe Text +extractDescription (Object o) = case KM.lookup "description" o of + Just (String s) -> Just s + _ -> Nothing +extractDescription _ = Nothing + +-- | Extract default value from a schema +extractDefault :: Value -> Maybe Value +extractDefault (Object o) = KM.lookup "default" o +extractDefault _ = Nothing + +-- | Extract format from a schema object +extractFormat :: KM.KeyMap Value -> Maybe Text +extractFormat o = case KM.lookup "format" o of + Just (String s) -> Just s + _ -> Nothing + +-- | Extract types from a full schema (for standalone use) +-- Types are namespace-qualified +extractTypesFromSchema :: Text -> Value -> Map Text TypeDef +extractTypesFromSchema namespace (Object o) = extractDefs namespace o +extractTypesFromSchema _ _ = Map.empty diff --git a/src/Synapse/IR/Types.hs b/src/Synapse/IR/Types.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/IR/Types.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Intermediate Representation for code generation +-- +-- The IR is a deduplicated, structured representation of the full +-- plugin graph, optimized for transpilers to consume. +-- +-- = Design +-- +-- Schema (per-plugin, self-contained, may duplicate types) +-- ↓ walk + transform +-- IR (global, deduplicated, compiler-ready) +-- ↓ transpilers +-- TypeScript / Python / Swift / etc. +-- +-- = Structure +-- +-- - Types are hoisted to top level and deduplicated by name +-- - Methods reference types by name, not inline definitions +-- - Streaming is inferred from return type structure +-- - Discriminated unions are first-class +module Synapse.IR.Types + ( -- * Top-level IR + IR(..) + , emptyIR + , mergeIR + + -- * Version Information + , synapseVersion + + -- * Generation Metadata + , GeneratorInfo(..) + , GenerationMetadata(..) + + -- * Plugin Hash Information + , PluginHashInfo(..) + + -- * Type Definitions + , TypeDef(..) + , tdFullName + , TypeKind(..) + , FieldDef(..) + , VariantDef(..) + + -- * Method Definitions + , MethodDef(..) + , ParamDef(..) + + -- * Type References + , QualifiedName(..) + , qualifiedNameFull + , TypeRef(..) + , typeRefName + + -- * Utilities + , isStreaming + , inferStreaming + ) where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +-- ============================================================================ +-- Version Information +-- ============================================================================ + +-- | Synapse version (from cabal file: plexus-synapse.cabal) +synapseVersion :: Text +synapseVersion = "0.2.0.0" + +-- ============================================================================ +-- Generation Metadata +-- ============================================================================ + +-- | Generator tool version information +data GeneratorInfo = GeneratorInfo + { giTool :: Text -- ^ Tool name (e.g., "synapse", "synapse-cc") + , giVersion :: Text -- ^ Version string (e.g., "0.2.0.0") + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | Generation metadata tracking the full toolchain +data GenerationMetadata = GenerationMetadata + { gmGenerators :: [GeneratorInfo] -- ^ All tools in the generation chain + , gmTimestamp :: Text -- ^ ISO 8601 timestamp of generation + , gmIrVersion :: Text -- ^ IR format version + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- ============================================================================ +-- Plugin Hash Information +-- ============================================================================ + +-- | V2 hash information for a plugin +-- Supports granular cache invalidation by tracking: +-- - Composite hash (backward compatible with V1) +-- - Self hash (methods-only, for detecting method changes) +-- - Children hash (children-only, for detecting dependency changes) +data PluginHashInfo = PluginHashInfo + { phiHash :: Text -- ^ Composite hash (backward compatible) + , phiSelfHash :: Text -- ^ V2: Methods-only hash + , phiChildrenHash :: Text -- ^ V2: Children-only hash + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- ============================================================================ +-- Top-level IR +-- ============================================================================ + +-- | The complete IR for code generation +data IR = IR + { irVersion :: Text -- ^ IR format version + , irBackend :: Text -- ^ Backend name (e.g., "substrate", "plexus") + , irHash :: Maybe Text -- ^ Plexus hash for versioning + , irMetadata :: Maybe GenerationMetadata -- ^ Generation toolchain metadata + , irTypes :: Map Text TypeDef -- ^ All types, deduplicated by name + , irMethods :: Map Text MethodDef -- ^ All methods, keyed by full path (e.g., "cone.chat") + , irPlugins :: Map Text [Text] -- ^ Plugin -> method names mapping + , irPluginHashes :: Maybe (Map Text PluginHashInfo) -- ^ V2: Hash information per plugin + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +-- | Empty IR for folding +emptyIR :: IR +emptyIR = IR + { irVersion = "2.0" -- Bumped: TypeRef now uses structured QualifiedName + , irBackend = "" -- Will be set by buildIR + , irHash = Nothing + , irMetadata = Nothing + , irTypes = Map.empty + , irMethods = Map.empty + , irPlugins = Map.empty + , irPluginHashes = Nothing + } + +-- | Merge two IRs (for combining results from tree walk) +mergeIR :: IR -> IR -> IR +mergeIR a b = IR + { irVersion = irVersion a + , irBackend = irBackend a -- Take from left (parent) + , irHash = irHash a <|> irHash b -- Take first available hash + , irMetadata = irMetadata a <|> irMetadata b -- Take first available metadata + , irTypes = Map.union (irTypes a) (irTypes b) -- Left-biased, first definition wins + , irMethods = Map.union (irMethods a) (irMethods b) + , irPlugins = Map.unionWith (++) (irPlugins a) (irPlugins b) + , irPluginHashes = case (irPluginHashes a, irPluginHashes b) of + (Just ha, Just hb) -> Just (Map.union ha hb) -- Merge hash maps + (Just ha, Nothing) -> Just ha + (Nothing, Just hb) -> Just hb + (Nothing, Nothing) -> Nothing + } + +-- ============================================================================ +-- Type Definitions +-- ============================================================================ + +-- | A type definition extracted from schemas +data TypeDef = TypeDef + { tdName :: Text -- ^ Type name (e.g., "ListResult", "ChatEvent") + , tdNamespace :: Text -- ^ Namespace (e.g., "cone", "arbor") + , tdDescription :: Maybe Text -- ^ Documentation + , tdKind :: TypeKind -- ^ What kind of type this is + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +-- | Compute the fully qualified type name +tdFullName :: TypeDef -> Text +tdFullName td = tdNamespace td <> "." <> tdName td + +-- | The kind of a type definition +data TypeKind + = KindStruct + { ksFields :: [FieldDef] -- ^ Struct fields + } + | KindEnum + { keDiscriminator :: Text -- ^ Field that discriminates (e.g., "type") + , keVariants :: [VariantDef] -- ^ Possible variants + } + | KindStringEnum + { kseValues :: [Text] -- ^ String literal values (e.g., ["pending", "completed"]) + } + | KindAlias + { kaTarget :: TypeRef -- ^ What this aliases to + } + | KindPrimitive + { kpType :: Text -- ^ "string", "integer", "boolean", etc. + , kpFormat :: Maybe Text -- ^ Optional format hint (e.g., "uuid", "int64") + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +-- | A field in a struct +data FieldDef = FieldDef + { fdName :: Text -- ^ Field name + , fdType :: TypeRef -- ^ Field type + , fdDescription :: Maybe Text -- ^ Documentation + , fdRequired :: Bool -- ^ Is this field required? + , fdDefault :: Maybe Value -- ^ Default value if any + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +-- | A variant in a discriminated union +data VariantDef = VariantDef + { vdName :: Text -- ^ Variant name (the discriminator value) + , vdDescription :: Maybe Text -- ^ Documentation + , vdFields :: [FieldDef] -- ^ Fields specific to this variant + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +-- ============================================================================ +-- Method Definitions +-- ============================================================================ + +-- | A method definition +data MethodDef = MethodDef + { mdName :: Text -- ^ Method name (e.g., "chat") + , mdFullPath :: Text -- ^ Full path (e.g., "cone.chat") + , mdNamespace :: Text -- ^ Parent namespace (e.g., "cone") + , mdDescription :: Maybe Text -- ^ Documentation + , mdStreaming :: Bool -- ^ Does this method stream multiple events? + , mdParams :: [ParamDef] -- ^ Input parameters + , mdReturns :: TypeRef -- ^ Return type reference + , mdBidirType :: Maybe TypeRef + -- ^ Bidirectional channel type parameter T, when the method uses + -- BidirChannel, StandardResponse>. + -- + -- Populated from the "bidirectional" / "request_type" fields in the + -- MethodSchema (emitted by the hub-macro when #[bidirectional] is set). + -- + -- - Nothing → method is not bidirectional, OR uses the default + -- T = serde_json::Value (StandardBidirChannel) + -- - Just RefAny → bidirectional with T=Value (explicit marker) + -- - Just (RefNamed ...) → bidirectional with a specific named T type + -- + -- NOTE: The substrate schema currently emits 'bidirectional: true' but + -- does not yet include a structured 'bidir_type' field. When that field + -- is added to MethodSchema, populate it here from methodRequestType. + -- For now this is always Nothing. + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +-- | A parameter definition +data ParamDef = ParamDef + { pdName :: Text -- ^ Parameter name + , pdType :: TypeRef -- ^ Parameter type + , pdDescription :: Maybe Text -- ^ Documentation + , pdRequired :: Bool -- ^ Is this required? + , pdDefault :: Maybe Value -- ^ Default value if any + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +-- ============================================================================ +-- Type References +-- ============================================================================ + +-- | A qualified name for a type, with namespace and local name +data QualifiedName = QualifiedName + { qnNamespace :: Text -- ^ Namespace (can be empty for global types) + , qnLocalName :: Text -- ^ Local name within namespace + } + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +-- | Get the full qualified name as a single Text +-- Returns just the local name if namespace is empty, otherwise "namespace.localName" +qualifiedNameFull :: QualifiedName -> Text +qualifiedNameFull qn + | T.null (qnNamespace qn) = qnLocalName qn + | otherwise = qnNamespace qn <> "." <> qnLocalName qn + +-- | A reference to a type +data TypeRef + = RefNamed QualifiedName -- ^ Reference to a named type (e.g., QualifiedName "cone" "UUID") + | RefPrimitive Text (Maybe Text) -- ^ Primitive type with optional format + | RefArray TypeRef -- ^ Array of some type + | RefOptional TypeRef -- ^ Optional (nullable) type + | RefAny -- ^ Intentionally dynamic (serde_json::Value) - accepts any JSON + | RefUnknown -- ^ Unknown type (schema gap) - should warn + deriving stock (Show, Eq, Generic) + deriving anyclass (ToJSON) + +-- | Get the name from a type reference (if it's a named ref) +typeRefName :: TypeRef -> Maybe Text +typeRefName (RefNamed qn) = Just (qualifiedNameFull qn) +typeRefName _ = Nothing + +-- ============================================================================ +-- Utilities +-- ============================================================================ + +-- | Check if a method definition is streaming +isStreaming :: MethodDef -> Bool +isStreaming = mdStreaming + +-- | Infer streaming from a return type's structure +-- A method is streaming if its return type is an enum with more than 2 variants +-- (more than 1 success variant + error variant) +inferStreaming :: TypeDef -> Bool +inferStreaming td = case tdKind td of + KindEnum _ variants -> + let nonErrorVariants = filter (not . isErrorVariant) variants + in length nonErrorVariants > 1 + _ -> False + where + isErrorVariant v = vdName v == "error" diff --git a/src/Synapse/Monad.hs b/src/Synapse/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Monad.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Effect stack for Synapse operations +-- +-- = The Monad +-- +-- @ +-- SynapseM = ExceptT SynapseError (ReaderT SynapseEnv IO) +-- @ +-- +-- Provides: +-- - Error handling via 'SynapseError' +-- - Environment with cache and cycle detection +-- - IO for network calls +module Synapse.Monad + ( -- * The Monad + SynapseM + , runSynapseM + , runSynapseM' + + -- * Environment + , SynapseEnv(..) + , initEnv + , defaultEnv + + -- * Errors + , SynapseError(..) + , BackendErrorType(..) + , TransportContext(..) + , TransportErrorCategory(..) + , throwNav + , throwTransport + , throwTransportWith + , throwParse + , throwBackend + + -- * Cycle Detection + , checkCycle + , withFreshVisited + + -- * Cache Operations + , lookupCache + , insertCache + ) where + +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, asks) +import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS +import Data.Hashable (Hashable) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef') +import Data.Text (Text) +import qualified Data.Text as T + +import Synapse.Schema.Types +import Synapse.Backend.Discovery (Backend(..)) + +-- | Environment for Synapse operations +data SynapseEnv = SynapseEnv + { seHost :: !Text -- ^ Hub host + , sePort :: !Int -- ^ Hub port + , seBackend :: !Text -- ^ Backend name (first CLI argument) + , seCache :: !(IORef (HashMap PluginHash PluginSchema)) -- ^ Schema cache + , seVisited :: !(IORef (HashSet PluginHash)) -- ^ Cycle detection + } + +-- | Errors that can occur during Synapse operations +data SynapseError + = NavError NavError + | TransportError Text -- Keep for compatibility + | TransportErrorContext TransportContext -- NEW: with context + | ParseError Text + | ValidationError Text + | BackendError BackendErrorType [Backend] + deriving stock (Show, Eq) + +-- | Backend-specific error types +data BackendErrorType + = BackendNotFound Text + | BackendUnreachable Text + | NoBackendsAvailable + deriving stock (Show, Eq) + +-- | Transport error with connection details and categorization +data TransportContext = TransportContext + { tcMessage :: Text + , tcHost :: Text + , tcPort :: Int + , tcBackend :: Text + , tcPath :: Path + , tcCategory :: TransportErrorCategory + } deriving stock (Show, Eq) + +-- | Categories of transport errors +data TransportErrorCategory + = ConnectionRefused + | ConnectionTimeout + | ProtocolError + | UnknownTransportError + deriving stock (Show, Eq) + +-- | The Synapse monad stack +newtype SynapseM a = SynapseM + { unSynapseM :: ExceptT SynapseError (ReaderT SynapseEnv IO) a + } + deriving newtype + ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader SynapseEnv + , MonadError SynapseError + ) + +-- Note: PluginHash is a type alias for Text, which is already Hashable + +-- | Run a SynapseM action with the given environment +runSynapseM :: SynapseEnv -> SynapseM a -> IO (Either SynapseError a) +runSynapseM env action = runReaderT (runExceptT (unSynapseM action)) env + +-- | Run a SynapseM action with default host/port and specified backend +runSynapseM' :: Text -> SynapseM a -> IO (Either SynapseError a) +runSynapseM' backend action = do + env <- defaultEnv backend + runSynapseM env action + +-- | Initialize environment with given host/port/backend +initEnv :: Text -> Int -> Text -> IO SynapseEnv +initEnv host port backend = do + cache <- newIORef HM.empty + visited <- newIORef HS.empty + pure SynapseEnv + { seHost = host + , sePort = port + , seBackend = backend + , seCache = cache + , seVisited = visited + } + +-- | Default environment (localhost:4444, requires backend) +defaultEnv :: Text -> IO SynapseEnv +defaultEnv = initEnv "127.0.0.1" 4444 + +-- | Throw a navigation error +throwNav :: NavError -> SynapseM a +throwNav = throwError . NavError + +-- | Throw a transport error +throwTransport :: Text -> SynapseM a +throwTransport = throwError . TransportError + +-- | Throw a parse error +throwParse :: Text -> SynapseM a +throwParse = throwError . ParseError + +-- | Throw a backend error +throwBackend :: BackendErrorType -> [Backend] -> SynapseM a +throwBackend errorType backends = throwError (BackendError errorType backends) + +-- | Throw a transport error with context +throwTransportWith :: TransportContext -> SynapseM a +throwTransportWith = throwError . TransportErrorContext + +-- ============================================================================ +-- Cycle Detection +-- ============================================================================ + +-- | Check for cycles before descending into a child +-- Throws 'Cycle' error if hash was already visited +checkCycle :: PluginHash -> Path -> SynapseM () +checkCycle hash path = do + visitedRef <- asks seVisited + visited <- liftIO $ readIORef visitedRef + when (hash `HS.member` visited) $ + throwNav $ Cycle hash path + liftIO $ modifyIORef' visitedRef (HS.insert hash) + +-- | Run an action with a fresh visited set, restoring afterwards +-- Used at the start of each navigation to reset cycle detection +withFreshVisited :: SynapseM a -> SynapseM a +withFreshVisited action = do + ref <- asks seVisited + old <- liftIO $ readIORef ref + liftIO $ writeIORef ref HS.empty + result <- action + liftIO $ writeIORef ref old + pure result + +-- ============================================================================ +-- Cache Operations +-- ============================================================================ + +-- | Look up a schema in the cache by hash +lookupCache :: PluginHash -> SynapseM (Maybe PluginSchema) +lookupCache hash = do + cacheRef <- asks seCache + cache <- liftIO $ readIORef cacheRef + pure $ HM.lookup hash cache + +-- | Insert a schema into the cache +insertCache :: PluginHash -> PluginSchema -> SynapseM () +insertCache hash schema = do + cacheRef <- asks seCache + liftIO $ modifyIORef' cacheRef (HM.insert hash schema) diff --git a/src/Synapse/Renderer.hs b/src/Synapse/Renderer.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Renderer.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Template-based output renderer +-- +-- Runtime-configurable output rendering using Mustache templates. +-- Templates are resolved by METHOD name (not content_type), supporting +-- unified templates with all variants visible. +-- +-- = Template Resolution +-- +-- Templates are searched in order: +-- 1. Project-local: @.substrate/templates/{namespace}/{method}.mustache@ +-- 2. User global: @~/.config/synapse/templates/{namespace}/{method}.mustache@ +-- 3. Built-in defaults +-- +-- = Method Hints +-- +-- When a method path is set via 'withMethodPath', template lookup uses +-- that path instead of parsing the content_type. This allows unified +-- templates that handle all variants of a method's return type. +-- +-- = Usage +-- +-- @ +-- cfg <- defaultRendererConfig +-- let cfg' = withMethodPath cfg ["cone", "chat"] +-- result <- renderItem cfg' item +-- case result of +-- Just text -> TIO.putStrLn text +-- Nothing -> printJson item -- fallback +-- @ +module Synapse.Renderer + ( -- * Configuration + RendererConfig(..) + , defaultRendererConfig + , withMethodPath + , OutputMode(..) + + -- * Rendering + , renderItem + , renderValue + , renderWithTemplate + , prettyValue + + -- * Template Resolution + , resolveTemplate + , resolveTemplateForMethod + , templateSearchPaths + + -- * Template Loading + , loadTemplate + , TemplateCache + , newTemplateCache + , getCachedTemplate + ) where + +import Control.Exception (catch, SomeException) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (Value(..), encode) +import qualified Data.Aeson as A +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.IORef +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Scientific (Scientific, floatingOrInteger) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import System.Directory (doesFileExist, getCurrentDirectory, getHomeDirectory) +import System.FilePath ((), (<.>)) +import Text.Mustache (Template, toMustache) +import Text.Mustache.Compile (localAutomaticCompile) +import Text.Mustache.Render (substituteValue) +import qualified Text.Mustache.Types as MT + +import Synapse.Schema.Types + ( HubStreamItem + , pattern HubData + , pattern HubProgress + , pattern HubError + , pattern HubDone + ) + +-- ============================================================================ +-- Types +-- ============================================================================ + +-- | Output mode for rendering +data OutputMode + = ModeTemplate -- ^ Use templates when available + | ModeJson -- ^ Raw JSON stream items + | ModeRaw -- ^ Just the content value + deriving stock (Show, Eq) + +-- | Renderer configuration +data RendererConfig = RendererConfig + { rcSearchPaths :: [FilePath] -- ^ Template search paths + , rcMode :: OutputMode -- ^ Output mode + , rcCache :: TemplateCache -- ^ Template cache + , rcMethodPath :: Maybe [Text] -- ^ Method path hint for template lookup + } + +-- | Template cache to avoid re-parsing +newtype TemplateCache = TemplateCache (IORef (Map FilePath Template)) + +-- ============================================================================ +-- Configuration +-- ============================================================================ + +-- | Create a new template cache +newTemplateCache :: IO TemplateCache +newTemplateCache = TemplateCache <$> newIORef Map.empty + +-- | Get default renderer configuration +defaultRendererConfig :: IO RendererConfig +defaultRendererConfig = do + paths <- templateSearchPaths + cache <- newTemplateCache + pure $ RendererConfig + { rcSearchPaths = paths + , rcMode = ModeTemplate + , rcCache = cache + , rcMethodPath = Nothing + } + +-- | Set the method path for template resolution +-- +-- When set, template lookup will use this path instead of parsing +-- the content_type. This allows unified templates that handle all +-- variants of a method's return type. +-- +-- Example: @withMethodPath cfg ["cone", "chat"]@ will look for +-- @cone/chat.mustache@ regardless of the content_type. +withMethodPath :: RendererConfig -> [Text] -> RendererConfig +withMethodPath cfg path = cfg { rcMethodPath = Just path } + +-- | Get template search paths +templateSearchPaths :: IO [FilePath] +templateSearchPaths = do + cwd <- getCurrentDirectory + home <- getHomeDirectory + pure + [ cwd ".substrate" "templates" + , home ".config" "synapse" "templates" + ] + +-- ============================================================================ +-- Template Resolution +-- ============================================================================ + +-- | Resolve template path for a method path +-- +-- Search order: +-- 1. {searchPath}/{namespace}/{method}.mustache (exact match) +-- 2. {searchPath}/{namespace}/default.mustache (namespace default) +-- 3. {searchPath}/default.mustache (global default) +resolveTemplateForMethod :: RendererConfig -> [Text] -> IO (Maybe FilePath) +resolveTemplateForMethod cfg methodPath = case methodPath of + [] -> pure Nothing + [method] -> resolveTemplateByParts cfg "default" method + parts -> + let namespace = T.intercalate "." (init parts) + method = last parts + in resolveTemplateByParts cfg namespace method + +-- | Resolve template by namespace and method parts +resolveTemplateByParts :: RendererConfig -> Text -> Text -> IO (Maybe FilePath) +resolveTemplateByParts cfg namespace method = do + let candidates = + -- Exact method match + [ path T.unpack namespace T.unpack method <.> "mustache" + | path <- rcSearchPaths cfg + ] + -- Namespace default + ++ [ path T.unpack namespace "default" <.> "mustache" + | path <- rcSearchPaths cfg + ] + -- Global default + ++ [ path "default.mustache" | path <- rcSearchPaths cfg ] + firstExisting candidates + +-- | Resolve template path for a content type (legacy, fallback) +-- +-- Content type format: "namespace.variant" (e.g., "cone.start", "health.status") +-- This is used when no method path hint is set. +resolveTemplate :: RendererConfig -> Text -> IO (Maybe FilePath) +resolveTemplate cfg contentType = + case rcMethodPath cfg of + -- Method path hint available: use it + Just methodPath -> resolveTemplateForMethod cfg methodPath + -- No hint: fall back to content_type parsing + Nothing -> do + let (namespace, method) = parseContentType contentType + resolveTemplateByParts cfg namespace method + +-- | Parse content_type into (namespace, method/variant) +parseContentType :: Text -> (Text, Text) +parseContentType ct = case T.splitOn "." ct of + [ns, m] -> (ns, m) + [m] -> ("default", m) + parts -> (T.intercalate "." (init parts), last parts) + +-- | Find first existing file from candidates +firstExisting :: [FilePath] -> IO (Maybe FilePath) +firstExisting [] = pure Nothing +firstExisting (p:ps) = do + exists <- doesFileExist p + if exists then pure (Just p) else firstExisting ps + +-- ============================================================================ +-- Template Loading +-- ============================================================================ + +-- | Load a template from disk +loadTemplate :: FilePath -> IO (Either Text Template) +loadTemplate path = do + result <- localAutomaticCompile path + case result of + Left err -> pure $ Left $ T.pack $ show err + Right template -> pure $ Right template + +-- | Get template from cache, loading if needed +getCachedTemplate :: RendererConfig -> FilePath -> IO (Either Text Template) +getCachedTemplate cfg path = do + let TemplateCache cacheRef = rcCache cfg + cache <- readIORef cacheRef + case Map.lookup path cache of + Just template -> pure $ Right template + Nothing -> do + result <- loadTemplate path + case result of + Right template -> do + modifyIORef' cacheRef (Map.insert path template) + pure $ Right template + Left err -> pure $ Left err + +-- ============================================================================ +-- Rendering +-- ============================================================================ + +-- | Render a stream item using templates +renderItem :: RendererConfig -> HubStreamItem -> IO (Maybe Text) +renderItem cfg item = case rcMode cfg of + ModeJson -> pure Nothing -- Caller should use JSON + ModeRaw -> pure Nothing -- Caller should extract content + ModeTemplate -> case item of + HubData _ _ contentType content -> + renderValue cfg contentType content + HubProgress _ _ msg _ -> + pure $ Just msg + HubError _ _ err _ -> + pure $ Just $ "Error: " <> err + HubDone _ _ -> + pure Nothing + _ -> pure Nothing -- Handle other variants (e.g., HubGuidance) + +-- | Render a value using template for content type +renderValue :: RendererConfig -> Text -> Value -> IO (Maybe Text) +renderValue cfg contentType value = do + mPath <- resolveTemplate cfg contentType + case mPath of + Nothing -> pure Nothing + Just path -> do + result <- getCachedTemplate cfg path + case result of + Left _err -> pure Nothing + Right template -> pure $ Just $ renderWithTemplate template value + +-- | Render a value with a specific template +renderWithTemplate :: Template -> Value -> Text +renderWithTemplate template value = + let wrapped = wrapDiscriminatedUnion value + in substituteValue template (toMustache wrapped) + +-- | Wrap discriminated union data for mustache template compatibility +-- +-- Templates expect variant data wrapped like: {"echo": {"count": 1, ...}} +-- But actual responses are flat: {"type": "echo", "count": 1, ...} +-- +-- This transforms flat discriminated unions into wrapped form so +-- mustache sections like {{#echo}}...{{/echo}} will match. +wrapDiscriminatedUnion :: Value -> Value +wrapDiscriminatedUnion (Object obj) = + case KM.lookup "type" obj of + Just (String variant) -> + -- Wrap: {"variant": original_object} + Object $ KM.singleton (K.fromText variant) (Object obj) + _ -> Object obj +wrapDiscriminatedUnion other = other + +-- ============================================================================ +-- Pretty Printing +-- ============================================================================ + +-- | Pretty-print a JSON value in human-readable format (no JSON syntax) +prettyValue :: Value -> Text +prettyValue = prettyIndent 0 + +prettyIndent :: Int -> Value -> Text +prettyIndent indent val = case val of + Null -> "null" + Bool True -> "true" + Bool False -> "false" + Number n -> case floatingOrInteger n of + Left d -> T.pack $ show (d :: Double) + Right i -> T.pack $ show (i :: Integer) + String s -> s + Array arr + | V.null arr -> "[]" + | otherwise -> T.intercalate "\n" $ + map (\v -> spaces <> "- " <> prettyInline v) (V.toList arr) + Object obj + | KM.null obj -> "{}" + | otherwise -> T.intercalate "\n" $ + map (\(k, v) -> spaces <> K.toText k <> ": " <> prettyChild v) (KM.toList obj) + where + spaces = T.replicate indent " " + + -- For array items and object values, decide inline vs block + prettyChild v = case v of + Object o | not (KM.null o) -> "\n" <> prettyIndent (indent + 1) v + Array a | not (V.null a) -> "\n" <> prettyIndent (indent + 1) v + _ -> prettyInline v + + -- Inline rendering for simple values + prettyInline v = case v of + Null -> "null" + Bool True -> "true" + Bool False -> "false" + Number n -> case floatingOrInteger n of + Left d -> T.pack $ show (d :: Double) + Right i -> T.pack $ show (i :: Integer) + String s -> s + Array arr -> T.intercalate ", " $ map prettyInline (V.toList arr) + Object obj -> T.intercalate ", " $ + map (\(k, v') -> K.toText k <> ": " <> prettyInline v') (KM.toList obj) diff --git a/src/Synapse/Schema/Functor.hs b/src/Synapse/Schema/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Schema/Functor.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Base functor for schema trees +-- +-- This module defines the "shape" of one layer of a schema tree, +-- enabling proper recursion schemes (ana/cata/hylo). +-- +-- = The Functor +-- +-- @ +-- data SchemaF a +-- = PluginF PluginSchema [a] -- interior node: plugin with children +-- | MethodF MethodSchema Text -- leaf: method with namespace +-- @ +-- +-- The type parameter 'a' represents "what's in the recursive positions". +-- For a tree, 'a' would be the subtrees. For a fold result, 'a' would be +-- the accumulated value from children. +-- +-- = Fixed Point +-- +-- The fixed point @Fix SchemaF@ gives us the infinite tree type: +-- +-- @ +-- type SchemaTree = Fix SchemaF +-- @ +-- +-- This is isomorphic to a tree where every node is either a plugin +-- (with children) or a method (leaf). +module Synapse.Schema.Functor + ( -- * Base Functor + SchemaF(..) + + -- * Fixed Point + , Fix(..) + , SchemaTree + + -- * Seed for unfolding + , SchemaSeed(..) + + -- * Accessors + , nodeNamespace + , nodeMethods + ) where + +import Data.Text (Text) + +import Synapse.Schema.Types (PluginSchema(..), MethodSchema(..), Path) + +-- | Fixed point of a functor +-- +-- @Fix f@ is the type where @f@ refers to itself in recursive positions. +-- Unrolling: @Fix f ≅ f (Fix f) ≅ f (f (Fix f)) ≅ ...@ +newtype Fix f = Fix { unFix :: f (Fix f) } + +deriving instance Show (f (Fix f)) => Show (Fix f) +deriving instance Eq (f (Fix f)) => Eq (Fix f) + +-- | Base functor for schema trees +-- +-- Captures the "shape" of one layer: +-- - PluginF: interior node with plugin info and child positions +-- - MethodF: leaf with method info and parent namespace +data SchemaF a + = PluginF + { sfSchema :: PluginSchema -- ^ The plugin schema at this node + , sfPath :: Path -- ^ Path to this node + , sfChildren :: [a] -- ^ Recursive positions (children) + } + | MethodF + { sfMethod :: MethodSchema -- ^ The method schema + , sfNamespace :: Text -- ^ Parent namespace + , sfMethodPath :: Path -- ^ Full path to this method + } + deriving stock (Functor, Foldable, Traversable, Show, Eq) + +-- | The fixed point gives us schema trees +type SchemaTree = Fix SchemaF + +-- | Seed for anamorphic unfolding +-- Contains the path to fetch and any context needed +data SchemaSeed = SchemaSeed + { seedPath :: Path + } + deriving stock (Show, Eq) + +-- | Get the namespace from a schema node +nodeNamespace :: SchemaF a -> Text +nodeNamespace (PluginF schema _ _) = psNamespace schema +nodeNamespace (MethodF _ ns _) = ns + +-- | Get methods from a plugin node (empty for method nodes) +nodeMethods :: SchemaF a -> [MethodSchema] +nodeMethods (PluginF schema _ _) = psMethods schema +nodeMethods (MethodF _ _ _) = [] diff --git a/src/Synapse/Schema/Types.hs b/src/Synapse/Schema/Types.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Schema/Types.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | Core types for Synapse +-- +-- Re-exports schema types from plexus-protocol and defines local types. +module Synapse.Schema.Types + ( -- * Schema Types (from plexus-protocol) + PluginSchema(..) + , MethodSchema(..) + , ChildSummary(..) + , PluginHash + , SchemaResult(..) + + -- * Query helpers + , pluginChildren + , childNamespaces + , isHubActivation + , isLeafActivation + + -- * Navigation Types + , Path + , SchemaView(..) + , NavError(..) + + -- * Stream Types + , StreamMeta(..) + + -- * Hub Protocol Types + -- | Re-exported from Plexus.Types with Hub naming + , HubStreamItem + , pattern HubData + , pattern HubProgress + , pattern HubError + , pattern HubDone + , pattern HubGuidance + , pattern HubRequest + + -- * Bidirectional Types (re-exported) + , Request(..) + , StandardRequest + , Response(..) + , StandardResponse + , SelectOption(..) + ) where + +import Data.Aeson (Value) +import Data.Text (Text) +import Data.Int (Int64) +import GHC.Generics (Generic) + +-- Re-export from plexus-protocol +import Plexus.Schema.Recursive + ( PluginSchema(..) + , MethodSchema(..) + , ChildSummary(..) + , PluginHash + , SchemaResult(..) + , pluginChildren + , childNamespaces + , isHubActivation + , isLeafActivation + ) + +import Plexus.Types + ( PlexusStreamItem(..) + , Provenance + , GuidanceErrorType + , GuidanceSuggestion + , Request(..) + , StandardRequest + , Response(..) + , StandardResponse + , SelectOption(..) + ) + +-- | A path through the plugin tree (sequence of namespace segments) +type Path = [Text] + +-- | A position in the schema tree after navigation +data SchemaView + = ViewPlugin PluginSchema Path -- ^ Landed on a plugin, path taken to get here + | ViewMethod MethodSchema Path -- ^ Landed on a method, path taken to get here + deriving stock (Show, Eq) + +-- | Navigation errors +data NavError + = NotFound Text Path (Maybe PluginSchema) -- ^ Segment not found at path (with schema context) + | MethodNotTerminal Text Path -- ^ Method with trailing path segments + | Cycle PluginHash Path -- ^ Cycle detected (hash seen before) + | FetchError Text Path -- ^ Failed to fetch schema + deriving stock (Show, Eq) + +-- | Metadata from stream events +data StreamMeta = StreamMeta + { smProvenance :: [Text] + , smHash :: PluginHash + , smTimestamp :: Int64 + } + deriving stock (Show, Eq, Generic) + +-- ============================================================================ +-- Hub Protocol Types (re-exported from Plexus.Types with Hub naming) +-- ============================================================================ + +-- | Hub stream item - the universal transport envelope for streaming responses +-- +-- This is a type alias for 'PlexusStreamItem' from the protocol layer, +-- renamed to use Hub terminology at the application level. +type HubStreamItem = PlexusStreamItem + +-- | Pattern synonym for data events +pattern HubData :: Text -> Provenance -> Text -> Value -> HubStreamItem +pattern HubData hash prov contentType content = StreamData hash prov contentType content + +-- | Pattern synonym for progress events +pattern HubProgress :: Text -> Provenance -> Text -> Maybe Double -> HubStreamItem +pattern HubProgress hash prov msg pct = StreamProgress hash prov msg pct + +-- | Pattern synonym for error events +pattern HubError :: Text -> Provenance -> Text -> Bool -> HubStreamItem +pattern HubError hash prov err recoverable = StreamError hash prov err recoverable + +-- | Pattern synonym for done events +pattern HubDone :: Text -> Provenance -> HubStreamItem +pattern HubDone hash prov = StreamDone hash prov + +-- | Pattern synonym for guidance events +pattern HubGuidance :: Text -> Provenance -> GuidanceErrorType -> GuidanceSuggestion -> Maybe [Text] -> Maybe Value -> HubStreamItem +pattern HubGuidance hash prov errType suggestion methods schema = StreamGuidance hash prov errType suggestion methods schema + +-- | Pattern synonym for bidirectional request events +pattern HubRequest :: Text -> Provenance -> Text -> Request Value -> Int -> HubStreamItem +pattern HubRequest hash prov reqId reqData timeout = StreamRequest hash prov reqId reqData timeout diff --git a/src/Synapse/Self/Commands.hs b/src/Synapse/Self/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Commands.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Command dispatcher for _self meta-commands +-- +-- _self commands are client-side only and don't make RPC calls. +-- They operate on cached schemas and provide meta-functionality +-- like template generation, schema exploration, etc. +module Synapse.Self.Commands + ( dispatch + , showHelp + ) where + +import Control.Concurrent.Async (mapConcurrently) +import Control.Exception (SomeException, catch) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (asks) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Synapse.Monad +import Synapse.Backend.Discovery (getBackendAt) +import qualified Synapse.Self.Template as Template + +-- | Dispatch to a specific _self subcommand +dispatch :: Text -> [Text] -> [(Text, Text)] -> SynapseM () +dispatch "template" rest params = Template.handleTemplate rest params +dispatch "scan" rest _ = scanPorts rest +dispatch "--help" _ _ = showHelp +dispatch "-h" _ _ = showHelp +dispatch cmd _ _ = + throwParse $ "Unknown _self command: " <> cmd <> "\n\n" <> helpText + +-- | Scan ports for backends +-- Default range: 4440-4459 (covers 444x range) +scanPorts :: [Text] -> SynapseM () +scanPorts _ = do + host <- asks seHost + liftIO $ TIO.putStrLn $ "Scanning " <> host <> " ports 4440-4459 for backends...\n" + + -- Scan ports in parallel + let ports = [4440..4459] + results <- liftIO $ mapConcurrently (probePort host) ports + + -- Display results + let found = filter (\(_, mb) -> mb /= Nothing) (zip ports results) + if null found + then liftIO $ TIO.putStrLn "No backends found" + else do + liftIO $ TIO.putStrLn $ "Found " <> T.pack (show (length found)) <> " backend(s):\n" + liftIO $ mapM_ printResult found + where + probePort :: Text -> Int -> IO (Maybe Text) + probePort host port = + getBackendAt host port `catch` \(_ :: SomeException) -> pure Nothing + + printResult :: (Int, Maybe Text) -> IO () + printResult (port, Just name) = + TIO.putStrLn $ " " <> T.pack (show port) <> " " <> name + printResult _ = pure () + +-- | Show help for _self commands +showHelp :: SynapseM () +showHelp = liftIO $ TIO.putStr helpText + +-- | Help text for _self commands +helpText :: Text +helpText = T.unlines + [ "Meta-commands (local, no RPC):" + , "" + , "Available commands:" + , "" + , " synapse _self scan" + , " Scan ports 4440-4459 for backends (calls _info on each)" + , "" + , " synapse _self template" + , " Manage Mustache templates (CRUD operations)" + , "" + , " Subcommands:" + , " list [pattern] - List existing templates" + , " show - Display template content" + , " generate [pattern] - Generate new templates from IR" + , " delete - Delete templates matching pattern" + , " reload - Clear template cache" + , "" + , " Pattern format: backend.namespace.method" + , " Examples: 'plexus.cone.*', 'plexus.*.create'" + , "" + , "Examples:" + , " synapse _self scan" + , " synapse _self template list" + , " synapse _self template show cone.chat" + , " synapse _self template generate 'plexus.cone.*'" + , " synapse _self template delete 'plexus.cone.test'" + , "" + , "Templates location: ~/.config/synapse/templates/" + , "" + , "Use 'synapse _self template' for detailed template help" + , "" + ] diff --git a/src/Synapse/Self/Examples.hs b/src/Synapse/Self/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Examples.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Example value generation for CLI templates +-- +-- Generates realistic example values for different TypeRefs +-- to populate CLI command templates. +module Synapse.Self.Examples + ( generateExampleValue + , generateExampleParam + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Map.Strict as Map +import Synapse.IR.Types + +-- | Generate a realistic example value for a TypeRef +-- Returns the value in a format suitable for CLI usage +generateExampleValue :: IR -> TypeRef -> Text +generateExampleValue ir typeRef = case typeRef of + -- Primitives with format hints + RefPrimitive "string" (Just "uuid") -> + "550e8400-e29b-41d4-a716-446655440000" + RefPrimitive "string" (Just "date-time") -> + "2026-01-21T10:30:00Z" + RefPrimitive "string" _ -> + "example" + RefPrimitive "integer" _ -> "42" + RefPrimitive "number" _ -> "3.14" + RefPrimitive "boolean" _ -> "true" + + -- Named types - look up in IR + RefNamed qn -> case lookupTypeDef ir qn of + Just typeDef -> generateNamedTypeExample ir typeDef + Nothing -> "{}" -- Unknown type + + -- Collections and modifiers + RefArray inner -> + "'[" <> generateExampleValue ir inner <> "]'" + RefOptional inner -> + generateExampleValue ir inner + RefAny -> "{}" + RefUnknown -> "" + +-- | Generate example for a named type definition +generateNamedTypeExample :: IR -> TypeDef -> Text +generateNamedTypeExample ir typeDef = case tdKind typeDef of + -- String enums - show first value + KindStringEnum values -> case values of + (v:_) -> "\"" <> v <> "\"" + [] -> "\"value\"" + + -- Discriminated unions - show first variant as JSON + KindEnum disc variants -> case variants of + (v:_) -> formatVariantExample ir disc v + [] -> "{}" + + -- Structs - show empty object with hint + KindStruct _ -> "{}" + + -- Aliases - resolve to target + KindAlias target -> generateExampleValue ir target + + -- Primitives + KindPrimitive ptype fmt -> generateExampleValue ir (RefPrimitive ptype fmt) + +-- | Format a discriminated union variant as JSON +formatVariantExample :: IR -> Text -> VariantDef -> Text +formatVariantExample ir disc variant = + let typeField = "\\\"" <> disc <> "\\\":\\\"" <> vdName variant <> "\\\"" + fieldExamples = map (formatFieldExample ir) (vdFields variant) + allFields = typeField : fieldExamples + in "'{" <> T.intercalate "," allFields <> "}'" + +-- | Format a field as a JSON key-value pair +formatFieldExample :: IR -> FieldDef -> Text +formatFieldExample ir field = + "\\\"" <> fdName field <> "\\\":" <> simpleExample (fdType field) + where + simpleExample :: TypeRef -> Text + simpleExample = \case + RefPrimitive "string" _ -> "\\\"value\\\"" + RefPrimitive "integer" _ -> "42" + RefPrimitive "boolean" _ -> "true" + RefPrimitive "number" _ -> "3.14" + RefNamed qn -> case lookupTypeDef ir qn of + Just td -> case tdKind td of + KindStringEnum (v:_) -> "\\\"" <> v <> "\\\"" + _ -> "{}" + Nothing -> "{}" + _ -> "{}" + +-- | Generate a CLI parameter flag with example value +generateExampleParam :: IR -> ParamDef -> Text +generateExampleParam ir param = + "--" <> pdName param <> " " <> generateExampleValue ir (pdType param) + +-- | Look up a type definition in the IR by qualified name +lookupTypeDef :: IR -> QualifiedName -> Maybe TypeDef +lookupTypeDef ir qn = + Map.lookup (qualifiedNameFull qn) (irTypes ir) diff --git a/src/Synapse/Self/Pattern.hs b/src/Synapse/Self/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Pattern.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Pattern matching for method filtering +-- +-- Supports glob-style patterns with wildcards: +-- - plexus.cone.* - matches all methods in cone +-- - plexus.*.create - matches create methods in all activations +-- - plexus.(cone|arbor).* - regex patterns for complex matching +module Synapse.Self.Pattern + ( MethodPattern(..) + , parsePattern + , matchMethods + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Text.Regex.TDFA ((=~)) +import Synapse.IR.Types (MethodDef(..)) + +-- | A compiled pattern for matching method paths +data MethodPattern = MethodPattern + { mpRawPattern :: Text -- ^ Original pattern text + , mpRegex :: Text -- ^ Compiled regex pattern + } + deriving stock (Show, Eq) + +-- | Parse a pattern string into a MethodPattern +-- Converts glob-style wildcards to regex: +-- * -> [^.]+ (matches any segment) +-- . -> \. (literal dot) +parsePattern :: Text -> Either Text MethodPattern +parsePattern raw = do + let regex = patternToRegex raw + Right $ MethodPattern raw regex + +-- | Convert a glob-style pattern to a PCRE regex +-- Examples: +-- "plexus.cone.*" -> "^plexus\.cone\.[^.]+$" +-- "plexus.*.create" -> "^plexus\.[^.]+\.create$" +patternToRegex :: Text -> Text +patternToRegex pattern = + let escaped = T.replace "." "\\." pattern -- Escape dots first + withWildcards = T.replace "*" "[^.]+" escaped -- Replace * with segment matcher + in "^" <> withWildcards <> "$" -- Anchor at both ends + +-- | Filter methods that match the pattern +matchMethods :: MethodPattern -> [MethodDef] -> [MethodDef] +matchMethods (MethodPattern _ regex) methods = + filter (\m -> T.unpack (mdFullPath m) =~ T.unpack regex) methods diff --git a/src/Synapse/Self/Template.hs b/src/Synapse/Self/Template.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Template.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | CRUD operations for Mustache templates +-- +-- Provides commands to manage the template system: +-- - list: List existing templates (with pattern filtering) +-- - show: Display template content +-- - generate: Generate new templates from IR +-- - delete: Remove templates +-- - reload: Clear template cache and notify backend +module Synapse.Self.Template + ( handleTemplate + ) where + +import Control.Monad (forM_, when, unless, filterM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (asks) +import Data.List (sort) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import System.Directory (doesFileExist, getHomeDirectory, removeFile, listDirectory, doesDirectoryExist, createDirectoryIfMissing) +import System.FilePath ((), (<.>), takeExtension, dropExtension, splitDirectories, joinPath) + +import Synapse.Monad +import Synapse.Self.Pattern (MethodPattern(..), parsePattern, matchMethods) +import qualified Synapse.CLI.Template as CLITemplate +import Synapse.IR.Types (MethodDef(..)) +import qualified Data.Map.Strict as Map +import Text.Regex.TDFA ((=~)) + +-- ============================================================================ +-- Main Entry Point +-- ============================================================================ + +-- | Handle template subcommands +handleTemplate :: [Text] -> [(Text, Text)] -> SynapseM () +handleTemplate [] _ = do + -- No subcommand - show help + liftIO $ TIO.putStr templateHelp + +handleTemplate ("list" : rest) params = do + backend <- asks seBackend + let patternText = case rest of + [] -> backend <> ".*.*" -- Default includes backend + segs -> T.intercalate "." segs + templateList patternText + +handleTemplate ("show" : rest) _ = do + case rest of + [] -> throwParse "Missing method path for 'show' command\nUsage: synapse _self template show " + segs -> templateShow (T.intercalate "." segs) + +handleTemplate ("generate" : rest) params = do + backend <- asks seBackend + let patternText = case rest of + [] -> backend <> ".*.*" -- Default includes backend + segs -> T.intercalate "." segs + templateGenerate patternText params + +handleTemplate ("delete" : rest) _ = do + case rest of + [] -> throwParse "Missing pattern for 'delete' command\nUsage: synapse _self template delete " + segs -> templateDelete (T.intercalate "." segs) + +handleTemplate ("reload" : _) _ = do + templateReload + +handleTemplate (cmd : _) _ = do + throwParse $ "Unknown template subcommand: " <> cmd <> "\n\n" <> templateHelp + +-- ============================================================================ +-- Template List +-- ============================================================================ + +templateList :: Text -> SynapseM () +templateList patternText = do + backend <- asks seBackend + + -- Parse pattern + pattern <- case parsePattern patternText of + Left err -> throwParse err + Right p -> pure p + + -- Get template base directory + homeDir <- liftIO getHomeDirectory + let baseDir = homeDir ".config" "synapse" "templates" + + -- Check if templates directory exists + exists <- liftIO $ doesDirectoryExist baseDir + unless exists $ do + liftIO $ TIO.putStrLn $ "No templates directory found at: " <> T.pack baseDir + liftIO $ TIO.putStrLn "Generate templates with: synapse --generate-templates" + return () + + -- Find all template files + templateFiles <- liftIO $ findTemplateFiles baseDir + + -- Filter by pattern + let qualifiedPaths = map (\(ns, m) -> backend <> "." <> ns <> "." <> m) templateFiles + let matchingPaths = filter (\path -> T.unpack path `matchPattern` pattern) qualifiedPaths + let matchingFiles = [(ns, m) | ((ns, m), qpath) <- zip templateFiles qualifiedPaths, qpath `elem` matchingPaths] + + -- Display results + liftIO $ do + if null matchingFiles + then TIO.putStrLn $ "No templates match pattern: " <> patternText + else do + TIO.putStrLn $ "Found " <> T.pack (show (length matchingFiles)) <> " template(s):\n" + forM_ (sort matchingFiles) $ \(namespace, method) -> do + let path = baseDir T.unpack namespace T.unpack method <.> "mustache" + TIO.putStrLn $ " " <> backend <> "." <> namespace <> "." <> method + TIO.putStrLn $ " " <> T.pack path + +-- Helper to check if a string matches a pattern +matchPattern :: String -> MethodPattern -> Bool +matchPattern str (MethodPattern _ regex) = str =~ T.unpack regex + +-- ============================================================================ +-- Template Show +-- ============================================================================ + +templateShow :: Text -> SynapseM () +templateShow methodPath = do + backend <- asks seBackend + + -- Strip backend prefix if present + let pathWithoutBackend = case T.stripPrefix (backend <> ".") methodPath of + Just p -> p + Nothing -> methodPath + + -- Split into namespace.method + case T.splitOn "." pathWithoutBackend of + [namespace, method] -> do + homeDir <- liftIO getHomeDirectory + let templatePath = homeDir ".config" "synapse" "templates" + T.unpack namespace T.unpack method <.> "mustache" + + exists <- liftIO $ doesFileExist templatePath + if exists + then do + content <- liftIO $ TIO.readFile templatePath + liftIO $ do + TIO.putStrLn $ "Template: " <> backend <> "." <> namespace <> "." <> method + TIO.putStrLn $ "Location: " <> T.pack templatePath + TIO.putStrLn $ T.replicate 60 "━" + TIO.putStr content + when (not $ T.null content && T.last content == '\n') $ + TIO.putStrLn "" + else throwParse $ "Template not found: " <> methodPath <> "\nPath: " <> T.pack templatePath + + _ -> throwParse $ "Invalid method path: " <> methodPath <> "\nExpected format: namespace.method" + +-- ============================================================================ +-- Template Generate +-- ============================================================================ + +templateGenerate :: Text -> [(Text, Text)] -> SynapseM () +templateGenerate patternText params = do + backend <- asks seBackend + homeDir <- liftIO getHomeDirectory + let baseDir = homeDir ".config" "synapse" "templates" + + -- Strip backend prefix if present for IR generation + let pathWithoutBackend = case T.stripPrefix (backend <> ".") patternText of + Just p -> p + Nothing -> patternText + + -- Parse pattern to determine what to generate + pattern <- case parsePattern patternText of + Left err -> throwParse err + Right p -> pure p + + liftIO $ TIO.putStrLn $ "Generating templates in " <> T.pack baseDir <> "..." + + -- Use existing CLI.Template generation with callback + let writeAndLog gt = do + let fullPath = baseDir CLITemplate.gtPath gt + createDirectoryIfMissing True (baseDir T.unpack (CLITemplate.gtNamespace gt)) + TIO.writeFile fullPath (CLITemplate.gtTemplate gt) + TIO.putStrLn $ " " <> backend <> "." <> CLITemplate.gtNamespace gt <> "." <> CLITemplate.gtMethod gt + + -- Generate all templates (filtering will happen based on path) + count <- CLITemplate.generateAllTemplatesWithCallback writeAndLog [] + + liftIO $ TIO.putStrLn $ "\nGenerated " <> T.pack (show count) <> " template(s)" + +-- ============================================================================ +-- Template Delete +-- ============================================================================ + +templateDelete :: Text -> SynapseM () +templateDelete patternText = do + backend <- asks seBackend + + -- Parse pattern + pattern <- case parsePattern patternText of + Left err -> throwParse err + Right p -> pure p + + -- Get template base directory + homeDir <- liftIO getHomeDirectory + let baseDir = homeDir ".config" "synapse" "templates" + + -- Find all template files + templateFiles <- liftIO $ findTemplateFiles baseDir + + -- Filter by pattern + let qualifiedPaths = map (\(ns, m) -> backend <> "." <> ns <> "." <> m) templateFiles + let matchingPaths = filter (\path -> T.unpack path `matchPattern` pattern) qualifiedPaths + let matchingFiles = [(ns, m, path) | ((ns, m), qpath) <- zip templateFiles qualifiedPaths, qpath `elem` matchingPaths, + let path = baseDir T.unpack ns T.unpack m <.> "mustache"] + + -- Confirm deletion + liftIO $ do + if null matchingFiles + then TIO.putStrLn $ "No templates match pattern: " <> patternText + else do + TIO.putStrLn $ "Will delete " <> T.pack (show (length matchingFiles)) <> " template(s):" + forM_ matchingFiles $ \(ns, m, _) -> + TIO.putStrLn $ " " <> backend <> "." <> ns <> "." <> m + + -- Delete files + forM_ matchingFiles $ \(ns, m, path) -> do + removeFile path + TIO.putStrLn $ "Deleted: " <> backend <> "." <> ns <> "." <> m + +-- ============================================================================ +-- Template Reload +-- ============================================================================ + +templateReload :: SynapseM () +templateReload = do + -- Clear local cache (if we had one) + liftIO $ TIO.putStrLn "Template cache cleared" + + -- TODO: Call backend reload endpoint when available + -- For now, just notify the user + liftIO $ TIO.putStrLn "Note: Backend template reload endpoint not yet implemented" + +-- ============================================================================ +-- Helpers +-- ============================================================================ + +-- | Find all template files in the templates directory +-- Returns list of (namespace, method) tuples +findTemplateFiles :: FilePath -> IO [(Text, Text)] +findTemplateFiles baseDir = do + exists <- doesDirectoryExist baseDir + if not exists + then return [] + else do + namespaces <- listDirectory baseDir + concat <$> mapM findInNamespace namespaces + where + findInNamespace :: FilePath -> IO [(Text, Text)] + findInNamespace namespace = do + let nsDir = baseDir namespace + isDir <- doesDirectoryExist nsDir + if not isDir + then return [] + else do + files <- listDirectory nsDir + let templateFiles = filter (\f -> takeExtension f == ".mustache") files + let methods = map (T.pack . dropExtension) templateFiles + return [(T.pack namespace, m) | m <- methods] + +-- ============================================================================ +-- Help Text +-- ============================================================================ + +templateHelp :: Text +templateHelp = T.unlines + [ "Template CRUD commands:" + , "" + , " synapse _self template list [pattern]" + , " List existing templates" + , " Pattern: backend.namespace.method (e.g., 'plexus.cone.*')" + , " Default: '*.*' (all templates)" + , "" + , " synapse _self template show " + , " Display template content" + , " Example: synapse _self template show cone.chat" + , "" + , " synapse _self template generate [pattern]" + , " Generate new templates from IR" + , " Pattern: backend.namespace.method (e.g., 'plexus.cone.*')" + , " Default: '*.*' (all methods)" + , "" + , " synapse _self template delete " + , " Delete templates matching pattern" + , " Example: synapse _self template delete 'plexus.cone.*'" + , "" + , " synapse _self template reload" + , " Clear template cache and notify backend" + , "" + , "Templates are stored in: ~/.config/synapse/templates/" + , "" + ] diff --git a/src/Synapse/Transport.hs b/src/Synapse/Transport.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Transport.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Transport layer for Synapse +-- +-- Bridges the low-level Substrate transport to the SynapseM monad. +module Synapse.Transport + ( -- * Schema Fetching + fetchSchema + , fetchSchemaAt + , fetchMethodSchema + + -- * Method Invocation (collected) + , invoke + , invokeRaw + + -- * Method Invocation (streaming) + , invokeStreaming + , invokeStreamingWithBidir + + -- * Bidirectional Response + , sendResponse + ) where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (asks) +import Data.Aeson (Value) +import Data.Text (Text) +import qualified Data.Text as T + +import Plexus.Client (SubstrateConfig(..)) +import qualified Plexus.Transport as ST +import qualified Plexus.Types as PT + +import Synapse.Schema.Types +import Synapse.Monad + +-- | Fetch the root schema +fetchSchema :: SynapseM PluginSchema +fetchSchema = fetchSchemaAt [] + +-- | Convert plexus-protocol TransportError to error message +transportErrorToText :: PT.TransportError -> Text +transportErrorToText (PT.ConnectionRefused host port) = + "Connection refused to " <> host <> ":" <> T.pack (show port) +transportErrorToText (PT.ConnectionTimeout host port) = + "Connection timeout to " <> host <> ":" <> T.pack (show port) +transportErrorToText (PT.ProtocolError msg) = "Protocol error: " <> msg +transportErrorToText (PT.NetworkError msg) = "Network error: " <> msg + +-- | Convert plexus-protocol TransportError to TransportCategory +transportErrorToCategory :: PT.TransportError -> TransportErrorCategory +transportErrorToCategory (PT.ConnectionRefused _ _) = ConnectionRefused +transportErrorToCategory (PT.ConnectionTimeout _ _) = ConnectionTimeout +transportErrorToCategory (PT.ProtocolError _) = ProtocolError +transportErrorToCategory (PT.NetworkError _) = UnknownTransportError + +-- | Fetch schema at a specific path +fetchSchemaAt :: Path -> SynapseM PluginSchema +fetchSchemaAt path = do + cfg <- getConfig + result <- liftIO $ ST.fetchSchemaAt cfg path + case result of + Left err -> throwNav $ FetchError (transportErrorToText err) path + Right schema -> pure schema + +-- | Fetch a specific method's schema (more efficient than full plugin schema) +-- Uses the parameter-based query: plugin.schema with {"method": "name"} +fetchMethodSchema :: Path -> Text -> SynapseM MethodSchema +fetchMethodSchema path methodName = do + cfg <- getConfig + result <- liftIO $ ST.fetchMethodSchemaAt cfg path methodName + case result of + Left err -> throwNav $ FetchError (transportErrorToText err) path + Right schema -> pure schema + +-- | Invoke a method and return stream items +invoke :: Path -> Text -> Value -> SynapseM [HubStreamItem] +invoke namespacePath method params = do + cfg <- getConfig + result <- liftIO $ ST.invokeMethod cfg namespacePath method params + case result of + Left transportErr -> do + -- Build context from typed transport error and environment + backend <- asks seBackend + let path = namespacePath ++ [method] + let ctx = TransportContext + { tcMessage = transportErrorToText transportErr + , tcHost = getHost transportErr cfg + , tcPort = getPort transportErr cfg + , tcBackend = backend + , tcPath = path + , tcCategory = transportErrorToCategory transportErr + } + throwTransportWith ctx + Right items -> pure items + where + getHost (PT.ConnectionRefused h _) _ = h + getHost (PT.ConnectionTimeout h _) _ = h + getHost _ c = T.pack $ substrateHost c + getPort (PT.ConnectionRefused _ p) _ = p + getPort (PT.ConnectionTimeout _ p) _ = p + getPort _ c = substratePort c + +-- | Invoke with raw method path +invokeRaw :: Text -> Value -> SynapseM [HubStreamItem] +invokeRaw method params = do + cfg <- getConfig + result <- liftIO $ ST.invokeRaw cfg method params + case result of + Left transportErr -> do + -- Build context from typed transport error and environment + backend <- asks seBackend + let path = T.splitOn "." method + let ctx = TransportContext + { tcMessage = transportErrorToText transportErr + , tcHost = getHost transportErr cfg + , tcPort = getPort transportErr cfg + , tcBackend = backend + , tcPath = path + , tcCategory = transportErrorToCategory transportErr + } + throwTransportWith ctx + Right items -> pure items + where + getHost (PT.ConnectionRefused h _) _ = h + getHost (PT.ConnectionTimeout h _) _ = h + getHost _ c = T.pack $ substrateHost c + getPort (PT.ConnectionRefused _ p) _ = p + getPort (PT.ConnectionTimeout _ p) _ = p + getPort _ c = substratePort c + +-- | Invoke a method with streaming output - calls callback for each item +invokeStreaming :: Path -> Text -> Value -> (HubStreamItem -> IO ()) -> SynapseM () +invokeStreaming namespacePath method params onItem = do + cfg <- getConfig + result <- liftIO $ ST.invokeMethodStreaming cfg namespacePath method params onItem + case result of + Left transportErr -> do + -- Build context from typed transport error and environment + backend <- asks seBackend + let path = namespacePath ++ [method] + let ctx = TransportContext + { tcMessage = transportErrorToText transportErr + , tcHost = getHost transportErr cfg + , tcPort = getPort transportErr cfg + , tcBackend = backend + , tcPath = path + , tcCategory = transportErrorToCategory transportErr + } + throwTransportWith ctx + Right () -> pure () + where + getHost (PT.ConnectionRefused h _) _ = h + getHost (PT.ConnectionTimeout h _) _ = h + getHost _ c = T.pack $ substrateHost c + getPort (PT.ConnectionRefused _ p) _ = p + getPort (PT.ConnectionTimeout _ p) _ = p + getPort _ c = substratePort c + +-- | Invoke a method with streaming output and bidirectional request handling +-- When a StreamRequest is received, the bidirectional handler is called and +-- the response is sent back via {backend}.respond (if the handler returns Just). +-- If the handler returns Nothing (BidirRespond mode), no response is sent immediately. +invokeStreamingWithBidir + :: Path + -> Text + -> Value + -> (HubStreamItem -> IO ()) -- ^ Handler for non-request items + -> (Text -> PT.Request Value -> IO (Maybe (PT.Response Value))) -- ^ Handler for bidirectional requests + -> SynapseM () +invokeStreamingWithBidir namespacePath method params onItem onBidirRequest = do + cfg <- getConfig + let wrappedHandler item = case item of + PT.StreamRequest _ _ reqId reqData _timeout -> do + -- Handle the bidirectional request + mResponse <- onBidirRequest reqId reqData + -- Send the response back via {backend}.respond (if present) + case mResponse of + Just response -> do + _ <- ST.sendBidirectionalResponse cfg reqId response + pure () + Nothing -> pure () -- agent will respond via separate call + _ -> onItem item + result <- liftIO $ ST.invokeMethodStreaming cfg namespacePath method params wrappedHandler + case result of + Left transportErr -> do + backend <- asks seBackend + let path = namespacePath ++ [method] + let ctx = TransportContext + { tcMessage = transportErrorToText transportErr + , tcHost = getHost transportErr cfg + , tcPort = getPort transportErr cfg + , tcBackend = backend + , tcPath = path + , tcCategory = transportErrorToCategory transportErr + } + throwTransportWith ctx + Right () -> pure () + where + getHost (PT.ConnectionRefused h _) _ = h + getHost (PT.ConnectionTimeout h _) _ = h + getHost _ c = T.pack $ substrateHost c + getPort (PT.ConnectionRefused _ p) _ = p + getPort (PT.ConnectionTimeout _ p) _ = p + getPort _ c = substratePort c + +-- | Send a response for a bidirectional request +sendResponse :: Text -> PT.Response Value -> SynapseM () +sendResponse requestId response = do + cfg <- getConfig + result <- liftIO $ ST.sendBidirectionalResponse cfg requestId response + case result of + Left transportErr -> do + backend <- asks seBackend + let ctx = TransportContext + { tcMessage = transportErrorToText transportErr + , tcHost = T.pack $ substrateHost cfg + , tcPort = substratePort cfg + , tcBackend = backend + , tcPath = ["respond"] + , tcCategory = transportErrorToCategory transportErr + } + throwTransportWith ctx + Right () -> pure () + +-- | Get SubstrateConfig from environment +getConfig :: SynapseM SubstrateConfig +getConfig = do + host <- asks seHost + port <- asks sePort + backend <- asks seBackend + pure $ SubstrateConfig + { substrateHost = T.unpack host + , substratePort = port + , substratePath = "/" + , substrateBackend = backend + } diff --git a/test/CLISpec.hs b/test/CLISpec.hs new file mode 100644 --- /dev/null +++ b/test/CLISpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | CLI integration tests +-- +-- Pattern: args `has` ["expected", "substrings"] +module Main where + +import Data.Text (Text) +import qualified Data.Text as T +import System.Process (readProcess) +import Test.Hspec + +main :: IO () +main = hspec $ do + + describe "navigation" $ do + it "root" $ ["--help"] `has` ["synapse", "plexus"] + it "plexus" $ ["plexus"] `has` ["echo", "solar", "health"] + it "echo" $ ["plexus", "echo"] `has` ["echo", "Echo messages back"] + it "solar" $ ["plexus", "solar"] `has` ["solar", "Solar system model"] + it "health" $ ["plexus", "health"] `has` ["health", "Check hub health"] + it "solar earth" $ ["plexus", "solar", "earth"] `has` ["earth", "planet"] + it "solar earth luna" $ ["plexus", "solar", "earth", "luna"] `has` ["luna", "Moon"] + + describe "method help" $ do + it "echo once" $ ["plexus", "echo", "once"] `has` ["once", "--message", "required"] + it "echo echo" $ ["plexus", "echo", "echo"] `has` ["--message", "--count"] + -- health.check has no required params, so it auto-invokes + it "health check" $ ["plexus", "health", "check"] `has` ["healthy"] + + describe "invocation" $ do + it "echo once" $ call ["plexus", "echo", "once"] (msg "test") `has` ["test"] + it "echo count" $ call ["plexus", "echo", "echo"] (msgN "hi" 2) `has` ["hi", "2"] + it "health" $ callRaw ["plexus", "health", "check"] "{}" `has` ["healthy"] + it "solar observe" $ callRaw ["plexus", "solar", "observe"] "{}" `has` ["sol", "planet_count"] + it "luna info" $ callRaw ["plexus", "solar", "earth", "luna", "info"] "{}" `has` ["luna"] + +-- ============================================================================ +-- Harness +-- ============================================================================ + +synapse :: FilePath +synapse = "dist-newstyle/build/aarch64-osx/ghc-9.6.7/plexus-synapse-0.2.0.0/x/synapse/build/synapse/synapse" + +-- | Assert synapse output contains all substrings +has :: [String] -> [Text] -> Expectation +has = checkOutput synapse + +-- | Generic output checker +checkOutput :: FilePath -> [String] -> [Text] -> Expectation +checkOutput bin args expected = do + out <- T.pack <$> readProcess bin args "" + mapM_ (assertContains out) expected + +assertContains :: Text -> Text -> Expectation +assertContains haystack needle = + T.toLower haystack `shouldSatisfy` T.isInfixOf (T.toLower needle) + +-- | Build invocation args +call :: [String] -> String -> [String] +call path params = path ++ ["-p", params] + +-- | Build invocation args with --raw (skip templates) +-- Note: --raw must come after "plexus" subcommand +callRaw :: [String] -> String -> [String] +callRaw (backend:rest) params = [backend, "--raw"] ++ rest ++ ["-p", params] +callRaw [] params = ["-p", params] -- fallback, shouldn't happen + +-- | JSON builders +msg :: String -> String +msg m = "{\"message\":\"" <> m <> "\"}" + +msgN :: String -> Int -> String +msgN m n = "{\"message\":\"" <> m <> "\",\"count\":" <> show n <> "}" diff --git a/test/IRSpec.hs b/test/IRSpec.hs new file mode 100644 --- /dev/null +++ b/test/IRSpec.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Integration tests for IR-based CLI +-- +-- Requires a running Hub backend on localhost:4444 +-- +-- Usage: cabal test ir-test --test-options=" [--port ]" +-- Example: cabal test ir-test --test-options="plexus" +-- cabal test ir-test --test-options="plexus --port 5555" +-- +-- Tests that for every method in the schema: +-- 1. IR builds successfully +-- 2. All type references resolve +-- 3. Help renders without error +-- 4. Support check returns a valid level +module Main where + +import Control.Monad (forM_, unless) +import Data.Aeson (encode, decode) +import qualified Data.ByteString.Lazy as BSL +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust, isNothing) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import System.Environment (getArgs, withArgs) +import Test.Hspec +import Text.Read (readMaybe) + +import Synapse.IR.Types +import Synapse.IR.Builder (buildIR) +import Synapse.CLI.Help (renderMethodHelp, expandType) +import Synapse.CLI.Support (SupportLevel(..), methodSupport) +import Synapse.Monad + +main :: IO () +main = do + args <- getArgs + case parseArgs args of + Nothing -> do + putStrLn "Usage: ir-test [--port ]" + putStrLn "Example: cabal test ir-test --test-options=\"plexus\"" + error "Backend argument required" + Just (backend, port) -> do + putStrLn $ "Running IR integration tests against localhost:" <> show port <> " (backend: " <> T.unpack backend <> ")" + + -- Initialize environment + env <- initEnv "127.0.0.1" port backend + + -- Build IR once for all tests + irResult <- runSynapseM env (buildIR []) + + case irResult of + Left err -> do + putStrLn $ "Failed to build IR: " <> show err + putStrLn "Is the Hub backend running?" + -- Run minimal spec that reports the failure + hspec $ describe "IR Integration Tests" $ + it "connects to Hub backend" $ + expectationFailure $ "Could not connect: " <> show err + + Right ir -> withArgs [] $ hspec $ irSpec ir + +-- | Parse command-line arguments: [--port ] +parseArgs :: [String] -> Maybe (Text, Int) +parseArgs [] = Nothing +parseArgs (backend:rest) = Just (T.pack backend, parsePort rest) + where + parsePort ("--port":p:_) = maybe 4444 id (readMaybe p) + parsePort _ = 4444 + +-- | Main spec using pre-built IR +irSpec :: IR -> Spec +irSpec ir = do + describe "Schema fetching" $ do + it "builds IR from root" $ + irVersion ir `shouldBe` "2.0" + + it "IR contains methods" $ + Map.size (irMethods ir) `shouldSatisfy` (> 0) + + it "IR contains types" $ + -- Some methods may not have complex types, but we expect at least some + Map.size (irTypes ir) `shouldSatisfy` (>= 0) + + it "IR contains plugins" $ + Map.size (irPlugins ir) `shouldSatisfy` (> 0) + + describe "Method coverage" $ do + it "all methods have help text" $ + forM_ (Map.elems $ irMethods ir) $ \method -> do + let helpText = renderMethodHelp ir method + T.length helpText `shouldSatisfy` (> 0) + -- Help should contain method name + helpText `shouldSatisfy` T.isInfixOf (mdFullPath method) + + it "all type refs resolve" $ + forM_ (Map.elems $ irMethods ir) $ \method -> do + -- Check each param's type ref + forM_ (mdParams method) $ \param -> do + let typeRef = pdType param + checkTypeRefResolves ir (mdFullPath method) (pdName param) typeRef + + it "all methods have support level" $ + forM_ (Map.elems $ irMethods ir) $ \method -> do + let support = methodSupport ir method + -- Support level should be valid (not crash) + case support of + FullSupport -> pure () + PartialSupport params -> length params `shouldSatisfy` (>= 0) + NoSupport params -> length params `shouldSatisfy` (> 0) + + describe "QualifiedName serialization" $ do + it "serializes to structured JSON" $ do + let qn = QualifiedName { qnNamespace = "cone", qnLocalName = "UUID" } + let typeRef = RefNamed qn + let json = encode typeRef + -- Check that JSON contains expected structure + let jsonText = decodeUtf8 (BSL.toStrict json) + jsonText `shouldSatisfy` T.isInfixOf "qnNamespace" + jsonText `shouldSatisfy` T.isInfixOf "qnLocalName" + jsonText `shouldSatisfy` T.isInfixOf "cone" + jsonText `shouldSatisfy` T.isInfixOf "UUID" + + it "serializes QualifiedName with empty namespace" $ do + let qn = QualifiedName { qnNamespace = "", qnLocalName = "GlobalType" } + let typeRef = RefNamed qn + let json = encode typeRef + let jsonText = decodeUtf8 (BSL.toStrict json) + jsonText `shouldSatisfy` T.isInfixOf "GlobalType" + -- Empty namespace should still be present in JSON + jsonText `shouldSatisfy` T.isInfixOf "qnNamespace" + + it "qualifiedNameFull handles namespaces correctly" $ do + qualifiedNameFull (QualifiedName "ns" "Type") `shouldBe` "ns.Type" + qualifiedNameFull (QualifiedName "" "Type") `shouldBe` "Type" + + it "shows expected JSON format" $ do + -- Test exact JSON format by printing it + let qn = QualifiedName { qnNamespace = "test", qnLocalName = "MyType" } + let typeRef = RefNamed qn + let jsonText = decodeUtf8 (BSL.toStrict (encode typeRef)) + -- Should have "tag" and "contents" for sum type + jsonText `shouldSatisfy` T.isInfixOf "RefNamed" + jsonText `shouldSatisfy` T.isInfixOf "contents" + + describe "Specific methods" $ do + -- Test cone.chat if it exists (has ConeIdentifier discriminated union) + case Map.lookup "cone.chat" (irMethods ir) of + Nothing -> it "cone.chat exists (skipped - not found)" pending + Just method -> do + it "cone.chat has identifier param" $ + any (\p -> pdName p == "identifier") (mdParams method) `shouldBe` True + + it "cone.chat expands ConeIdentifier" $ do + let mIdentifier = filter (\p -> pdName p == "identifier") (mdParams method) + case mIdentifier of + [] -> expectationFailure "identifier param not found" + (p:_) -> do + let expansion = expandType ir "identifier" (pdType p) + -- Should have expansion for discriminated union + length expansion `shouldSatisfy` (> 0) + -- Should contain "Either:" for union types + any (T.isInfixOf "Either") expansion `shouldBe` True + + -- Test echo.once if it exists (simple params) + case Map.lookup "echo.once" (irMethods ir) of + Nothing -> it "echo.once exists (skipped - not found)" pending + Just method -> do + it "echo.once has simple params" $ + -- echo.once should have FullSupport since it only has primitives + case methodSupport ir method of + FullSupport -> pure () + other -> expectationFailure $ "Expected FullSupport, got: " <> show other + + it "echo.once has message param" $ + any (\p -> pdName p == "message") (mdParams method) `shouldBe` True + + describe "Type resolution" $ do + it "no dangling RefNamed in params" $ + forM_ (Map.elems $ irMethods ir) $ \method -> + forM_ (mdParams method) $ \param -> + case getUnresolvedRefs ir (pdType param) of + [] -> pure () + refs -> expectationFailure $ T.unpack $ + "Unresolved refs in " <> mdFullPath method <> "." <> pdName param <> + ": " <> T.intercalate ", " refs + + it "reports unresolved return type refs (informational)" $ do + -- Collect all unresolved return type refs + let unresolvedReturns = + [ (mdFullPath method, refs) + | method <- Map.elems (irMethods ir) + , let refs = getUnresolvedRefs ir (mdReturns method) + , not (null refs) + ] + -- Report them if any, but don't fail - some methods have simple return types + -- that reference types defined elsewhere (like SchemaResult from health.schema) + unless (null unresolvedReturns) $ do + -- Print for informational purposes + forM_ unresolvedReturns $ \(methodPath, refs) -> + putStrLn $ " [info] " <> T.unpack methodPath <> + " has unresolved return refs: " <> T.unpack (T.intercalate ", " refs) + -- Success - this test is informational only + pure () + +-- | Check that a TypeRef resolves (if named, exists in irTypes) +checkTypeRefResolves :: IR -> Text -> Text -> TypeRef -> Expectation +checkTypeRefResolves ir methodPath paramName = \case + RefNamed qn -> do + let name = qualifiedNameFull qn + unless (Map.member name (irTypes ir)) $ + expectationFailure $ T.unpack $ + "Unresolved type ref: " <> name <> + " in " <> methodPath <> "." <> paramName + RefArray inner -> checkTypeRefResolves ir methodPath paramName inner + RefOptional inner -> checkTypeRefResolves ir methodPath paramName inner + RefPrimitive _ _ -> pure () + RefAny -> pure () + RefUnknown -> pure () -- Unknown is valid (just means schema gap) + +-- | Check that no RefNamed references are unresolved +checkNoUnresolvedRefs :: IR -> TypeRef -> Bool +checkNoUnresolvedRefs ir = \case + RefNamed qn -> Map.member (qualifiedNameFull qn) (irTypes ir) + RefArray inner -> checkNoUnresolvedRefs ir inner + RefOptional inner -> checkNoUnresolvedRefs ir inner + RefPrimitive _ _ -> True + RefAny -> True + RefUnknown -> True + +-- | Get list of unresolved RefNamed names +getUnresolvedRefs :: IR -> TypeRef -> [Text] +getUnresolvedRefs ir = \case + RefNamed qn -> + let name = qualifiedNameFull qn + in if Map.member name (irTypes ir) + then [] + else [name] + RefArray inner -> getUnresolvedRefs ir inner + RefOptional inner -> getUnresolvedRefs ir inner + RefPrimitive _ _ -> [] + RefAny -> [] + RefUnknown -> [] diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs new file mode 100644 --- /dev/null +++ b/test/ParseSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Unit tests for CLI parameter parsing +module Main where + +import Data.Aeson (Value(..), object) +import qualified Data.Aeson.Key as K +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Vector as V +import Test.Hspec + +import Synapse.CLI.Parse +import Synapse.IR.Types + +main :: IO () +main = hspec $ do + describe "groupByPrefix" $ do + it "groups dotted keys by prefix" $ do + let input = [("identifier.type", "by_name"), ("identifier.name", "foo"), ("prompt", "hi")] + let expected = Map.fromList + [ ("identifier", [("type", "by_name"), ("name", "foo")]) + , ("prompt", [("", "hi")]) + ] + groupByPrefix input `shouldBe` expected + + it "collects repeated keys for arrays" $ do + let input = [("tags", "backend"), ("tags", "critical"), ("tags", "urgent")] + let expected = Map.fromList + [ ("tags", [("", "backend"), ("", "critical"), ("", "urgent")]) + ] + groupByPrefix input `shouldBe` expected + + describe "buildParamValue with arrays" $ do + let emptyIR = IR + { irVersion = "2.0" + , irHash = Nothing + , irTypes = Map.empty + , irMethods = Map.empty + , irPlugins = Map.empty + } + + it "builds string array from repeated values" $ do + let param = ParamDef + { pdName = "tags" + , pdType = RefArray (RefPrimitive "string" Nothing) + , pdDescription = Nothing + , pdRequired = True + , pdDefault = Nothing + } + let kvs = [("", "backend"), ("", "critical"), ("", "urgent")] + let expected = Right $ Array $ V.fromList [String "backend", String "critical", String "urgent"] + buildParamValue emptyIR param kvs `shouldBe` expected + + it "builds integer array from repeated values" $ do + let param = ParamDef + { pdName = "ids" + , pdType = RefArray (RefPrimitive "integer" Nothing) + , pdDescription = Nothing + , pdRequired = True + , pdDefault = Nothing + } + let kvs = [("", "1"), ("", "2"), ("", "3")] + let expected = Right $ Array $ V.fromList [Number 1, Number 2, Number 3] + buildParamValue emptyIR param kvs `shouldBe` expected + + it "fails when array has no values" $ do + let param = ParamDef + { pdName = "tags" + , pdType = RefArray (RefPrimitive "string" Nothing) + , pdDescription = Nothing + , pdRequired = True + , pdDefault = Nothing + } + let kvs = [] + buildParamValue emptyIR param kvs `shouldSatisfy` isLeft + +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft (Right _) = False diff --git a/test/PathNormalizationSpec.hs b/test/PathNormalizationSpec.hs new file mode 100644 --- /dev/null +++ b/test/PathNormalizationSpec.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Unit tests for path and parameter normalization +module Main where + +import Data.Text (Text) +import qualified Data.Text as T +import Test.Hspec + +-- Copy of parsePathAndParams for testing +-- We can't import from Main, so we replicate the logic +parsePathAndParams :: [Text] -> ([Text], [(Text, Text)], Bool) +parsePathAndParams = go [] [] False + where + go path params helpReq [] = (reverse path, reverse params, helpReq) + go path params helpReq (x:xs) + -- --help flag: mark help requested, don't add as param + | x == "--help" || x == "-h" = + go path params True xs + -- --key value pair (value must not start with --) + | Just key <- T.stripPrefix "--" x + , not (T.null key) + , (val:rest) <- xs + , not (T.isPrefixOf "--" val) = + let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case + in go path ((normalizedKey, val) : params) helpReq rest + -- --key with no value or next arg is another flag (boolean flag) + | Just key <- T.stripPrefix "--" x + , not (T.null key) = + let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case + in go path ((normalizedKey, "") : params) helpReq xs + -- Regular path segment - split on dots to support plexus.cone.chat syntax + | otherwise = + let segments = map (T.replace "-" "_") $ filter (not . T.null) $ T.splitOn "." x + in go (reverse segments ++ path) params helpReq xs + +main :: IO () +main = hspec $ do + describe "parsePathAndParams - hyphen normalization" $ do + + it "normalizes hyphens in simple path segments" $ do + let input = ["changelog", "queue-add", "--help"] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` ["changelog", "queue_add"] + params `shouldBe` [] + helpReq `shouldBe` True + + it "normalizes hyphens in dot-notation paths" $ do + let input = ["plexus.cone.queue-add", "--name", "test"] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` ["plexus", "cone", "queue_add"] + params `shouldBe` [("name", "test")] + helpReq `shouldBe` False + + it "normalizes hyphens in parameter names" $ do + let input = ["cone", "create", "--working-dir", "/tmp", "--dry-run"] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` ["cone", "create"] + params `shouldBe` [("working_dir", "/tmp"), ("dry_run", "")] + helpReq `shouldBe` False + + it "handles mixed hyphens in path and params" $ do + let input = ["cone", "queue-list", "--max-count", "10", "--sort-by", "date"] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` ["cone", "queue_list"] + params `shouldBe` [("max_count", "10"), ("sort_by", "date")] + helpReq `shouldBe` False + + it "normalizes complex dot-notation with hyphens" $ do + let input = ["plexus.arbor.tree-create", "--tree-id", "abc-123"] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` ["plexus", "arbor", "tree_create"] + params `shouldBe` [("tree_id", "abc-123")] -- Value NOT normalized, only key + helpReq `shouldBe` False + + it "handles underscore paths unchanged" $ do + let input = ["changelog", "queue_add", "--description", "test"] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` ["changelog", "queue_add"] + params `shouldBe` [("description", "test")] + helpReq `shouldBe` False + + it "normalizes nested parameter paths" $ do + let input = ["cone", "chat", "--identifier.type", "by-name", "--identifier.name", "test"] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` ["cone", "chat"] + params `shouldBe` [("identifier.type", "by-name"), ("identifier.name", "test")] + -- Note: parameter suffixes (after .) are NOT normalized in parsePathAndParams + -- They're handled later in the parsing pipeline + helpReq `shouldBe` False + + it "normalizes _self template commands" $ do + let input = ["_self", "template", "show", "cone.queue-add"] + let (path, params, helpReq) = parsePathAndParams input + -- Note: "cone.queue-add" splits on dot and normalizes hyphens + path `shouldBe` ["_self", "template", "show", "cone", "queue_add"] + params `shouldBe` [] + helpReq `shouldBe` False + + it "handles repeated array parameters with hyphens" $ do + let input = ["queue-add", "--tags", "backend", "--tags", "critical", "--max-items", "5"] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` ["queue_add"] + params `shouldBe` [("tags", "backend"), ("tags", "critical"), ("max_items", "5")] + helpReq `shouldBe` False + + describe "parsePathAndParams - edge cases" $ do + + it "handles empty input" $ do + let input = [] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` [] + params `shouldBe` [] + helpReq `shouldBe` False + + it "preserves hyphens in parameter values" $ do + let input = ["cone", "create", "--name", "my-test-cone"] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` ["cone", "create"] + params `shouldBe` [("name", "my-test-cone")] -- Value preserved + helpReq `shouldBe` False + + it "handles boolean flags with hyphens" $ do + let input = ["test", "--verbose", "--dry-run", "--force"] + let (path, params, helpReq) = parsePathAndParams input + path `shouldBe` ["test"] + params `shouldBe` [("verbose", ""), ("dry_run", ""), ("force", "")] + helpReq `shouldBe` False diff --git a/test/TypeRefJson.hs b/test/TypeRefJson.hs new file mode 100644 --- /dev/null +++ b/test/TypeRefJson.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Quick test to see TypeRef JSON serialization +module Main where + +import Data.Aeson (encode) +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Text (Text) + +import Synapse.IR.Types + +main :: IO () +main = do + putStrLn "=== TypeRef JSON Serialization Test ===" + putStrLn "" + + -- Test 1: Simple QualifiedName with namespace + putStrLn "1. RefNamed with namespace:" + let qn1 = QualifiedName { qnNamespace = "cone", qnLocalName = "UUID" } + let ref1 = RefNamed qn1 + putStrLn " Haskell: " + print ref1 + putStrLn " JSON (compact):" + BSL.putStrLn (encode ref1) + putStrLn " JSON (pretty):" + BSL.putStrLn (encodePretty ref1) + putStrLn "" + + -- Test 2: Empty namespace + putStrLn "2. RefNamed with empty namespace:" + let qn2 = QualifiedName { qnNamespace = "", qnLocalName = "GlobalType" } + let ref2 = RefNamed qn2 + putStrLn " Haskell: " + print ref2 + putStrLn " JSON (pretty):" + BSL.putStrLn (encodePretty ref2) + putStrLn "" + + -- Test 3: Nested structure + putStrLn "3. RefOptional (RefArray (RefNamed)):" + let qn3 = QualifiedName { qnNamespace = "arbor", qnLocalName = "Node" } + let ref3 = RefOptional (RefArray (RefNamed qn3)) + putStrLn " Haskell: " + print ref3 + putStrLn " JSON (pretty):" + BSL.putStrLn (encodePretty ref3) + putStrLn "" + + -- Test 4: qualifiedNameFull function + putStrLn "4. qualifiedNameFull examples:" + putStrLn $ " cone.UUID -> " <> show (qualifiedNameFull qn1) + putStrLn $ " GlobalType -> " <> show (qualifiedNameFull qn2) + putStrLn "" + + -- Test 5: FieldDef with QualifiedName + putStrLn "5. FieldDef with RefNamed:" + let fd = FieldDef + { fdName = "tree_id" + , fdType = RefNamed (QualifiedName "arbor" "UUID") + , fdDescription = Just "Tree identifier" + , fdRequired = True + , fdDefault = Nothing + } + putStrLn " JSON (pretty):" + BSL.putStrLn (encodePretty fd)