diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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{..} diff --git a/plexus-synapse.cabal b/plexus-synapse.cabal --- a/plexus-synapse.cabal +++ b/plexus-synapse.cabal @@ -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 diff --git a/src/Synapse/Algebra/Recursion.hs b/src/Synapse/Algebra/Recursion.hs --- a/src/Synapse/Algebra/Recursion.hs +++ b/src/Synapse/Algebra/Recursion.hs @@ -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 diff --git a/src/Synapse/Algebra/Walk.hs b/src/Synapse/Algebra/Walk.hs --- a/src/Synapse/Algebra/Walk.hs +++ b/src/Synapse/Algebra/Walk.hs @@ -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 diff --git a/src/Synapse/Backend/Discovery.hs b/src/Synapse/Backend/Discovery.hs --- a/src/Synapse/Backend/Discovery.hs +++ b/src/Synapse/Backend/Discovery.hs @@ -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 () diff --git a/src/Synapse/Bidir.hs b/src/Synapse/Bidir.hs --- a/src/Synapse/Bidir.hs +++ b/src/Synapse/Bidir.hs @@ -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 respond --request-id --response -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" diff --git a/src/Synapse/CLI/Parse.hs b/src/Synapse/CLI/Parse.hs --- a/src/Synapse/CLI/Parse.hs +++ b/src/Synapse/CLI/Parse.hs @@ -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 diff --git a/src/Synapse/IR/Builder.hs b/src/Synapse/IR/Builder.hs --- a/src/Synapse/IR/Builder.hs +++ b/src/Synapse/IR/Builder.hs @@ -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 diff --git a/src/Synapse/IR/Cache.hs b/src/Synapse/IR/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/IR/Cache.hs @@ -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 diff --git a/src/Synapse/IR/Types.hs b/src/Synapse/IR/Types.hs --- a/src/Synapse/IR/Types.hs +++ b/src/Synapse/IR/Types.hs @@ -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 diff --git a/src/Synapse/Schema/Types.hs b/src/Synapse/Schema/Types.hs --- a/src/Synapse/Schema/Types.hs +++ b/src/Synapse/Schema/Types.hs @@ -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 diff --git a/test/BidirIntegrationSpec.hs b/test/BidirIntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/BidirIntegrationSpec.hs @@ -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 [--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: [--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 diff --git a/test/BidirSpec.hs b/test/BidirSpec.hs new file mode 100644 --- /dev/null +++ b/test/BidirSpec.hs @@ -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 diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -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 diff --git a/test/IRSpec.hs b/test/IRSpec.hs --- a/test/IRSpec.hs +++ b/test/IRSpec.hs @@ -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=" [--port ]" -- --- Usage: cabal test ir-test --test-options=" [--port ]" --- Example: cabal test ir-test --test-options="plexus" --- cabal test ir-test --test-options="plexus --port 5555" +-- 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 [--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: [--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