substrate-synapse (empty) → 0.1.0.0
raw patch · 16 files changed
+2377/−0 lines, 16 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, bytestring, containers, directory, filepath, hashable, hspec, mtl, mustache, network, optparse-applicative, prettyprinter, process, scientific, stm, streaming, substrate-protocol, substrate-synapse, text, transformers, unordered-containers, vector, websockets, yaml
Files
- app/Main.hs +396/−0
- examples/SchemaDiscovery.hs +114/−0
- src/Synapse/Algebra/Complete.hs +24/−0
- src/Synapse/Algebra/Navigate.hs +96/−0
- src/Synapse/Algebra/Recursion.hs +197/−0
- src/Synapse/Algebra/Render.hs +207/−0
- src/Synapse/Algebra/TemplateGen.hs +295/−0
- src/Synapse/Algebra/Walk.hs +149/−0
- src/Synapse/Cache.hs +27/−0
- src/Synapse/Monad.hs +164/−0
- src/Synapse/Renderer.hs +267/−0
- src/Synapse/Schema/Functor.hs +99/−0
- src/Synapse/Schema/Types.hs +67/−0
- src/Synapse/Transport.hs +92/−0
- substrate-synapse.cabal +112/−0
- test/CLISpec.hs +71/−0
+ app/Main.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE ApplicativeDo #-}++-- | 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+--+-- Compare with Main.hs which takes pragmatic shortcuts.+module Main where++import Control.Monad.IO.Class (liftIO)+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 System.Exit (exitFailure, exitSuccess)+import System.IO (hPutStrLn, stderr, hFlush, stdout)++import Plexus (PlexusStreamItem(..))++import Synapse.Schema.Types+import Synapse.Monad+import Synapse.Algebra.Navigate+import Synapse.Algebra.Render (renderSchema, renderMethodFull)+import Synapse.Algebra.TemplateGen (GeneratedTemplate(..), generateAllTemplatesWithCallback)+import Synapse.Transport+import Synapse.Renderer (RendererConfig, defaultRendererConfig, renderItem, prettyValue)+import System.Directory (createDirectoryIfMissing)++-- ============================================================================+-- Types+-- ============================================================================++data Args = Args+ { argHost :: Text+ , argPort :: Int+ , argJson :: Bool -- ^ Output raw JSON stream items+ , argRaw :: Bool -- ^ Output raw content (no templates)+ , argDryRun :: Bool+ , argSchema :: Bool -- ^ Show raw schema JSON+ , argGenerate :: Bool -- ^ Generate templates from schemas+ , argParams :: Maybe Text -- ^ JSON params via -p+ , argRpc :: Maybe Text -- ^ Raw JSON-RPC passthrough+ , argPath :: [Text] -- ^ Path segments and --key value params+ }+ deriving Show++-- ============================================================================+-- Main+-- ============================================================================++main :: IO ()+main = do+ args <- execParser argsInfo+ env <- initEnv (argHost args) (argPort args)+ 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{..} rendererCfg = do+ -- Mode 1: Raw JSON-RPC passthrough+ case argRpc 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 argJson argRaw rendererCfg) items+ return ()++ Nothing -> do+ -- Parse path and inline params (--key value pairs)+ let (pathSegs, inlineParams) = parsePathAndParams argPath++ -- Mode 2: Schema request+ if argSchema+ 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+ else if argGenerate+ then do+ let baseDir = ".substrate/templates"+ writeAndLog gt = do+ writeGeneratedTemplate baseDir gt+ TIO.putStrLn $ " " <> T.pack (gtPath gt)+ liftIO $ TIO.putStrLn $ "Generating templates in " <> T.pack baseDir <> "..."+ count <- generateAllTemplatesWithCallback writeAndLog pathSegs+ liftIO $ TIO.putStrLn $ "Generated " <> T.pack (show count) <> " templates"++ else do+ -- Mode 4: 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 params: start with schema defaults, then merge user params+ -- Schema defaults are extracted from methodParams JSON Schema+ let schemaDefaults = extractSchemaDefaults method+ userParams <- case argParams of+ Just jsonStr ->+ case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 jsonStr) of+ Left err -> throwParse $ T.pack err+ Right p -> pure p+ Nothing+ | not (null inlineParams) -> pure $ buildParamsObject inlineParams+ | otherwise -> pure $ object []+ -- Merge: user params override schema defaults+ let params = mergeParams schemaDefaults userParams++ if argDryRun+ then liftIO $ LBS.putStrLn $ encodeDryRun (init path) (last path) params+ else if hasRequiredParams method && params == object [] && null inlineParams+ then liftIO $ TIO.putStrLn $ renderMethodFull method+ else invokeMethod path params+ where+ invokeMethod path params = do+ let namespacePath = init path -- path without method name+ let methodName' = last path+ invokeStreaming namespacePath methodName' params (printResult argJson argRaw rendererCfg)++ -- 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 [PlexusStreamItem]+ 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)+-- Example: ["echo", "once", "--message", "hello", "--count", "3"]+-- -> (["echo", "once"], [("message", "hello"), ("count", "3")])+parsePathAndParams :: [Text] -> ([Text], [(Text, Text)])+parsePathAndParams = go [] []+ where+ go path params [] = (reverse path, reverse params)+ go path params (x:xs)+ -- --key value pair+ | Just key <- T.stripPrefix "--" x+ , not (T.null key)+ , (val:rest) <- xs =+ go path ((key, val) : params) rest+ -- --key with no value (skip malformed)+ | T.isPrefixOf "--" x =+ go path params xs+ -- Regular path segment+ | otherwise =+ go (x : path) params 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")+ where+ failure = parserFailure defaultPrefs argsInfo (ShowHelpText Nothing) mempty++-- | Render an error for display+renderError :: SynapseError -> String+renderError = \case+ NavError (NotFound seg path) ->+ "Not found: '" <> T.unpack seg <> "' at " <> showPath path+ 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+ ParseError msg ->+ "Parse error: " <> T.unpack msg+ ValidationError msg ->+ "Validation error: " <> T.unpack msg+ where+ showPath [] = "root"+ showPath p = T.unpack $ T.intercalate "." p++-- | Write a generated template to disk (no logging)+writeGeneratedTemplate :: FilePath -> GeneratedTemplate -> IO ()+writeGeneratedTemplate baseDir gt = do+ let fullPath = baseDir </> gtPath gt+ createDirectoryIfMissing True (baseDir </> T.unpack (gtNamespace gt))+ TIO.writeFile fullPath (gtTemplate gt)+ where+ (</>) = \a b -> a ++ "/" ++ b++-- | Encode a dry-run request+encodeDryRun :: [Text] -> Text -> Value -> LBS.ByteString+encodeDryRun namespacePath method params =+ let fullPath = if null namespacePath then ["plexus"] else namespacePath+ dotPath = T.intercalate "." (fullPath ++ [method])+ in encode $ object+ [ "jsonrpc" .= ("2.0" :: Text)+ , "id" .= (1 :: Int)+ , "method" .= ("plexus_call" :: Text)+ , "params" .= object+ [ "method" .= dotPath+ , "params" .= params+ ]+ ]++-- | Print a stream result+-- argJson: output raw JSON stream items+-- argRaw: skip template rendering, just output content JSON+-- otherwise: try template rendering, fall back to content JSON+printResult :: Bool -> Bool -> RendererConfig -> PlexusStreamItem -> IO ()+printResult True _ _ item = LBS.putStrLn $ encode item+printResult _ True _ item = case item of+ -- Raw mode: just output the content+ StreamData _ _ _ dat -> do+ LBS.putStrLn $ encode dat+ hFlush stdout+ StreamProgress _ _ msg _ -> do+ TIO.putStr msg+ TIO.putStr "\r"+ hFlush stdout+ StreamError _ _ 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 -> do+ TIO.putStrLn text+ hFlush stdout+ Nothing -> case item of+ -- Fallback to pretty-printed content+ StreamData _ _ _ dat -> do+ TIO.putStrLn $ prettyValue dat+ hFlush stdout+ StreamProgress _ _ msg _ -> do+ TIO.putStr msg+ TIO.putStr "\r"+ hFlush stdout+ StreamError _ _ err _ ->+ hPutStrLn stderr $ "Error: " <> T.unpack err+ _ -> pure ()++-- ============================================================================+-- Argument Parsing+-- ============================================================================++argsInfo :: ParserInfo Args+argsInfo = info (argsParser <**> helper)+ ( fullDesc+ <> header "synapse - Algebraic CLI for Plexus"+ <> progDesc "Navigate and invoke methods via coalgebraic schema traversal"+ <> forwardOptions -- Pass unrecognized --flags to positional args+ )++argsParser :: Parser Args+argsParser = do+ argHost <- T.pack <$> strOption+ ( long "host" <> short 'H' <> metavar "HOST"+ <> value "127.0.0.1" <> showDefault+ <> help "Plexus server host" )+ argPort <- option auto+ ( long "port" <> short 'P' <> metavar "PORT"+ <> value 4444 <> showDefault+ <> help "Plexus server port" )+ argJson <- switch+ ( long "json" <> short 'j'+ <> help "Output raw JSON stream items" )+ argRaw <- switch+ ( long "raw"+ <> help "Output raw content JSON (skip templates)" )+ argDryRun <- switch+ ( long "dry-run" <> short 'n'+ <> help "Show JSON-RPC request without sending" )+ argSchema <- switch+ ( long "schema" <> short 's'+ <> help "Fetch raw schema JSON for path" )+ argGenerate <- switch+ ( long "generate-templates" <> short 'g'+ <> help "Generate mustache templates from schemas" )+ argParams <- optional $ T.pack <$> strOption+ ( long "params" <> short 'p' <> metavar "JSON"+ <> help "Method parameters as JSON object" )+ argRpc <- optional $ T.pack <$> strOption+ ( long "rpc" <> short 'r' <> metavar "JSON"+ <> help "Raw JSON-RPC request (bypass navigation)" )+ argPath <- many $ T.pack <$> argument str+ ( metavar "PATH... [--key value ...]"+ <> help "Path to plugin/method, with optional --key value params" )+ pure Args{..}
+ examples/SchemaDiscovery.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Demonstrates the two-call schema discovery pattern+--+-- 1. Call plexus_schema → get list of activations+-- 2. For each activation, call plexus_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 plexus_schema to discover activations..."+ mSchema <- S.head_ $ S.mapMaybe extractSchemaEvent $+ substrateRpc conn "plexus_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 "plexus_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 plexus_activation_schema RPC+ -- 2. ActivationInfo.methods → used to know which method corresponds to which oneOf variant+ -- 3. Same structure drives CLI: "symbols-dyn <namespace> <method>"++-- | 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: plexus_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.
+ src/Synapse/Algebra/Complete.hs view
@@ -0,0 +1,24 @@+-- | Completion functions for shell tab-completion+module Synapse.Algebra.Complete+ ( completions+ , completeMethods+ , completeChildren+ ) where++import Data.Text (Text)+import Synapse.Schema.Types++-- | Get all completions (methods + children)+completions :: PluginSchema -> [Text]+completions PluginSchema{..} = concat+ [ map methodName psMethods+ , maybe [] (map csNamespace) psChildren+ ]++-- | Get method completions only+completeMethods :: PluginSchema -> [Text]+completeMethods = map methodName . psMethods++-- | Get child namespace completions only+completeChildren :: PluginSchema -> [Text]+completeChildren = maybe [] (map csNamespace) . psChildren
@@ -0,0 +1,96 @@+-- | 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+navigate :: Path -> SynapseM SchemaView+navigate target = do+ root <- fetchSchemaAt []+ withFreshVisited $ navigateFrom root [] target++-- | 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++-- | 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)
+ src/Synapse/Algebra/Recursion.hs view
@@ -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
+ src/Synapse/Algebra/Render.hs view
@@ -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) " "
+ src/Synapse/Algebra/TemplateGen.hs view
@@ -0,0 +1,295 @@+-- | Template generation from schemas via recursion schemes+--+-- This module demonstrates two catamorphisms:+--+-- = Tree-level Catamorphism+--+-- We fold over the schema tree (SchemaF) to collect templates:+--+-- @+-- templateAlgebra :: SchemaF [GeneratedTemplate] -> [GeneratedTemplate]+-- @+--+-- This algebra is applied via hylomorphism:+--+-- @+-- generateAllTemplates = walkSchema templateAlgebraM+-- @+--+-- = Schema-level Catamorphism+--+-- We also fold over JSON Schema structure to generate mustache:+--+-- @+-- schemaToMustache :: Value -> Text+-- @+--+-- This is a catamorphism over the JSON Schema ADT, handling:+-- - oneOf/anyOf → collect all variant properties+-- - object → list properties as {{key}}+-- - array → generate {{#.}}...{{/.}} iteration+-- - primitives → {{.}}+module Synapse.Algebra.TemplateGen+ ( -- * Generation+ generateAllTemplates+ , generateAllTemplatesWithCallback+ , generateTemplate+ , generateTemplateFor++ -- * Algebras+ , templateAlgebra+ , schemaToMustache++ -- * Types+ , GeneratedTemplate(..)+ ) where++import Data.Aeson (Value(..))+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+import Data.Text (Text)+import qualified Data.Text as T+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Vector as V+import System.FilePath ((</>), (<.>))+import System.Directory (createDirectoryIfMissing)+import qualified Data.Text.IO as TIO++import Control.Monad.IO.Class (liftIO)++import Synapse.Schema.Types+import Synapse.Schema.Functor (SchemaF(..))+import Synapse.Monad+import Synapse.Transport (fetchMethodSchema)+import Synapse.Algebra.Walk++-- | A generated template with metadata+data GeneratedTemplate = GeneratedTemplate+ { gtNamespace :: Text -- ^ Plugin namespace+ , gtMethod :: Text -- ^ Method name+ , gtTemplate :: Text -- ^ Mustache template content+ , gtPath :: FilePath -- ^ Relative path for template file+ }+ deriving stock (Show, Eq)++-- | Generate template for a method+-- Template named by method (matches content_type: namespace.method)+generateTemplate :: MethodInfo -> [GeneratedTemplate]+generateTemplate MethodInfo{..} =+ [ GeneratedTemplate+ { gtNamespace = miNamespace+ , gtMethod = methodName miMethod+ , gtTemplate = "{{! " <> miNamespace <> "." <> methodName miMethod <> " }}\n" <> templateBody+ , gtPath = T.unpack miNamespace </> T.unpack (methodName miMethod) <.> "mustache"+ }+ ]+ where+ templateBody = case methodReturns miMethod of+ Nothing -> "{{.}}"+ Just schema -> schemaToMustache schema++-- | Extract event types from schema (oneOf/anyOf with event discriminator)+extractEventTypes :: Value -> [(Text, Value)]+extractEventTypes (Object o) = case KM.lookup "oneOf" o of+ Just (Array variants) -> mapMaybe extractEvent (V.toList variants)+ Nothing -> case KM.lookup "anyOf" o of+ Just (Array variants) -> mapMaybe extractEvent (V.toList variants)+ Nothing -> []+extractEventTypes _ = []++-- | Extract event name and schema from a variant+extractEvent :: Value -> Maybe (Text, Value)+extractEvent v@(Object o) = case KM.lookup "properties" o of+ Just (Object props) -> case KM.lookup "event" props of+ Just eventSchema -> case extractConstValue eventSchema of+ "event" -> Nothing -- fallback value, no const found+ evtName -> Just (evtName, v)+ Nothing -> Nothing+ Nothing -> Nothing+extractEvent _ = Nothing++-- | Extract const value from a schema (for discriminators)+extractConstValue :: Value -> Text+extractConstValue (Object o) = case KM.lookup "const" o of+ Just (String s) -> s+ _ -> "event"+extractConstValue _ = "event"++-- | Generate template for a specific method path+generateTemplateFor :: Path -> Text -> SynapseM GeneratedTemplate+generateTemplateFor path methodName' = do+ schema <- fetchMethodSchema path methodName'+ let namespace = if null path then "plexus" else T.intercalate "." path+ pure $ GeneratedTemplate+ { gtNamespace = namespace+ , gtMethod = methodName'+ , gtTemplate = generateFromReturns namespace methodName' (methodReturns schema)+ , gtPath = T.unpack namespace </> T.unpack methodName' <.> "mustache"+ }++-- ============================================================================+-- Tree-Level Algebra (SchemaF)+-- ============================================================================++-- | Algebra for folding schema tree into templates+--+-- This is a proper F-algebra: @SchemaF [GeneratedTemplate] -> [GeneratedTemplate]@+--+-- At each node:+-- - PluginF: generate templates for local methods, combine with children+-- - MethodF: leaf case (not used since methods are inside plugins)+templateAlgebra :: SchemaF [GeneratedTemplate] -> [GeneratedTemplate]+templateAlgebra (PluginF schema path childResults) =+ let namespace = psNamespace schema+ localTemplates = concatMap (methodToTemplate namespace) (psMethods schema)+ in localTemplates ++ concat childResults+templateAlgebra (MethodF method ns path) =+ -- Methods appear as leaves when walked individually+ methodToTemplate ns method++-- | Convert a method to template(s)+methodToTemplate :: Text -> MethodSchema -> [GeneratedTemplate]+methodToTemplate namespace method =+ [ GeneratedTemplate+ { gtNamespace = namespace+ , gtMethod = methodName method+ , gtTemplate = "{{! " <> namespace <> "." <> methodName method <> " }}\n" <> body+ , gtPath = T.unpack namespace </> T.unpack (methodName method) <.> "mustache"+ }+ ]+ where+ body = case methodReturns method of+ Nothing -> "{{.}}"+ Just schema -> schemaToMustache schema++-- | Monadic version for use with hyloM+templateAlgebraM :: SchemaF [GeneratedTemplate] -> SynapseM [GeneratedTemplate]+templateAlgebraM = pure . templateAlgebra++-- | Generate all templates by walking the schema tree+--+-- This is a hylomorphism: unfold tree, fold with template algebra.+-- The walkSchema function applies hyloM under the hood.+generateAllTemplates :: Path -> SynapseM [GeneratedTemplate]+generateAllTemplates = walkSchema templateAlgebraM++-- | Generate templates with a callback for each one (for streaming output)+--+-- The callback is invoked as each template is generated during the walk.+generateAllTemplatesWithCallback+ :: (GeneratedTemplate -> IO ()) -- ^ Called for each template+ -> Path+ -> SynapseM Int -- ^ Returns count+generateAllTemplatesWithCallback callback = walkSchema streamingAlgebra+ where+ streamingAlgebra :: SchemaF Int -> SynapseM Int+ streamingAlgebra (PluginF schema path childCounts) = do+ let namespace = psNamespace schema+ templates = concatMap (methodToTemplate namespace) (psMethods schema)+ liftIO $ mapM_ callback templates+ pure $ length templates + sum childCounts+ streamingAlgebra (MethodF method ns path) = do+ let templates = methodToTemplate ns method+ liftIO $ mapM_ callback templates+ pure $ length templates++-- | Generate mustache template from a method's return schema+generateFromReturns :: Text -> Text -> Maybe Value -> Text+generateFromReturns namespace method Nothing =+ "{{! " <> namespace <> "." <> method <> " - no return schema }}\n{{.}}"+generateFromReturns namespace method (Just schema) =+ "{{! " <> namespace <> "." <> method <> " }}\n" <> schemaToMustache schema++-- ============================================================================+-- Schema-Level Algebra (JSON Schema)+-- ============================================================================++-- | Convert JSON Schema to mustache template+--+-- This is a catamorphism over the JSON Schema structure.+-- The Value type is the fixed point, and we fold with:+--+-- @+-- schemaAlg :: SchemaNode -> Text+-- @+--+-- where SchemaNode would be the base functor for JSON Schema.+-- Since JSON Schema isn't defined as Fix F, we pattern match directly,+-- but the structure is the same: recursively process children, combine.+schemaToMustache :: Value -> Text+schemaToMustache (Object o) = case KM.lookup "oneOf" o of+ -- Handle oneOf (discriminated union by 'event' field)+ Just (Array variants) -> generateVariants (V.toList variants)+ Nothing -> case KM.lookup "anyOf" o of+ Just (Array variants) -> generateVariants (V.toList variants)+ Nothing -> case KM.lookup "type" o of+ Just (String "object") -> generateObject o+ Just (String "array") -> generateArray o+ Just (String "string") -> "{{.}}"+ Just (String "number") -> "{{.}}"+ Just (String "integer") -> "{{.}}"+ Just (String "boolean") -> "{{.}}"+ _ -> generateObject o -- Default to object handling+schemaToMustache _ = "{{.}}"++-- | Generate template for oneOf/anyOf variants+-- Collect all unique properties across variants (flat template, no sections)+generateVariants :: [Value] -> Text+generateVariants variants =+ let allProps = concatMap extractProps variants+ uniqueKeys = dedupe $ map fst allProps+ displayKeys = filter (not . isInternalField) uniqueKeys+ in T.intercalate " " $ map (\k -> "{{" <> k <> "}}") displayKeys+ where+ extractProps :: Value -> [(Text, Value)]+ extractProps (Object o) = case KM.lookup "properties" o of+ Just (Object props) -> [(K.toText k, v) | (k, v) <- KM.toList props]+ Nothing -> []+ extractProps _ = []++ dedupe :: Eq a => [a] -> [a]+ dedupe [] = []+ dedupe (x:xs) = x : dedupe (filter (/= x) xs)++-- | Generate template for object properties+generateObject :: KM.KeyMap Value -> Text+generateObject o = case KM.lookup "properties" o of+ Just (Object props) -> generateProps props+ Nothing -> "{{.}}"++-- | Generate output for properties+generateProps :: KM.KeyMap Value -> Text+generateProps props =+ let keys = map K.toText $ KM.keys props+ -- Filter out internal fields like 'event'+ displayKeys = filter (not . isInternalField) keys+ lines' = map (\k -> "{{" <> k <> "}}") displayKeys+ in T.intercalate " " lines'++-- | Check if a field is internal (shouldn't be displayed)+isInternalField :: Text -> Bool+isInternalField "event" = True+isInternalField "type" = True+isInternalField _ = False++-- | Generate template for array+generateArray :: KM.KeyMap Value -> Text+generateArray o = case KM.lookup "items" o of+ Just itemSchema ->+ "{{#.}}\n" <> schemaToMustache itemSchema <> "\n{{/.}}"+ Nothing -> "{{#.}}{{.}}{{/.}}"++-- | Write generated templates to disk+writeTemplates :: FilePath -> [GeneratedTemplate] -> IO ()+writeTemplates baseDir templates = do+ mapM_ (writeTemplate baseDir) templates++-- | Write a single template to disk+writeTemplate :: FilePath -> GeneratedTemplate -> IO ()+writeTemplate baseDir gt = do+ let fullPath = baseDir </> gtPath gt+ dir = takeDirectory fullPath+ createDirectoryIfMissing True dir+ TIO.writeFile fullPath (gtTemplate gt)+ where+ takeDirectory = reverse . dropWhile (/= '/') . reverse
+ src/Synapse/Algebra/Walk.hs view
@@ -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
+ src/Synapse/Cache.hs view
@@ -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
+ src/Synapse/Monad.hs view
@@ -0,0 +1,164 @@+{-# 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(..)+ , throwNav+ , throwTransport+ , throwParse++ -- * 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 Synapse.Schema.Types++-- | Environment for Synapse operations+data SynapseEnv = SynapseEnv+ { seHost :: !Text -- ^ Plexus host+ , sePort :: !Int -- ^ Plexus port+ , 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+ | ParseError Text+ | ValidationError Text+ 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 environment+runSynapseM' :: SynapseM a -> IO (Either SynapseError a)+runSynapseM' action = do+ env <- defaultEnv+ runSynapseM env action++-- | Initialize environment with given host/port+initEnv :: Text -> Int -> IO SynapseEnv+initEnv host port = do+ cache <- newIORef HM.empty+ visited <- newIORef HS.empty+ pure SynapseEnv+ { seHost = host+ , sePort = port+ , seCache = cache+ , seVisited = visited+ }++-- | Default environment (localhost:4444)+defaultEnv :: 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++-- ============================================================================+-- 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)
+ src/Synapse/Renderer.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Template-based output renderer+--+-- Runtime-configurable output rendering using Mustache templates.+-- Templates map content_type to human-readable output.+--+-- = 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+--+-- = Usage+--+-- @+-- cfg <- defaultRendererConfig+-- result <- renderItem cfg item+-- case result of+-- Just text -> TIO.putStrLn text+-- Nothing -> printJson item -- fallback+-- @+module Synapse.Renderer+ ( -- * Configuration+ RendererConfig(..)+ , defaultRendererConfig+ , OutputMode(..)++ -- * Rendering+ , renderItem+ , renderValue+ , renderWithTemplate+ , prettyValue++ -- * Template Resolution+ , resolveTemplate+ , 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 Plexus.Types (PlexusStreamItem(..))++-- ============================================================================+-- 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+ }++-- | 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+ }++-- | 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 content type+-- Content type format: "namespace.method" (e.g., "echo.once", "arbor.tree_list")+-- Search order:+-- 1. {searchPath}/{namespace}/{event}.mustache (exact match)+-- 2. {searchPath}/{namespace}/default.mustache (namespace default)+-- 3. {searchPath}/default.mustache (global default)+resolveTemplate :: RendererConfig -> Text -> IO (Maybe FilePath)+resolveTemplate cfg contentType = do+ let (namespace, method) = parseContentType contentType+ let candidates =+ -- Exact event 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++-- | Parse content_type into (namespace, method)+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 -> PlexusStreamItem -> 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+ StreamData _ _ contentType content ->+ renderValue cfg contentType content+ StreamProgress _ _ msg _ ->+ pure $ Just msg+ StreamError _ _ err _ ->+ pure $ Just $ "Error: " <> err+ StreamDone _ _ ->+ pure Nothing++-- | 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 = substituteValue template (toMustache value)++-- ============================================================================+-- 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)
+ src/Synapse/Schema/Functor.hs view
@@ -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 _ _ _) = []
+ src/Synapse/Schema/Types.hs view
@@ -0,0 +1,67 @@+-- | Core types for Synapse+--+-- Re-exports schema types from substrate-protocol and defines local types.+module Synapse.Schema.Types+ ( -- * Schema Types (from substrate-protocol)+ PluginSchema(..)+ , MethodSchema(..)+ , ChildSummary(..)+ , PluginHash+ , SchemaResult(..)++ -- * Query helpers+ , pluginChildren+ , childNamespaces+ , isHub+ , isLeaf++ -- * Navigation Types+ , Path+ , SchemaView(..)+ , NavError(..)++ -- * Stream Types+ , StreamMeta(..)+ ) where++import Data.Text (Text)+import Data.Int (Int64)+import GHC.Generics (Generic)++-- Re-export from substrate-protocol+import Plexus.Schema.Recursive+ ( PluginSchema(..)+ , MethodSchema(..)+ , ChildSummary(..)+ , PluginHash+ , SchemaResult(..)+ , pluginChildren+ , childNamespaces+ , isHub+ , isLeaf+ )++-- | 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 -- ^ Segment not found at path+ | 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)
+ src/Synapse/Transport.hs view
@@ -0,0 +1,92 @@+{-# 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+ ) 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 Substrate.Client (SubstrateConfig(..))+import qualified Substrate.Transport as ST+import Plexus.Types (PlexusStreamItem(..))++import Synapse.Schema.Types+import Synapse.Monad++-- | Fetch the root schema+fetchSchema :: SynapseM PluginSchema+fetchSchema = fetchSchemaAt []++-- | 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 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 err path+ Right schema -> pure schema++-- | Invoke a method and return stream items+invoke :: Path -> Text -> Value -> SynapseM [PlexusStreamItem]+invoke namespacePath method params = do+ cfg <- getConfig+ result <- liftIO $ ST.invokeMethod cfg namespacePath method params+ case result of+ Left err -> throwTransport err+ Right items -> pure items++-- | Invoke with raw method path+invokeRaw :: Text -> Value -> SynapseM [PlexusStreamItem]+invokeRaw method params = do+ cfg <- getConfig+ result <- liftIO $ ST.invokeRaw cfg method params+ case result of+ Left err -> throwTransport err+ Right items -> pure items++-- | Invoke a method with streaming output - calls callback for each item+invokeStreaming :: Path -> Text -> Value -> (PlexusStreamItem -> IO ()) -> SynapseM ()+invokeStreaming namespacePath method params onItem = do+ cfg <- getConfig+ result <- liftIO $ ST.invokeMethodStreaming cfg namespacePath method params onItem+ case result of+ Left err -> throwTransport err+ Right () -> pure ()++-- | Get SubstrateConfig from environment+getConfig :: SynapseM SubstrateConfig+getConfig = do+ host <- asks seHost+ port <- asks sePort+ pure $ SubstrateConfig+ { substrateHost = T.unpack host+ , substratePort = port+ , substratePath = "/"+ }
+ substrate-synapse.cabal view
@@ -0,0 +1,112 @@+cabal-version: 3.0+name: substrate-synapse+version: 0.1.0.0+synopsis: Algebraic CLI for Plexus - coalgebraic schema navigation+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.Complete+ Synapse.Algebra.Walk+ Synapse.Algebra.TemplateGen+ Synapse.Algebra.Recursion+ Synapse.Transport+ Synapse.Cache+ Synapse.Renderer+ build-depends:+ base >= 4.17 && < 5,+ substrate-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+ hs-source-dirs: src+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ DeriveGeneric+ DeriveAnyClass+ DerivingStrategies+ GeneralizedNewtypeDeriving+ LambdaCase+ RecordWildCards++executable synapse+ main-is: Main.hs+ build-depends:+ base >= 4.17 && < 5,+ substrate-protocol,+ substrate-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,+ 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,+ substrate-protocol,+ substrate-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/CLISpec.hs view
@@ -0,0 +1,71 @@+{-# 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" $ [] `has` ["synapse", "plexus", "methods", "activations"]+ it "echo" $ ["echo"] `has` ["echo", "Echo messages back"]+ it "solar" $ ["solar"] `has` ["solar", "Solar system model"]+ it "health" $ ["health"] `has` ["health", "Check hub health"]+ it "solar earth" $ ["solar", "earth"] `has` ["earth", "planet"]+ it "solar earth luna" $ ["solar", "earth", "luna"] `has` ["luna", "Moon"]++ describe "method help" $ do+ it "echo once" $ ["echo", "once"] `has` ["once", "--message", "required"]+ it "echo echo" $ ["echo", "echo"] `has` ["--message", "--count"]+ -- health.check has no required params, so it auto-invokes+ it "health check" $ ["health", "check"] `has` ["healthy"]++ describe "invocation" $ do+ it "echo once" $ call ["echo", "once"] (msg "test") `has` ["test"]+ it "echo count" $ call ["echo", "echo"] (msgN "hi" 2) `has` ["hi", "2"]+ it "health" $ callRaw ["health", "check"] "{}" `has` ["healthy"]+ it "solar observe" $ callRaw ["solar", "observe"] "{}" `has` ["sol", "planet_count"]+ it "luna info" $ callRaw ["solar", "earth", "luna", "info"] "{}" `has` ["luna"]++-- ============================================================================+-- Harness+-- ============================================================================++synapse :: FilePath+synapse = "dist-newstyle/build/aarch64-osx/ghc-9.6.7/synapse-0.1.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)+callRaw :: [String] -> String -> [String]+callRaw path params = ["--raw"] ++ path ++ ["-p", params]++-- | JSON builders+msg :: String -> String+msg m = "{\"message\":\"" <> m <> "\"}"++msgN :: String -> Int -> String+msgN m n = "{\"message\":\"" <> m <> "\",\"count\":" <> show n <> "}"