plexus-synapse 0.3.0.0 → 3.5.0
raw patch · 15 files changed
+1092/−142 lines, 15 filesdep ~aesondep ~time
Dependency ranges changed: aeson, time
Files
- app/Main.hs +103/−57
- plexus-synapse.cabal +38/−2
- src/Synapse/Algebra/Recursion.hs +41/−2
- src/Synapse/Algebra/Walk.hs +2/−1
- src/Synapse/Backend/Discovery.hs +38/−0
- src/Synapse/Bidir.hs +15/−14
- src/Synapse/CLI/Parse.hs +10/−2
- src/Synapse/IR/Builder.hs +14/−2
- src/Synapse/IR/Cache.hs +161/−0
- src/Synapse/IR/Types.hs +21/−9
- src/Synapse/Schema/Types.hs +1/−1
- test/BidirIntegrationSpec.hs +264/−0
- test/BidirSpec.hs +325/−0
- test/CLISpec.hs +20/−22
- test/IRSpec.hs +39/−30
app/Main.hs view
@@ -15,12 +15,14 @@ -- is passed through for method invocation. module Main where +import Control.Monad (when) 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.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO@@ -51,7 +53,7 @@ import System.Directory (createDirectoryIfMissing, getHomeDirectory) import System.FilePath ((</>)) import qualified Synapse.Self.Commands as Self-import Synapse.Backend.Discovery (Backend(..), BackendDiscovery(..), registryDiscovery, pingBackends, getBackendAt)+import Synapse.Backend.Discovery (Backend(..), BackendDiscovery(..), registryDiscovery, pingBackends, getBackendAt, registerWithRegistry) -- ============================================================================ -- Types@@ -73,6 +75,7 @@ , soGeneratorInfo :: [Text] -- ^ Generator tool info (tool:version pairs) , soBidirMode :: Maybe Text -- ^ Bidirectional mode override , soBidirCmd :: Maybe Text -- ^ Bidirectional subprocess command (--bidir-cmd)+ , soNoCache :: Bool -- ^ Disable IR caching } deriving Show @@ -113,6 +116,22 @@ maybeBackend <- getBackendAt (soHost opts) (soPort opts) let hostBackend = maybe "plexus" id maybeBackend + -- Auto-register: if we're connecting to a non-default port, push the+ -- discovered backend to the registry at the default port (if reachable)+ let targetPort = soPort opts+ targetHost = soHost opts+ when (targetPort /= defaultPort) $ do+ case maybeBackend of+ Just name -> do+ -- Check if the registry is at the default port+ maybeRegistry <- getBackendAt targetHost defaultPort+ case maybeRegistry of+ Just registryName ->+ registerWithRegistry targetHost defaultPort registryName+ name targetHost targetPort+ Nothing -> pure ()+ Nothing -> pure ()+ case argBackend args of Nothing -- Suppress banner for data output modes@@ -157,9 +176,19 @@ 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+ -- Verify the resolved backend actually identifies as the requested name.+ -- This catches cases where -P points to a different backend than expected,+ -- or the registry has stale entries.+ actualName <- getBackendAt (backendHost backend) (backendPort backend)+ case actualName of+ Just name | name /= backendName -> do+ hPutStrLn stderr $ "Backend mismatch: requested '" <> T.unpack backendName+ <> "' but " <> T.unpack (backendHost backend) <> ":" <> show (backendPort backend)+ <> " identifies as '" <> T.unpack name <> "'"+ exitFailure+ _ ->+ -- Match confirmed (or _info unavailable — proceed optimistically)+ run backendName (backendHost backend) (backendPort backend) args Nothing -> do -- Backend not found in registry - gather available backends and show error backends <- discoverBackends discovery@@ -274,63 +303,77 @@ -- 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+ -- Optimization: Skip IR construction for parameter-less methods+ -- IR is only needed for:+ -- 1. Help rendering (--help flag)+ -- 2. Parameter parsing (methods with params)+ let needsIR = helpRequested+ || isJust (methodParams method)+ || isJust soParams+ || not (null inlineParams)++ -- Fast path: parameter-less method with no help requested+ if not needsIR+ then invokeMethod path (object []) 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+ -- Build IR for this method's namespace+ ir <- buildIR soGeneratorInfo (init path) - if soDryRun+ -- If --help was explicitly requested, show help and exit+ if helpRequested 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+ 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@@ -365,7 +408,7 @@ methodName' params (printResult soJson soRaw rendererCfg')- (handleBidirRequest bidirMode)+ (handleBidirRequest bidirMode Nothing) -- Extract default values from JSON Schema properties -- Schema format: {"properties": {"key": {"default": value, ...}, ...}, ...}@@ -797,4 +840,7 @@ soBidirCmd <- optional $ T.pack <$> strOption ( long "bidir-cmd" <> metavar "CMD" <> help "Shell command to handle bidir requests (stdin=JSON request, stdout=JSON response)" )+ soNoCache <- switch+ ( long "no-cache"+ <> help "Disable IR caching (force rebuild from schema)" ) pure SynapseOpts{..}
plexus-synapse.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: plexus-synapse-version: 0.3.0.0+version: 3.5.0 synopsis: Schema-driven CLI for Plexus RPC servers license: MIT author:@@ -26,6 +26,7 @@ Synapse.Renderer Synapse.IR.Types Synapse.IR.Builder+ Synapse.IR.Cache Synapse.Bidir Synapse.CLI.Help Synapse.CLI.Parse@@ -92,7 +93,8 @@ directory >= 1.3 && < 1.4, filepath >= 1.4 && < 1.6, optparse-applicative >= 0.18 && < 0.19,- prettyprinter >= 1.7 && < 1.8+ prettyprinter >= 1.7 && < 1.8,+ time >= 1.12 && < 1.14 hs-source-dirs: app default-language: GHC2021 default-extensions:@@ -193,4 +195,38 @@ default-language: GHC2021 default-extensions: OverloadedStrings+ ghc-options: -threaded++test-suite bidir-test+ type: exitcode-stdio-1.0+ main-is: BidirSpec.hs+ build-depends:+ base >= 4.17 && < 5,+ plexus-protocol,+ plexus-synapse,+ text >= 2.0 && < 2.2,+ bytestring >= 0.11 && < 0.13,+ aeson >= 2.2 && < 2.3,+ hspec >= 2.10 && < 2.12+ hs-source-dirs: test+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ RecordWildCards+ ghc-options: -threaded++test-suite bidir-integration-test+ type: exitcode-stdio-1.0+ main-is: BidirIntegrationSpec.hs+ build-depends:+ base >= 4.17 && < 5,+ plexus-synapse,+ text >= 2.0 && < 2.2,+ containers >= 0.6 && < 0.8,+ hspec >= 2.10 && < 2.12+ hs-source-dirs: test+ default-language: GHC2021+ default-extensions:+ OverloadedStrings+ RecordWildCards ghc-options: -threaded
src/Synapse/Algebra/Recursion.hs view
@@ -54,22 +54,27 @@ , cataM , anaM , hyloM+ , hyloMPar -- * Schema-specific operations , unfoldSchema , foldSchema , walkSchema+ , walkSchemaPar -- * Re-exports , Fix(..) ) where +import Control.Concurrent.Async (mapConcurrently) import Control.Monad (forM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (asks) import Data.Text (Text) import Synapse.Schema.Types (Path, PluginSchema(..), MethodSchema(..), ChildSummary(..)) import Synapse.Schema.Functor (SchemaF(..), Fix(..), SchemaTree)-import Synapse.Monad+import Synapse.Monad (SynapseM, runSynapseM) import Synapse.Transport (fetchSchemaAt) -- ============================================================================@@ -157,9 +162,36 @@ where go a = do fa <- coalg a -- unfold one step- fb <- traverse go fa -- recursively process+ fb <- traverse go fa -- recursively process (sequential) alg fb -- fold one step +-- | Parallel monadic hylomorphism specialized for SchemaF+--+-- Like hyloM but processes child schemas in parallel using mapConcurrently.+-- This provides a significant speedup when fetching multiple plugin schemas.+hyloMPar :: (SchemaF b -> SynapseM b) -> (a -> SynapseM (SchemaF a)) -> a -> SynapseM b+hyloMPar alg coalg = go+ where+ go a = do+ fa <- coalg a -- unfold one step+ case fa of+ PluginF schema path children -> do+ -- Process children in parallel+ -- We need to capture the environment to run each child action+ env <- asks id -- Get the SynapseEnv+ childResults <- liftIO $ mapConcurrently+ (\child -> do+ result <- runSynapseM env (go child) -- Fixed: env first, action second+ case result of+ Left err -> error $ "Schema fetch failed: " ++ show err+ Right val -> pure val+ )+ children+ alg (PluginF schema path childResults)+ MethodF method ns path ->+ -- Methods are leaves, just apply algebra+ alg (MethodF method ns path)+ -- ============================================================================ -- Schema-Specific Operations -- ============================================================================@@ -195,3 +227,10 @@ -- Fused, so doesn't build intermediate tree in memory. walkSchema :: (SchemaF a -> SynapseM a) -> Path -> SynapseM a walkSchema alg = hyloM alg schemaCoalgebra++-- | Walk the schema tree with parallel child fetching+--+-- Like walkSchema but fetches child plugin schemas in parallel.+-- Provides significant speedup for backends with many plugins.+walkSchemaPar :: (SchemaF a -> SynapseM a) -> Path -> SynapseM a+walkSchemaPar alg = hyloMPar alg schemaCoalgebra
src/Synapse/Algebra/Walk.hs view
@@ -44,6 +44,7 @@ ( -- * Recursion Schemes walkMethods , walkSchema+ , walkSchemaPar , foldMethods -- * Building Trees@@ -64,7 +65,7 @@ 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.Algebra.Recursion (hyloM, hyloMPar, unfoldSchema, foldSchema, walkSchemaPar) import Synapse.Transport (fetchSchemaAt) -- | Information about a method in context
src/Synapse/Backend/Discovery.hs view
@@ -51,6 +51,9 @@ -- * Health Checks , pingBackend , pingBackends++ -- * Registry Registration+ , registerWithRegistry ) where import Data.Aeson (ToJSON, FromJSON, (.:), (.:?), withObject)@@ -348,3 +351,38 @@ -- | Ping all backends in parallel pingBackends :: [Backend] -> IO [Backend] pingBackends backends = mapConcurrently pingBackend backends++-- ============================================================================+-- Registry Registration+-- ============================================================================++-- | Register a backend with the registry, if the registry is reachable.+--+-- Called when synapse connects to a backend at a non-default location.+-- Silently does nothing if the registry is unreachable or the call fails.+registerWithRegistry+ :: Text -- ^ Registry host+ -> Int -- ^ Registry port+ -> Text -- ^ Registry backend name (discovered via _info at registry port)+ -> Text -- ^ Backend name to register+ -> Text -- ^ Backend host+ -> Int -- ^ Backend port+ -> IO ()+registerWithRegistry registryHost registryPort registryBackend name host port = do+ let cfg = SubstrateConfig+ { substrateHost = T.unpack registryHost+ , substratePort = registryPort+ , substratePath = "/"+ , substrateBackend = registryBackend+ }+ params = Aeson.object+ [ "name" Aeson..= name+ , "host" Aeson..= host+ , "port" Aeson..= port+ , "protocol" Aeson..= ("ws" :: Text)+ ]+ -- Fire and forget — don't block the CLI on registry registration+ void $ async $ do+ _ <- ST.invokeMethod cfg ["registry"] "register" params+ `catch` \(_e :: SomeException) -> pure (Left $ NetworkError "Registry unavailable")+ pure ()
src/Synapse/Bidir.hs view
@@ -95,14 +95,15 @@ 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+-- The response schema (if available) is passed for modes that output requests (e.g., BidirRespond)+handleBidirRequest :: BidirMode -> Maybe Value -> Text -> Request Value -> IO (Maybe (Response Value))+handleBidirRequest mode mResponseSchema 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+ BidirRespond -> handleRespond mResponseSchema requestId req -- | Interactive TTY handling handleInteractive :: Text -> Request Value -> IO (Response Value)@@ -149,8 +150,6 @@ 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@@ -213,8 +212,6 @@ <> 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": {...}}@@ -248,13 +245,18 @@ -- | 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 <backend> respond --request-id <id> --response <json>-handleRespond :: Text -> Request Value -> IO (Maybe (Response Value))-handleRespond requestId req = do- let jsonReq = encode $ object+handleRespond :: Maybe Value -> Text -> Request Value -> IO (Maybe (Response Value))+handleRespond mResponseSchema requestId req = do+ let baseFields = [ "type" .= ("bidir_request" :: Text) , "request_id" .= requestId , "request" .= req ]+ -- Include response_schema if available+ allFields = case mResponseSchema of+ Just schema -> baseFields ++ ["response_schema" .= schema]+ Nothing -> baseFields+ jsonReq = encode $ object allFields LBS.putStrLn jsonReq hFlush stdout pure Nothing@@ -262,7 +264,6 @@ -- | Get a human-readable name for the request type requestTypeName :: Request t -> Text requestTypeName = \case- Confirm{} -> "confirm"- Prompt{} -> "prompt"- Select{} -> "select"- CustomRequest{} -> "custom"+ Confirm{} -> "confirm"+ Prompt{} -> "prompt"+ Select{} -> "select"
src/Synapse/CLI/Parse.hs view
@@ -203,8 +203,9 @@ else buildParamValue ir param{pdType = inner} kvs RefArray innerType ->- -- Collect all repeated --key value entries- let values = [val | ("", val) <- kvs]+ -- Collect all repeated --key value entries, splitting comma-separated values+ let rawValues = [val | ("", val) <- kvs]+ values = concatMap splitCommas rawValues 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@@ -220,6 +221,13 @@ case lookup "" kvs of Just val -> Right $ inferValue val Nothing -> Left $ InvalidValue (pdName param) "unknown type needs value"++-- | Split a string on commas, trimming whitespace. A value with no commas+-- returns as a singleton list, preserving backward compatibility.+splitCommas :: Text -> [Text]+splitCommas t =+ let parts = T.splitOn "," t+ in map T.strip parts -- | Build value from a TypeDef buildFromTypeDef :: IR -> Text -> TypeDef -> [(Text, Text)] -> Either ParseError Value
src/Synapse/IR/Builder.hs view
@@ -36,7 +36,7 @@ import Synapse.Schema.Types import Synapse.Schema.Functor (SchemaF(..))-import Synapse.Algebra.Walk (walkSchema)+import Synapse.Algebra.Walk (walkSchemaPar) import Synapse.Monad import Synapse.IR.Types hiding (QualifiedName(..), qualifiedNameFull) import Synapse.IR.Types (QualifiedName(..), qualifiedNameFull, synapseVersion)@@ -66,10 +66,11 @@ -- | 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+-- Uses parallel schema fetching for better performance buildIR :: [Text] -> Path -> SynapseM IR buildIR generatorInfoStrs path = do backend <- asks seBackend- raw <- walkSchema irAlgebra path+ raw <- walkSchemaPar irAlgebra path -- Parse generator info and add synapse itself let parsedGens = mapMaybe parseGeneratorInfo generatorInfoStrs@@ -264,6 +265,8 @@ { mdParams = map (updateParamRefs redirects) (mdParams md) , mdReturns = updateTypeRef redirects (mdReturns md) , mdBidirType = fmap (updateTypeRef redirects) (mdBidirType md)+ , mdBidirResponseType = mdBidirResponseType md -- Preserve as-is+ , mdBidirResponseSchema = mdBidirResponseSchema md -- Preserve as-is } -- | Update type references in a parameter@@ -361,6 +364,7 @@ -- structured "bidir_type" field (distinct from the full request_type schema) -- should be handled here. bidirTypeRef = inferBidirType method+ bidirResponseSchema = methodResponseType method mdef = MethodDef { mdName = name@@ -371,6 +375,8 @@ , mdParams = params , mdReturns = returnRef , mdBidirType = bidirTypeRef+ , mdBidirResponseType = Nothing -- TODO: could extract from response_type title+ , mdBidirResponseSchema = bidirResponseSchema } in (allTypes, mdef) @@ -644,6 +650,12 @@ 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 "array"] ->+ -- Nullable array: type: ["array", "null"] with items+ let inner = case KM.lookup "items" o of+ Just items -> RefArray (schemaToTypeRef namespace items)+ Nothing -> RefArray RefAny+ in if hasNull then RefOptional inner else inner [String t] -> let base = RefPrimitive t (extractFormat o) in if hasNull then RefOptional base else base
+ src/Synapse/IR/Cache.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE RecordWildCards #-}++-- | IR caching with hash-based invalidation+--+-- Caches built IR keyed by plugin hash to avoid rebuilding when schemas haven't changed.+-- The plugin hash changes whenever any method or child activation changes, making it+-- perfect for cache invalidation.+module Synapse.IR.Cache+ ( IRCache+ , CacheConfig(..)+ , defaultCacheConfig+ , newIRCache+ , lookupIR+ , insertIR+ , clearCache+ , getCacheStats+ , CacheStats(..)+ ) where++import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_, readMVar)+import Control.Monad (when)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)+import System.FilePath ((</>))+import Data.Aeson (encode, eitherDecodeFileStrict')+import qualified Data.ByteString.Lazy as LBS++import Synapse.IR.Types (IR)++-- | Cache configuration+data CacheConfig = CacheConfig+ { cacheEnabled :: Bool -- ^ Whether caching is enabled+ , cacheMaxSize :: Int -- ^ Max number of cached IRs (0 = unlimited)+ , cachePersist :: Bool -- ^ Persist cache to disk+ , cachePath :: FilePath -- ^ Path to cache directory+ }+ deriving stock (Show, Eq)++-- | Default cache configuration+-- - Enabled by default+-- - Max 100 cached IRs+-- - Persist to ~/.cache/synapse/ir+defaultCacheConfig :: FilePath -> CacheConfig+defaultCacheConfig homeDir = CacheConfig+ { cacheEnabled = True+ , cacheMaxSize = 100+ , cachePersist = True+ , cachePath = homeDir </> ".cache" </> "synapse" </> "ir"+ }++-- | Cache statistics+data CacheStats = CacheStats+ { statsHits :: Int -- ^ Cache hits+ , statsMisses :: Int -- ^ Cache misses+ , statsSize :: Int -- ^ Current cache size+ }+ deriving stock (Show, Eq)++-- | In-memory IR cache+data IRCache = IRCache+ { cacheConfig :: CacheConfig+ , cacheStore :: MVar (Map Text IR)+ , cacheStats :: MVar CacheStats+ }++-- | Create a new IR cache+newIRCache :: CacheConfig -> IO IRCache+newIRCache config = do+ when (cachePersist config) $+ createDirectoryIfMissing True (cachePath config)++ store <- newMVar Map.empty+ stats <- newMVar (CacheStats 0 0 0)++ pure IRCache+ { cacheConfig = config+ , cacheStore = store+ , cacheStats = stats+ }++-- | Look up IR by hash+lookupIR :: IRCache -> Text -> IO (Maybe IR)+lookupIR IRCache{..} hash+ | not (cacheEnabled cacheConfig) = pure Nothing+ | otherwise = do+ -- Try memory cache first+ mIR <- Map.lookup hash <$> readMVar cacheStore+ case mIR of+ Just ir -> do+ recordHit+ pure (Just ir)+ Nothing+ | cachePersist cacheConfig -> do+ -- Try disk cache+ mDiskIR <- loadFromDisk hash+ case mDiskIR of+ Just ir -> do+ -- Load into memory cache+ modifyMVar_ cacheStore $ \store ->+ pure $ Map.insert hash ir store+ recordHit+ pure (Just ir)+ Nothing -> do+ recordMiss+ pure Nothing+ | otherwise -> do+ recordMiss+ pure Nothing+ where+ recordHit = modifyMVar_ cacheStats $ \stats ->+ pure $ stats { statsHits = statsHits stats + 1 }++ recordMiss = modifyMVar_ cacheStats $ \stats ->+ pure $ stats { statsMisses = statsMisses stats + 1 }++ loadFromDisk hash = do+ let path = cachePath cacheConfig </> T.unpack hash <> ".json"+ exists <- doesFileExist path+ if exists+ then do+ result <- eitherDecodeFileStrict' path+ case result of+ Right ir -> pure (Just ir)+ Left _ -> pure Nothing -- Corrupted cache, ignore+ else pure Nothing++-- | Insert IR into cache+insertIR :: IRCache -> Text -> IR -> IO ()+insertIR IRCache{..} hash ir+ | not (cacheEnabled cacheConfig) = pure ()+ | otherwise = do+ -- Insert into memory cache+ modifyMVar_ cacheStore $ \store -> do+ let newStore = Map.insert hash ir store+ -- Evict if over max size (simple LRU: remove first element)+ let finalStore = if cacheMaxSize cacheConfig > 0 && Map.size newStore > cacheMaxSize cacheConfig+ then Map.deleteMin newStore+ else newStore+ pure finalStore++ -- Update stats+ modifyMVar_ cacheStats $ \stats ->+ pure $ stats { statsSize = statsSize stats + 1 }++ -- Persist to disk if enabled+ when (cachePersist cacheConfig) $ do+ let path = cachePath cacheConfig </> T.unpack hash <> ".json"+ LBS.writeFile path (encode ir)++-- | Clear the cache+clearCache :: IRCache -> IO ()+clearCache IRCache{..} = do+ modifyMVar_ cacheStore $ \_ -> pure Map.empty+ modifyMVar_ cacheStats $ \_ -> pure (CacheStats 0 0 0)++-- | Get cache statistics+getCacheStats :: IRCache -> IO CacheStats+getCacheStats IRCache{..} = readMVar cacheStats
src/Synapse/IR/Types.hs view
@@ -129,7 +129,7 @@ , irPluginHashes :: Maybe (Map Text PluginHashInfo) -- ^ V2: Hash information per plugin } deriving stock (Show, Eq, Generic)- deriving anyclass (ToJSON)+ deriving anyclass (ToJSON, FromJSON) -- | Empty IR for folding emptyIR :: IR@@ -173,7 +173,7 @@ , tdKind :: TypeKind -- ^ What kind of type this is } deriving stock (Show, Eq, Generic)- deriving anyclass (ToJSON)+ deriving anyclass (ToJSON, FromJSON) -- | Compute the fully qualified type name tdFullName :: TypeDef -> Text@@ -199,7 +199,7 @@ , kpFormat :: Maybe Text -- ^ Optional format hint (e.g., "uuid", "int64") } deriving stock (Show, Eq, Generic)- deriving anyclass (ToJSON)+ deriving anyclass (ToJSON, FromJSON) -- | A field in a struct data FieldDef = FieldDef@@ -210,7 +210,7 @@ , fdDefault :: Maybe Value -- ^ Default value if any } deriving stock (Show, Eq, Generic)- deriving anyclass (ToJSON)+ deriving anyclass (ToJSON, FromJSON) -- | A variant in a discriminated union data VariantDef = VariantDef@@ -219,7 +219,7 @@ , vdFields :: [FieldDef] -- ^ Fields specific to this variant } deriving stock (Show, Eq, Generic)- deriving anyclass (ToJSON)+ deriving anyclass (ToJSON, FromJSON) -- ============================================================================ -- Method Definitions@@ -250,9 +250,21 @@ -- 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.+ , mdBidirResponseType :: Maybe TypeRef+ -- ^ Expected response type for bidirectional methods.+ --+ -- Populated from the "response_type" field in the MethodSchema.+ -- This allows agents to know what response format is expected+ -- when they receive a bidirectional request.+ , mdBidirResponseSchema :: Maybe Value+ -- ^ Full JSON Schema for the bidirectional response type.+ --+ -- Cached from MethodSchema.response_type so synapse can include it+ -- in bidir_request output. Synapse controls whether to print this+ -- (e.g., first request, --bidir-schemas flag, etc.) } deriving stock (Show, Eq, Generic)- deriving anyclass (ToJSON)+ deriving anyclass (ToJSON, FromJSON) -- | A parameter definition data ParamDef = ParamDef@@ -263,7 +275,7 @@ , pdDefault :: Maybe Value -- ^ Default value if any } deriving stock (Show, Eq, Generic)- deriving anyclass (ToJSON)+ deriving anyclass (ToJSON, FromJSON) -- ============================================================================ -- Type References@@ -275,7 +287,7 @@ , qnLocalName :: Text -- ^ Local name within namespace } deriving stock (Show, Eq, Generic)- deriving anyclass (ToJSON)+ deriving anyclass (ToJSON, FromJSON) -- | Get the full qualified name as a single Text -- Returns just the local name if namespace is empty, otherwise "namespace.localName"@@ -293,7 +305,7 @@ | RefAny -- ^ Intentionally dynamic (serde_json::Value) - accepts any JSON | RefUnknown -- ^ Unknown type (schema gap) - should warn deriving stock (Show, Eq, Generic)- deriving anyclass (ToJSON)+ deriving anyclass (ToJSON, FromJSON) -- | Get the name from a type reference (if it's a named ref) typeRefName :: TypeRef -> Maybe Text
src/Synapse/Schema/Types.hs view
@@ -129,5 +129,5 @@ 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 :: Text -> Provenance -> Text -> Request Value -> Maybe Int -> HubStreamItem pattern HubRequest hash prov reqId reqData timeout = StreamRequest hash prov reqId reqData timeout
+ test/BidirIntegrationSpec.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Bidirectional integration tests+--+-- Tests for schema-driven bidirectional communication:+-- - IR builder correctly sets mdBidirType field+-- - Methods with bidirectional flag are detected+-- - Schema-driven dispatch logic+--+-- This test requires a running Hub backend on localhost:4444+-- with at least one method marked as bidirectional.+module Main where++import Control.Monad (forM_)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust, isNothing, catMaybes, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import System.Environment (getArgs, withArgs)+import Test.Hspec+import Text.Read (readMaybe)++import Synapse.IR.Types+import Synapse.IR.Builder (buildIR)+import Synapse.Monad++main :: IO ()+main = do+ args <- getArgs+ case parseArgs args of+ Nothing -> do+ putStrLn "Usage: bidir-integration-test <backend> [--port <port>]"+ putStrLn "Example: cabal test bidir-integration-test --test-options=\"plexus\""+ putStrLn ""+ putStrLn "Note: This test validates bidirectional communication features."+ putStrLn " Some tests may be skipped if no bidirectional methods exist."+ error "Backend argument required"+ Just (backend, port) -> do+ putStrLn $ "Running bidirectional integration tests against localhost:" <> show port+ putStrLn $ "(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?"+ hspec $ describe "Bidirectional Integration Tests" $+ it "connects to Hub backend" $+ expectationFailure $ "Could not connect: " <> show err++ Right ir -> withArgs [] $ hspec $ bidirIntegrationSpec ir++-- | Parse command-line arguments: <backend> [--port <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+bidirIntegrationSpec :: IR -> Spec+bidirIntegrationSpec ir = do+ describe "IR bidirectional field population" $ do+ it "IR has methods" $+ Map.size (irMethods ir) `shouldSatisfy` (> 0)++ it "mdBidirType field exists on all methods" $ do+ forM_ (Map.elems $ irMethods ir) $ \method ->+ -- Field should exist (even if Nothing)+ -- This tests that the field is part of MethodDef+ case mdBidirType method of+ Nothing -> (pure () :: IO ()) -- Not bidirectional+ Just _ -> (pure () :: IO ()) -- Bidirectional++ it "reports methods with mdBidirType set" $ do+ let bidirMethods = filter (isJust . mdBidirType) (Map.elems $ irMethods ir)+ let count = length bidirMethods+ putStrLn $ " Found " <> show count <> " bidirectional method(s)"+ forM_ bidirMethods $ \method ->+ putStrLn $ " - " <> T.unpack (mdFullPath method) <>+ " (type: " <> show (mdBidirType method) <> ")"+ -- Don't fail if none exist - this is informational+ pure ()++ describe "Bidirectional type inference" $ do+ it "mdBidirType is Nothing for non-bidirectional methods" $ do+ -- Find methods that are NOT streaming and likely not bidirectional+ let nonStreamingMethods = filter (not . mdStreaming) (Map.elems $ irMethods ir)+ -- Check a sample (if any exist)+ case take 1 nonStreamingMethods of+ [] -> pending -- No non-streaming methods to test+ (method:_) -> do+ -- Most non-streaming methods shouldn't be bidirectional+ -- But we can't enforce this strictly as it depends on the backend+ case mdBidirType method of+ Nothing -> pure () -- Expected for most methods+ Just _ -> putStrLn $ " Note: " <> T.unpack (mdFullPath method) <>+ " is bidirectional despite being non-streaming"++ it "mdBidirType is RefAny for standard bidirectional methods" $ do+ let bidirMethods = filter (isJust . mdBidirType) (Map.elems $ irMethods ir)+ forM_ bidirMethods $ \method ->+ case mdBidirType method of+ Just RefAny -> pure () -- Standard bidir with T=Value+ Just other ->+ -- Future: when custom bidir types are supported, this is valid+ putStrLn $ " Note: " <> T.unpack (mdFullPath method) <>+ " has custom bidir type: " <> show other+ Nothing -> expectationFailure "Expected bidir method to have mdBidirType"++ describe "Bidirectional method detection" $ do+ it "can identify all bidirectional methods" $ do+ let allMethods = Map.elems $ irMethods ir+ let bidirMethods = filter (isJust . mdBidirType) allMethods+ -- Report findings+ putStrLn $ " Total methods: " <> show (length allMethods)+ putStrLn $ " Bidirectional: " <> show (length bidirMethods)+ -- Test passes - we're just collecting data+ length allMethods `shouldSatisfy` (>= length bidirMethods)++ it "bidirectional methods have valid structure" $ do+ let bidirMethods = filter (isJust . mdBidirType) (Map.elems $ irMethods ir)+ forM_ bidirMethods $ \method -> do+ -- Should have a name+ T.length (mdName method) `shouldSatisfy` (> 0)+ -- Should have a full path+ T.length (mdFullPath method) `shouldSatisfy` (> 0)+ -- Should have a return type+ mdReturns method `shouldSatisfy` (/= RefUnknown)++ describe "Type reference validation for bidirectional types" $ do+ it "mdBidirType references resolve in irTypes (if not RefAny)" $ do+ let bidirMethods = filter (isJust . mdBidirType) (Map.elems $ irMethods ir)+ forM_ bidirMethods $ \method ->+ case mdBidirType method of+ Nothing -> pure ()+ Just RefAny -> pure () -- RefAny doesn't need resolution+ Just (RefNamed qn) -> do+ let typeName = qualifiedNameFull qn+ case Map.lookup typeName (irTypes ir) of+ Nothing -> expectationFailure $ T.unpack $+ "Bidirectional type not found in IR: " <> typeName <>+ " (referenced by " <> mdFullPath method <> ")"+ Just _ -> pure ()+ Just (RefArray _) ->+ -- Array types are valid, but we don't validate the inner type here+ pure ()+ Just (RefOptional _) ->+ -- Optional types are valid+ pure ()+ Just RefUnknown -> expectationFailure $ T.unpack $+ "mdBidirType should not be RefUnknown for " <> mdFullPath method+ Just (RefPrimitive _ _) ->+ -- Primitive types are valid+ pure ()++ describe "Schema-driven dispatch assumptions" $ do+ it "bidirectional methods are streaming (typically)" $ do+ let bidirMethods = filter (isJust . mdBidirType) (Map.elems $ irMethods ir)+ forM_ bidirMethods $ \method ->+ if mdStreaming method+ then pure () -- Expected - bidir usually requires streaming+ else putStrLn $ " Note: Bidirectional method " <> T.unpack (mdFullPath method) <>+ " is NOT streaming (unusual but valid)"++ it "non-bidirectional methods have Nothing for mdBidirType" $ do+ let allMethods = Map.elems $ irMethods ir+ forM_ allMethods $ \method ->+ case mdBidirType method of+ Nothing -> (pure () :: IO ()) -- Standard method+ Just _ -> (pure () :: IO ()) -- Should only be set for truly bidirectional methods++ describe "Specific bidirectional method tests (if available)" $ do+ -- Test common bidirectional methods if they exist+ -- These are examples - actual methods depend on the backend+ testBidirMethod ir "cone.chat"+ testBidirMethod ir "cone.edit"+ testBidirMethod ir "cone.generate"++ describe "IR metadata for bidirectional support" $ do+ it "IR version is set" $+ T.length (irVersion ir) `shouldSatisfy` (> 0)++ it "IR backend is set" $+ T.length (irBackend ir) `shouldSatisfy` (> 0)++ it "IR contains type definitions" $ do+ -- Should have at least some types (even if no bidirectional methods)+ Map.size (irTypes ir) `shouldSatisfy` (>= 0)++ describe "Edge cases and validation" $ do+ it "handles methods with no parameters but bidirectional" $ do+ let bidirMethods = filter (isJust . mdBidirType) (Map.elems $ irMethods ir)+ let noParamBidirMethods = filter (null . mdParams) bidirMethods+ -- These are valid - bidirectional methods can have no input params+ -- Just report findings+ unless (null noParamBidirMethods) $+ putStrLn $ " Found " <> show (length noParamBidirMethods) <>+ " bidirectional method(s) with no parameters"+ pure ()++ it "handles methods with complex return types and bidirectional" $ do+ let bidirMethods = filter (isJust . mdBidirType) (Map.elems $ irMethods ir)+ forM_ bidirMethods $ \method ->+ -- Return type should be valid (not RefUnknown)+ case mdReturns method of+ RefUnknown -> expectationFailure $ T.unpack $+ "Bidirectional method " <> mdFullPath method <> " has RefUnknown return type"+ _ -> pure ()++ it "mdBidirType is consistent across IR operations" $ do+ -- Test that mdBidirType survives IR transformations+ let allMethods = Map.elems $ irMethods ir+ let bidirCount = length $ filter (isJust . mdBidirType) allMethods+ -- The count should be stable+ bidirCount `shouldSatisfy` (>= 0)+ pure ()++ describe "Statistics and reporting" $ do+ it "reports bidirectional coverage statistics" $ do+ let allMethods = Map.elems $ irMethods ir+ let bidirMethods = filter (isJust . mdBidirType) allMethods+ let streamingMethods = filter mdStreaming allMethods++ putStrLn "\n Bidirectional Statistics:"+ putStrLn $ " Total methods: " <> show (length allMethods)+ putStrLn $ " Streaming methods: " <> show (length streamingMethods)+ putStrLn $ " Bidirectional methods:" <> show (length bidirMethods)++ if null bidirMethods+ then putStrLn " (No bidirectional methods found - tests are informational)"+ else do+ putStrLn " Bidirectional methods:"+ forM_ bidirMethods $ \method ->+ putStrLn $ " - " <> T.unpack (mdFullPath method)++ pure ()++-- Helper to avoid importing Control.Monad.Extra+unless :: Bool -> IO () -> IO ()+unless condition action = if condition then pure () else action++-- Helper function to test a specific bidirectional method+testBidirMethod :: IR -> Text -> Spec+testBidirMethod ir methodPath =+ case Map.lookup methodPath (irMethods ir) of+ Nothing -> it (T.unpack methodPath <> " exists (skipped - not found)") pending+ Just method -> do+ it (T.unpack methodPath <> " is marked as bidirectional") $+ isJust (mdBidirType method) `shouldBe` True++ it (T.unpack methodPath <> " has standard bidir type (RefAny)") $+ mdBidirType method `shouldBe` Just RefAny++ it (T.unpack methodPath <> " is a streaming method") $+ mdStreaming method `shouldBe` True
+ test/BidirSpec.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Bidirectional communication tests+--+-- Tests for Synapse.Bidir module, covering:+-- - Request/Response type handling+-- - BidirMode parsing and handling+-- - JSON serialization/deserialization+-- - BidirHandler functions+module Main where++import Data.Aeson (Value(..), decode, encode, object, (.=))+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS8+import Data.Maybe (isJust, isNothing, fromJust)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Test.Hspec++import Plexus.Types+ ( Request(..)+ , Response(..)+ , SelectOption(..)+ )+import Synapse.Bidir+ ( BidirMode(..)+ , parseBidirMode+ , defaultBidirMode+ )++main :: IO ()+main = hspec $ do++ describe "Request type constructors" $ do+ it "creates Confirm request" $ do+ let req = Confirm "Are you sure?" (Just True) :: Request Value+ confirmMessage req `shouldBe` "Are you sure?"+ confirmDefault req `shouldBe` Just True++ it "creates Prompt request with default" $ do+ let req = Prompt "Enter name" (Just (String "default")) (Just "placeholder") :: Request Value+ promptMessage req `shouldBe` "Enter name"+ promptDefault req `shouldBe` Just (String "default")+ promptPlaceholder req `shouldBe` Just "placeholder"++ it "creates Prompt request without default" $ do+ let req = Prompt "Enter value" Nothing Nothing :: Request Value+ promptMessage req `shouldBe` "Enter value"+ promptDefault req `shouldBe` Nothing+ promptPlaceholder req `shouldBe` Nothing++ it "creates Select request" $ do+ let opts = [ SelectOption (String "a") "Option A" Nothing+ , SelectOption (String "b") "Option B" (Just "Description B")+ ]+ let req = Select "Choose one" opts False :: Request Value+ selectMessage req `shouldBe` "Choose one"+ length (selectOptions req) `shouldBe` 2+ selectMulti req `shouldBe` False++ describe "Response type constructors" $ do+ it "creates Confirmed response" $ do+ let resp = Confirmed True :: Response Value+ confirmedValue resp `shouldBe` True++ it "creates Value response" $ do+ let resp = Value (String "result") :: Response Value+ responseValue resp `shouldBe` String "result"++ it "creates Selected response" $ do+ let resp = Selected [String "a", String "b"] :: Response Value+ selectedValues resp `shouldBe` [String "a", String "b"]++ it "creates Cancelled response" $ do+ let resp = Cancelled :: Response Value+ resp `shouldBe` Cancelled++ describe "Request JSON serialization" $ do+ it "serializes Confirm request" $ do+ let req = Confirm "Proceed?" (Just True) :: Request Value+ let json = encode req+ let decoded = decode json :: Maybe (Request Value)+ decoded `shouldBe` Just req++ it "serializes Confirm without default" $ do+ let req = Confirm "Proceed?" Nothing :: Request Value+ let json = encode req+ let decoded = decode json :: Maybe (Request Value)+ decoded `shouldBe` Just req++ it "serializes Prompt request" $ do+ let req = Prompt "Enter name" (Just (String "default")) (Just "hint") :: Request Value+ let json = encode req+ let decoded = decode json :: Maybe (Request Value)+ decoded `shouldBe` Just req++ it "serializes Select request" $ do+ let opts = [SelectOption (String "x") "Label" Nothing]+ let req = Select "Choose" opts False :: Request Value+ let json = encode req+ let decoded = decode json :: Maybe (Request Value)+ decoded `shouldBe` Just req++ it "deserializes confirm request from JSON" $ do+ let jsonStr = "{\"type\":\"confirm\",\"message\":\"Continue?\",\"default\":true}"+ let decoded = decode (LBS8.pack jsonStr) :: Maybe (Request Value)+ isJust decoded `shouldBe` True+ case decoded of+ Just (Confirm msg def) -> do+ msg `shouldBe` "Continue?"+ def `shouldBe` Just True+ _ -> expectationFailure "Expected Confirm request"++ it "deserializes prompt request from JSON" $ do+ let jsonStr = "{\"type\":\"prompt\",\"message\":\"Name?\",\"placeholder\":\"John\"}"+ let decoded = decode (LBS8.pack jsonStr) :: Maybe (Request Value)+ isJust decoded `shouldBe` True+ case decoded of+ Just (Prompt msg _ placeholder) -> do+ msg `shouldBe` "Name?"+ placeholder `shouldBe` Just "John"+ _ -> expectationFailure "Expected Prompt request"++ describe "Response JSON serialization" $ do+ it "serializes Confirmed response" $ do+ let resp = Confirmed True :: Response Value+ let json = encode resp+ let decoded = decode json :: Maybe (Response Value)+ decoded `shouldBe` Just resp++ it "serializes Value response with 'text' tag" $ do+ let resp = Value (String "answer") :: Response Value+ let json = encode resp+ let jsonText = T.decodeUtf8 $ LBS.toStrict json+ -- Should serialize with "text" tag for wire compatibility+ jsonText `shouldSatisfy` T.isInfixOf "\"text\""+ let decoded = decode json :: Maybe (Response Value)+ decoded `shouldBe` Just resp++ it "serializes Selected response" $ do+ let resp = Selected [String "a"] :: Response Value+ let json = encode resp+ let decoded = decode json :: Maybe (Response Value)+ decoded `shouldBe` Just resp++ it "serializes Cancelled response" $ do+ let resp = Cancelled :: Response Value+ let json = encode resp+ let decoded = decode json :: Maybe (Response Value)+ decoded `shouldBe` Just resp++ it "deserializes confirmed response from JSON" $ do+ let jsonStr = "{\"type\":\"confirmed\",\"value\":true}"+ let decoded = decode (LBS8.pack jsonStr) :: Maybe (Response Value)+ decoded `shouldBe` Just (Confirmed True)++ it "deserializes text response from JSON" $ do+ let jsonStr = "{\"type\":\"text\",\"value\":\"hello\"}"+ let decoded = decode (LBS8.pack jsonStr) :: Maybe (Response Value)+ decoded `shouldBe` Just (Value (String "hello"))++ it "deserializes cancelled response from JSON" $ do+ let jsonStr = "{\"type\":\"cancelled\"}"+ let decoded = decode (LBS8.pack jsonStr) :: Maybe (Response Value)+ decoded `shouldBe` Just Cancelled++ describe "SelectOption JSON serialization" $ do+ it "serializes SelectOption with description" $ do+ let opt = SelectOption (String "val") "Label" (Just "Desc") :: SelectOption Value+ let json = encode opt+ let decoded = decode json :: Maybe (SelectOption Value)+ decoded `shouldBe` Just opt++ it "serializes SelectOption without description" $ do+ let opt = SelectOption (String "val") "Label" Nothing :: SelectOption Value+ let json = encode opt+ let decoded = decode json :: Maybe (SelectOption Value)+ decoded `shouldBe` Just opt++ it "deserializes SelectOption from JSON" $ do+ let jsonStr = "{\"value\":\"x\",\"label\":\"X\",\"description\":\"Choose X\"}"+ let decoded = decode (LBS8.pack jsonStr) :: Maybe (SelectOption Value)+ isJust decoded `shouldBe` True+ case decoded of+ Just opt -> do+ optionValue opt `shouldBe` String "x"+ optionLabel opt `shouldBe` "X"+ optionDescription opt `shouldBe` Just "Choose X"+ _ -> expectationFailure "Expected SelectOption"++ describe "BidirMode parsing" $ do+ it "parses 'interactive'" $+ parseBidirMode "interactive" `shouldBe` Just BidirInteractive++ it "parses 'json'" $+ parseBidirMode "json" `shouldBe` Just BidirJson++ it "parses 'auto-cancel'" $+ parseBidirMode "auto-cancel" `shouldBe` Just BidirAutoCancel++ it "parses 'defaults'" $+ parseBidirMode "defaults" `shouldBe` Just BidirDefaults++ it "parses 'respond'" $+ parseBidirMode "respond" `shouldBe` Just BidirRespond++ it "returns Nothing for invalid mode" $+ parseBidirMode "invalid" `shouldBe` Nothing++ it "is case-sensitive" $+ parseBidirMode "INTERACTIVE" `shouldBe` Nothing++ describe "BidirMode defaults" $ do+ it "default mode is Interactive" $+ defaultBidirMode `shouldBe` BidirInteractive++ describe "BidirMode equality" $ do+ it "BidirInteractive equals itself" $+ BidirInteractive `shouldBe` BidirInteractive++ it "BidirJson equals itself" $+ BidirJson `shouldBe` BidirJson++ it "BidirAutoCancel equals itself" $+ BidirAutoCancel `shouldBe` BidirAutoCancel++ it "BidirDefaults equals itself" $+ BidirDefaults `shouldBe` BidirDefaults++ it "BidirRespond equals itself" $+ BidirRespond `shouldBe` BidirRespond++ it "BidirCmd with same command equals itself" $+ BidirCmd "test.sh" `shouldBe` BidirCmd "test.sh"++ it "BidirCmd with different commands are not equal" $+ BidirCmd "a.sh" `shouldNotBe` BidirCmd "b.sh"++ it "different modes are not equal" $+ BidirInteractive `shouldNotBe` BidirJson++ describe "Request/Response type compatibility" $ do+ it "Confirm request expects Confirmed response" $ do+ let req = Confirm "OK?" Nothing :: Request Value+ let resp = Confirmed True :: Response Value+ -- Test that types are compatible (both compile and serialize)+ isJust (decode (encode resp) :: Maybe (Response Value)) `shouldBe` True++ it "Prompt request expects Value response" $ do+ let req = Prompt "Input?" Nothing Nothing :: Request Value+ let resp = Value (String "answer") :: Response Value+ isJust (decode (encode resp) :: Maybe (Response Value)) `shouldBe` True++ it "Select request expects Selected response" $ do+ let opts = [SelectOption (String "a") "A" Nothing]+ let req = Select "Pick" opts False :: Request Value+ let resp = Selected [String "a"] :: Response Value+ isJust (decode (encode resp) :: Maybe (Response Value)) `shouldBe` True++ it "Any request can receive Cancelled response" $ do+ let req = Confirm "?" Nothing :: Request Value+ let resp = Cancelled :: Response Value+ isJust (decode (encode resp) :: Maybe (Response Value)) `shouldBe` True++ describe "Complex Request/Response scenarios" $ do+ it "handles Select with multiple options" $ do+ let opts = [ SelectOption (String "opt1") "Option 1" (Just "First option")+ , SelectOption (String "opt2") "Option 2" (Just "Second option")+ , SelectOption (String "opt3") "Option 3" Nothing+ ]+ let req = Select "Choose multiple" opts True :: Request Value+ let json = encode req+ let decoded = decode json :: Maybe (Request Value)+ isJust decoded `shouldBe` True+ case decoded of+ Just (Select _ decodedOpts multi) -> do+ length decodedOpts `shouldBe` 3+ multi `shouldBe` True+ optionLabel (head decodedOpts) `shouldBe` "Option 1"+ _ -> expectationFailure "Expected Select request"++ it "handles Selected with multiple values" $ do+ let resp = Selected [String "a", String "b", String "c"] :: Response Value+ let json = encode resp+ let decoded = decode json :: Maybe (Response Value)+ case decoded of+ Just (Selected vals) -> length vals `shouldBe` 3+ _ -> expectationFailure "Expected Selected response"++ it "handles Prompt with complex default value" $ do+ let defaultVal = object ["name" .= String "John", "age" .= (30 :: Int)]+ let req = Prompt "User info" (Just defaultVal) Nothing :: Request Value+ let json = encode req+ let decoded = decode json :: Maybe (Request Value)+ isJust decoded `shouldBe` True+ case decoded of+ Just (Prompt _ def _) -> def `shouldBe` Just defaultVal+ _ -> expectationFailure "Expected Prompt request"++ describe "Edge cases" $ do+ it "handles empty string in Confirm message" $ do+ let req = Confirm "" Nothing :: Request Value+ let json = encode req+ let decoded = decode json :: Maybe (Request Value)+ decoded `shouldBe` Just req++ it "handles empty options list in Select" $ do+ let req = Select "Choose" [] False :: Request Value+ let json = encode req+ let decoded = decode json :: Maybe (Request Value)+ decoded `shouldBe` Just req++ it "handles empty selected values" $ do+ let resp = Selected [] :: Response Value+ let json = encode resp+ let decoded = decode json :: Maybe (Response Value)+ decoded `shouldBe` Just resp++ it "handles SelectOption with empty label" $ do+ let opt = SelectOption (String "val") "" Nothing :: SelectOption Value+ let json = encode opt+ let decoded = decode json :: Maybe (SelectOption Value)+ decoded `shouldBe` Just opt
test/CLISpec.hs view
@@ -14,33 +14,33 @@ 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"]+ it "root" $ ["--help"] `has` ["synapse", "backend"]+ it "substrate" $ ["substrate"] `has` ["echo", "solar", "health"]+ it "echo" $ ["substrate", "echo"] `has` ["echo", "Echo messages back"]+ it "solar" $ ["substrate", "solar"] `has` ["solar", "Solar system model"]+ it "health" $ ["substrate", "health"] `has` ["health", "Check hub health"]+ it "solar earth" $ ["substrate", "solar", "earth"] `has` ["earth", "planet"]+ it "solar earth luna" $ ["substrate", "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"]+ it "echo once" $ ["substrate", "echo", "once"] `has` ["once", "--message", "required"]+ it "echo echo" $ ["substrate", "echo", "echo"] `has` ["--message", "--count"] -- health.check has no required params, so it auto-invokes- it "health check" $ ["plexus", "health", "check"] `has` ["healthy"]+ it "health check" $ ["substrate", "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"]+ it "echo once" $ call ["substrate", "echo", "once"] (msg "test") `has` ["test"]+ it "echo count" $ call ["substrate", "echo", "echo"] (msgN "hi" 2) `has` ["hi", "2"]+ it "health" $ callRaw ["substrate", "health", "check"] "{}" `has` ["healthy"]+ it "solar observe" $ callRaw ["substrate", "solar", "observe"] "{}" `has` ["sol", "planet_count"]+ it "luna info" $ callRaw ["substrate", "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"+synapse = "dist-newstyle/build/aarch64-osx/ghc-9.6.7/plexus-synapse-0.3.0.0/x/synapse/build/synapse/synapse" -- | Assert synapse output contains all substrings has :: [String] -> [Text] -> Expectation@@ -56,15 +56,13 @@ assertContains haystack needle = T.toLower haystack `shouldSatisfy` T.isInfixOf (T.toLower needle) --- | Build invocation args+-- | Build invocation args (options before backend due to noIntersperse) call :: [String] -> String -> [String]-call path params = path ++ ["-p", params]+call path params = ["-p", params] ++ path --- | Build invocation args with --raw (skip templates)--- Note: --raw must come after "plexus" subcommand+-- | Build invocation args with --raw (options before backend) callRaw :: [String] -> String -> [String]-callRaw (backend:rest) params = [backend, "--raw"] ++ rest ++ ["-p", params]-callRaw [] params = ["-p", params] -- fallback, shouldn't happen+callRaw path params = ["--raw", "-p", params] ++ path -- | JSON builders msg :: String -> String
test/IRSpec.hs view
@@ -4,11 +4,13 @@ -- | Integration tests for IR-based CLI ----- Requires a running Hub backend on localhost:4444+-- By default, discovers "substrate" via registry at localhost:4444.+-- Override with: cabal test ir-test --test-options="<backend> [--port <port>]" ----- Usage: cabal test ir-test --test-options="<backend> [--port <port>]"--- Example: cabal test ir-test --test-options="plexus"--- cabal test ir-test --test-options="plexus --port 5555"+-- Examples:+-- cabal test ir-test -- auto-discover via registry+-- cabal test ir-test --test-options="substrate" -- direct connect, default port 4445+-- cabal test ir-test --test-options="substrate --port 4445" -- -- Tests that for every method in the schema: -- 1. IR builds successfully@@ -35,42 +37,49 @@ import Synapse.CLI.Help (renderMethodHelp, expandType) import Synapse.CLI.Support (SupportLevel(..), methodSupport) import Synapse.Monad+import Synapse.Backend.Discovery (Backend(..), BackendDiscovery(..), registryDiscovery) main :: IO () main = do args <- getArgs- case parseArgs args of- Nothing -> do- putStrLn "Usage: ir-test <backend> [--port <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 <> ")"+ (backend, host, port) <- resolveBackend args+ putStrLn $ "Running IR integration tests against " <> T.unpack host <> ":" <> show port <> " (backend: " <> T.unpack backend <> ")" - -- Initialize environment- env <- initEnv "127.0.0.1" port backend+ env <- initEnv host port backend - -- Build IR once for all tests- irResult <- runSynapseM env (buildIR [])+ -- 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+ case irResult of+ Left err -> do+ putStrLn $ "Failed to build IR: " <> show err+ putStrLn "Is the Hub backend running?"+ withArgs [] $ hspec $ describe "IR Integration Tests" $+ it "connects to Hub backend" $+ expectationFailure $ "Could not connect: " <> show err - Right ir -> withArgs [] $ hspec $ irSpec ir+ Right ir -> withArgs [] $ hspec $ irSpec ir --- | Parse command-line arguments: <backend> [--port <port>]-parseArgs :: [String] -> Maybe (Text, Int)-parseArgs [] = Nothing-parseArgs (backend:rest) = Just (T.pack backend, parsePort rest)+-- | Resolve backend connection: explicit args or registry discovery+resolveBackend :: [String] -> IO (Text, Text, Int)+resolveBackend (backendStr:rest) = do+ let backend = T.pack backendStr+ port = parsePort rest+ putStrLn $ "Using explicit backend: " <> backendStr <> " on port " <> show port+ pure (backend, "127.0.0.1", port) where- parsePort ("--port":p:_) = maybe 4444 id (readMaybe p)- parsePort _ = 4444+ parsePort ("--port":p:_) = maybe 4445 id (readMaybe p)+ parsePort _ = 4445+resolveBackend [] = do+ putStrLn "No backend specified, discovering substrate via registry at localhost:4444..."+ let discovery = registryDiscovery "127.0.0.1" 4444+ result <- getBackendInfo discovery "substrate"+ case result of+ Just backend -> do+ putStrLn $ "Discovered substrate at " <> T.unpack (backendHost backend) <> ":" <> show (backendPort backend)+ pure (backendName backend, backendHost backend, backendPort backend)+ Nothing ->+ error "substrate not found via registry at localhost:4444. Is the registry and substrate running?" -- | Main spec using pre-built IR irSpec :: IR -> Spec