plexus-synapse 3.13.0 → 3.15.0

raw patch · 55 files changed

+13872/−1266 lines, 55 filesdep +aeson-qqdep +base64-bytestringdep +case-insensitivedep ~aesondep ~plexus-protocoldep ~timePVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-qq, base64-bytestring, case-insensitive, crypton, ram, temporary, tls, unix, uuid

Dependency ranges changed: aeson, plexus-protocol, time, vector

API changes (from Hackage documentation)

Files

• app/Main.hs +1770/−980
• plexus-synapse.cabal +316/−3
• src/Synapse/Algebra/Render.hs +270/−88
• src/Synapse/Auth.hs +330/−0
• src/Synapse/Auth/Loopback.hs +199/−0
• src/Synapse/Backend/Discovery.hs +199/−72
• src/Synapse/CLI/Help.hs +356/−25
• src/Synapse/CLI/Parse.hs +241/−7
• src/Synapse/CLI/Source.hs +130/−0
• src/Synapse/CLI/Transform.hs +16/−7
• src/Synapse/Endpoint.hs +204/−0
• src/Synapse/Find.hs +657/−0
• src/Synapse/IR/Builder.hs +34/−1
• src/Synapse/IR/Cache.hs +14/−1
• src/Synapse/IR/Types.hs +65/−3
• src/Synapse/Identity/Command.hs +157/−0
• src/Synapse/Identity/Proof.hs +165/−0
• src/Synapse/Identity/Session.hs +521/−0
• src/Synapse/Identity/Store.hs +552/−0
• src/Synapse/Monad.hs +58/−8
• src/Synapse/Reconnect.hs +418/−0
• src/Synapse/Self.hs +139/−0
• src/Synapse/Self/Command.hs +1020/−0
• src/Synapse/Self/Commands.hs +3/−10
• src/Synapse/Self/IO.hs +445/−0
• src/Synapse/Self/Protocol/TestRunner.hs +3/−0
• src/Synapse/Self/Resolve.hs +216/−0
• src/Synapse/Self/Resolve/Default.hs +43/−0
• src/Synapse/Self/Resolve/Env.hs +53/−0
• src/Synapse/Self/Resolve/File.hs +86/−0
• src/Synapse/Self/Resolve/Keychain.hs +256/−0
• src/Synapse/Self/Resolve/Literal.hs +40/−0
• src/Synapse/Self/Types.hs +176/−0
• src/Synapse/Transport.hs +115/−17
• test/AuthSpec.hs +369/−0
• test/DeprecationSpec.hs +5/−1
• test/EndpointSpec.hs +107/−0
• test/FindSpec.hs +249/−0
• test/IR12MethodRoleSpec.hs +46/−1
• test/IRSpec.hs +3/−2
• test/IdentitySpec.hs +296/−0
• test/KeychainSpec.hs +147/−0
• test/MockHub.hs +320/−0
• test/ParseSpec.hs +354/−0
• test/PathNormalizationSpec.hs +13/−40
• test/ReconnectSpec.hs +284/−0
• test/RenderSpec.hs +318/−0
• test/Req8RenderSpec.hs +137/−0
• test/SchemaDecodeSpec.hs +190/−0
• test/SelfCommandSpec.hs +278/−0
• test/SelfMigrationSpec.hs +260/−0
• test/SelfSafeWriteSpec.hs +301/−0
• test/SelfSpec.hs +629/−0
• test/SourceSpec.hs +94/−0
• test/TlsSpec.hs +205/−0

@@ -15,983 +15,1773 @@ -- 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-import qualified Data.Text.Encoding as TE-import Options.Applicative-import Data.Version (showVersion)-import qualified Paths_plexus_synapse as Meta-import System.Directory (doesFileExist, getHomeDirectory)-import System.Exit (exitFailure, exitSuccess)-import System.FilePath ((</>))-import System.IO (hPutStrLn, stderr, hFlush, stdout)---import Synapse.Schema.Types-import Synapse.Monad (SynapseM, SynapseEnv(..), SynapseError(..), BackendErrorType(..), TransportContext(..), TransportErrorCategory(..), initEnv, runSynapseM, throwNav, throwTransport, throwParse, throwBackend)-import qualified Synapse.Log as Log-import qualified Katip-import Synapse.Algebra.Navigate-import Synapse.Algebra.Render (renderSchema)-import Synapse.CLI.Help (renderMethodHelp)-import Synapse.CLI.Parse (parseParams)-import qualified Synapse.CLI.Parse as Parse-import Synapse.IR.Types (IR, irMethods, MethodDef)-import qualified Data.Map.Strict as Map-import qualified Synapse.CLI.Template as TemplateIR-import Synapse.Deprecation (emitActivationWarning, emitMethodWarning)-import Synapse.Transport-import Synapse.Bidir (BidirMode(..), parseBidirMode, detectBidirMode, handleBidirRequest)-import Plexus.Types (Response(..))-import Synapse.CLI.Transform (mkTransformEnv, transformParams, defaultTransformers, injectBooleanDefaults, injectSmartDefaults)-import Synapse.IR.Builder (buildIR)-import Synapse.Renderer (RendererConfig, defaultRendererConfig, renderItem, prettyValue, withMethodPath)-import System.Directory (createDirectoryIfMissing, getHomeDirectory)-import System.FilePath ((</>))-import qualified Synapse.Self.Commands as Self-import Synapse.Backend.Discovery (Backend(..), BackendDiscovery(..), registryDiscovery, pingBackends, getBackendAt, registerWithRegistry)---- ============================================================================--- Types--- ============================================================================---- | Synapse-level options (must appear before backend)--- Controls connection settings and output format-data SynapseOpts = SynapseOpts-  { soHost          :: Text          -- ^ Registry host for discovery-  , soPort          :: Int           -- ^ Registry port for discovery-  , soJson          :: Bool          -- ^ Output raw JSON stream items-  , soRaw           :: Bool          -- ^ Output raw content (no templates)-  , soDryRun        :: Bool          -- ^ Show request without sending-  , soSchema        :: Bool          -- ^ Fetch raw schema JSON-  , soGenerate      :: Bool          -- ^ Generate templates from IR-  , soEmitIR        :: Bool          -- ^ Emit IR for code generation-  , soParams        :: Maybe Text    -- ^ JSON params via -p-  , soRpc           :: Maybe Text    -- ^ Raw JSON-RPC passthrough-  , soGeneratorInfo :: [Text]        -- ^ Generator tool info (tool:version pairs)-  , soBidirMode     :: Maybe Text    -- ^ Bidirectional mode override-  , soBidirCmd      :: Maybe Text    -- ^ Bidirectional subprocess command (--bidir-cmd)-  , soNoCache       :: Bool          -- ^ Disable IR caching-  , soLogLevel      :: Maybe Text    -- ^ Log level: info, debug, trace-  , soLogSubsystems :: [Text]        -- ^ Filter logs by subsystems (empty = all)-  , soToken         :: Maybe Text    -- ^ JWT sent as Cookie: access_token=<jwt>-  , soTokenFile     :: Maybe Text    -- ^ Path to token file (overridden by --token)-  , soNoDeprecationWarnings :: Bool  -- ^ Suppress invocation-time deprecation warnings (IR-15)-  }-  deriving Show---- | Full CLI arguments after two-phase parsing-data Args = Args-  { argOpts    :: SynapseOpts   -- ^ Synapse-level options-  , argBackend :: Maybe Text    -- ^ Backend name (first positional)-  , argPath    :: [Text]        -- ^ Path segments and --key value params (raw)-  }-  deriving Show----- ============================================================================--- Constants--- ============================================================================--defaultHost :: Text-defaultHost = "127.0.0.1"--defaultPort :: Int-defaultPort = 4444---- ============================================================================--- Logging Helper--- ============================================================================---- | Create a logger from command-line options--- Default: ErrorS (only show errors)-makeLoggerFromOpts :: SynapseOpts -> IO Log.Logger-makeLoggerFromOpts opts = do-  let level = case soLogLevel opts of-        Nothing -> Katip.ErrorS  -- Default: only errors-        Just levelStr -> parseLogLevel levelStr-  Log.makeLogger level-  where-    parseLogLevel "error" = Katip.ErrorS-    parseLogLevel "warn" = Katip.WarningS-    parseLogLevel "info" = Katip.InfoS-    parseLogLevel "debug" = Katip.DebugS-    parseLogLevel _ = Katip.ErrorS  -- Default to error---- ============================================================================--- Token Resolution--- ============================================================================---- | Resolve the auth token to use for this invocation.------ Priority:---   1. --token <jwt>           (explicit, highest priority)---   2. --token-file <path>     (explicit file)---   3. ~/.plexus/tokens/<backend>  (per-backend default)------ Token files contain just the raw JWT, optionally with a trailing newline.-resolveToken :: SynapseOpts -> Text -> IO (Maybe Text)-resolveToken opts backend =-  case soToken opts of-    Just tok -> pure (Just tok)-    Nothing  -> do-      mPath <- case soTokenFile opts of-        Just path -> pure (Just (T.unpack path))-        Nothing   -> do-          home <- getHomeDirectory-          let defaultPath = home </> ".plexus" </> "tokens" </> T.unpack backend-          exists <- doesFileExist defaultPath-          pure $ if exists then Just defaultPath else Nothing-      case mPath of-        Nothing   -> pure Nothing-        Just path -> do-          contents <- TIO.readFile path-          let tok = T.strip contents-          pure $ if T.null tok then Nothing else Just tok---- ============================================================================--- Argument Splitting--- ============================================================================--- Main--- ============================================================================--main :: IO ()-main = do-  args <- execParser argsInfo-  let opts = argOpts args--  -- Initialize logger (default: ErrorS, only show errors)-  logger <- makeLoggerFromOpts opts--  Log.logDebug logger Log.SubsystemCLI "synapse starting..."--  -- Use specified host/port for registry discovery-  let discovery = registryDiscovery (soHost opts) (soPort opts)--  -- Get the backend at the connection point (host:port)-  -- If it has a registry plugin, that's used for discovering other backends-  Log.logDebug logger Log.SubsystemDiscovery $-    "Checking backend at " <> soHost opts <> ":" <> T.pack (show (soPort opts))--  maybeBackend <- getBackendAt (soHost opts) (soPort opts)--  Log.logDebug logger Log.SubsystemDiscovery $-    "Backend check complete: " <> T.pack (show maybeBackend)-  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-      | soEmitIR opts || soSchema opts || soJson opts || soRaw opts ->-          runWithDiscovery discovery hostBackend args-      | otherwise -> do-          -- No backend specified, show available backends-          TIO.putStr cliHeader-          backends <- discoverBackends discovery-          -- Ping backends to check if they're reachable-          backendsWithStatus <- pingBackends backends-          TIO.putStrLn "\nAvailable backends:"-          mapM_ printBackend backendsWithStatus-          TIO.putStrLn "\nUsage: synapse <backend> [command...]"-    Just backend-      -- Handle --help/-h if it somehow ends up as the backend-      | backend `elem` ["--help", "-h"] -> TIO.putStr cliHeader-      -- Handle _self meta-commands (use discovered primary backend)-      | backend == "_self" -> runWithDiscovery discovery hostBackend args-      | otherwise -> runWithDiscovery discovery backend args---- | Print a backend in the list-printBackend :: Backend -> IO ()-printBackend b = do-  let nameField = T.justifyLeft 15 ' ' (backendName b)-  let hostPort = backendHost b <> ":" <> T.pack (show (backendPort b))-  let status = case backendReachable b of-        Just True  -> " [OK]"-        Just False -> " [UNREACHABLE]"-        Nothing    -> ""-  let desc = if T.null (backendDescription b)-             then ""-             else " - " <> backendDescription b-  TIO.putStrLn $ "  " <> nameField <> hostPort <> status <> desc---- | Run a Hub command with backend discovery-runWithDiscovery :: BackendDiscovery -> Text -> Args -> IO ()-runWithDiscovery discovery backendName args = do-  let opts = argOpts args-  -- Try to discover backend info-  maybeBackend <- getBackendInfo discovery backendName--  case maybeBackend of-    Just backend -> do-      -- 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-        Nothing -> do-          -- Protocol handshake failed when verifying backend-          logger <- makeLoggerFromOpts opts-          token <- resolveToken opts backendName-          env <- initEnv (soHost opts) (soPort opts) backendName logger token-          result <- runSynapseM env (throwBackend (ProtocolHandshakeFailed (backendHost backend) (backendPort backend)) [])-          case result of-            Left err -> do-              hPutStrLn stderr $ renderError err-              exitFailure-            Right () -> exitSuccess-        Just _ ->-          -- Match confirmed-          run backendName (backendHost backend) (backendPort backend) args-    Nothing -> do-      -- Backend not found in registry - check if this was a direct connection attempt-      -- where the protocol handshake failed-      maybeDirectBackend <- getBackendAt (soHost opts) (soPort opts)-      logger <- makeLoggerFromOpts opts-      token <- resolveToken opts backendName-      env <- initEnv (soHost opts) (soPort opts) backendName logger token-      case maybeDirectBackend of-        Nothing -> do-          -- Protocol handshake failed at the specified host:port-          result <- runSynapseM env (throwBackend (ProtocolHandshakeFailed (soHost opts) (soPort opts)) [])-          case result of-            Left err -> do-              hPutStrLn stderr $ renderError err-              exitFailure-            Right () -> exitSuccess-        Just discoveredName | discoveredName /= backendName -> do-          -- Backend exists but has a different name-          backends <- discoverBackends discovery-          backendsWithStatus <- pingBackends backends-          result <- runSynapseM env (throwBackend (BackendNotFound backendName) backendsWithStatus)-          case result of-            Left err -> do-              hPutStrLn stderr $ renderError err-              exitFailure-            Right () -> exitSuccess-        Just _ -> do-          -- Backend discovered successfully - should not reach here, but proceed-          run backendName (soHost opts) (soPort opts) args---- | Run a Hub command with specified backend and connection details-run :: Text -> Text -> Int -> Args -> IO ()-run backend host port args = do-  let opts = argOpts args-  logger <- makeLoggerFromOpts opts-  Log.logInfo logger Log.SubsystemCLI $ "Synapse starting: backend=" <> backend <> ", host=" <> host <> ", port=" <> T.pack (show port)-  token <- resolveToken opts backend-  env <- initEnv host port backend logger token-  rendererCfg <- defaultRendererConfig-  Log.logDebug logger Log.SubsystemCLI "Running dispatch..."-  result <- runSynapseM env (dispatch args rendererCfg)-  case result of-    Left err -> do-      hPutStrLn stderr $ renderError err-      exitFailure-    Right () -> exitSuccess---- | Dispatch based on navigation result-dispatch :: Args -> RendererConfig -> SynapseM ()-dispatch Args{argOpts = SynapseOpts{..}, argBackend, argPath} rendererCfg = do-  -- Check for _self commands first (before anything else)-  case argBackend of-    Just "_self" -> do-      -- _self meta-command: parse subcommand and rest from argPath-      let (pathSegs, rawParams, _) = parsePathAndParams argPath-      case pathSegs of-        (subcommand : rest) -> do-          Self.dispatch subcommand rest rawParams-          return ()-        [] -> do-          -- No subcommand provided, show help-          Self.showHelp-          return ()--    -- Normal dispatch-    _ -> do-      -- Mode 1: Raw JSON-RPC passthrough-      case soRpc of-        Just rpcJson -> do-          case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 rpcJson) of-            Left err -> throwParse $ T.pack err-            Right rpcReq -> do-              items <- invokeRawRpc rpcReq-              liftIO $ mapM_ (printResult soJson soRaw rendererCfg) items-          return ()--        Nothing -> do-          -- Parse path and inline params (--key value pairs)-          let (pathSegs, rawParams, helpRequested) = parsePathAndParams argPath--          -- Normal Plexus RPC routing-          -- Apply parameter transformations (path expansion, env vars)-          transformEnv <- liftIO mkTransformEnv-          inlineParams <- liftIO $ transformParams transformEnv defaultTransformers rawParams--          -- Mode 1.5: Respond subcommand (agent sends a response to a pending bidir request)-          if not (null pathSegs) && head pathSegs == "respond"-            then handleRespondCommand rawParams--          -- Mode 2: Schema request-          else if soSchema-            then do-              -- Try to navigate and determine if last segment is a method-              schemaResult <- fetchSchemaForPath pathSegs-              case schemaResult of-                Left err -> throwNav $ FetchError err pathSegs-                Right val -> liftIO $ LBS.putStrLn $ encode val--            -- Mode 3: Generate templates (IR-driven approach)-            else if soGenerate-              then do-                homeDir <- liftIO getHomeDirectory-                let baseDir = homeDir </> ".config" </> "synapse" </> "templates"-                    writeAndLog gt = do-                      writeGeneratedTemplateIR baseDir gt-                      TIO.putStrLn $ "  " <> T.pack (TemplateIR.gtPath gt)-                liftIO $ TIO.putStrLn $ "Generating templates in " <> T.pack baseDir <> "..."-                count <- TemplateIR.generateAllTemplatesWithCallback writeAndLog pathSegs-                liftIO $ TIO.putStrLn $ "Generated " <> T.pack (show count) <> " templates"--              -- Mode 4: Emit IR for code generation-              else if soEmitIR-                then do-                  ir <- buildIR soGeneratorInfo pathSegs-                  liftIO $ LBS.putStrLn $ encode ir--                else do-                  -- Mode 5: Normal navigation-                  if null pathSegs-                    then do-                      rootSchema <- navigate []-                      case rootSchema of-                        ViewPlugin schema _ -> liftIO $ do-                          TIO.putStr cliHeader-                          TIO.putStr "\n\n"-                          TIO.putStr $ renderSchema schema-                        _ -> pure ()-                    else do-                      -- Navigate to target-                      view <- navigate pathSegs-                      case view of-                        -- Landed on a plugin: show help-                        ViewPlugin schema _ ->-                          liftIO $ TIO.putStr $ renderSchema schema--                        -- Landed on a method: invoke or show help-                        ViewMethod method path -> do-                          let fullPath = T.intercalate "." path--                          -- IR-15: emit stderr deprecation warnings right before any-                          -- real invocation. Dedupe is per-process-lifetime, so this-                          -- action is idempotent on repeat calls. We bind it as a-                          -- local SynapseM action and invoke it at both invocation-                          -- sites below (fast path and slow path). --help, --dry-run,-                          -- --schema, and --emit-ir do not invoke, and intentionally-                          -- do not fire these warnings.-                          let fireDeprecationWarnings :: SynapseM ()-                              fireDeprecationWarnings = do-                                liftIO $ emitMethodWarning-                                  soNoDeprecationWarnings-                                  fullPath-                                  (methodDeprecation method)-                                let namespacePath = init path-                                when (not (null namespacePath)) $ do-                                  let activationNs = T.intercalate "." namespacePath-                                  parentPlugin <- fetchSchemaAt namespacePath-                                  liftIO $ emitActivationWarning-                                    soNoDeprecationWarnings-                                    activationNs-                                    (psDeprecation parentPlugin)--                          -- 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 fireDeprecationWarnings >> invokeMethod path (object [])-                            else do-                              -- Build IR for this method's namespace-                              ir <- buildIR soGeneratorInfo (init path)--                              -- If --help was explicitly requested, show help and exit-                              if helpRequested-                                then do-                                  case Map.lookup fullPath (irMethods ir) of-                                    Just methodDef ->-                                      liftIO $ TIO.putStr $ renderMethodHelp ir methodDef-                                    Nothing ->-                                      liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method-                                else do-                                  -- Build params: use IR-driven parsing for inline params-                                  let schemaDefaults = extractSchemaDefaults method-                                  userParams <- case soParams of-                                    -- -p JSON: parse as raw JSON (bypass IR parsing)-                                    Just jsonStr ->-                                      case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 jsonStr) of-                                        Left err -> throwParse $ T.pack err-                                        Right p -> pure p-                                    Nothing-                                      | not (null inlineParams) ->-                                          -- Use IR-driven parsing for inline params-                                          case Map.lookup fullPath (irMethods ir) of-                                            Just methodDef -> do-                                              -- Inject boolean defaults for flags without values-                                              let paramsWithBools = injectBooleanDefaults ir methodDef inlineParams-                                              -- Inject smart defaults for missing required params (e.g., --path defaults to cwd)-                                              paramsWithDefaults <- liftIO $ injectSmartDefaults transformEnv ir methodDef paramsWithBools-                                              case parseParams ir methodDef paramsWithDefaults of-                                                Right p -> pure p-                                                Left errs -> do-                                                  liftIO $ mapM_ (hPutStrLn stderr . renderParseError) errs-                                                  throwParse "Parameter parsing failed"-                                            Nothing ->-                                              -- Fallback to flat object if method not in IR-                                              pure $ buildParamsObject inlineParams-                                      | otherwise -> pure $ object []-                                  -- Merge: user params override schema defaults-                                  let params = mergeParams schemaDefaults userParams--                                  if soDryRun-                                    then do-                                      backend <- asks seBackend-                                      liftIO $ LBS.putStrLn $ encodeDryRun backend (init path) (last path) params-                                    -- Show help when: method has required params AND user provided no params-                                    else if hasRequiredParams method && userParams == object [] && null inlineParams-                                      then do-                                        -- Render help from IR-                                        case Map.lookup fullPath (irMethods ir) of-                                          Just methodDef ->-                                            liftIO $ TIO.putStr $ renderMethodHelp ir methodDef-                                          Nothing ->-                                            -- Fallback: method not in IR, use basic info-                                            liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method-                                      -- IR-15: fire stderr deprecation warnings before real invocation.-                                      else fireDeprecationWarnings >> invokeMethod path params-  where-    handleRespondCommand :: [(Text, Text)] -> SynapseM ()-    handleRespondCommand params = do-      let mRequestId = lookup "request_id" params-          mResponseStr = lookup "response" params-      case (mRequestId, mResponseStr) of-        (Nothing, _) -> throwParse "Missing --request-id for respond subcommand"-        (_, Nothing) -> throwParse "Missing --response for respond subcommand"-        (Just requestId, Just responseStr) ->-          case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 responseStr) of-            Left err -> throwParse $ "Invalid --response JSON: " <> T.pack err-            Right (resp :: Response Value) -> sendResponse requestId resp--    invokeMethod path params = do-      let namespacePath = init path  -- path without method name-      let methodName' = last path-      -- Set method path hint for template resolution-      let rendererCfg' = withMethodPath rendererCfg path-      -- Determine bidirectional mode (--bidir-cmd takes precedence)-      bidirMode <- liftIO $ case soBidirCmd of-        Just cmd -> pure $ BidirCmd cmd-        Nothing  -> case soBidirMode of-          Just modeStr -> case parseBidirMode modeStr of-            Just mode -> pure mode-            Nothing -> do-              TIO.hPutStrLn stderr $ "[synapse] Unknown --bidir-mode: " <> modeStr <> ", using auto-detect"-              detectBidirMode-          Nothing -> detectBidirMode-      -- Use bidirectional streaming handler-      invokeStreamingWithBidir-        namespacePath-        methodName'-        params-        (printResult soJson soRaw rendererCfg')-        (handleBidirRequest bidirMode Nothing)--    -- Extract default values from JSON Schema properties-    -- Schema format: {"properties": {"key": {"default": value, ...}, ...}, ...}-    extractSchemaDefaults :: MethodSchema -> Value-    extractSchemaDefaults m = case methodParams m of-      Nothing -> object []-      Just (Object o) -> case KM.lookup "properties" o of-        Just (Object props) -> object-          [ (k, defaultVal)-          | (k, propSchema) <- KM.toList props-          , Object propObj <- [propSchema]-          , Just defaultVal <- [KM.lookup "default" propObj]-          ]-        _ -> object []-      Just _ -> object []--    -- Merge two JSON objects: right takes precedence over left-    mergeParams :: Value -> Value -> Value-    mergeParams (Object defaults) (Object user) =-      Object (KM.union user defaults)  -- union prefers first arg on conflict-    mergeParams _ user = user  -- if defaults aren't an object, just use user params--    -- Check if method has required parameters-    hasRequiredParams :: MethodSchema -> Bool-    hasRequiredParams m = case methodParams m of-      Nothing -> False-      Just (Object o) -> case KM.lookup "required" o of-        Just (Array arr) -> not (null arr)-        _ -> False-      Just _ -> False--    -- Fetch schema for a path, detecting if last segment is a method-    -- Uses navigate to determine what type of schema to fetch-    fetchSchemaForPath :: [Text] -> SynapseM (Either Text Value)-    fetchSchemaForPath segs = do-      view <- navigate segs-      case view of-        ViewPlugin schema _ -> pure $ Right $ toJSON schema-        ViewMethod method path -> do-          -- Use method-specific schema query for detailed method info-          let parentPath = init path-              methodName' = last path-          detailedMethod <- fetchMethodSchema parentPath methodName'-          pure $ Right $ toJSON detailedMethod--    -- Invoke raw JSON-RPC request-    invokeRawRpc :: Value -> SynapseM [HubStreamItem]-    invokeRawRpc rpcReq = do-      case rpcReq of-        Object o -> case (KM.lookup "method" o, KM.lookup "params" o) of-          (Just (String method), Just params) -> invokeRaw method params-          (Just (String method), Nothing) -> invokeRaw method (object [])-          _ -> throwParse "JSON-RPC must have 'method' field"-        _ -> throwParse "JSON-RPC must be an object"---- | Parse path segments and --key value params--- Returns (path segments, [(key, value)] params, help requested)--- Example: ["echo", "once", "--message", "hello", "--count", "3"]---       -> (["echo", "once"], [("message", "hello"), ("count", "3")], False)--- Example: ["echo", "once", "--help"]---       -> (["echo", "once"], [], True)-parsePathAndParams :: [Text] -> ([Text], [(Text, Text)], Bool)-parsePathAndParams = go [] [] False-  where-    go path params helpReq [] = (reverse path, reverse params, helpReq)-    go path params helpReq (x:xs)-      -- --help flag: mark help requested, don't add as param-      | x == "--help" || x == "-h" =-          go path params True xs-      -- --key value pair (value must not start with --)-      | Just key <- T.stripPrefix "--" x-      , not (T.null key)-      , (val:rest) <- xs-      , not (T.isPrefixOf "--" val) =-          let normalizedKey = T.replace "-" "_" key  -- Normalize kebab-case to snake_case-          in go path ((normalizedKey, val) : params) helpReq rest-      -- --key with no value or next arg is another flag (boolean flag)-      | Just key <- T.stripPrefix "--" x-      , not (T.null key) =-          let normalizedKey = T.replace "-" "_" key  -- Normalize kebab-case to snake_case-          in go path ((normalizedKey, "") : params) helpReq xs-      -- Regular path segment - split on dots to support Plexus RPC path syntax (e.g., cone.chat)-      | otherwise =-          let segments = map (T.replace "-" "_") $ filter (not . T.null) $ T.splitOn "." x-          in go (reverse segments ++ path) params helpReq xs---- | Build JSON object from key-value pairs-buildParamsObject :: [(Text, Text)] -> Value-buildParamsObject pairs = object-  [ (K.fromText k, inferValue v) | (k, v) <- pairs ]-  where-    -- Try to infer the JSON type from the string value-    inferValue :: Text -> Value-    inferValue t-      | t == "true" = Bool True-      | t == "false" = Bool False-      | Just n <- readMaybe (T.unpack t) :: Maybe Integer = Number (fromInteger n)-      | Just n <- readMaybe (T.unpack t) :: Maybe Double = Number (realToFrac n)-      | otherwise = String t--readMaybe :: Read a => String -> Maybe a-readMaybe s = case reads s of-  [(x, "")] -> Just x-  _ -> Nothing---- | ASCII splash logo-splash :: Text-splash = T.unlines-  [ ""-  , "███████╗██╗   ██╗███╗   ██╗ █████╗ ██████╗ ███████╗███████╗"-  , "██╔════╝╚██╗ ██╔╝████╗  ██║██╔══██╗██╔══██╗██╔════╝██╔════╝"-  , "███████╗ ╚████╔╝ ██╔██╗ ██║███████║██████╔╝███████╗█████╗  "-  , "╚════██║  ╚██╔╝  ██║╚██╗██║██╔══██║██╔═══╝ ╚════██║██╔══╝  "-  , "███████║   ██║   ██║ ╚████║██║  ██║██║     ███████║███████╗"-  , "╚══════╝   ╚═╝   ╚═╝  ╚═══╝╚═╝  ╚═╝╚═╝     ╚══════╝╚══════╝"-  , ""-  ]---- | Get CLI help text from optparse-applicative-cliHeader :: Text-cliHeader = splash <> T.pack (fst $ renderFailure failure "synapse") <> selfHelp-  where-    failure = parserFailure defaultPrefs argsInfo (ShowHelpText Nothing) mempty-    selfHelp = T.unlines-      [ ""-      , "Meta-commands (local, no RPC):"-      , ""-      , "  synapse _self template"-      , "      Manage Mustache templates (CRUD operations)"-      , ""-      , "      Subcommands:"-      , "        list [pattern]      - List existing templates"-      , "        show <method>       - Display template content"-      , "        generate [pattern]  - Generate new templates from IR"-      , "        delete <pattern>    - Delete templates"-      , "        reload              - Clear template cache"-      , ""-      , "      Examples:"-      , "        synapse _self template list"-      , "        synapse _self template show cone.chat"-      , "        synapse _self template generate 'plexus.cone.*'"-      , ""-      ]---- | Render an error for display-renderError :: SynapseError -> String-renderError = \case-  NavError (NotFound seg path maybeSchema) ->-    let baseMsg = "Command not found: '" <> T.unpack seg <> "' at " <> showPath path-    in case maybeSchema of-      Nothing -> baseMsg-      Just schema ->-        let methods = psMethods schema-            children = pluginChildren schema-            suggestions = if null methods && null children-                         then ""-                         else "\n\nAvailable commands:"-                              <> renderMethods methods-                              <> renderChildren children-        in baseMsg <> suggestions-  NavError (MethodNotTerminal seg path) ->-    "Method '" <> T.unpack seg <> "' cannot have subcommands at " <> showPath path-  NavError (Cycle hash path) ->-    "Cycle detected: hash " <> T.unpack hash <> " at " <> showPath path-  NavError (FetchError msg path) ->-    "Fetch error at " <> showPath path <> ": " <> T.unpack msg-  TransportError msg ->-    "Transport error: " <> T.unpack msg-  TransportErrorContext ctx ->-    renderTransportError ctx-  ParseError msg ->-    "Parse error: " <> T.unpack msg-  ValidationError msg ->-    "Validation error: " <> T.unpack msg-  BackendError errorType backends ->-    case errorType of-      BackendNotFound name ->-        "Backend not found: '" <> T.unpack name <> "'"-        <> renderBackendList backends-      BackendUnreachable name ->-        "Backend unreachable: '" <> T.unpack name <> "'"-        <> renderBackendList backends-      NoBackendsAvailable ->-        "No backends available"-        <> renderBackendList backends-      ProtocolHandshakeFailed host port ->-        "Protocol handshake failed at " <> T.unpack host <> ":" <> show port <> "\n"-        <> "The _info request did not complete successfully within 2 seconds.\n"-        <> "This typically means:\n"-        <> "  - The server is not responding to Plexus RPC protocol messages\n"-        <> "  - The server is not sending required StreamDone messages\n"-        <> "  - The connection is timing out"-  where-    showPath [] = "root"-    showPath p = T.unpack $ T.intercalate "." p--    renderMethods [] = ""-    renderMethods methods =-      let header = "\n\n  Methods:"-          methodLines = map renderMethod methods-      in header <> concat methodLines--    renderMethod method =-      let name = T.unpack $ methodName method-          desc = T.unpack $ methodDescription method-          padding = 20-          namePadded = name <> replicate (max 1 (padding - length name)) ' '-      in "\n    " <> namePadded <> desc--    renderChildren [] = ""-    renderChildren children =-      let header = "\n\n  Child plugins:"-          childLines = map renderChild children-      in header <> concat childLines--    renderChild child =-      let name = T.unpack $ csNamespace child-          desc = T.unpack $ csDescription child-          padding = 20-          namePadded = name <> replicate (max 1 (padding - length name)) ' '-      in "\n    " <> namePadded <> desc--    renderBackendList [] = "\n\nNo backends available."-    renderBackendList backends =-      let header = "\n\nAvailable backends:"-          backendLines = map renderBackendLine backends-          usageHint = "\n\nUsage: synapse <backend> [command...]"-      in header <> concat backendLines <> usageHint--    renderBackendLine backend =-      let name = T.unpack $ backendName backend-          nameField = name <> replicate (max 1 (15 - length name)) ' '-          hostPort = T.unpack $ backendHost backend <> ":" <> T.pack (show (backendPort backend))-          status = case backendReachable backend of-                     Just True  -> " [OK]"-                     Just False -> " [UNREACHABLE]"-                     Nothing    -> ""-          desc = if T.null (backendDescription backend)-                 then ""-                 else " - " <> T.unpack (backendDescription backend)-      in "\n  " <> nameField <> hostPort <> status <> desc---- | Render transport error with context-renderTransportError :: TransportContext -> String-renderTransportError TransportContext{..} = case tcCategory of-  ConnectionRefused ->-    "Connection refused\n\n" <>-    "Backend: " <> T.unpack tcBackend <> "\n" <>-    "Address: " <> T.unpack tcHost <> ":" <> show tcPort <> "\n" <>-    "Path: " <> showPath tcPath <> "\n\n" <>-    "Troubleshooting:\n" <>-    "  - Check if the backend is running\n" <>-    "  - Verify host (-H) and port (-P) settings\n" <>-    "  - Run 'synapse' (no args) to list backends"--  ConnectionTimeout ->-    "Connection timeout\n\n" <>-    "Backend: " <> T.unpack tcBackend <> " @ " <>-    T.unpack tcHost <> ":" <> show tcPort <> "\n\n" <>-    "The server may be overloaded or network latency is high\n" <>-    "Error: " <> T.unpack tcMessage--  ProtocolError ->-    "Protocol error\n\n" <>-    "Backend: " <> T.unpack tcBackend <> "\n" <>-    "This may indicate a version mismatch\n\n" <>-    "Error: " <> T.unpack tcMessage--  UnknownTransportError ->-    "Transport error: " <> T.unpack tcMessage <> "\n\n" <>-    "Backend: " <> T.unpack tcBackend <> " @ " <>-    T.unpack tcHost <> ":" <> show tcPort-  where-    showPath [] = "root"-    showPath p = T.unpack $ T.intercalate "." p---- | Render a parse error for display-renderParseError :: Parse.ParseError -> String-renderParseError = \case-  Parse.UnknownParam name suggestions ->-    "Unknown parameter: --" <> T.unpack name <>-    case suggestions of-      [] -> ""-      [s] -> "\n\nDid you mean: --" <> T.unpack s <> "?"-      ss -> "\n\nDid you mean one of:\n" <>-            unlines ["  --" <> T.unpack s | s <- ss]-  Parse.MissingRequired name ->-    "Missing required parameter: --" <> T.unpack name-  Parse.InvalidValue name reason ->-    "Invalid value for --" <> T.unpack name <> ": " <> T.unpack reason-  Parse.AmbiguousVariant name variants ->-    "Ambiguous variant for --" <> T.unpack name <> ": could be one of " <> show (map T.unpack variants)-  Parse.MissingDiscriminator param field ->-    "Missing discriminator for --" <> T.unpack param <> ": need --" <> T.unpack param <> "." <> T.unpack field-  Parse.UnknownVariant param value valid suggestions ->-    "Unknown variant '" <> T.unpack value <> "' for --" <> T.unpack param <>-    "\n\nValid variants: " <> T.unpack (T.intercalate ", " valid) <>-    case suggestions of-      [] -> ""-      [s] -> "\n\nDid you mean: " <> T.unpack s <> "?"-      ss -> "\n\nDid you mean one of: " <> T.unpack (T.intercalate ", " ss) <> "?"-  Parse.TypeNotFound name ->-    "Type not found in IR: " <> T.unpack name----- | Write a generated template to disk (no logging)-writeGeneratedTemplateIR :: FilePath -> TemplateIR.GeneratedTemplate -> IO ()-writeGeneratedTemplateIR baseDir gt = do-  let fullPath = baseDir </> TemplateIR.gtPath gt-  createDirectoryIfMissing True (baseDir </> T.unpack (TemplateIR.gtNamespace gt))-  TIO.writeFile fullPath (TemplateIR.gtTemplate gt)---- | Encode a dry-run request-encodeDryRun :: Text -> [Text] -> Text -> Value -> LBS.ByteString-encodeDryRun backend namespacePath method params =-  let fullPath = if null namespacePath then [backend] else namespacePath-      dotPath = T.intercalate "." (fullPath ++ [method])-  in encode $ object-    [ "jsonrpc" .= ("2.0" :: Text)-    , "id" .= (1 :: Int)-    , "method" .= (backend <> ".call")-    , "params" .= object-        [ "method" .= dotPath-        , "params" .= params-        ]-    ]---- | Print a stream result--- soJson: output raw JSON stream items--- soRaw: skip template rendering, just output content JSON--- otherwise: try template rendering, fall back to content JSON-printResult :: Bool -> Bool -> RendererConfig -> HubStreamItem -> IO ()-printResult True _ _ item = LBS.putStrLn $ encode item-printResult _ True _ item = case item of-  -- Raw mode: just output the content-  HubData _ _ _ dat -> do-    LBS.putStrLn $ encode dat-    hFlush stdout-  HubProgress _ _ msg _ -> do-    TIO.putStr msg-    TIO.putStr "\r"-    hFlush stdout-  HubError _ _ err _ ->-    hPutStrLn stderr $ "Error: " <> T.unpack err-  _ -> pure ()-printResult _ _ cfg item = do-  -- Template mode: try to render with template-  mRendered <- renderItem cfg item-  case mRendered of-    Just text-      | T.null (T.strip text) -> pure ()-      | otherwise -> do-          TIO.putStr text-          hFlush stdout-    Nothing -> case item of-      -- Fallback to pretty-printed content-      HubData _ _ _ dat -> do-        TIO.putStrLn $ prettyValue dat-        hFlush stdout-      HubProgress _ _ msg _ -> do-        TIO.putStr msg-        TIO.putStr "\r"-        hFlush stdout-      HubError _ _ err _ ->-        hPutStrLn stderr $ "Error: " <> T.unpack err-      _ -> pure ()---- ============================================================================--- Argument Parsing (Synapse Options Only)--- ============================================================================---- | Parser for synapse-level options only--- Backend and path are handled separately after arg splitting-argsInfo :: ParserInfo Args-argsInfo = info (argsParser <**> versionOption <**> helper)-  ( fullDesc- <> header "synapse - Algebraic CLI for Hub"- <> progDesc "synapse [OPTIONS] <backend> <path...> [--param value ...]"- <> noIntersperse  -- Stop option parsing at first positional arg-  )-  where-    versionOption = infoOption (showVersion Meta.version)-      ( long "version" <> short 'V' <> help "Show version" )--argsParser :: Parser Args-argsParser = Args <$> optsParser <*> backendParser <*> restParser-  where-    backendParser = optional $ T.pack <$> argument str-      ( metavar "BACKEND"-     <> help "Backend name (e.g., plexus, registry-hub)" )--    restParser = many $ T.pack <$> argument str-      ( metavar "PATH... [--param value ...]"-     <> help "Path and method parameters (passed through)" )--optsParser :: Parser SynapseOpts-optsParser = do-  soHost <- T.pack <$> strOption-    ( long "host" <> short 'H' <> metavar "HOST"-   <> value (T.unpack defaultHost)-   <> help "Registry/discovery host (default: 127.0.0.1)" )-  soPort <- option auto-    ( long "port" <> short 'P' <> metavar "PORT"-   <> value defaultPort-   <> help "Registry/discovery port (default: 4444)" )-  soJson <- switch-    ( long "json" <> short 'j'-   <> help "Output raw JSON stream items" )-  soRaw <- switch-    ( long "raw"-   <> help "Output raw content JSON (skip templates)" )-  soDryRun <- switch-    ( long "dry-run" <> short 'n'-   <> help "Show JSON-RPC request without sending" )-  soSchema <- switch-    ( long "schema" <> short 's'-   <> help "Fetch raw schema JSON for path" )-  soGenerate <- switch-    ( long "generate-templates" <> short 'g'-   <> help "Generate mustache templates from IR" )-  soEmitIR <- switch-    ( long "emit-ir" <> short 'i'-   <> help "Emit IR for code generation (JSON)" )-  soParams <- optional $ T.pack <$> strOption-    ( long "params" <> short 'p' <> metavar "JSON"-   <> help "Method parameters as JSON object" )-  soRpc <- optional $ T.pack <$> strOption-    ( long "rpc" <> short 'r' <> metavar "JSON"-   <> help "Raw JSON-RPC request (bypass navigation)" )-  soGeneratorInfo <- many $ T.pack <$> strOption-    ( long "generator-info" <> metavar "TOOL:VERSION"-   <> help "Generator tool version info (can be specified multiple times)" )-  soBidirMode <- optional $ T.pack <$> strOption-    ( long "bidir-mode" <> short 'b' <> metavar "MODE"-   <> help "Bidirectional mode: interactive (TTY), json (pipe protocol), auto-cancel, defaults, respond" )-  soBidirCmd <- optional $ T.pack <$> strOption-    ( long "bidir-cmd" <> metavar "CMD"-   <> help "Shell command to handle bidir requests (stdin=JSON request, stdout=JSON response)" )-  soNoCache <- switch-    ( long "no-cache"-   <> help "Disable IR caching (force rebuild from schema)" )-  soLogLevel <- optional $ T.pack <$> strOption-    ( long "log-level" <> metavar "LEVEL"-   <> help "Log level: info, debug, trace (default: disabled)" )-  soLogSubsystems <- many $ T.pack <$> strOption-    ( long "log-subsystem" <> metavar "SUBSYSTEM"-   <> help "Filter logs by subsystem: discovery, transport, rpc, schema, cache, navigation (can specify multiple, default: all)" )-  soToken <- optional $ T.pack <$> strOption-    ( long "token" <> short 't' <> metavar "JWT"-   <> help "JWT sent as Cookie: access_token=<jwt> on WebSocket upgrade" )-  soTokenFile <- optional $ T.pack <$> strOption-    ( long "token-file" <> metavar "PATH"-   <> help "Path to token file (default lookup: ~/.plexus/tokens/<backend>)" )-  soNoDeprecationWarnings <- switch-    ( long "no-deprecation-warnings"-   <> help "Suppress invocation-time deprecation warnings on stderr (IR-15)" )-  pure SynapseOpts{..}+import Control.Monad (filterM, 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.List (stripPrefix)+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Text.Encoding as TE+import Options.Applicative+import qualified Options.Applicative.Help.Pretty as Pretty+import System.Environment (getEnvironment)+import Data.Version (showVersion)+import qualified Paths_plexus_synapse as Meta+import System.Directory (getHomeDirectory)+import System.Exit (exitFailure, exitSuccess)+import System.FilePath ((</>))+import System.IO (hPutStrLn, stderr, hFlush, stdout, hIsTerminalDevice)+++import Synapse.Schema.Types+import Synapse.Monad (SynapseM, SynapseEnv(..), SynapseError(..), BackendErrorType(..), TransportContext(..), TransportErrorCategory(..), initEnvAt, runSynapseM, throwNav, throwTransport, throwParse, throwBackend, withRequestContext, withViewKey)+import qualified Synapse.Self as Self+  ( CredentialRef(..)+  , ResolveError(..)+  , ResolvedDefaults(..)+  , defaultRegistry+  , loadDefaults+  , merge+  , resolveAll+  )+import qualified Control.Exception as E+import qualified Synapse.Log as Log+import qualified Katip+import Synapse.Algebra.Navigate+import Synapse.Algebra.Render (Listing(..), renderListing, defaultStyle)+import Synapse.Auth (AnonPage(..), anonymousMethods, renderAnonymousPage, renderCallerHeader, renderRefusal, SessionGrant(..))+import Plexus.Auth (BackendInfo(..), View(..), viewText)+import Plexus.Types (itemRefusal)+import Control.Monad.Except (catchError, throwError)+import Synapse.CLI.Help (MethodPage(..), renderMethodPage)+import Synapse.CLI.Parse (parseParams, parsePathAndParams, pairFlags)+import qualified Synapse.CLI.Parse as Parse+import Synapse.IR.Types (IR, irMethods, MethodDef)+import qualified Data.Map.Strict as Map+import qualified Synapse.CLI.Template as TemplateIR+import Synapse.Deprecation (emitActivationWarning, emitMethodWarning)+import Synapse.Transport+import Synapse.Bidir (BidirMode(..), parseBidirMode, detectBidirMode, handleBidirRequest)+import Plexus.Types (Response(..))+import Synapse.CLI.Transform (TransformEnv(..), mkTransformEnv, transformParams, defaultTransformers, injectBooleanDefaults, injectSmartDefaults)+import Synapse.CLI.Source (SourceEnv, mkSourceEnv, expandSources, expandValue, stdinWasRead, renderSourceError)+import Synapse.IR.Builder (buildIR)+import Synapse.Renderer (RendererConfig, defaultRendererConfig, renderItem, prettyValue, withMethodPath)+import System.Directory (createDirectoryIfMissing, doesFileExist, getHomeDirectory)+import System.FilePath ((</>))+import qualified Synapse.Self.Commands as Self+import qualified Synapse.Self.Command as SelfCmd+import Synapse.Backend.Discovery (Backend(..), BackendDiscovery(..), registryDiscoveryAt, endpointFor, pingBackendsVia, getBackendAt, getBackendAtEp, probeBackendAtEp, registerWithRegistry, probedInfoAt, probeFailureAt)+import Synapse.Endpoint (Endpoint(..), plainAt, isPlain, parseUrl, normalisePath, cliOptions)+import qualified Synapse.Endpoint as E+import Control.Applicative ((<|>))+import System.Environment (lookupEnv)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Time.Format (formatTime, defaultTimeLocale)+import qualified Synapse.Identity.Command as IdCmd+import qualified Synapse.Identity.Proof as Proof+import qualified Synapse.Identity.Session as Session+import qualified Synapse.Reconnect as Reconnect+import qualified Synapse.Identity.Store as Store+import System.Exit (ExitCode(..), exitWith)+import qualified Synapse.Find as Find+import Synapse.IR.Cache (newIRCache, defaultCacheConfig)++-- ============================================================================+-- Types+-- ============================================================================++-- | Synapse-level options (must appear before backend)+-- Controls connection settings and output format+data SynapseOpts = SynapseOpts+  { soHost          :: Text          -- ^ Registry host for discovery+  , soPort          :: Int           -- ^ Registry port for discovery+  , soHostFlag      :: Maybe Text    -- ^ SCAFFOLD-21: -H as given+  , soPortFlag      :: Maybe Int     -- ^ SCAFFOLD-21: -P as given+  , soUrl           :: Maybe Text    -- ^ SCAFFOLD-21: --url ws[s]://HOST[:PORT][/PATH]+  , soTls           :: Bool          -- ^ SCAFFOLD-21: --tls — wss to -H / -P+  , soPath          :: Maybe Text    -- ^ SCAFFOLD-21: --path — the socket's path+  , soCaCerts       :: [Text]        -- ^ SCAFFOLD-21: --cacert FILE — trusted beside the system's+  , soEndpoint      :: Endpoint      -- ^ SCAFFOLD-21: the connection point, resolved from the above+  , soJson          :: Bool          -- ^ Output raw JSON stream items+  , soRaw           :: Bool          -- ^ Output raw content (no templates)+  , soDryRun        :: Bool          -- ^ Show request without sending+  , soSchema        :: Bool          -- ^ Fetch raw schema JSON+  , soGenerate      :: Bool          -- ^ Generate templates from IR+  , soEmitIR        :: Bool          -- ^ Emit IR for code generation+  , soParams        :: Maybe Text    -- ^ JSON params via -p+  , soRpc           :: Maybe Text    -- ^ Raw JSON-RPC passthrough+  , soGeneratorInfo :: [Text]        -- ^ Generator tool info (tool:version pairs)+  , soBidirMode     :: Maybe Text    -- ^ Bidirectional mode override+  , soBidirCmd      :: Maybe Text    -- ^ Bidirectional subprocess command (--bidir-cmd)+  , soNoCache       :: Bool          -- ^ Disable IR caching+  , soLogLevel      :: Maybe Text    -- ^ Log level: info, debug, trace+  , soLogSubsystems :: [Text]        -- ^ Filter logs by subsystems (empty = all)+  , soToken         :: Maybe Text    -- ^ JWT sent as Cookie: access_token=<jwt>+  , soTokenFile     :: Maybe Text    -- ^ Path to token file (overridden by --token)+  , soCookies       :: [(Text, Text)]  -- ^ SAFE-S04/REQ-5: extra --cookie KEY=VALUE entries+  , soHeaders       :: [(Text, Text)]  -- ^ SAFE-S04/REQ-5: extra --header KEY=VALUE entries+  , soNoDeprecationWarnings :: Bool  -- ^ Suppress invocation-time deprecation warnings (IR-15)+  , soAs            :: Maybe Text    -- ^ IDENTITY-43: which stored agent session to carry+  , soReconnectFor  :: Maybe Text    -- ^ SYNAPSE-20: how long to ride out an outage (10m; 0 = never)+  }+  deriving Show++-- | Full CLI arguments after two-phase parsing+data Args = Args+  { argOpts    :: SynapseOpts   -- ^ Synapse-level options+  , argBackend :: Maybe Text    -- ^ Backend name (first positional)+  , argPath    :: [Text]        -- ^ Path segments and --key value params (raw)+  , argFind    :: Maybe Find.FindOpts  -- ^ SYNAPSE-17: a search (_find), not a call+  }+  deriving Show+++-- ============================================================================+-- Constants+-- ============================================================================++defaultHost :: Text+defaultHost = "127.0.0.1"++defaultPort :: Int+defaultPort = 4444++-- ============================================================================+-- Logging Helper+-- ============================================================================++-- | Create a logger from command-line options+-- Default: ErrorS (only show errors)+makeLoggerFromOpts :: SynapseOpts -> IO Log.Logger+makeLoggerFromOpts opts = do+  let level = case soLogLevel opts of+        Nothing -> Katip.ErrorS  -- Default: only errors+        Just levelStr -> parseLogLevel levelStr+  Log.makeLogger level+  where+    parseLogLevel "error" = Katip.ErrorS+    parseLogLevel "warn" = Katip.WarningS+    parseLogLevel "info" = Katip.InfoS+    parseLogLevel "debug" = Katip.DebugS+    parseLogLevel _ = Katip.ErrorS  -- Default to error++-- ============================================================================+-- Token Resolution+-- ============================================================================++-- | Build the request-context (extra cookies/headers) for the WS upgrade,+-- combining --cookie/--header flags with SYNAPSE_COOKIE_*/SYNAPSE_HEADER_*+-- env vars. Env keys are lowercased.+collectRequestContext :: SynapseOpts -> IO ([(Text, Text)], [(Text, Text)])+collectRequestContext opts = do+  envVars <- getEnvironment+  let envCookies = [ (T.toLower (T.pack k), T.pack v)+                   | (k0, v) <- envVars+                   , Just k <- [stripPrefix "SYNAPSE_COOKIE_" k0]+                   ]+      envHeaders = [ (T.toLower (T.pack k), T.pack v)+                   | (k0, v) <- envVars+                   , Just k <- [stripPrefix "SYNAPSE_HEADER_" k0]+                   ]+  pure (soCookies opts ++ envCookies, soHeaders opts ++ envHeaders)++-- | Resolve the auth token to use for this invocation from CLI-only+-- sources.+--+-- Priority:+--   1. --token <jwt>           (explicit, highest priority)+--   2. --token-file <path>     (explicit file)+--+-- Any persistent per-backend default (including the former+-- @~\/.plexus\/tokens\/\<backend\>@, now auto-migrated by+-- 'Synapse.Self.loadDefaults' on first read) lives in+-- @~\/.plexus\/\<backend\>\/defaults.json@ as a+-- @cookies.access_token@ ref and is loaded through the SELF-2 pipeline+-- in 'buildEnv'. This function therefore only consults+-- invocation-scoped flags; returning 'Nothing' means "no CLI override",+-- not "no token available".+--+-- Token files contain just the raw JWT, optionally with a trailing+-- newline.+resolveToken :: SynapseOpts -> Text -> IO (Maybe Text)+resolveToken opts _backend =+  case soToken opts of+    Just tok -> pure (Just tok)+    Nothing  -> case soTokenFile opts of+      Nothing   -> pure Nothing+      Just path -> do+        contents <- TIO.readFile (T.unpack path)+        let tok = T.strip contents+        pure $ if T.null tok then Nothing else Just tok++-- | IDENTITY-16: the upgrade headers a discovery probe carries — the token+-- (as the access_token cookie), --cookie and --header, as the command line+-- and its env forms give them. Stored per-backend defaults are not read+-- here: the probe runs before the backend is named.+--+-- (No signature: the result is the websockets package's header list, which+-- this executable does not depend on by name.)+probeHeaders opts ep = do+  mToken <- resolveToken opts ""+  (cookies, headers) <- collectRequestContext opts+  sess <- sessionHeaders opts ep (isJust mToken || hasCredential cookies headers)+  pure (mergeUpgradeHeaders mToken cookies (headers ++ sess))++-- | Does this cookie/header set already carry a credential (an+-- access_token cookie or an Authorization header)? Then no stored session+-- is added to it.+hasCredential :: [(Text, Text)] -> [(Text, Text)] -> Bool+hasCredential cookies headers =+  any ((== "access_token") . T.toLower . fst) cookies+    || any ((== "authorization") . T.toLower . fst) headers++-- | IDENTITY-43: the agent asked for — @--as@, else @SYNAPSE_AS@.+askedAgent :: SynapseOpts -> IO (Maybe Text)+askedAgent opts = do+  env <- lookupEnv "SYNAPSE_AS"+  pure (soAs opts <|> (T.pack <$> mfilter' (not . null) env))+  where mfilter' f m = m >>= \x -> if f x then Just x else Nothing++-- | IDENTITY-43: the stored session's @Authorization: Bearer@ for a call to+-- the address — none when the call already carries a credential (-t,+-- --token-file, an access_token cookie, an Authorization header).+sessionHeaders :: SynapseOpts -> Endpoint -> Bool -> IO [(Text, Text)]+sessionHeaders opts ep explicit+  | explicit = pure []+  | otherwise = do+      st <- Store.systemStoreEnv+      asked <- askedAgent opts+      logger <- makeLoggerFromOpts opts+      maybe [] (\s -> [Session.bearer (Session.asToken s)]) <$> Session.sessionFor logger st asked ep++-- | IDENTITY-43: the _info probe, logging in again from the key once when+-- the upgrade is refused (401) while a stored session is carried.+probeWithSession :: SynapseOpts -> Endpoint -> IO (Maybe Text)+probeWithSession = probeWithSession' False++-- | SYNAPSE-20: with @waits@, a probe that fails as an outage does is+-- tried again for the reconnect window.+probeWithSession' :: Bool -> SynapseOpts -> Endpoint -> IO (Maybe Text)+probeWithSession' waits opts ep = do+  probe <- probeHeaders opts ep+  let once = probeBackendAtEp probe ep+      whereTo = Store.addressKey ep+  r <- if waits+    then Reconnect.awaitBackend+           (\why -> Reconnect.isOutageText why && not (Session.isUpgradeRefused why))+           whereTo once+    else once+  case r of+    Right name -> pure (Just name)+    Left why+      | Session.isUpgradeRefused why -> do+          can <- Session.canReattest ep+          if not can then pure Nothing else do+            st <- Store.systemStoreEnv+            logger <- makeLoggerFromOpts opts+            new <- Session.reattest logger st ep+            case new of+              Nothing -> pure Nothing+              Just _ -> do+                probe' <- probeHeaders opts ep+                getBackendAtEp probe' ep+      | otherwise -> pure Nothing++-- ============================================================================+-- Env Construction (SELF-2 read path)+-- ============================================================================++-- | Render a 'Self.ResolveError' as a human-readable message naming the+-- failing URI and the underlying reason.+renderResolveError :: Self.ResolveError -> String+renderResolveError = \case+  Self.ResolveUnknownScheme scheme ->+    "unknown credential scheme: " <> T.unpack scheme+    <> " (no resolver registered; known schemes: literal, env, file)"+  Self.ResolveNotFound (Self.CredentialRef uri) ->+    "credential not found: " <> T.unpack uri+  Self.ResolveBackendError (Self.CredentialRef uri) msg ->+    "credential backend error for " <> T.unpack uri <> ": " <> T.unpack msg+  Self.ResolveParseError msg ->+    "malformed credential reference: " <> T.unpack msg++-- | Build a fully-wired 'SynapseEnv' for a backend invocation.+--+-- SELF-2 read path:+--+-- 1. CLI token resolution (--token / --token-file; persistent defaults+--    live in ~/.plexus/<b>/defaults.json and are loaded in step 3)+-- 2. Collect CLI --cookie / --header flags and SYNAPSE_COOKIE_*/HEADER_* env+-- 3. Load stored defaults from @~\/.plexus\/\<backend\>\/defaults.json@+-- 4. Resolve every 'CredentialRef' through the default registry+--    (literal / env / file)+-- 5. Wrap the legacy token (if any) as a CLI @access_token@ cookie so it+--    flows through the same 'Self.merge' and wins over any stored default+--    — preserving the pre-SELF-2 precedence of the --token flag.+-- 6. Merge CLI overrides onto resolved stored defaults (CLI wins per key).+--+-- On resolve failure: print a clear message and 'exitFailure'. We never+-- build a half-authenticated 'SynapseEnv'.+buildEnv :: Endpoint -> Text -> Log.Logger -> SynapseOpts -> IO SynapseEnv+buildEnv ep backend logger opts = do+  -- Legacy token path (unchanged semantically; SELF-3 consolidates).+  mToken <- resolveToken opts backend+  (cliCookieList, cliHeaderList) <- collectRequestContext opts++  -- SELF-2: load + resolve + merge.+  stored <- E.catch (Self.loadDefaults backend) $ \e -> do+    hPutStrLn stderr $ "Error: " <> show (e :: E.IOException)+    exitFailure+  resolved <- Self.resolveAll Self.defaultRegistry stored []+  resolvedDefaults <- case resolved of+    Left err -> do+      hPutStrLn stderr $ "Error resolving defaults for backend '"+        <> T.unpack backend <> "': " <> renderResolveError err+      exitFailure+    Right rd -> pure rd++  -- Fold CLI flags (and the legacy --token / SYNAPSE_TOKEN / token file)+  -- into the CLI-side maps so the unified 'Self.merge' produces the final+  -- cookie + header set.+  let cliCookiesBase = Map.fromList cliCookieList+      cliCookies = case mToken of+        Just tok -> Map.insert "access_token" tok cliCookiesBase+        Nothing  -> cliCookiesBase+      cliHeaders = Map.fromList cliHeaderList+      (mergedCookies, mergedHeaders) =+        Self.merge resolvedDefaults cliCookies cliHeaders++  -- IDENTITY-43: no credential given or stored for this backend — carry+  -- the agent's stored session, if there is one.+  sess <- sessionHeaders opts ep+            (hasCredential (Map.toList mergedCookies) (Map.toList mergedHeaders))++  -- 'seToken = Nothing' here: any access_token cookie already sits in the+  -- merged cookie map. Transport's mergeUpgradeHeaders joins them into a+  -- single Cookie header exactly as before.+  env0 <- initEnvAt ep backend logger Nothing+  pure $ withRequestContext (Map.toList mergedCookies)+                             (Map.toList mergedHeaders ++ sess)+                             env0++-- ============================================================================+-- Argument Splitting+-- ============================================================================+-- Main+-- ============================================================================++main :: IO ()+main = do+  args0 <- execParser argsInfo+  -- SCAFFOLD-21: where the connection point is — --url, or -H / -P with+  -- --tls / --path — resolved once, before anything dials+  opts <- either (\e -> hPutStrLn stderr ("synapse: " <> T.unpack e) >> exitWith (ExitFailure 2)) pure+            =<< resolveConnection (argOpts args0)+  let args = args0 { argOpts = opts }+      ep = soEndpoint opts++  -- SYNAPSE-20: the reconnect window, before anything dials+  envWindow <- lookupEnv "SYNAPSE_RECONNECT_FOR"+  case soReconnectFor opts <|> fmap T.pack envWindow of+    Nothing -> pure ()+    Just w -> case Reconnect.parseDuration w of+      Just secs -> Reconnect.setReconnectWindow secs+      Nothing -> do+        hPutStrLn stderr $ "synapse: --reconnect-for takes a duration (10m, 90s, 1h, 0), not '" <> T.unpack w <> "'"+        exitWith (ExitFailure 2)++  -- IDENTITY-43: keys are local; _login / _logout dial the backend+  -- themselves (a proof opens exactly one connection — no probe first).+  when (argBackend args == Just "_key") $ runKey (argPath args)+  when (argBackend args == Just "_login") $ runLogin opts (argPath args)+  when (argBackend args == Just "_logout") $ runLogout opts (argPath args)++  -- Initialize logger (default: ErrorS, only show errors)+  logger <- makeLoggerFromOpts opts++  Log.logDebug logger Log.SubsystemCLI "synapse starting..."++  -- Use specified host/port for registry discovery+  let discovery = registryDiscoveryAt ep++  -- Get the backend at the connection point (host:port)+  -- If it has a registry plugin, that's used for discovering other backends+  Log.logDebug logger Log.SubsystemDiscovery $+    "Checking backend at " <> Store.addressKey ep++  -- IDENTITY-16: the probe carries what the command line supplied (-t,+  -- --token-file, --cookie, --header and their env forms), so a backend that+  -- refuses anonymous upgrades still answers it.+  -- IDENTITY-43: and the agent's stored session, made again from its key+  -- if the upgrade refuses it.+ -- SYNAPSE-20: a call to a named backend waits out an outage at start+  -- too (a promote's restart); the registry listing and _self never wait.+  let waits = case argBackend args of+        Just b -> b == "_find" || not ("_" `T.isPrefixOf` b || "-" `T.isPrefixOf` b)+        Nothing -> False+  maybeBackend <- probeWithSession' waits opts ep++  Log.logDebug logger Log.SubsystemDiscovery $+    "Backend check complete: " <> T.pack (show maybeBackend)+  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+  -- SCAFFOLD-21: a registry records ws://HOST:PORT; an address behind TLS+  -- or on a path is not registered+  when (targetPort /= defaultPort && isPlain ep) $ 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+      | soEmitIR opts || soSchema opts || soJson opts || soRaw opts ->+          runWithDiscovery discovery hostBackend args+      | otherwise -> do+          -- No backend specified, show available backends+          TIO.putStr cliHeader+          backends <- discoverBackends discovery+          -- Ping backends to check if they're reachable+          backendsWithStatus <- pingBackendsVia ep backends+          TIO.putStrLn "\nAvailable backends:"+          mapM_ (printBackend ep) backendsWithStatus+          TIO.putStrLn "\nUsage: synapse <backend> [command...]"+    Just backend+      -- Handle --help/-h if it somehow ends up as the backend+      | backend `elem` ["--help", "-h"] -> TIO.putStr cliHeader+      -- SYNAPSE-17: _find BACKEND [activation…] WORDS… — a search over the+      -- backend's schema, reached as a call to that backend is+      | backend == "_find" -> do+          fo <- parseBuiltin "_find" Find.findInfo (argPath args)+          runWithDiscovery discovery (Find.foBackend fo)+            args { argBackend = Just (Find.foBackend fo), argPath = [], argFind = Just fo }+      -- Handle _self meta-commands+      | backend == "_self" ->+          -- SELF-4 verbs (synapse _self <backend> <verb>) dispatch through+          -- a dedicated parser on the raw argPath. Legacy _self+          -- subcommands (template / scan / debug / validate / test) keep+          -- the original path through runWithDiscovery.+          if isSelfV4Invocation (argPath args)+            then runSelfV4 (argPath args)+            else runWithDiscovery discovery hostBackend args+      | otherwise -> runWithDiscovery discovery backend args++-- | Legacy @_self@ subcommands that predate SELF-4. These keep their+-- original dispatch path through 'Synapse.Self.Commands.dispatch'.+--+-- Anything else under @_self@ is treated as SELF-4 (@_self \<backend\>+-- ...@) and routes through 'Synapse.Self.Command.runSelfCommand'.+legacySelfSubcommands :: [Text]+legacySelfSubcommands =+  [ "template", "scan", "debug", "validate", "test"+  , "--help", "-h"  -- Legacy help path is also handled by the old dispatcher+  ]++-- | True when @_self@ was invoked in the SELF-4 shape — anything other+-- than a legacy subcommand as the first positional. The SELF-4 parser+-- handles its own help / error messaging from there, so even+-- @_self \<backend\>@ (no verb) routes here: optparse emits a+-- "Missing: COMMAND" message listing the SELF-4 verbs.+isSelfV4Invocation :: [Text] -> Bool+isSelfV4Invocation []          = False  -- No args at all: legacy help.+isSelfV4Invocation (first : _) = first `notElem` legacySelfSubcommands++-- | Re-parse the post-@_self@ token stream through the SELF-4+-- optparse-applicative parser, then run the resulting command.+runSelfV4 :: [Text] -> IO ()+runSelfV4 rest = do+  let argv = map T.unpack rest+      parserInfo = SelfCmd.selfCommandInfo+      pr = execParserPure defaultPrefs parserInfo argv+  cmd <- handleParseResult pr+  code <- SelfCmd.runSelfCommand cmd+  case code of+    ExitSuccess   -> pure ()+    ExitFailure _ -> exitWith code++-- | A builtin's options, its usage said as @synapse NAME …@.+parseBuiltin :: String -> ParserInfo a -> [Text] -> IO a+parseBuiltin name pinfo rest =+  case execParserPure defaultPrefs pinfo (map T.unpack rest) of+    Failure f -> do+      let (msg, code) = renderFailure f ("synapse " <> name)+      case code of+        ExitSuccess -> putStrLn msg >> exitSuccess+        _ -> hPutStrLn stderr msg >> exitWith code+    r -> handleParseResult r++-- | IDENTITY-43: @synapse _key new|show|list@ — local.+runKey :: [Text] -> IO ()+runKey rest = do+  cmd <- handleParseResult (execParserPure defaultPrefs IdCmd.keyCommandInfo (map T.unpack rest))+  st <- Store.systemStoreEnv+  IdCmd.runKeyCommand st cmd >>= exitWith++-- | IDENTITY-43: where @_login@ / @_logout@ dial — the connection point+-- named with @-P@, else what the registry says of the backend, else the+-- connection point.+loginAddress :: SynapseOpts -> Text -> IO Endpoint+loginAddress opts backendName+  | soPort opts /= defaultPort || not (isPlain ep) = pure ep+  | otherwise = do+      registered <- getBackendInfo (registryDiscoveryAt ep) backendName+      pure $ maybe ep (endpointFor ep) registered+  where ep = soEndpoint opts++dieWith :: Text -> IO a+dieWith msg = TIO.hPutStrLn stderr ("synapse: " <> msg) >> exitFailure++-- | IDENTITY-43: @synapse -P PORT _login BACKEND --key NAME --as AGENT+-- [--scope role\@SCOPE …] [--ttl SECS]@.+runLogin :: SynapseOpts -> [Text] -> IO ()+runLogin opts rest = do+  lo <- handleParseResult (execParserPure defaultPrefs IdCmd.loginInfo (map T.unpack rest))+  asked <- askedAgent opts+  -- AUTH-8: no key and no agent named — a person, through the browser+  when (IdCmd.loKey lo == Nothing && IdCmd.loAs lo == Nothing && asked == Nothing) $+    runLoginPerson opts lo+  agent <- maybe (dieWith "name the agent to log in as: --as AGENT (or SYNAPSE_AS)") pure (IdCmd.loAs lo <|> asked)+  let keyName = maybe "default" id (IdCmd.loKey lo)+  st <- Store.systemStoreEnv+  seed <- Store.lookupKey st keyName >>= \case+    Left e -> dieWith e+    Right Nothing -> dieWith ("no key " <> keyName <> " (synapse _key new " <> keyName <> ")")+    Right (Just (s, _)) -> pure s+  ep <- loginAddress opts (IdCmd.loBackend lo)+  logger <- makeLoggerFromOpts opts+  r <- Session.loginWithKey logger ep (IdCmd.loBackend lo) seed agent (IdCmd.loScope lo) (IdCmd.loTtl lo)+  lr <- either (\e -> dieWith ("login to " <> IdCmd.loBackend lo <> " at " <> Store.addressKey ep <> " failed: " <> e)) pure r+  let rec = Store.SessionRec+        { Store.srToken = Session.lrToken lr+        , Store.srPrincipal = if T.null (Session.lrPrincipal lr) then Proof.principalOf seed else Session.lrPrincipal lr+        , Store.srAgent = Session.lrAgent lr+        , Store.srExpiresAt = Session.lrExpiresAt lr+        , Store.srKey = keyName+        , Store.srScope = IdCmd.loScope lo+        , Store.srTtl = IdCmd.loTtl lo+        , Store.srBackend = IdCmd.loBackend lo+        }+  src <- Store.writeSession st ep rec+  Store.writeDefaultAgent st ep (Store.srAgent rec)+  let until' = case Store.srExpiresAt rec of+        Just t -> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" (posixSecondsToUTCTime (fromIntegral t)))+        Nothing -> "(the server named no end)"+      scope = if null (Session.lrScope lr) then "the key's own grants" else T.intercalate ", " (Session.lrScope lr)+      kept = case src of+        Store.SessionFromKeychain -> "keychain"+        Store.SessionFromFile p -> T.pack p+        Store.SessionFromEnv -> "PLEXUS_SESSION"+  TIO.putStrLn $ "signed in to " <> IdCmd.loBackend lo <> " at " <> Store.addressKey ep <> " as " <> Store.srAgent rec+  mapM_ (\(k, v) -> TIO.putStrLn ("  " <> T.justifyLeft 10 ' ' k <> v))+    [ ("principal", Store.srPrincipal rec)+    , ("scope", scope)+    , ("until", until')+    , ("kept in", kept)+    ]+  exitSuccess++-- | AUTH-8: the session slot a person's sign-in is kept under.+personAgent :: Text+personAgent = "me"++-- | AUTH-8: @synapse -P PORT _login BACKEND@ — a person signs in through+-- the browser (the loopback flow), and the session is kept as an agent's+-- is (keychain, else file), under the name @me@, with no key to make it+-- again from: when it ends, synapse says to sign in again.+runLoginPerson :: SynapseOpts -> IdCmd.LoginOpts -> IO ()+runLoginPerson opts lo = do+  let backend = IdCmd.loBackend lo+  ep <- loginAddress opts backend+  logger <- makeLoggerFromOpts opts+  r <- Session.loginPerson logger ep backend 300 (TIO.hPutStrLn stderr)+  g <- either (\e -> dieWith ("sign-in to " <> backend <> " at " <> Store.addressKey ep <> " failed: " <> e)) pure r+  who <- case sgWhoami g of+    Just w -> pure (Just w)+    Nothing -> Session.whoamiWith logger ep backend (sgToken g)+  let rec = Store.SessionRec+        { Store.srToken = sgToken g+        , Store.srPrincipal = sgPrincipal g+        , Store.srAgent = personAgent+        , Store.srExpiresAt = sgExpiresAt g+        , Store.srKey = ""          -- a person's: nothing to sign in again from+        , Store.srScope = sgCeiling g+        , Store.srTtl = Nothing+        , Store.srBackend = backend+        }+  st <- Store.systemStoreEnv+  src <- Store.writeSession st ep rec+  Store.writeDefaultAgent st ep personAgent+  let named = case who of+        Just w -> maybe "" id (T.stripPrefix "you are " (renderCallerHeader w))+        Nothing -> case sgName g of+          Just n -> n <> " (" <> sgPrincipal g <> ")"+          Nothing -> sgPrincipal g+      until' = case sgExpiresAt g of+        Just t -> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" (posixSecondsToUTCTime (fromIntegral t)))+        Nothing -> "(the server named no end)"+      kept = case src of+        Store.SessionFromKeychain -> "keychain"+        Store.SessionFromFile p -> T.pack p+        Store.SessionFromEnv -> "PLEXUS_SESSION"+  TIO.putStrLn $ "signed in to " <> backend <> " as " <> named+  mapM_ (\(k, v) -> TIO.putStrLn ("  " <> T.justifyLeft 10 ' ' k <> v))+    [ ("until", until')+    , ("kept in", kept <> " (as " <> personAgent <> ")")+    ]+  exitSuccess++-- | IDENTITY-43: @synapse -P PORT _logout BACKEND [--as AGENT]@.+runLogout :: SynapseOpts -> [Text] -> IO ()+runLogout opts rest = do+  lo <- handleParseResult (execParserPure defaultPrefs IdCmd.logoutInfo (map T.unpack rest))+  st <- Store.systemStoreEnv+  ep <- loginAddress opts (IdCmd.lgBackend lo)+  asked <- askedAgent opts+  dflt <- Store.readDefaultAgent st ep+  agent <- maybe (dieWith ("no agent is signed in to " <> Store.addressKey ep <> " (name one: --as AGENT)")) pure+             (IdCmd.lgAs lo <|> asked <|> dflt)+  found <- Store.lookupSession st ep agent+  rec <- case found of+    Just (Right r, src) | src /= Store.SessionFromEnv -> pure r+    _ -> dieWith ("no stored session for " <> agent <> " at " <> Store.addressKey ep)+  logger <- makeLoggerFromOpts opts+  r <- Session.logoutWithToken logger ep (IdCmd.lgBackend lo) (Store.srToken rec)+  Store.removeSession st ep agent+  Store.clearDefaultAgent st ep agent+  case r of+    Right () -> TIO.putStrLn ("signed out " <> agent <> " at " <> Store.addressKey ep)+    Left e -> TIO.putStrLn ("forgot " <> agent <> "'s session at " <> Store.addressKey ep+                             <> " (the server said: " <> e <> ")")+  exitSuccess++-- | Print a backend in the list+-- (SCAFFOLD-21: the connection point by the URL it was named with, when+-- it is not plain ws://HOST:PORT/)+printBackend :: Endpoint -> Backend -> IO ()+printBackend ep b = do+  let nameField = T.justifyLeft 15 ' ' (backendName b)+  let hostPort = Store.addressKey (endpointFor ep b)+  let status = case backendReachable b of+        Just True  -> " [OK]"+        Just False -> " [UNREACHABLE]"+        Nothing    -> ""+  let desc = if T.null (backendDescription b)+             then ""+             else " - " <> backendDescription b+  TIO.putStrLn $ "  " <> nameField <> hostPort <> status <> desc++-- | Run a Hub command with backend discovery+runWithDiscovery :: BackendDiscovery -> Text -> Args -> IO ()+runWithDiscovery discovery backendName args = do+  let opts = argOpts args+      ep = soEndpoint opts+  -- Try to discover backend info+  maybeBackend <- getBackendInfo discovery backendName++  case maybeBackend of+    Just backend -> do+      -- 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.+      -- SYNAPSE-20: a named backend's probe waits out an outage (or the+      -- server's 429 under many parallel calls) as the first one did+      -- SCAFFOLD-21: at the connection point, reached as it was named+      let at = endpointFor ep backend+      actualName <- probeWithSession' True opts at+      case actualName of+        Just name | name /= backendName -> do+          hPutStrLn stderr $ "Backend mismatch: requested '" <> T.unpack backendName+            <> "' but " <> T.unpack (Store.addressKey at)+            <> " identifies as '" <> T.unpack name <> "'"+          exitFailure+        Nothing -> do+          -- Protocol handshake failed when verifying backend+          when (epTls at) $ tlsUnreachable at+          logger <- makeLoggerFromOpts opts+          env <- buildEnv ep backendName logger opts+          result <- runSynapseM env (throwBackend (ProtocolHandshakeFailed (backendHost backend) (backendPort backend)) [])+          case result of+            Left err -> do+              hPutStrLn stderr $ renderError err+              exitFailure+            Right () -> exitSuccess+        Just _ ->+          -- Match confirmed+          run backendName at args+    Nothing -> do+      -- Backend not found in registry - check if this was a direct connection attempt+      -- where the protocol handshake failed+      maybeDirectBackend <- probeWithSession' True opts ep+      logger <- makeLoggerFromOpts opts+      env <- buildEnv ep backendName logger opts+      case maybeDirectBackend of+        Nothing -> do+          -- Protocol handshake failed at the specified host:port+          when (epTls ep) $ tlsUnreachable ep+          result <- runSynapseM env (throwBackend (ProtocolHandshakeFailed (soHost opts) (soPort opts)) [])+          case result of+            Left err -> do+              hPutStrLn stderr $ renderError err+              exitFailure+            Right () -> exitSuccess+        Just discoveredName | discoveredName /= backendName -> do+          -- Backend exists but has a different name+          backends <- discoverBackends discovery+          backendsWithStatus <- pingBackendsVia ep backends+          result <- runSynapseM env (throwBackend (BackendNotFound backendName) backendsWithStatus)+          case result of+            Left err -> do+              hPutStrLn stderr $ renderError err+              exitFailure+            Right () -> exitSuccess+        Just _ -> do+          -- Backend discovered successfully - should not reach here, but proceed+          run backendName ep args++-- | SCAFFOLD-21: a wss address whose probe failed — why, from the probe+-- (a certificate the trust store refused, a name it does not cover, a+-- proxy that does not upgrade), and what to do about a local CA. Exits 1.+tlsUnreachable :: Endpoint -> IO ()+tlsUnreachable at = do+  why <- maybe "no answer" id <$> probeFailureAt at+  let shown = T.replace "\\\"" "\"" (fst (T.breakOn "\\nCallStack" why))+      detail = case T.breakOn "Error_Protocol \"" shown of+        (_, r) | not (T.null r) -> T.takeWhile (/= '"') (T.drop (T.length "Error_Protocol \"") r)+        _ -> shown+      has = any (`T.isInfixOf` shown)+  if has ["HandshakeFailed"]+    then do+      TIO.hPutStrLn stderr $ "synapse: the TLS handshake with " <> E.shortUrl at <> " failed: " <> detail+      TIO.hPutStrLn stderr $+        if has ["UnknownCa", "unknown CA", "ertificate", "NameMismatch", "Expired", "SelfSigned"]+          then "  its certificate is checked against the system's trust store and each --cacert, and its name\n"+            <> "  against " <> epHost at <> "; for a local CA, add --cacert ROOT.pem"+          else "  the server refused it — does it serve a certificate for " <> epHost at <> "?"+    else case T.breakOn "responseCode = " shown of+      (_, r) | not (T.null r) -> do+        let code = T.takeWhile (`elem` ['0' .. '9']) (T.drop (T.length "responseCode = ") r)+        TIO.hPutStrLn stderr $ "synapse: " <> E.shortUrl at <> " answered the upgrade with HTTP " <> code+          <> ", not a WebSocket"+        TIO.hPutStrLn stderr $ if code `elem` ["401", "403"]+          then "  it refused the credential: sign in with synapse " <> cliOptions at <> " _login BACKEND"+          else "  is " <> epPath at <> " the socket's path? (a hosted app's is /ws)"+      _ -> TIO.hPutStrLn stderr $ "synapse: " <> E.shortUrl at <> " did not answer the _info probe: " <> detail+  exitFailure++-- | Run a Hub command with specified backend and connection details+run :: Text -> Endpoint -> Args -> IO ()+run backend ep args = do+  let opts = argOpts args+  logger <- makeLoggerFromOpts opts+  Log.logInfo logger Log.SubsystemCLI $ "Synapse starting: backend=" <> backend <> ", at " <> Store.addressKey ep+  env <- withView ep =<< buildEnv ep backend logger opts+  rendererCfg <- defaultRendererConfig+  Log.logDebug logger Log.SubsystemCLI "Running dispatch..."+  result <- runSynapseM env (dispatch args rendererCfg)+  -- IDENTITY-43: the server refused the stored session (the upgrade's 401,+  -- or the in-band "you have signed out" held back before anything was+  -- shown): log in again from the key, and run the call once more.+  ended <- Session.takeSessionEnded+  let refused = case result of+        Left (TransportErrorContext ctx) -> Session.isUpgradeRefused (tcMessage ctx)+        Left (NavError (FetchError m _)) -> Session.isUpgradeRefused m+        _ -> False+  result' <- if not (isJust ended || refused) then pure result else do+    st <- Store.systemStoreEnv+    new <- Session.reattest logger st ep+    case new of+      Just _ -> do+        env' <- withView ep =<< buildEnv ep backend logger opts+        runSynapseM env' (dispatch args rendererCfg)+      Nothing -> do+        mapM_ (\m -> hPutStrLn stderr ("Error: " <> T.unpack m)) ended+        pure result+  case result' of+    Left err -> do+      hPutStrLn stderr $ renderError err+      exitFailure+    Right () -> do+      -- AUTH-8: a refusal was shown — the call did not happen+      refused' <- Session.wasRefused+      if refused' then exitWith (ExitFailure refusedExit) else exitSuccess++-- | AUTH-8: the exit status of a call the hub refused (sysexits' EX_NOPERM).+refusedExit :: Int+refusedExit = 77++-- | AUTH-8: the env's cache keys qualified by the caller's view, as the+-- _info probe at this address answered it (the view's hash, else its kind).+withView :: Endpoint -> SynapseEnv -> IO SynapseEnv+withView ep env = do+  info <- probedInfoAt ep+  let key = info >>= \i -> infoViewHash i <|> (viewText <$> infoView i)+  pure (withViewKey key env)++-- | Dispatch based on navigation result+dispatch :: Args -> RendererConfig -> SynapseM ()+dispatch Args{argOpts = soOpts@SynapseOpts{..}, argBackend, argPath, argFind} rendererCfg = do+  -- Check for _self commands first (before anything else)+  case argBackend of+    _ | Just fo <- argFind -> runFind fo+    Just "_self" -> do+      -- _self meta-command: parse subcommand and rest from argPath+      let (pathSegs, rawParams, _, _) = parsePathAndParams argPath+      case pathSegs of+        (subcommand : rest) -> do+          Self.dispatch subcommand rest rawParams+          return ()+        [] -> do+          -- No subcommand provided, show help+          Self.showHelp+          return ()++    -- Normal dispatch+    _ -> do+      -- Mode 1: Raw JSON-RPC passthrough+      case soRpc of+        Just rpcJson -> do+          case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 rpcJson) of+            Left err -> throwParse $ T.pack err+            Right rpcReq -> do+              items <- invokeRawRpc rpcReq+              liftIO $ mapM_ (printResult soJson soRaw rendererCfg) items+          return ()++        Nothing -> do+          -- Parse path and inline params (--key value pairs)+          let (pathSegs, rawParams, flagArgs, helpRequested) = parsePathAndParams argPath++          -- Normal Plexus RPC routing+          -- Apply parameter transformations (path expansion, env vars)+          transformEnv <- liftIO mkTransformEnv+          -- SYNAPSE-10: a value that names its source (@file, -) is read+          -- first, so no other step ever sees the literal "@file"; stdin is+          -- read once and kept for the second pass below+          sourceEnv <- liftIO $ mkSourceEnv (teCwd transformEnv) (teHome transformEnv)+          let fromSources pairs = liftIO (expandSources sourceEnv pairs) >>= either (throwParse . renderSourceError) pure+          sourcedParams <- if helpRequested then pure rawParams else fromSources rawParams+          inlineParams <- liftIO $ transformParams transformEnv defaultTransformers sourcedParams++          -- Mode 1.5: Respond subcommand (agent sends a response to a pending bidir request)+          if not (null pathSegs) && head pathSegs == "respond"+            then handleRespondCommand sourcedParams++          -- Mode 2: Schema request+          else if soSchema+            then do+              -- Try to navigate and determine if last segment is a method+              schemaResult <- fetchSchemaForPath pathSegs+              case schemaResult of+                Left err -> throwNav $ FetchError err pathSegs+                Right val -> liftIO $ LBS.putStrLn $ encode val++            -- Mode 3: Generate templates (IR-driven approach)+            else if soGenerate+              then do+                homeDir <- liftIO getHomeDirectory+                let baseDir = homeDir </> ".config" </> "synapse" </> "templates"+                    writeAndLog gt = do+                      writeGeneratedTemplateIR baseDir gt+                      TIO.putStrLn $ "  " <> T.pack (TemplateIR.gtPath gt)+                liftIO $ TIO.putStrLn $ "Generating templates in " <> T.pack baseDir <> "..."+                count <- TemplateIR.generateAllTemplatesWithCallback writeAndLog pathSegs+                liftIO $ TIO.putStrLn $ "Generated " <> T.pack (show count) <> " templates"++              -- Mode 4: Emit IR for code generation+              else if soEmitIR+                then do+                  ir <- buildIR soGeneratorInfo pathSegs+                  liftIO $ LBS.putStrLn $ encode ir++                else do+                  -- Mode 5: Normal navigation+                  info <- currentInfo+                  let anonymous = (info >>= infoView) == Just Anonymous+                  if null pathSegs+                    then do+                      -- SYNAPSE-12: a backend named, its help is the+                      -- backend's alone — no banner, options or meta-commands.+                      -- AUTH-8: to an anonymous caller, only the door.+                      rootSchema <- if anonymous+                        then (Just <$> navigate []) `catchError` \_ -> pure Nothing+                        else Just <$> navigate []+                      case rootSchema of+                        _ | anonymous -> showAnonymous info (rootSchema >>= viewSchema)+                        Just (ViewPlugin schema _) -> showPluginHelp info [] schema+                        _ -> pure ()+                    else do+                      -- Navigate to target+                      -- AUTH-8: an anonymous caller asking for anything the+                      -- door does not show is shown the door+                      view <- navigate pathSegs `catchError` \e -> case e of+                        NavError (NotFound {}) | anonymous -> do+                          root <- (Just <$> navigate []) `catchError` \_ -> pure Nothing+                          showAnonymous info (root >>= viewSchema)+                          liftIO $ do+                            TIO.hPutStrLn stderr $ "synapse: sign in to reach " <> T.intercalate " " pathSegs+                            exitWith (ExitFailure refusedExit)+                        _ -> throwError e+                      case view of+                        -- Landed on a plugin: show help+                        ViewPlugin schema _ -> showPluginHelp info pathSegs schema++                        -- Landed on a method: invoke or show help+                        ViewMethod method path -> do+                          let fullPath = T.intercalate "." path++                          -- IR-15: emit stderr deprecation warnings right before any+                          -- real invocation. Dedupe is per-process-lifetime, so this+                          -- action is idempotent on repeat calls. We bind it as a+                          -- local SynapseM action and invoke it at both invocation+                          -- sites below (fast path and slow path). --help, --dry-run,+                          -- --schema, and --emit-ir do not invoke, and intentionally+                          -- do not fire these warnings.+                          let fireDeprecationWarnings :: SynapseM ()+                              fireDeprecationWarnings = do+                                liftIO $ emitMethodWarning+                                  soNoDeprecationWarnings+                                  fullPath+                                  (methodDeprecation method)+                                let namespacePath = init path+                                when (not (null namespacePath)) $ do+                                  let activationNs = T.intercalate "." namespacePath+                                  parentPlugin <- fetchSchemaAt namespacePath+                                  liftIO $ emitActivationWarning+                                    soNoDeprecationWarnings+                                    activationNs+                                    (psDeprecation parentPlugin)++                          -- 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 fireDeprecationWarnings >> invokeMethod sourceEnv method path (object [])+                            else do+                              -- Build IR for this method's namespace+                              ir <- buildIR soGeneratorInfo (init path)++                              -- If --help was explicitly requested, show help and exit+                              if helpRequested+                                then do+                                  case Map.lookup fullPath (irMethods ir) of+                                    Just methodDef -> do+                                      page <- pageFor info pathSegs method+                                      liftIO $ do+                                        TIO.putStr $ renderMethodPage page ir methodDef+                                        backendHelpFooter+                                    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);+                                    -- SYNAPSE-10: -p @params.json and -p - name a source+                                    Just given -> do+                                      jsonStr <- liftIO (expandValue sourceEnv "" given) >>= either (throwParse . renderSourceError) pure+                                      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+                                              -- Pair the flags again by parameter type, now that the+                                              -- method is known (a value may begin with dashes)+                                              methodParams <- case pairFlags ir methodDef flagArgs of+                                                Right pairs -> fromSources pairs >>= liftIO . transformParams transformEnv defaultTransformers+                                                Left errs -> do+                                                  liftIO $ mapM_ (hPutStrLn stderr . renderParseError) errs+                                                  throwParse "Parameter parsing failed"+                                              -- Inject boolean defaults for flags without values+                                              let paramsWithBools = injectBooleanDefaults ir methodDef methodParams+                                              -- 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 -> do+                                            page <- pageFor info pathSegs method+                                            liftIO $ do+                                              TIO.putStr $ renderMethodPage page ir methodDef+                                              backendHelpFooter+                                          Nothing ->+                                            -- Fallback: method not in IR, use basic info+                                            liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method+                                      -- IR-15: fire stderr deprecation warnings before real invocation.+                                      else fireDeprecationWarnings >> invokeMethod sourceEnv method path params+  where+    -- AUTH-8: what the _info probe at this address answered (view, auth)+    currentInfo :: SynapseM (Maybe BackendInfo)+    currentInfo = do+      ep <- asks seEndpoint+      liftIO (probedInfoAt ep)++    viewSchema = \case+      ViewPlugin schema _ -> Just schema+      _ -> Nothing++    -- A plugin's help: as SYNAPSE-12 laid it out; in a caller's view (AUTH-4)+    -- with who the caller is under the description, and each method's+    -- grant and where it is held when the schema says them.+    --+    -- SYNAPSE-13: in gh's shape — a usage line, one line per method in its+    -- group, and how to see a method's options.+    showPluginHelp :: Maybe BackendInfo -> [Text] -> PluginSchema -> SynapseM ()+    showPluginHelp info segs schema = do+      backend <- asks seBackend+      let invoke = T.unwords ([invokeProgram, backend] ++ segs)+      who <- case info >>= infoView of+        Just Caller -> Session.whoamiM+        _ -> pure Nothing+      let caller = case info >>= infoView of+            Just Caller -> Just (maybe "you are signed in" renderCallerHeader who)+            _ -> Nothing+      liftIO $ do+        TIO.putStr $ renderListing defaultStyle (Listing invoke caller) schema+        synapseHelpLine++    -- SYNAPSE-13: synapse and the global options that reach this backend,+    -- as a command line shown in help (@synapse -P 4455@).+    invokeProgram :: Text+    invokeProgram = T.unwords (filter (not . T.null) ["synapse", cliOptions soEndpoint])++    -- SYNAPSE-13: what a method's page needs beside the IR — how it is+    -- reached, its schema (examples, values, grant) and the caller's view.+    pageFor :: Maybe BackendInfo -> [Text] -> MethodSchema -> SynapseM MethodPage+    pageFor info segs method = do+      backend <- asks seBackend+      pure MethodPage+        { mpProgram = invokeProgram+        , mpTarget = T.unwords (backend : segs)+        , mpSchema = Just method+        , mpCaller = (info >>= infoView) == Just Caller+        }++    -- SYNAPSE-17: search the backend's methods and parameters (the+    -- caller's view of its schema, from the IR cache when its hash is+    -- current) and answer in help's shape; -j: one JSON object per hit.+    runFind :: Find.FindOpts -> SynapseM ()+    runFind fo = do+      backend <- asks seBackend+      cache <- liftIO $ if soNoCache then pure Nothing else+        (Just <$> (newIRCache . defaultCacheConfig =<< getHomeDirectory))+          `E.catch` \(_ :: E.SomeException) -> pure Nothing+      ir <- Find.loadCatalog cache+      tty <- liftIO $ hIsTerminalDevice stdout+      noColor <- liftIO $ lookupEnv "NO_COLOR"+      let ans = Find.answer invokeProgram backend (tty && maybe True null noColor) fo ir+      liftIO $ if not (Find.anMatched ans)+        then do+          if soJson+            then TIO.hPutStrLn stderr ("No match for '" <> T.unwords (Find.foTerms fo) <> "' in " <> Find.anScope ans <> ".")+            else TIO.putStr (Find.anText ans)+          exitWith (ExitFailure 1)+        else if soJson+          then mapM_ (LBS.putStrLn . encode) (Find.anJson ans)+          else TIO.putStr (Find.anText ans)++    -- AUTH-8: the page an anonymous caller sees: the door, and how to sign in.+    showAnonymous :: Maybe BackendInfo -> Maybe PluginSchema -> SynapseM ()+    showAnonymous info root = do+      backend <- asks seBackend+      authSchema <- (Just <$> fetchSchemaAt ["auth"]) `catchError` \_ -> pure Nothing+      let invokePrefix = invokeProgram+          page = AnonPage+            { apBackend = backend+            , apVersion = psVersion <$> root+            , apMethods = anonymousMethods (info >>= infoAuth) authSchema+            , apInvoke = invokePrefix+            }+      liftIO $ TIO.putStr (renderAnonymousPage page)++    handleRespondCommand :: [(Text, Text)] -> SynapseM ()+    handleRespondCommand params = do+      let mRequestId = lookup "request_id" params+          mResponseStr = lookup "response" params+      case (mRequestId, mResponseStr) of+        (Nothing, _) -> throwParse "Missing --request-id for respond subcommand"+        (_, Nothing) -> throwParse "Missing --response for respond subcommand"+        (Just requestId, Just responseStr) ->+          case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 responseStr) of+            Left err -> throwParse $ "Invalid --response JSON: " <> T.pack err+            Right (resp :: Response Value) -> sendResponse requestId resp++    invokeMethod srcEnv method path params = do+      let namespacePath = init path  -- path without method name+      let methodName' = last path+      -- Set method path hint for template resolution+      let rendererCfg' = withMethodPath rendererCfg path+      -- Determine bidirectional mode (--bidir-cmd takes precedence)+      bidirMode <- liftIO $ case soBidirCmd of+        Just cmd -> pure $ BidirCmd cmd+        Nothing  -> case soBidirMode of+          Just modeStr -> case parseBidirMode modeStr of+            Just mode -> pure mode+            Nothing -> do+              TIO.hPutStrLn stderr $ "[synapse] Unknown --bidir-mode: " <> modeStr <> ", using auto-detect"+              detectBidirMode+          Nothing -> detectBidirMode+      -- SYNAPSE-10: a value read from stdin (-) has taken it; the JSON+      -- bidirectional mode reads stdin too, and the two cannot share+      stdinTaken <- liftIO $ stdinWasRead srcEnv+      case bidirMode of+        BidirJson | stdinTaken -> throwParse "a value was read from stdin (-), so --bidir-mode json cannot read it too; answer the backend's requests with --bidir-cmd, or use a file (@FILE) for the value"+        _ -> pure ()+      -- IDENTITY-43: while the stored session could still be made again,+      -- a "you have signed out" answered before anything else is held back+      -- for 'run' to log in again and retry.+      ep <- asks seEndpoint+      armed <- liftIO $ Session.canReattest ep+      let printer item = do+            shown <- Session.printedAny+            if armed && not shown && Session.isSessionEndedItem item+              then Session.markSessionEnded (endedMessage item)+              else do+                case item of+                  HubData{} -> Session.notePrinted+                  _ -> pure ()+                printResult soJson soRaw rendererCfg' item+      -- SYNAPSE-20: a stream that resumed after a gap says so — on -j as a+      -- line of its own (stdout, in the stream), else on stderr+      let resumed r+            | soJson = do+                LBS.putStrLn $ encode $ object $+                  [ "type" .= ("reconnected" :: Text)+                  , "outage_secs" .= (fromIntegral (round (Reconnect.rsOutageSecs r) :: Int) :: Int)+                  , "attempts" .= Reconnect.rsAttempts r+                  ] ++ maybe [] (\s -> ["since" .= s]) (Reconnect.rsSince r)+                hFlush stdout+            | otherwise = TIO.hPutStrLn stderr $+                "synapse: the stream resumed"+                  <> maybe "; anything sent during the gap may be missing" (\s -> " from " <> T.pack (show s) <> " (since)") (Reconnect.rsSince r)+      -- SYNAPSE-20: a stream outliving a restart finds its session gone+      -- (menger keeps them in memory): sign in again from the key, and+      -- reconnect with the new one+      backendName' <- asks seBackend+      logger' <- asks seLogger+      let refreshAuth = do+            st <- Store.systemStoreEnv+            new <- Session.reattestAgain logger' st ep+            case new of+              Nothing -> pure Nothing+              Just _ -> do+                env' <- buildEnv ep backendName' logger' soOpts+                pure (Just (mergeUpgradeHeaders (seToken env') (seCookies env') (seHeaders env')))+      -- Use bidirectional streaming handler+      invokeStreamingWithBidir+        (Reconnect.callShape method)+        refreshAuth+        resumed+        namespacePath+        methodName'+        params+        printer+        (handleBidirRequest bidirMode Nothing)++    endedMessage item = case item of+      HubData _ _ _ (Object o) | Just (String m) <- KM.lookup "message" o -> m+      HubError _ _ e _ -> e+      _ -> "your session has ended"++    -- Extract default values from JSON Schema properties+    -- Schema format: {"properties": {"key": {"default": value, ...}, ...}, ...}+    extractSchemaDefaults :: MethodSchema -> Value+    extractSchemaDefaults m = case methodParams m of+      Nothing -> object []+      Just (Object o) -> case KM.lookup "properties" o of+        Just (Object props) -> object+          [ (k, defaultVal)+          | (k, propSchema) <- KM.toList props+          , Object propObj <- [propSchema]+          , Just defaultVal <- [KM.lookup "default" propObj]+          ]+        _ -> object []+      Just _ -> object []++    -- Merge two JSON objects: right takes precedence over left+    mergeParams :: Value -> Value -> Value+    mergeParams (Object defaults) (Object user) =+      Object (KM.union user defaults)  -- union prefers first arg on conflict+    mergeParams _ user = user  -- if defaults aren't an object, just use user params++    -- Check if method has required parameters+    hasRequiredParams :: MethodSchema -> Bool+    hasRequiredParams m = case methodParams m of+      Nothing -> False+      Just (Object o) -> case KM.lookup "required" o of+        Just (Array arr) -> not (null arr)+        _ -> False+      Just _ -> False++    -- Fetch schema for a path, detecting if last segment is a method+    -- Uses navigate to determine what type of schema to fetch+    fetchSchemaForPath :: [Text] -> SynapseM (Either Text Value)+    fetchSchemaForPath segs = do+      view <- navigate segs+      case view of+        ViewPlugin schema _ -> pure $ Right $ toJSON schema+        ViewMethod method path -> do+          -- Use method-specific schema query for detailed method info+          let parentPath = init path+              methodName' = last path+          detailedMethod <- fetchMethodSchema parentPath methodName'+          pure $ Right $ toJSON detailedMethod++    -- Invoke raw JSON-RPC request+    invokeRawRpc :: Value -> SynapseM [HubStreamItem]+    invokeRawRpc rpcReq = do+      case rpcReq of+        Object o -> case (KM.lookup "method" o, KM.lookup "params" o) of+          (Just (String method), Just params) -> invokeRaw method params+          (Just (String method), Nothing) -> invokeRaw method (object [])+          _ -> throwParse "JSON-RPC must have 'method' field"+        _ -> throwParse "JSON-RPC must be an object"++-- | Build JSON object from key-value pairs+buildParamsObject :: [(Text, Text)] -> Value+buildParamsObject pairs = object+  [ (K.fromText k, inferValue v) | (k, v) <- pairs ]+  where+    -- Try to infer the JSON type from the string value+    inferValue :: Text -> Value+    inferValue t+      | t == "true" = Bool True+      | t == "false" = Bool False+      | Just n <- readMaybe (T.unpack t) :: Maybe Integer = Number (fromInteger n)+      | Just n <- readMaybe (T.unpack t) :: Maybe Double = Number (realToFrac n)+      | otherwise = String t++readMaybe :: Read a => String -> Maybe a+readMaybe s = case reads s of+  [(x, "")] -> Just x+  _ -> Nothing++-- | SYNAPSE-12: the one line under a backend's help that points at+-- synapse's own (dim on a terminal).+backendHelpFooter :: IO ()+backendHelpFooter = TIO.putStrLn "" >> synapseHelpLine++-- | SYNAPSE-13: the pointer to synapse's own help, dimmed on a terminal —+-- under a listing's own "Run '…'" lines, with no blank between.+synapseHelpLine :: IO ()+synapseHelpLine = do+  tty <- hIsTerminalDevice stdout+  let line = "Run 'synapse --help' for synapse's own options."+  TIO.putStrLn (if tty then "\ESC[2m" <> line <> "\ESC[0m" else line)++-- | ASCII splash logo+splash :: Text+splash = T.unlines+  [ ""+  , "███████╗██╗   ██╗███╗   ██╗ █████╗ ██████╗ ███████╗███████╗"+  , "██╔════╝╚██╗ ██╔╝████╗  ██║██╔══██╗██╔══██╗██╔════╝██╔════╝"+  , "███████╗ ╚████╔╝ ██╔██╗ ██║███████║██████╔╝███████╗█████╗  "+  , "╚════██║  ╚██╔╝  ██║╚██╗██║██╔══██║██╔═══╝ ╚════██║██╔══╝  "+  , "███████║   ██║   ██║ ╚████║██║  ██║██║     ███████║███████╗"+  , "╚══════╝   ╚═╝   ╚═╝  ╚═══╝╚═╝  ╚═╝╚═╝     ╚══════╝╚══════╝"+  , ""+  ]++-- | Get CLI help text from optparse-applicative+cliHeader :: Text+cliHeader = splash <> T.pack (fst $ renderFailure failure "synapse") <> "\n"+  where+    failure = parserFailure defaultPrefs argsInfo (ShowHelpText Nothing) mempty++-- | The meta-commands, under synapse's own options: in @synapse --help@ and+-- on the page bare @synapse@ shows.+metaCommands :: [Text]+metaCommands =+      [ ""+      , "Values (after the backend and the method):"+      , "  --flag @FILE        the value is that file's contents; --flag - reads stdin"+      , "                      (once, however many values ask); @@text sends a literal"+      , "                      @text. -p @params.json and -p - take the whole object the"+      , "                      same way. No argument then carries the value, so a body"+      , "                      can be as large as the backend accepts"+      , ""+      , "Where the hub is (before the backend):"+      , "  -P PORT / -H HOST   plain ws://HOST:PORT/ (default 127.0.0.1:4444, the registry)"+      , "  --url wss://HOST/ws a hub behind TLS (every hosted app), or ws://HOST:PORT/PATH;"+      , "                      the same as -H HOST --tls --path /ws (443 unless -P). The"+      , "                      certificate is checked against the system's trust store;"+      , "                      --cacert FILE trusts a local CA too. Sessions are kept per"+      , "                      URL, so _login and every call take the same options"+      , ""+      , "Meta-commands:"+      , ""+      , "  synapse _key new|show|list [NAME]"+      , "      Ed25519 keys an agent proves who it is with (keychain, else"+      , "      ~/.plexus/keys/NAME.key; PLEXUS_KEY and $CREDENTIALS_DIRECTORY read first)"+      , ""+      , "  synapse -P PORT _login BACKEND"+      , "  synapse -P PORT _login BACKEND --key NAME --as AGENT [--scope ROLE@SCOPE] [--ttl SECS]"+      , "  synapse -P PORT _logout BACKEND [--as AGENT]"+      , "      A person signs in through the browser (a loopback on 127.0.0.1; kept as"+      , "      'me'); an agent logs in from a key. Later calls to that backend carry the"+      , "      session by themselves (--as AGENT / SYNAPSE_AS picks one; else the last"+      , "      logged in), and an agent's logs in again from the key when it ends"+      , ""+      , "  synapse -P PORT _find BACKEND [ACTIVATION...] WORDS... [--limit N] [--methods|--params]"+      , "      Search the backend's methods and parameters: names and descriptions,"+      , "      typos and abbreviations too (setpar finds set_parent), best first, in"+      , "      help's shape (METHODS, PARAMETERS, MENTIONED IN); -j one JSON object per hit"+      , ""+      , "  synapse _self template"+      , "      Manage Mustache templates (CRUD operations)"+      , ""+      , "      Subcommands:"+      , "        list [pattern]      - List existing templates"+      , "        show <method>       - Display template content"+      , "        generate [pattern]  - Generate new templates from IR"+      , "        delete <pattern>    - Delete templates"+      , "        reload              - Clear template cache"+      , ""+      , "      Examples:"+      , "        synapse _self template list"+      , "        synapse _self template show cone.chat"+      , "        synapse _self template generate 'plexus.cone.*'"+      , ""+      ]++-- | Render an error for display+renderError :: SynapseError -> String+renderError = \case+  NavError (NotFound seg path maybeSchema) ->+    let baseMsg = "Command not found: '" <> T.unpack seg <> "' at " <> showPath path+    in case maybeSchema of+      Nothing -> baseMsg+      Just schema ->+        let methods = psMethods schema+            children = pluginChildren schema+            suggestions = if null methods && null children+                         then ""+                         else "\n\nAvailable commands:"+                              <> renderMethods methods+                              <> renderChildren children+        in baseMsg <> suggestions+  NavError (MethodNotTerminal seg path) ->+    "Method '" <> T.unpack seg <> "' cannot have subcommands at " <> showPath path+  NavError (Cycle hash path) ->+    "Cycle detected: hash " <> T.unpack hash <> " at " <> showPath path+  NavError (FetchError msg path) ->+    "Fetch error at " <> showPath path <> ": " <> T.unpack msg+  TransportError msg ->+    "Transport error: " <> T.unpack msg+  TransportErrorContext ctx ->+    renderTransportError ctx+  ParseError msg ->+    "Parse error: " <> T.unpack msg+  ValidationError msg ->+    "Validation error: " <> T.unpack msg+  BackendError errorType backends ->+    case errorType of+      BackendNotFound name ->+        "Backend not found: '" <> T.unpack name <> "'"+        <> renderBackendList backends+      BackendUnreachable name ->+        "Backend unreachable: '" <> T.unpack name <> "'"+        <> renderBackendList backends+      NoBackendsAvailable ->+        "No backends available"+        <> renderBackendList backends+      ProtocolHandshakeFailed host port ->+        "Protocol handshake failed at " <> T.unpack host <> ":" <> show port <> "\n"+        <> "The _info request did not complete successfully within 2 seconds.\n"+        <> "This typically means:\n"+        <> "  - The server is not responding to Plexus RPC protocol messages\n"+        <> "  - The server is not sending required StreamDone messages\n"+        <> "  - The connection is timing out"+  where+    showPath [] = "root"+    showPath p = T.unpack $ T.intercalate "." p++    renderMethods [] = ""+    renderMethods methods =+      let header = "\n\n  Methods:"+          methodLines = map renderMethod methods+      in header <> concat methodLines++    renderMethod method =+      let name = T.unpack $ methodName method+          desc = T.unpack $ methodDescription method+          padding = 20+          namePadded = name <> replicate (max 1 (padding - length name)) ' '+      in "\n    " <> namePadded <> desc++    renderChildren [] = ""+    renderChildren children =+      let header = "\n\n  Child plugins:"+          childLines = map renderChild children+      in header <> concat childLines++    renderChild child =+      let name = T.unpack $ csNamespace child+          desc = T.unpack $ csDescription child+          padding = 20+          namePadded = name <> replicate (max 1 (padding - length name)) ' '+      in "\n    " <> namePadded <> desc++    renderBackendList [] = "\n\nNo backends available."+    renderBackendList backends =+      let header = "\n\nAvailable backends:"+          backendLines = map renderBackendLine backends+          usageHint = "\n\nUsage: synapse <backend> [command...]"+      in header <> concat backendLines <> usageHint++    renderBackendLine backend =+      let name = T.unpack $ backendName backend+          nameField = name <> replicate (max 1 (15 - length name)) ' '+          hostPort = T.unpack $ backendHost backend <> ":" <> T.pack (show (backendPort backend))+          status = case backendReachable backend of+                     Just True  -> " [OK]"+                     Just False -> " [UNREACHABLE]"+                     Nothing    -> ""+          desc = if T.null (backendDescription backend)+                 then ""+                 else " - " <> T.unpack (backendDescription backend)+      in "\n  " <> nameField <> hostPort <> status <> desc++-- | Render transport error with context+renderTransportError :: TransportContext -> String+renderTransportError TransportContext{..} = case tcCategory of+  ConnectionRefused ->+    "Connection refused\n\n" <>+    "Backend: " <> T.unpack tcBackend <> "\n" <>+    "Address: " <> T.unpack tcHost <> ":" <> show tcPort <> "\n" <>+    "Path: " <> showPath tcPath <> "\n\n" <>+    "Troubleshooting:\n" <>+    "  - Check if the backend is running\n" <>+    "  - Verify host (-H) and port (-P) settings\n" <>+    "  - Run 'synapse' (no args) to list backends"++  ConnectionTimeout ->+    "Connection timeout\n\n" <>+    "Backend: " <> T.unpack tcBackend <> " @ " <>+    T.unpack tcHost <> ":" <> show tcPort <> "\n\n" <>+    "The server may be overloaded or network latency is high\n" <>+    "Error: " <> T.unpack tcMessage++  ProtocolError ->+    "Protocol error\n\n" <>+    "Backend: " <> T.unpack tcBackend <> "\n" <>+    "This may indicate a version mismatch\n\n" <>+    "Error: " <> T.unpack tcMessage++  UnknownTransportError ->+    "Transport error: " <> T.unpack tcMessage <> "\n\n" <>+    "Backend: " <> T.unpack tcBackend <> " @ " <>+    T.unpack tcHost <> ":" <> show tcPort+  where+    showPath [] = "root"+    showPath p = T.unpack $ T.intercalate "." p++-- | Render a parse error for display+renderParseError :: Parse.ParseError -> String+renderParseError = \case+  Parse.UnknownParam name suggestions ->+    "Unknown parameter: --" <> T.unpack name <>+    case suggestions of+      [] -> ""+      [s] -> "\n\nDid you mean: --" <> T.unpack s <> "?"+      ss -> "\n\nDid you mean one of:\n" <>+            unlines ["  --" <> T.unpack s | s <- ss]+  Parse.MissingRequired name ->+    "Missing required parameter: --" <> T.unpack name+  Parse.InvalidValue name reason ->+    "Invalid value for --" <> T.unpack name <> ": " <> T.unpack reason+  Parse.AmbiguousVariant name variants ->+    "Ambiguous variant for --" <> T.unpack name <> ": could be one of " <> show (map T.unpack variants)+  Parse.MissingDiscriminator param field ->+    "Missing discriminator for --" <> T.unpack param <> ": need --" <> T.unpack param <> "." <> T.unpack field+  Parse.UnknownVariant param value valid suggestions ->+    "Unknown variant '" <> T.unpack value <> "' for --" <> T.unpack param <>+    "\n\nValid variants: " <> T.unpack (T.intercalate ", " valid) <>+    case suggestions of+      [] -> ""+      [s] -> "\n\nDid you mean: " <> T.unpack s <> "?"+      ss -> "\n\nDid you mean one of: " <> T.unpack (T.intercalate ", " ss) <> "?"+  Parse.TypeNotFound name ->+    "Type not found in IR: " <> T.unpack name+  Parse.MalformedListValue name value reason ->+    "Malformed list value for --" <> T.unpack name <> ": " <> T.unpack value <>+    " (" <> T.unpack reason <> ")"+  Parse.UnexpectedArgument arg ->+    "Unexpected argument: " <> T.unpack arg <>+    "\n\nA value follows its flag (--key VALUE or --key=VALUE); a boolean flag takes none unless it is true or false."+++-- | Write a generated template to disk (no logging)+writeGeneratedTemplateIR :: FilePath -> TemplateIR.GeneratedTemplate -> IO ()+writeGeneratedTemplateIR baseDir gt = do+  let fullPath = baseDir </> TemplateIR.gtPath gt+  createDirectoryIfMissing True (baseDir </> T.unpack (TemplateIR.gtNamespace gt))+  TIO.writeFile fullPath (TemplateIR.gtTemplate gt)++-- | Encode a dry-run request+encodeDryRun :: Text -> [Text] -> Text -> Value -> LBS.ByteString+encodeDryRun backend namespacePath method params =+  let fullPath = if null namespacePath then [backend] else namespacePath+      dotPath = T.intercalate "." (fullPath ++ [method])+  in encode $ object+    [ "jsonrpc" .= ("2.0" :: Text)+    , "id" .= (1 :: Int)+    , "method" .= (backend <> ".call")+    , "params" .= object+        [ "method" .= dotPath+        , "params" .= params+        ]+    ]++-- | Print a stream result+-- soJson: output raw JSON stream items+-- soRaw: skip template rendering, just output content JSON+-- otherwise: try template rendering, fall back to content JSON+printResult :: Bool -> Bool -> RendererConfig -> HubStreamItem -> IO ()+printResult json raw cfg item = case itemRefusal item of+  -- AUTH-8: a refusal says what it needed (and the call exits non-zero)+  Just r -> do+    Session.noteRefused+    if json then LBS.putStrLn (encode item) else do+      ceiling' <- Session.currentCeiling+      TIO.hPutStr stderr (renderRefusal ceiling' r)+  Nothing -> printResult' json raw cfg item++printResult' :: Bool -> Bool -> RendererConfig -> HubStreamItem -> IO ()+printResult' True _ _ item = LBS.putStrLn $ encode item+printResult' _ True _ item = case item of+  -- Raw mode: just output the content+  HubData _ _ _ dat -> do+    LBS.putStrLn $ encode dat+    hFlush stdout+  HubProgress _ _ msg _ -> do+    TIO.putStr msg+    TIO.putStr "\r"+    hFlush stdout+  HubError _ _ err _ ->+    hPutStrLn stderr $ "Error: " <> T.unpack err+  _ -> pure ()+printResult' _ _ cfg item = do+  -- Template mode: try to render with template+  mRendered <- renderItem cfg item+  case mRendered of+    Just text+      | T.null (T.strip text) -> pure ()+      | otherwise -> do+          TIO.putStr text+          hFlush stdout+    Nothing -> case item of+      -- Fallback to pretty-printed content+      HubData _ _ _ dat -> do+        TIO.putStrLn $ prettyValue dat+        hFlush stdout+      HubProgress _ _ msg _ -> do+        TIO.putStr msg+        TIO.putStr "\r"+        hFlush stdout+      HubError _ _ err _ ->+        hPutStrLn stderr $ "Error: " <> T.unpack err+      _ -> pure ()++-- ============================================================================+-- Argument Parsing (Synapse Options Only)+-- ============================================================================++-- | Parser for synapse-level options only+-- Backend and path are handled separately after arg splitting+argsInfo :: ParserInfo Args+argsInfo = info (argsParser <**> versionOption <**> helper)+  ( fullDesc+ <> header "synapse - Algebraic CLI for Hub"+ <> progDesc "synapse [OPTIONS] <backend> <path...> [--param value ...]"+ <> noIntersperse  -- Stop option parsing at first positional arg+ <> footerDoc (Just (Pretty.vsep (map (Pretty.pretty . T.unpack) (drop 1 metaCommands))))+  )+  where+    versionOption = infoOption (showVersion Meta.version)+      ( long "version" <> short 'V' <> help "Show version" )++argsParser :: Parser Args+argsParser = Args <$> optsParser <*> backendParser <*> restParser <*> pure Nothing+  where+    backendParser = optional $ T.pack <$> argument str+      ( metavar "BACKEND"+     <> help "Backend name (e.g., plexus, registry-hub)" )++    restParser = many $ T.pack <$> argument str+      ( metavar "PATH... [--param value ...]"+     <> help "Path and method parameters (passed through)" )++optsParser :: Parser SynapseOpts+optsParser = do+  soHostFlag <- optional $ T.pack <$> strOption+    ( long "host" <> short 'H' <> metavar "HOST"+   <> help "Registry/discovery host (default: 127.0.0.1)" )+  soPortFlag <- optional $ option auto+    ( long "port" <> short 'P' <> metavar "PORT"+   <> help "Registry/discovery port (default: 4444; 443 with --tls)" )+  soUrl <- optional $ T.pack <$> strOption+    ( long "url" <> metavar "URL"+   <> help "The hub's socket as a URL: ws://HOST[:PORT][/PATH] or wss://HOST[:PORT][/PATH] (e.g. wss://app.menger.sh/ws); in place of -H/-P/--tls/--path" )+  soTls <- switch+    ( long "tls"+   <> help "Dial wss:// (TLS; the certificate checked against the system's trust store) at -H/-P" )+  soPath <- optional $ T.pack <$> strOption+    ( long "path" <> metavar "PATH"+   <> help "The socket's path at -H/-P (default: /), e.g. /ws" )+  soCaCerts <- many $ T.pack <$> strOption+    ( long "cacert" <> metavar "FILE"+   <> help "With wss: also trust the CA certificate(s) in this PEM file (repeatable; a local CA for a test)" )+  soJson <- switch+    ( long "json" <> short 'j'+   <> help "Output raw JSON stream items" )+  soRaw <- switch+    ( long "raw"+   <> help "Output raw content JSON (skip templates)" )+  soDryRun <- switch+    ( long "dry-run" <> short 'n'+   <> help "Show JSON-RPC request without sending" )+  soSchema <- switch+    ( long "schema" <> short 's'+   <> help "Fetch raw schema JSON for path" )+  soGenerate <- switch+    ( long "generate-templates" <> short 'g'+   <> help "Generate mustache templates from IR" )+  soEmitIR <- switch+    ( long "emit-ir" <> short 'i'+   <> help "Emit IR for code generation (JSON)" )+  soParams <- optional $ T.pack <$> strOption+    ( long "params" <> short 'p' <> metavar "JSON"+   <> help "Method parameters as a JSON object, sent as written; @FILE reads it from a file, - from stdin" )+  soRpc <- optional $ T.pack <$> strOption+    ( long "rpc" <> short 'r' <> metavar "JSON"+   <> help "Raw JSON-RPC request (bypass navigation)" )+  soGeneratorInfo <- many $ T.pack <$> strOption+    ( long "generator-info" <> metavar "TOOL:VERSION"+   <> help "Generator tool version info (can be specified multiple times)" )+  soBidirMode <- optional $ T.pack <$> strOption+    ( long "bidir-mode" <> short 'b' <> metavar "MODE"+   <> help "Bidirectional mode: interactive (TTY), json (pipe protocol), auto-cancel, defaults, respond" )+  soBidirCmd <- optional $ T.pack <$> strOption+    ( long "bidir-cmd" <> metavar "CMD"+   <> help "Shell command to handle bidir requests (stdin=JSON request, stdout=JSON response)" )+  soNoCache <- switch+    ( long "no-cache"+   <> help "Disable IR caching (force rebuild from schema)" )+  soLogLevel <- optional $ T.pack <$> strOption+    ( long "log-level" <> metavar "LEVEL"+   <> help "Log level: info, debug, trace (default: disabled)" )+  soLogSubsystems <- many $ T.pack <$> strOption+    ( long "log-subsystem" <> metavar "SUBSYSTEM"+   <> help "Filter logs by subsystem: discovery, transport, rpc, schema, cache, navigation (can specify multiple, default: all)" )+  soToken <- optional $ T.pack <$> strOption+    ( long "token" <> short 't' <> metavar "JWT"+   <> help "JWT sent as Cookie: access_token=<jwt> on WebSocket upgrade (overrides any access_token in ~/.plexus/<backend>/defaults.json)" )+  soTokenFile <- optional $ T.pack <$> strOption+    ( long "token-file" <> metavar "PATH"+   <> help "Path to file containing a raw JWT (overrides any access_token in ~/.plexus/<backend>/defaults.json)" )+  soCookies <- many (parseKv <$> strOption+    ( long "cookie" <> metavar "KEY=VALUE"+   <> help "Extra cookie attached to WS upgrade (repeatable; SAFE-S04/REQ-5)" ))+  soHeaders <- many (parseKv <$> strOption+    ( long "header" <> metavar "KEY=VALUE"+   <> help "Extra HTTP header attached to WS upgrade (repeatable; SAFE-S04/REQ-5)" ))+  soNoDeprecationWarnings <- switch+    ( long "no-deprecation-warnings"+   <> help "Suppress invocation-time deprecation warnings on stderr (IR-15)" )+  soAs <- optional $ T.pack <$> strOption+    ( long "as" <> metavar "AGENT"+   <> help "Carry this agent's stored session (see _login; else SYNAPSE_AS, else the backend's default agent)" )+  soReconnectFor <- optional $ T.pack <$> strOption+    ( long "reconnect-for" <> metavar "DURATION"+   <> help "Ride out an outage this long: a lost connection is retried, a read sent again, a stream resumed (10m, 90s, 1h; 0 = never; else SYNAPSE_RECONNECT_FOR, else 10m)" )+  pure SynapseOpts+    { soHost = maybe defaultHost id soHostFlag+    , soPort = maybe defaultPort id soPortFlag+    , soEndpoint = plainAt (maybe defaultHost id soHostFlag) (maybe defaultPort id soPortFlag)+    , ..+    }++-- | SCAFFOLD-21: the connection point from the options — @--url@, or @-H@+-- / @-P@ with @--tls@ (port 443 unless @-P@) and @--path@; plain+-- @ws://127.0.0.1:4444/@ when none is given. @soHost@ / @soPort@ follow it.+-- A @--cacert@ that cannot be read is refused here, not at the handshake.+resolveConnection :: SynapseOpts -> IO (Either Text SynapseOpts)+resolveConnection o = case pick of+  Left e -> pure (Left e)+  Right ep0 -> do+    let ep = ep0 { epCaFiles = map T.unpack (soCaCerts o) }+    missing <- filterM (fmap not . doesFileExist . T.unpack) (soCaCerts o)+    pure $ case () of+      _ | not (null (soCaCerts o)) && not (epTls ep) ->+            Left "--cacert is for a wss:// address (--url wss://… or --tls)"+        | (f : _) <- missing -> Left ("--cacert " <> f <> ": no such file")+        | otherwise -> Right o { soHost = epHost ep, soPort = epPort ep, soEndpoint = ep }+  where+    pick = case soUrl o of+      Just u+        | isJust (soHostFlag o) || isJust (soPortFlag o) || soTls o || isJust (soPath o) ->+            Left "--url names the whole address: give it alone, or -H / -P with --tls / --path"+        | otherwise -> parseUrl u+      Nothing -> Right Endpoint+        { epHost = maybe defaultHost id (soHostFlag o)+        , epPort = maybe (if soTls o then 443 else defaultPort) id (soPortFlag o)+        , epTls = soTls o+        , epPath = maybe "/" normalisePath (soPath o)+        , epCaFiles = []+        }++-- | Parse a KEY=VALUE pair (used by --cookie/--header). Treats the first '='+-- as the separator; everything before is the key, everything after is the value.+parseKv :: String -> (Text, Text)+parseKv s =+  let (k, rest) = break (== '=') s+      v = case rest of+            '=':vv -> vv+            _      -> ""+  in (T.pack k, T.pack v)

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               plexus-synapse-version:            3.13.0+version:            3.15.0 synopsis:           Schema-driven CLI for Plexus RPC servers license:            MIT author:@@ -12,10 +12,19 @@   default:     False   manual:      True +flag build-keychain-tests+  description: Build and run SELF-8 keychain tests. These shell out to+               `security` on macOS and touch the real keychain; they're+               opt-in so default `cabal test` runs stay quiet.+               Enable with: cabal test -f build-keychain-tests+  default:     False+  manual:      True+ library   exposed-modules:     Synapse.Schema.Types     Synapse.Schema.Functor+    Synapse.Endpoint     Synapse.Monad     Synapse.Log     Synapse.Algebra.Navigate@@ -23,6 +32,7 @@     Synapse.Algebra.Walk     Synapse.Algebra.Recursion     Synapse.Transport+    Synapse.Reconnect     Synapse.Cache     Synapse.Deprecation     Synapse.Renderer@@ -34,9 +44,21 @@     Synapse.CLI.Parse     Synapse.CLI.Support     Synapse.CLI.Template+    Synapse.CLI.Source     Synapse.CLI.Transform     Synapse.CLI.Similarity+    Synapse.Find     Synapse.Backend.Discovery+    Synapse.Self+    Synapse.Self.Types+    Synapse.Self.Resolve+    Synapse.Self.IO+    Synapse.Self.Resolve.Literal+    Synapse.Self.Resolve.Env+    Synapse.Self.Resolve.File+    Synapse.Self.Resolve.Keychain+    Synapse.Self.Resolve.Default+    Synapse.Self.Command     Synapse.Self.Commands     Synapse.Self.Template     Synapse.Self.Pattern@@ -46,13 +68,21 @@     Synapse.Self.Protocol.StreamTracker     Synapse.Self.Protocol.Reporter     Synapse.Self.Protocol.TestRunner+    Synapse.Identity.Proof+    Synapse.Identity.Store+    Synapse.Identity.Session+    Synapse.Identity.Command+    Synapse.Auth+    Synapse.Auth.Loopback   build-depends:     base >= 4.17 && < 5,-    plexus-protocol,+    -- SCAFFOLD-21: substrateTls (wss)+    plexus-protocol >= 0.5.2,     aeson >= 2.0 && < 2.3,     aeson-pretty >= 0.8 && < 0.9,     text >= 2.0 && < 2.2,     bytestring >= 0.11 && < 0.13,+    case-insensitive >= 1.2 && < 1.3,     websockets >= 0.13 && < 0.14,     network >= 3.1 && < 3.3,     async >= 2.2 && < 2.3,@@ -75,7 +105,13 @@     array >= 0.5 && < 0.6,     process >= 1.6 && < 1.7,     fast-logger >= 3.0 && < 3.3,-    katip >= 0.8 && < 0.9+    katip >= 0.8 && < 0.9,+    base64-bytestring >= 1.2 && < 1.3,+    optparse-applicative >= 0.18 && < 0.19,+    unix >= 2.7 && < 2.9,+    -- IDENTITY-43: Ed25519 keys and their randomness+    crypton >= 1.0 && < 1.2,+    ram >= 0.20 && < 0.23   hs-source-dirs:   src   default-language: GHC2021   default-extensions:@@ -203,6 +239,62 @@     RecordWildCards   ghc-options:      -threaded +test-suite schema-decode-test+  type:             exitcode-stdio-1.0+  main-is:          SchemaDecodeSpec.hs+  build-depends:+    base >= 4.17 && < 5,+    plexus-protocol,+    aeson >= 2.2 && < 2.3,+    aeson-qq >= 0.8 && < 0.9,+    bytestring >= 0.11 && < 0.13,+    vector >= 0.13 && < 0.14+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded++test-suite req8-render-test+  type:             exitcode-stdio-1.0+  main-is:          Req8RenderSpec.hs+  build-depends:+    base >= 4.17 && < 5,+    plexus-protocol,+    plexus-synapse,+    aeson >= 2.2 && < 2.3,+    aeson-qq >= 0.8 && < 0.9,+    containers >= 0.6 && < 0.8,+    text >= 2.0 && < 2.2+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded++test-suite render-test+  -- SYNAPSE-12: a backend's help laid out (blank lines, columns, wrapping,+  -- required before optional, types as the schema says them).+  -- SYNAPSE-13: in the gh / cargo shape — listings of one-line summaries in+  -- their groups; a method's page with its usage line, aligned options,+  -- values and examples; an older hub's schema still rendered.+  type:             exitcode-stdio-1.0+  main-is:          RenderSpec.hs+  build-depends:+    base >= 4.17 && < 5,+    plexus-protocol,+    plexus-synapse,+    aeson >= 2.2 && < 2.3,+    aeson-qq >= 0.8 && < 0.9,+    containers >= 0.6 && < 0.8,+    text >= 2.0 && < 2.2,+    hspec >= 2.10 && < 2.12+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded+ test-suite typeref-json   type:             exitcode-stdio-1.0   main-is:          TypeRefJson.hs@@ -236,11 +328,30 @@     OverloadedStrings   ghc-options:      -threaded +-- SYNAPSE-10: a parameter's value from a file or stdin+test-suite source-test+  type:             exitcode-stdio-1.0+  main-is:          SourceSpec.hs+  build-depends:+    base >= 4.17 && < 5,+    plexus-synapse,+    text >= 2.0 && < 2.2,+    bytestring >= 0.11 && < 0.13,+    directory >= 1.3 && < 1.4,+    filepath >= 1.4 && < 1.6,+    hspec >= 2.10 && < 2.12+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded+ test-suite path-normalization-test   type:             exitcode-stdio-1.0   main-is:          PathNormalizationSpec.hs   build-depends:     base >= 4.17 && < 5,+    plexus-synapse,     text >= 2.0 && < 2.2,     hspec >= 2.10 && < 2.12   hs-source-dirs:   test@@ -333,15 +444,217 @@     OverloadedStrings   ghc-options:      -threaded +test-suite self-test+  type:             exitcode-stdio-1.0+  main-is:          SelfSpec.hs+  other-modules:+    SelfCommandSpec+    SelfMigrationSpec+    SelfSafeWriteSpec+  build-depends:+    base >= 4.17 && < 5,+    plexus-synapse,+    text >= 2.0 && < 2.2,+    bytestring >= 0.11 && < 0.13,+    containers >= 0.6 && < 0.8,+    aeson >= 2.2 && < 2.3,+    directory >= 1.3 && < 1.4,+    filepath >= 1.4 && < 1.6,+    hspec >= 2.10 && < 2.12,+    time >= 1.12 && < 1.15,+    temporary >= 1.3 && < 1.4,+    base64-bytestring >= 1.2 && < 1.3,+    unix >= 2.7 && < 2.9+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded++test-suite identity-test+  -- IDENTITY-43: the canonical message, the fixed proof vector the Rust+  -- side cross-checks, and the key and session stores' order (env, a+  -- mocked keychain, files in a directory of the test's own).+  type:             exitcode-stdio-1.0+  main-is:          IdentitySpec.hs+  build-depends:+    base >= 4.17 && < 5,+    async >= 2.2 && < 2.3,+    plexus-synapse,+    text >= 2.0 && < 2.2,+    bytestring >= 0.11 && < 0.13,+    base64-bytestring >= 1.2 && < 1.3,+    aeson >= 2.2 && < 2.3,+    containers >= 0.6 && < 0.8,+    directory >= 1.3 && < 1.4,+    filepath >= 1.4 && < 1.6,+    hspec >= 2.10 && < 2.12,+    temporary >= 1.3 && < 1.4,+    unix >= 2.7 && < 2.9+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded+ test-suite ir12-method-role-test   type:             exitcode-stdio-1.0   main-is:          IR12MethodRoleSpec.hs   build-depends:     base >= 4.17 && < 5,+    containers >= 0.6 && < 0.8,     plexus-protocol,     plexus-synapse,     aeson >= 2.2 && < 2.3,     bytestring >= 0.11 && < 0.13,+    hspec >= 2.10 && < 2.12+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded++test-suite keychain-test+  -- SELF-8 keychain tests. Opt-in via `-f build-keychain-tests` because+  -- they shell out to macOS `security` and touch the real keychain.+  type:             exitcode-stdio-1.0+  main-is:          KeychainSpec.hs+  build-depends:+    base >= 4.17 && < 5,+    plexus-synapse,+    text >= 2.0 && < 2.2,+    hspec >= 2.10 && < 2.12,+    uuid >= 1.3 && < 1.4+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded+  if !flag(build-keychain-tests)+    buildable: False++test-suite auth-test+  -- AUTH-8: the auth shapes plexus-protocol parses (and their absence),+  -- the anonymous page, the caller's header and grant columns, the refusal+  -- block, the loopback's state check, and the flows end to end against a+  -- hub in miniature (test/MockHub.hs) on ports of their own.+  type:             exitcode-stdio-1.0+  main-is:          AuthSpec.hs+  other-modules:    MockHub+  build-depends:+    base >= 4.17 && < 5,+    plexus-protocol,+    plexus-synapse,+    aeson >= 2.2 && < 2.3,+    aeson-qq >= 0.8 && < 0.9,+    bytestring >= 0.11 && < 0.13,+    containers >= 0.6 && < 0.8,+    text >= 2.0 && < 2.2,+    katip >= 0.8 && < 0.9,+    network >= 3.1 && < 3.3,+    websockets >= 0.13 && < 0.14,+    vector >= 0.12 && < 0.14,+    hspec >= 2.10 && < 2.12+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded++test-suite find-test+  -- SYNAPSE-17: _find's matcher (exact, prefix, typo at both thresholds,+  -- snake_case subsequence, every word, ranking) and its renders against+  -- the mock hub's catalog (menger's schema as it was, test/fixtures), on a+  -- terminal and piped; a caller's view; the IR cache's hash check.+  type:             exitcode-stdio-1.0+  main-is:          FindSpec.hs+  other-modules:    MockHub+  build-depends:+    base >= 4.17 && < 5,+    plexus-synapse,+    aeson >= 2.2 && < 2.3,+    bytestring >= 0.11 && < 0.13,+    containers >= 0.6 && < 0.8,+    directory >= 1.3 && < 1.4,+    filepath >= 1.4 && < 1.6,+    text >= 2.0 && < 2.2,+    katip >= 0.8 && < 0.9,+    network >= 3.1 && < 3.3,+    websockets >= 0.13 && < 0.14,+    vector >= 0.12 && < 0.14,+    hspec >= 2.10 && < 2.12+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded++test-suite reconnect-test+  -- SYNAPSE-20: a lost connection is noticed (a close, a drop before any+  -- answer, a silent peer by its keepalive) and synapse rides out the+  -- outage — a read sent again, a stream resumed with since, a write that+  -- went out never repeated, one that never left sent when the backend is+  -- back, the window run out — against a flaky hub on ports of its own.+  type:             exitcode-stdio-1.0+  main-is:          ReconnectSpec.hs+  build-depends:+    base >= 4.17 && < 5,+    plexus-protocol,+    plexus-synapse,+    aeson >= 2.2 && < 2.3,+    text >= 2.0 && < 2.2,+    network >= 3.1 && < 3.3,+    websockets >= 0.13 && < 0.14,+    hspec >= 2.10 && < 2.12+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded++test-suite endpoint-test+  -- SCAFFOLD-21: --url and -H/-P with --tls/--path read into one address,+  -- and every key derived from it — the session store's (a plain address+  -- keyed exactly as before), the proof's audience, the options messages+  -- tell the reader to type, the plexus-protocol config.+  type:             exitcode-stdio-1.0+  main-is:          EndpointSpec.hs+  build-depends:+    base >= 4.17 && < 5,+    plexus-protocol,+    plexus-synapse,+    text >= 2.0 && < 2.2,+    hspec >= 2.10 && < 2.12+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings++test-suite tls-test+  -- SCAFFOLD-21: synapse speaks wss — the probe, a call and a key login+  -- through a TLS terminator of the test's own (a CA openssl makes for the+  -- run, in front of the mock hub), at a path; an unknown CA and a wrong+  -- name refused at the handshake. Pending without openssl.+  type:             exitcode-stdio-1.0+  main-is:          TlsSpec.hs+  other-modules:    MockHub+  build-depends:+    base >= 4.17 && < 5,+    plexus-protocol,+    plexus-synapse,+    aeson >= 2.2 && < 2.3,+    base64-bytestring >= 1.2 && < 1.3,+    bytestring >= 0.11 && < 0.13,+    directory >= 1.3 && < 1.4,+    filepath >= 1.4 && < 1.6,+    katip >= 0.8 && < 0.9,+    network >= 3.1 && < 3.3,+    process >= 1.6 && < 1.7,+    temporary >= 1.3 && < 1.4,+    text >= 2.0 && < 2.2,+    tls >= 2.1 && < 2.5,+    vector >= 0.12 && < 0.14,+    websockets >= 0.13 && < 0.14,     hspec >= 2.10 && < 2.12   hs-source-dirs:   test   default-language: GHC2021

@@ -3,6 +3,12 @@   ( -- * Rendering Functions     renderSchema   , renderSchemaWith+  , renderSchemaFor+  , renderListing+  , Listing(..)+  , summarize+  , fitText+  , quoteMask   , renderMethod   , renderMethodFull   , renderChild@@ -21,11 +27,14 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Aeson (Value(..))+import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM-import Data.List (intersperse, sortOn)-import Prettyprinter-import Prettyprinter.Render.Text (renderStrict)+import qualified Data.Vector as V+import Control.Applicative ((<|>))+import Data.Char (isAlphaNum, toLower)+import Data.List (sortOn)+import Data.Maybe (fromMaybe, isJust, isNothing)  import Synapse.Schema.Types import Plexus.Schema.Recursive (DeprecationInfo(..), ParamSchema(..))@@ -36,6 +45,7 @@   , rsShowHash  :: !Bool  -- ^ Show plugin/method hashes   , rsShowTypes :: !Bool  -- ^ Show parameter types   , rsCompact   :: !Bool  -- ^ Compact single-line format+  , rsWidth     :: !Int   -- ^ Columns to wrap descriptions at (SYNAPSE-12)   }   deriving stock (Show, Eq) @@ -46,6 +56,7 @@   , rsShowHash  = False   , rsShowTypes = True   , rsCompact   = False+  , rsWidth     = 80   }  -- | Compact style: single-line descriptions@@ -58,102 +69,247 @@  -- | Render with custom style renderSchemaWith :: RenderStyle -> PluginSchema -> Text-renderSchemaWith _style PluginSchema{..}-  | null psMethods && maybe True null psChildren = deprecationBanner <> headerText-  | otherwise = renderStrict $ layoutPretty layoutOpts doc+renderSchemaWith style = renderSchemaFor style Nothing++-- | AUTH-8: render for a caller — the header line saying who it is+-- (@you are … · editor on MENGER@) under the description, when given.+-- SYNAPSE-13: the listing as 'renderListing' lays it out, reached by+-- @synapse <namespace>@.+renderSchemaFor :: RenderStyle -> Maybe Text -> PluginSchema -> Text+renderSchemaFor style callerLine ps =+  renderListing style (Listing ("synapse " <> psNamespace ps) callerLine) ps++-- | SYNAPSE-13: what a listing needs beside the schema.+data Listing = Listing+  { lsInvoke :: Text        -- ^ the command line that reaches this plugin (@synapse -P 4455 menger tickets@)+  , lsCaller :: Maybe Text  -- ^ AUTH-8: who the caller is, in a caller's view+  }+  deriving stock (Show, Eq)++-- | SYNAPSE-13: a plugin's listing in gh's shape — the name, version and+-- description; a usage line; then one line per activation and per method+-- (its name and summary, the first sentence of its description), the+-- methods in their groups (the schema's @group@, in the order they first+-- appear; alphabetical within each; one METHODS section when there are+-- none), and how to see a method's options. In a caller's view (AUTH-8)+-- who the caller is sits under the description, and each method's line+-- ends with its grant and where it is held, in two aligned columns.+renderListing :: RenderStyle -> Listing -> PluginSchema -> Text+renderListing style Listing{..} PluginSchema{..} = T.unlines (dropTrailingBlanks body)   where-    layoutOpts = LayoutOptions (AvailablePerLine 80 1.0)+    width = rsWidth style+    authCols = isJust lsCaller || any (isJust . methodHeldOn) psMethods -    -- Activation-level deprecation banner (plain-text, rendered ahead-    -- of the compact header variant used for trivial schemas).-    deprecationBanner = case psDeprecation of-      Just di -> deprecationMarker <> " " <> formatDeprecationLine di <> "\n"-      Nothing -> ""+    body = concat+      [ [heading]+      , deprecationNotice+      , map ("  " <>) (wrap (width - 2) psDescription)+      , maybe [] (\l -> ["  " <> l]) lsCaller+      , section "USAGE" (map ("  " <>) usage)+      , section "ACTIVATIONS" (map childRow children)+      , concat [ section title (concatMap methodRows ms) | (title, ms) <- methodSections ]+      , if null footer then [] else "" : footer+      ] -    headerText = psNamespace <> " v" <> psVersion <> "\n" <> psDescription <> "\n"+    heading = case psDeprecation of+      Just _  -> deprecationMarker <> " " <> psNamespace <> " v" <> psVersion+      Nothing -> psNamespace <> " v" <> psVersion -    -- Name line; decorated with the warning marker when the activation-    -- carries Just DeprecationInfo.-    namespaceHeading = case psDeprecation of-      Just _  -> pretty (deprecationMarker <> " " <> psNamespace)-                   <+> pretty ("v" <> psVersion)-      Nothing -> pretty psNamespace <+> pretty ("v" <> psVersion)+    deprecationNotice = case psDeprecation of+      Just di -> ["  " <> formatDeprecationLine di]+      Nothing -> [] -    -- Full deprecation notice rendered immediately below the heading-    -- when relevant, before the description block.-    deprecationNoticeDoc = case psDeprecation of-      Just di -> vsep-        [ emptyDoc-        , indent 2 $ pretty (formatDeprecationLine di)-        ]-      Nothing -> emptyDoc+    section _ [] = []+    section title rows = "" : title : rows -    doc :: Doc ann-    doc = vsep-      [ namespaceHeading-      , deprecationNoticeDoc-      , emptyDoc-      , indent 2 $ align $ fillSep $ map pretty $ T.words psDescription-      , emptyDoc-      , childrenDoc-      , methodsDoc+    children = maybe [] (sortOn csNamespace) psChildren++    usage = concat+      [ [lsInvoke <> " <activation> <method> [flags]" | not (null children)]+      , [lsInvoke <> " <method> [flags]" | not (null psMethods)]       ] -    childrenDoc = case psChildren of-      Nothing -> emptyDoc-      Just [] -> emptyDoc-      Just children -> vsep-        [ pretty ("activations" :: Text)-        , emptyDoc-        , indent 2 $ vsep $ map renderChildDoc (sortOn csNamespace children)-        , emptyDoc-        ]+    footer = concat+      [ ["Run '" <> lsInvoke <> " <activation>' for its methods." | not (null children)]+      , ["Run '" <> lsInvoke <> " <method> --help' for its options." | not (null psMethods)]+      ] -    methodsDoc-      | null psMethods = emptyDoc-      | otherwise = vsep-        [ pretty ("methods" :: Text)-        , emptyDoc-        , indent 2 $ vsep $ intersperse emptyDoc $ map renderMethodDoc (sortOn methodName psMethods)-        ]+    -- The groups in the order they first appear, each alphabetical; the+    -- ungrouped last (as OTHER), or all of them as METHODS when no method+    -- says a group.+    methodSections =+      let groups = dedupe [g | Just g <- map methodGroup psMethods]+          inGroup g = sortOn methodName [m | m <- psMethods, methodGroup m == Just g]+          ungrouped = sortOn methodName [m | m <- psMethods, isNothing (methodGroup m)]+      in if null groups+           then [("METHODS", ungrouped) | not (null ungrouped)]+           else [(T.toUpper g, inGroup g) | g <- groups]+                  ++ [("OTHER", ungrouped) | not (null ungrouped)]+    dedupe = foldl (\acc x -> if x `elem` acc then acc else acc ++ [x]) [] -    renderChildDoc child = fillBreak 12 (pretty $ csNamespace child)-      <+> align (fillSep $ map pretty $ T.words $ csDescription child)+    decoratedName m = case methodDeprecation m of+      Just _  -> deprecationMarker <> " " <> methodName m+      Nothing -> methodName m -    renderMethodDoc method =-      let nameText = case methodDeprecation method of-            Just _  -> deprecationMarker <> " " <> methodName method-            Nothing -> methodName method-          nameLine = fillBreak 12 (pretty nameText)-                       <+> align (fillSep $ map pretty $ T.words $ methodDescription method)-          depLines = case methodDeprecation method of-            Just di -> [indent 12 $ pretty (formatDeprecationLine di)]-            Nothing -> []-      in vsep $ [nameLine] ++ depLines ++ paramsDocs (methodParams method)+    -- The name column: wide enough for the longest name (capped), shared by+    -- every section so the summaries start in one column.+    nameW = min 24 $ maximum $ 8 : map T.length (map csNamespace children ++ map decoratedName psMethods)+    descCol = 2 + nameW + 2 -    paramsDocs Nothing = []-    paramsDocs (Just (Object o)) = case KM.lookup "properties" o of-      Just (Object props) ->-        let reqList = case KM.lookup "required" o of-              Just (Array arr) -> [t | String t <- foldr (:) [] arr]-              _ -> []-            propList = KM.toList props-            sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList-        in [indent 12 $ vsep $ map (renderParamDoc reqList) sorted]-      _ -> []-    paramsDocs _ = []+    -- AUTH-8: the grant and where it is held, after the summary.+    grantOf m = fromMaybe "" (methodGrant m)+    heldOf m = maybe "" (T.intercalate ", ") (methodHeldOn m)+    grantW = maximum (0 : map (T.length . grantOf) psMethods)+    heldW = maximum (0 : map (T.length . heldOf) psMethods)+    summaryW+      | authCols = max 20 (width - descCol - 2 - grantW - 2 - heldW)+      | otherwise = width - descCol -    renderParamDoc :: [Text] -> (K.Key, Value) -> Doc ann-    renderParamDoc required (name, propSchema) =-      let nameText = K.toText name-          isReq = nameText `elem` required-          (typ, desc) = extractTypeDesc propSchema-          flag = "--" <> T.replace "_" "-" nameText-          typStr = " <" <> typ <> ">" <> if isReq then "" else "?"-          descWords = if T.null desc then [] else map pretty (T.words desc)-      in fillBreak 20 (pretty flag <> pretty typStr)-         <+> align (fillSep descWords)+    row name summary =+      T.stripEnd ("  " <> T.justifyLeft nameW ' ' name <> "  " <> summary) +    childRow c = row (csNamespace c) (fitText (width - descCol) (summarize (csDescription c)))++    methodRows m =+      let s = fitText summaryW (summarize (methodDescription m))+          line+            | authCols = row (decoratedName m)+                (T.justifyLeft summaryW ' ' s <> "  " <> T.justifyLeft grantW ' ' (grantOf m) <> "  " <> heldOf m)+            | otherwise = row (decoratedName m) s+      in line : maybe [] (\di -> [T.replicate descCol " " <> formatDeprecationLine di]) (methodDeprecation m)++-- | SYNAPSE-13: a description's summary — its first sentence: up to the+-- first @. @, @; @ or @: @ outside brackets and quotes (an @e.g.@ or+-- @i.e.@ is not an end), without the stop.+summarize :: Text -> Text+summarize desc = T.strip (go (0 :: Int) "" (zip str (quoteMask str)))+  where+    str = T.unpack (T.strip desc)+    go _ acc [] = T.pack (reverse acc)+    go d acc ((c, q) : rest)+      | q = go d (c : acc) rest+      | c `elem` ("([{" :: String) = go (d + 1) (c : acc) rest+      | c `elem` (")]}" :: String) = go (max 0 (d - 1)) (c : acc) rest+      | d == 0, c `elem` (".;:" :: String), startsSpace rest, not (abbrev c acc) = T.pack (reverse acc)+      | otherwise = go d (c : acc) rest+    startsSpace ((' ', _) : _) = True+    startsSpace _ = False+    abbrev '.' acc = map toLower (reverse (takeWhile (/= ' ') acc)) `elem` ["e.g", "i.e", "etc", "vs", "cf"]+    abbrev _ _ = False++-- | Which characters are inside a quoted span — @'…'@ or @`…`@, the quotes+-- included. A @'@ opens a quote after a non-letter and before a non-space+-- (so @ticket's@ is an apostrophe), and closes before a non-letter; a quote+-- never closed is no quote.+quoteMask :: String -> [Bool]+quoteMask str = case openAt of+  Just j -> take j marks ++ map (const False) (drop j marks)+  Nothing -> marks+  where+    (marks, openAt) = go Nothing Nothing (0 :: Int) str+    alnum = maybe False isAlphaNum+    go open _ _ [] = ([], fmap snd open)+    go open prev i (c : rest) =+      let next = case rest of { (x : _) -> Just x; [] -> Nothing }+          (m, open') = case open of+            Nothing+              | c == '`' -> (True, Just ('`', i))+              | c == '\'', not (alnum prev), maybe False (/= ' ') next -> (True, Just ('\'', i))+              | otherwise -> (False, Nothing)+            Just (q, _)+              | c == q, q == '`' || not (alnum next) -> (True, Nothing)+              | otherwise -> (True, open)+          (ms, o) = go open' (Just c) (i + 1) rest+      in (m : ms, o)++-- | SYNAPSE-13: a line's text in at most @w@ columns: whole when it fits;+-- else without its parentheticals; else up to the last @ — @ that fits;+-- else cut after a comma that keeps most of it, or at a word, ending in @…@.+-- SYNAPSE-17: a quoted span (@'…'@, @`…`@) is never cut or changed inside:+-- its brackets stay, and a cut ends before it (or keeps it whole when it+-- leads the line).+fitText :: Int -> Text -> Text+fitText w t+  | T.length t <= w = t+  | T.length bare <= w = bare+  | Just c <- lastFitting 0 " \x2014 " = c+  | Just c <- lastFitting 1 ", ", T.length c * 10 >= w * 6 = c <> "\x2026"+  | otherwise = wordCut atoms+  where+    chars = T.unpack t+    (bareCs, bareMask) = unzip (tidy (dropParens (zip chars (quoteMask chars))))+    bare = T.pack bareCs+    -- the longest prefix ending before @sep@ (outside a quote) that fits+    -- (with @room@ for an …)+    lastFitting room sep =+      case [ p | (p, _) <- T.breakOnAll sep bare, T.length p + room <= w+               , not (T.null (T.strip p)), not (quotedAt (T.length p)) ] of+        [] -> Nothing+        ps -> Just (T.stripEnd (last ps))+    quotedAt i = i < length bareMask && bareMask !! i+    -- words, a quoted span with its spaces one of them+    atoms = map (T.pack . map fst) (splitAtoms (zip bareCs bareMask))+    splitAtoms cs = case dropWhile (\(c, q) -> c == ' ' && not q) cs of+      [] -> []+      cs' -> let (a, rest) = break (\(c, q) -> c == ' ' && not q) cs' in a : splitAtoms rest+    quotedAtom x = T.any (`elem` ("'`" :: String)) x+    wordCut ws = go "" ws+      where+        go acc [] = acc+        go acc (x : xs)+          | T.length (join acc x) + 1 <= w = go (join acc x) xs+          | T.null acc = if quotedAtom x then x else T.take (max 1 (w - 1)) x <> "\x2026"+          | otherwise = T.dropWhileEnd (`elem` (",;:" :: String)) acc <> "\x2026"+        join acc x = if T.null acc then x else acc <> " " <> x+    -- whitespace runs outside quotes made one space, none left before a+    -- comma or a stop, none at the ends+    tidy = trimEnds . noSpaceBefore . collapse+      where+        collapse [] = []+        collapse ((c, False) : rest)+          | isSpaceC c = (' ', False) : collapse (dropWhile (\(x, q) -> isSpaceC x && not q) rest)+        collapse (x : rest) = x : collapse rest+        noSpaceBefore ((' ', False) : x@(c, False) : rest)+          | c `elem` (",.;:" :: String) = noSpaceBefore (x : rest)+        noSpaceBefore (x : rest) = x : noSpaceBefore rest+        noSpaceBefore [] = []+        trimEnds = reverse . dropWhile blank . reverse . dropWhile blank+        blank (c, q) = isSpaceC c && not q+        isSpaceC x = x == ' ' || x == '\n' || x == '\t'+    -- parentheticals outside quotes dropped (a quote inside one goes with it)+    dropParens = strip (0 :: Int)+      where+        strip _ [] = []+        strip d (x@(c, q) : rest)+          | not q, c == '(' = strip (d + 1) rest+          | not q, c == ')', d > 0 = strip (d - 1) rest+          | d > 0 = strip d rest+          | otherwise = x : strip d rest++-- | Words wrapped greedily to a width (at least 20); a word longer than the+-- width stands on its own line.+wrap :: Int -> Text -> [Text]+wrap w0 txt = go (T.words txt)+  where+    w = max 20 w0+    go [] = []+    go (x : xs) = line x xs+    line acc [] = [acc]+    line acc (y : ys)+      | T.length acc + 1 + T.length y <= w = line (acc <> " " <> y) ys+      | otherwise = acc : line y ys++-- | A lead and lines that start in column @col@: the first beside the lead+-- when it fits (two spaces between), else all of them under it.+hang :: Int -> Text -> [Text] -> [Text]+hang col lead ds = case ds of+  (d : rest) | T.length lead <= col - 2 -> (T.justifyLeft col ' ' lead <> d) : map (pad <>) rest+  _ -> lead : map (pad <>) ds+  where pad = T.replicate col " "++dropTrailingBlanks :: [Text] -> [Text]+dropTrailingBlanks = reverse . dropWhile (T.null . T.strip) . reverse+ -- | Render a method (short form) renderMethod :: MethodSchema -> Text renderMethod = renderMethodWith defaultStyle@@ -258,13 +414,39 @@   in "  " <> decoratedName <> " <" <> typ <> ">" <> reqText      <> "\n      " <> desc <> depLine --- | Extract type and description from property schema+-- | Extract type and description from property schema.+--+-- SYNAPSE-12: the type a flag takes, as the schema says it — a nullable+-- type is its non-null part (@["string", "null"]@ → @string@), an array+-- its element's (@string[]@), a @$ref@ the type it names, a union its+-- alternatives (@a|b@); @any@ only when the schema says nothing. extractTypeDesc :: Value -> (Text, Text)-extractTypeDesc (Object po) =-  ( case KM.lookup "type" po of { Just (String t) -> t; _ -> "any" }+extractTypeDesc v@(Object po) =+  ( schemaTypeName v   , case KM.lookup "description" po of { Just (String d) -> d; _ -> "" }   ) extractTypeDesc _ = ("any", "")++schemaTypeName :: Value -> Text+schemaTypeName (Object po)+  | Just (String ref) <- KM.lookup "$ref" po = last (T.splitOn "/" ref)+  | Just (String "array") <- KM.lookup "type" po = itemsName <> "[]"+  | Just (String t) <- KM.lookup "type" po = t+  | Just (Array ts) <- KM.lookup "type" po =+      case [t | String t <- V.toList ts, t /= "null"] of+        ["array"] -> itemsName <> "[]"+        [] -> "any"+        ts' -> T.intercalate "|" ts'+  | Just (Array alts) <- KM.lookup "anyOf" po <|> KM.lookup "oneOf" po =+      case filter (/= "null") (map schemaTypeName (V.toList alts)) of+        [] -> "any"+        ns -> T.intercalate "|" (dedupe ns)+  | Just (Array _) <- KM.lookup "enum" po = "string"+  | otherwise = "any"+  where+    itemsName = maybe "any" schemaTypeName (KM.lookup "items" po)+    dedupe = foldr (\x acc -> if x `elem` acc then acc else x : acc) []+schemaTypeName _ = "any"  -- | Pad text to a minimum width padRight :: Int -> Text -> Text

@@ -0,0 +1,330 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++-- | AUTH-8: what synapse shows of a hub's auth — pure, so every render is+-- tested from fixtures.+--+-- * The anonymous page: a hub whose @_info@ says @view: anonymous@ shows+--   only its door (login, signup, providers) and how to sign in from here.+-- * The caller's header: @you are NAME (PRINCIPAL) · ROLE on SCOPES, within+--   CEILING@, from @auth.whoami@ (or, on a hub without it, @session.whoami@).+-- * A refusal: @refused: needs GRANT on SCOPE@ and what would allow it.+--+-- Every wire field read here is optional (AUTH-1, "Login off stays open"):+-- a hub without a gate answers none of it, and nothing here is shown.+module Synapse.Auth+  ( -- * Who the caller is+    Whoami(..)+  , parseWhoami+  , renderCallerHeader+  , abbreviatePrincipal+  , scopeOf++    -- * The anonymous page+  , AnonPage(..)+  , anonymousMethods+  , renderAnonymousPage++    -- * Refusals+  , renderRefusal++    -- * The session auth.login answers+  , SessionGrant(..)+  , parseSessionGrant+  , isMissingAuth+  ) where++import Control.Applicative ((<|>))+import Data.Aeson (Value(..))+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+import Data.List (nub, sortOn)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Scientific (toBoundedInteger)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V++import Plexus.Auth (AuthInfo(..), Refusal(..))+import Plexus.Schema.Recursive (MethodSchema(..), PluginSchema(..))++-- ============================================================================+-- Who the caller is+-- ============================================================================++-- | What @auth.whoami@ (or @session.whoami@'s @identity@) says.+data Whoami = Whoami+  { whoPrincipal   :: Text+  , whoName        :: Maybe Text+  , whoAgent       :: Maybe Text+  , whoMemberships :: [(Text, Text)]  -- ^ (role, scope); scope "" when the hub names none+  , whoCeiling     :: [Text]          -- ^ as the hub says it: @editor\@MENGER-12@ or a scope+  } deriving (Eq, Show)++-- | A whoami from a data item's content. Shapes read (all fields but the+-- principal optional):+--+-- @+-- {"type":"whoami","principal":"key:ac79…","name":"worker-1","agent":"worker-1",+--  "memberships":[{"role":"editor","scope":"MENGER"}],"ceiling":["editor\@MENGER-12"]}+-- {"type":"identity","principal":"idp:…","name":"ada","roles":["admin"]}     -- session.whoami+-- @+--+-- @memberships@ (or @roles@) may also be strings, @role\@SCOPE@ or a bare+-- role; @ceiling@ strings or @{role|grant, scope}@ objects. An anonymous+-- answer (@type: anonymous@, or no principal) is Nothing.+parseWhoami :: Value -> Maybe Whoami+parseWhoami = \case+  Object o+    | Just (String "anonymous") <- KM.lookup "type" o -> Nothing+    | Just (String p) <- KM.lookup "principal" o, not (T.null p) -> Just Whoami+        { whoPrincipal = p+        , whoName = nonEmpty (str "name" o)+        , whoAgent = nonEmpty (str "agent" o)+        , whoMemberships = memberships o+        , whoCeiling = ceilingOf o+        }+    -- a whoami nested one level (e.g. {"type":"whoami","identity":{…}})+    | Just inner@(Object _) <- KM.lookup "identity" o -> parseWhoami inner+  _ -> Nothing+  where+    memberships o = case KM.lookup "memberships" o of+      Just v -> roleScopes v+      Nothing -> maybe [] roleScopes (KM.lookup "roles" o)+    roleScopes = \case+      Array xs -> mapMaybe one (V.toList xs)+      _ -> []+    one = \case+      String s -> Just (splitRoleScope s)+      Object e -> case (str "role" e, str "scope" e) of+        ("", _) -> Nothing+        (r, s) -> Just (r, s)+      _ -> Nothing++ceilingOf :: KM.KeyMap Value -> [Text]+ceilingOf o = case KM.lookup "ceiling" o <|> KM.lookup "scope" o of+  Just (Array xs) -> mapMaybe one (V.toList xs)+  Just (String s) | not (T.null s) -> [s]+  _ -> []+  where+    one = \case+      String s -> Just s+      Object e ->+        let what = case (str "role" e, str "grant" e) of+              (r, _) | not (T.null r) -> r+              (_, g) -> g+            sc = str "scope" e+        in if T.null what && T.null sc then Nothing+           else Just (if T.null what then sc else if T.null sc then what else what <> "@" <> sc)+      _ -> Nothing++-- | @editor\@MENGER@ → (editor, MENGER); @admin@ → (admin, "").+splitRoleScope :: Text -> (Text, Text)+splitRoleScope s = case T.breakOn "@" s of+  (r, rest) | not (T.null rest) -> (r, T.drop 1 rest)+  _ -> (s, "")++-- | The scope of a ceiling entry: @editor\@MENGER-12@ → @MENGER-12@; an+-- entry with no @\@@ is its own scope.+scopeOf :: Text -> Text+scopeOf s = case T.breakOn "@" s of+  (_, rest) | not (T.null rest) -> T.drop 1 rest+  _ -> s++-- | @you are worker-1 (key:ac79…) · editor on MENGER, within MENGER-12@.+--+-- Several roles: each @ROLE on SCOPES@, joined with @; @. A membership the+-- hub named no scope for is the role alone. No memberships: the name and+-- principal alone.+renderCallerHeader :: Whoami -> Text+renderCallerHeader w = "you are " <> who <> held <> within+  where+    shown = abbreviatePrincipal (whoPrincipal w)+    who = case whoName w <|> whoAgent w of+      Just n | n /= whoPrincipal w -> n <> " (" <> shown <> ")"+      _ -> shown+    roles = nub (map fst (whoMemberships w))+    onScopes r = case filter (not . T.null) [s | (r', s) <- whoMemberships w, r' == r] of+      [] -> r+      ss -> r <> " on " <> T.intercalate ", " (nub ss)+    held = if null roles then "" else " \x00B7 " <> T.intercalate "; " (map onScopes roles)+    within = case nub (map scopeOf (whoCeiling w)) of+      [] -> ""+      cs -> ", within " <> T.intercalate ", " cs++-- | A principal shortened for a one-line header: the part after its last+-- @:@ or @/@ kept to its leading word-and-underscore and four more+-- characters — @key:ac79e0…@ → @key:ac79…@, @oidc:workos/user_01M4QX…@ →+-- @oidc:workos/user_01M4…@. A short one is shown whole.+abbreviatePrincipal :: Text -> Text+abbreviatePrincipal p+  | T.length ident <= 12 = p+  | otherwise = prefix <> T.take keep ident <> "\x2026"+  where+    (prefix, ident) = splitIdent p+    lead = case T.breakOn "_" ident of+      (w, rest) | not (T.null rest), T.length w <= 8 -> T.length w + 1+      _ -> 0+    keep = lead + 4+    splitIdent t =+      let i = maximum (0 : [n + 1 | (n, c) <- zip [0 ..] (T.unpack t), c == ':' || c == '/'])+      in T.splitAt i t++-- ============================================================================+-- The anonymous page+-- ============================================================================++data AnonPage = AnonPage+  { apBackend :: Text              -- ^ the hub's name+  , apVersion :: Maybe Text        -- ^ the root schema's version, when the view shows it+  , apMethods :: [(Text, Text)]    -- ^ (method, description) under @auth@+  , apInvoke  :: Text              -- ^ how this synapse was pointed: @synapse -P 4455@+  } deriving (Eq, Show)++-- | The door's methods, each with its description: the ones @_info@'s @auth@+-- block names (@auth.login@ → @login@), else the auth schema's public+-- ones, else login, signup and providers; described by the auth schema+-- when it says, else in synapse's words. login, signup, providers first,+-- in that order; any others after, by name.+anonymousMethods :: Maybe AuthInfo -> Maybe PluginSchema -> [(Text, Text)]+anonymousMethods info authSchema = sortOn (rank . fst) [ (m, describe m) | m <- names ]+  where+    fromInfo = maybe [] (map (\m -> fromMaybe m (T.stripPrefix "auth." m)) . authMethods) info+    fromSchema = maybe [] (map methodName . filter methodPublic . psMethods) authSchema+    names = nub $ case (fromInfo, fromSchema) of+      ([], []) -> ["login", "signup", "providers"]+      ([], s) -> s+      (i, _) -> i+    described = maybe [] (\s -> [(methodName m, methodDescription m) | m <- psMethods s]) authSchema+    describe m = case lookup m described of+      Just d | not (T.null d) -> d+      _ -> fromMaybe "" (lookup m ownWords)+    ownWords =+      [ ("login", "Sign in \x2014 a person through the browser, an agent with its key")+      , ("signup", "Create an account, or ask for access")+      , ("providers", "The ways in this server offers")+      ]+    rank m = (fromMaybe 3 (lookup m (zip ["login", "signup", "providers"] [0 :: Int ..])), m)++-- | The page an anonymous caller sees for a hub (AUTH-8):+--+-- @+-- menger v1.0.0+--   Sign in to see what you can do here.+--+-- auth+--   login      Sign in — a person through the browser, an agent with its key+--   signup     Create an account, or ask for access+--   providers  The ways in this server offers+--+--   synapse -P 4455 _login menger                          # a person+--   synapse -P 4455 _login menger --key agent-7 --as w-1   # an agent+-- @+renderAnonymousPage :: AnonPage -> Text+renderAnonymousPage AnonPage{..} = T.unlines $+  [ apBackend <> maybe "" (\v -> if T.null v then "" else " v" <> v) apVersion+  , "  Sign in to see what you can do here."+  , ""+  , "auth"+  ]+  <> [ "  " <> T.justifyLeft nameW ' ' m <> (if T.null d then "" else "  " <> d) | (m, d) <- apMethods ]+  <> [ "" ]+  <> [ "  " <> T.justifyLeft exW ' ' ex <> "   # " <> who | (ex, who) <- examples ]+  where+    nameW = maximum (0 : map (T.length . fst) apMethods)+    examples =+      [ (apInvoke <> " _login " <> apBackend, "a person")+      , (apInvoke <> " _login " <> apBackend <> " --key agent-7 --as w-1", "an agent")+      ]+    exW = maximum (map (T.length . fst) examples)++-- ============================================================================+-- Refusals+-- ============================================================================++-- | A refusal, as a block for stderr:+--+-- @+-- refused: needs tickets.set_status on IDENTITY+--   roles with it   editor, admin+--   you hold it on  MENGER (within MENGER-12)+-- @+--+-- The ceiling is the refusal's own when the hub names one, else the one+-- passed in (the stored session's, as asked at login). A line with+-- nothing to say is left out; a refusal naming no grant is its message.+renderRefusal :: [Text] -> Refusal -> Text+renderRefusal fallbackCeiling r = T.unlines (headline : details)+  where+    headline = case (refusalGrant r, refusalScope r) of+      (Just g, Just s) -> "refused: needs " <> g <> " on " <> s+      (Just g, Nothing) -> "refused: needs " <> g+      _ -> "refused: " <> refusalMessage r+    ceilingScopes = nub $ map scopeOf $+      if null (refusalCeiling r) then fallbackCeiling else refusalCeiling r+    within = if null ceilingScopes then "" else " (within " <> T.intercalate ", " ceilingScopes <> ")"+    details =+      [ "  roles with it   " <> T.intercalate ", " (refusalRoles r) | not (null (refusalRoles r)) ]+      <> [ "  you hold it on  " <> heldText ]+    heldText = case refusalHeldOn r of+      [] -> "nowhere" <> within+      hs -> T.intercalate ", " hs <> within++-- ============================================================================+-- The session auth.login answers+-- ============================================================================++-- | @{type: session, token, principal, name?, agent?, expires_at?, ceiling?}@+-- (AUTH-5), or IDENTITY-42's @{type: login, …, scope}@ from session.login.+data SessionGrant = SessionGrant+  { sgToken     :: Text+  , sgPrincipal :: Text+  , sgName      :: Maybe Text+  , sgAgent     :: Maybe Text+  , sgExpiresAt :: Maybe Integer+  , sgCeiling   :: [Text]+  , sgWhoami    :: Maybe Whoami   -- ^ when the answer carries memberships+  } deriving (Eq, Show)++-- | The session in a data item's content, when it is one.+parseSessionGrant :: Value -> Maybe SessionGrant+parseSessionGrant = \case+  Object o+    | Just (String t) <- KM.lookup "type" o, t `elem` ["session", "login"]+    , Just (String tok) <- KM.lookup "token" o, not (T.null tok) -> Just SessionGrant+        { sgToken = tok+        , sgPrincipal = str "principal" o+        , sgName = nonEmpty (str "name" o)+        , sgAgent = nonEmpty (str "agent" o)+        , sgExpiresAt = KM.lookup "expires_at" o >>= int+        , sgCeiling = ceilingOf o+        , sgWhoami = case parseWhoami (Object o) of+            Just w | not (null (whoMemberships w)) -> Just w+            _ -> Nothing+        }+  _ -> Nothing++-- | Is this error the hub saying it has no @auth@ activation (or no such+-- method on it)? Then synapse falls back to IDENTITY-42's @session.*@.+isMissingAuth :: Text -> Bool+isMissingAuth m = any (`T.isInfixOf` T.toLower m)+  [ "activation not found", "method not found", "unknown method", "no such method"+  , "unknown activation", "not found: auth", "-32601", "activationnotfound", "methodnotfound" ]++-- ============================================================================+-- Helpers+-- ============================================================================++str :: Text -> KM.KeyMap Value -> Text+str k o = case KM.lookup (K.fromText k) o of+  Just (String s) -> s+  _ -> ""++nonEmpty :: Text -> Maybe Text+nonEmpty t = if T.null t then Nothing else Just t++int :: Value -> Maybe Integer+int = \case+  Number n -> fromIntegral <$> (toBoundedInteger n :: Maybe Int)+  String s | [(i, "")] <- reads (T.unpack s) -> Just i+  _ -> Nothing

@@ -0,0 +1,199 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | AUTH-8: a person signing in from synapse — the loopback flow (AUTH-1,+-- "Settled to start", Q3).+--+-- synapse listens on @127.0.0.1:<a port the OS picks>@, asks the hub for a+-- sign-in URL that returns there (@auth.login {flow: {browser: {redirect}}}@),+-- opens it, and waits — at most five minutes — for the browser to come+-- back with @GET /cb?code=…&state=…@. The state must be the one the hub+-- handed out with the URL; anything else is refused and ends the wait.+-- The code then goes back to the hub (@auth.login {flow: {code: …}}@).+--+-- The parsing and the state check are pure ('parseRequestLine',+-- 'checkCallback') and tested; the socket is only 127.0.0.1, accepts one+-- answer and closes.+module Synapse.Auth.Loopback+  ( -- * The listener+    Loopback+  , loopbackPort+  , loopbackRedirect+  , withLoopback+  , awaitCallback++    -- * Pure parts+  , parseRequestLine+  , checkCallback+  , CallbackResult(..)+  , percentDecode+  , callbackPage+  , durationText++    -- * The browser+  , openBrowser+  ) where++import Control.Exception (SomeException, bracket, try)+import Control.Monad (void)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Char (chr, digitToInt, isHexDigit)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TEE+import qualified Network.Socket as N+import qualified Network.Socket.ByteString as NB+import System.Environment (lookupEnv)+import System.Info (os)+import System.Process (createProcess, proc, std_err, std_out, std_in, StdStream(..))+import System.Timeout (timeout)++-- | A listening socket on 127.0.0.1 and the port the OS gave it.+data Loopback = Loopback+  { lbSocket :: N.Socket+  , lbPort   :: Int+  }++loopbackPort :: Loopback -> Int+loopbackPort = lbPort++-- | Where the hub sends the browser back: @http://127.0.0.1:<port>/cb@.+loopbackRedirect :: Loopback -> Text+loopbackRedirect lb = "http://127.0.0.1:" <> T.pack (show (lbPort lb)) <> "/cb"++-- | Listen on 127.0.0.1 (never another interface), port 0, for the+-- duration of the action.+withLoopback :: (Loopback -> IO a) -> IO a+withLoopback act = bracket open (N.close . lbSocket) act+  where+    open = do+      sock <- N.socket N.AF_INET N.Stream N.defaultProtocol+      N.setSocketOption sock N.ReuseAddr 1+      N.bind sock (N.SockAddrInet 0 (N.tupleToHostAddress (127, 0, 0, 1)))+      N.listen sock 4+      port <- N.socketPort sock+      pure (Loopback sock (fromIntegral port))++-- | What one request to the loopback came to.+data CallbackResult+  = CallbackCode Text        -- ^ @/cb@ with the state expected: the code+  | CallbackRefused Text     -- ^ @/cb@ that cannot be accepted: why (ends the wait)+  | CallbackIgnored          -- ^ anything else (@/favicon.ico@): answered 404, keep waiting+  deriving (Eq, Show)++-- | The method, path and query of an HTTP request line:+-- @GET /cb?code=c_1&state=s_2 HTTP/1.1@ → @("GET", "/cb", [("code","c_1"),("state","s_2")])@.+parseRequestLine :: BS.ByteString -> Maybe (Text, Text, [(Text, Text)])+parseRequestLine raw = case BS8.words (BS8.takeWhile (\c -> c /= '\r' && c /= '\n') raw) of+  (method : target : _) ->+    let (path, query) = BS8.break (== '?') target+        params = [ (dec k, dec (BS.drop 1 v))+                 | kv <- BS8.split '&' (BS.drop 1 query), not (BS.null kv)+                 , let (k, v) = BS8.break (== '=') kv ]+    in Just (utf8 method, utf8 path, params)+  _ -> Nothing+  where+    dec = percentDecode . utf8+    utf8 = TE.decodeUtf8With TEE.lenientDecode++-- | Decide a request: @GET /cb@ carrying the expected state and a code is+-- the code; @/cb@ with a provider's @error@, a missing code, or another+-- state is refused (a mismatched state is never a code); any other path+-- is ignored.+checkCallback :: Text -> (Text, Text, [(Text, Text)]) -> CallbackResult+checkCallback expected (_method, path, params)+  | path /= "/cb" = CallbackIgnored+  | Just e <- lookup "error" params =+      CallbackRefused ("the sign-in was not completed: " <> e+        <> maybe "" (" \x2014 " <>) (lookup "error_description" params))+  | lookup "state" params /= Just expected =+      CallbackRefused "the browser came back with a state this sign-in did not ask for; refused"+  | otherwise = case lookup "code" params of+      Just c | not (T.null c) -> CallbackCode c+      _ -> CallbackRefused "the browser came back without a code"++-- | @%2F@ → @/@, @+@ → space.+percentDecode :: Text -> Text+percentDecode = T.pack . go . T.unpack+  where+    go ('%' : a : b : rest) | isHexDigit a && isHexDigit b = chr (digitToInt a * 16 + digitToInt b) : go rest+    go ('+' : rest) = ' ' : go rest+    go (c : rest) = c : go rest+    go [] = []++-- | @300@ → @5 minutes@; @90@ → @90 seconds@.+durationText :: Int -> Text+durationText secs+  | secs >= 60 && secs `mod` 60 == 0 = T.pack (show (secs `div` 60)) <> " minutes"+  | secs == 1 = "1 second"+  | otherwise = T.pack (show secs) <> " seconds"++-- | The small page the browser shows once synapse has the answer.+callbackPage :: Bool -> Text -> BS.ByteString+callbackPage ok msg = response+  where+    status = if ok then "200 OK" else "400 Bad Request"+    title = if ok then "Signed in" else "Not signed in"+    body = TE.encodeUtf8 $ T.concat+      [ "<!doctype html><meta charset=utf-8><title>", title, "</title>"+      , "<body style=\"font:16px system-ui,sans-serif;margin:3em\"><h1>", title, "</h1><p>"+      , escape msg, "</p></body>" ]+    response = BS.concat+      [ "HTTP/1.1 ", status, "\r\nContent-Type: text/html; charset=utf-8\r\n"+      , "Content-Length: ", BS8.pack (show (BS.length body)), "\r\nConnection: close\r\n"+      , "Cache-Control: no-store\r\n\r\n", body ]+    escape = T.concatMap (\case '<' -> "&lt;"; '>' -> "&gt;"; '&' -> "&amp;"; '"' -> "&quot;"; c -> T.singleton c)++-- | Wait (up to @secs@) for the browser to come back with the state+-- expected. The code, or why there is none.+awaitCallback :: Loopback -> Text -> Int -> IO (Either Text Text)+awaitCallback lb expected secs = do+  r <- timeout (secs * 1000000) loop+  pure $ case r of+    Nothing -> Left ("no answer from the browser within " <> durationText secs)+    Just x -> x+  where+    loop = do+      (conn, _) <- N.accept (lbSocket lb)+      req <- readHead conn+      let decided = maybe CallbackIgnored (checkCallback expected) (parseRequestLine req)+      case decided of+        CallbackIgnored -> do+          send conn "HTTP/1.1 404 Not Found\r\nContent-Length: 0\r\nConnection: close\r\n\r\n"+          N.close conn+          loop+        CallbackRefused why -> do+          send conn (callbackPage False why)+          N.close conn+          pure (Left why)+        CallbackCode code -> do+          send conn (callbackPage True "You are signed in to synapse. You can close this tab.")+          N.close conn+          pure (Right code)+    send conn bytes = void (try (NB.sendAll conn bytes) :: IO (Either SomeException ()))+    -- the request line is all that is read; enough of the head to hold it+    readHead conn = go BS.empty+      where+        go acc+          | "\r\n" `BS.isInfixOf` acc || BS.length acc > 16384 = pure acc+          | otherwise = do+              chunk <- try (NB.recv conn 4096) :: IO (Either SomeException BS.ByteString)+              case chunk of+                Right c | not (BS.null c) -> go (acc <> c)+                _ -> pure acc++-- | Open the URL in the person's browser (@xdg-open@; @open@ on macOS),+-- detached and silent. @SYNAPSE_NO_BROWSER=1@ opens nothing (the URL is+-- printed either way). True when a browser was asked.+openBrowser :: Text -> IO Bool+openBrowser url = do+  off <- lookupEnv "SYNAPSE_NO_BROWSER"+  if maybe False (`elem` ["1", "true", "yes"]) off then pure False else do+    let opener = if os == "darwin" then "open" else "xdg-open"+    r <- try (void (createProcess (proc opener [T.unpack url])+                { std_in = NoStream, std_out = NoStream, std_err = NoStream }))+           :: IO (Either SomeException ())+    pure (either (const False) (const True) r)

@@ -44,16 +44,34 @@     -- * Implementations   , stubDiscovery   , registryDiscovery+  , registryDiscoveryAt +    -- * SCAFFOLD-21: an address that is not plain ws://HOST:PORT/+  , endpointFor+     -- * Backend Discovery   , getBackendAt+  , getBackendAtWith+  , getBackendAtEp+  , probeBackendAtWith+  , probeBackendAtEp+  , probedInfo+  , probedInfoAt+  , probeFailureAt      -- * Health Checks   , pingBackend   , pingBackends+  , pingBackendsVia      -- * Registry Registration   , registerWithRegistry++    -- * Registry Endpoint+  , registryUrlEnvVar+  , defaultRegistryHost+  , defaultRegistryPort+  , registryEndpointFromEnv   ) where  import Data.Aeson (ToJSON, FromJSON, (.:), (.:?), withObject)@@ -66,13 +84,19 @@ import Data.Either (isRight) import Control.Concurrent.Async (mapConcurrently, race, async, wait) import Control.Concurrent (threadDelay)-import Data.IORef (newIORef, writeIORef, readIORef)+import Data.IORef (IORef, newIORef, writeIORef, readIORef, modifyIORef')+import qualified Data.Map.Strict as Map+import System.IO.Unsafe (unsafePerformIO)+import Plexus.Auth (BackendInfo, parseBackendInfo) import Control.Monad (void)-import Plexus.Client (SubstrateConfig(..))+import Synapse.Endpoint (Endpoint(..), plainAt, substrateConfig, addressKey)+import qualified Network.WebSockets as WS import qualified Plexus.Transport as ST import Plexus.Types (PlexusStreamItem(..), TransportError(..)) import qualified Synapse.Log as Log import qualified System.IO as IO+import qualified Data.Text.Read as TR+import System.Environment (lookupEnv)  -- ============================================================================ -- Backend Type@@ -178,10 +202,17 @@ -- Connects to the registry service and queries for registered backends. -- Falls back to stubDiscovery if registry is unavailable. registryDiscovery :: Text -> Int -> BackendDiscovery-registryDiscovery registryHost registryPort = BackendDiscovery+registryDiscovery registryHost registryPort = registryDiscoveryAt (plainAt registryHost registryPort)++-- | SCAFFOLD-21: 'registryDiscovery' through a connection point at any+-- address (a hub behind TLS, on a path). The backends a registry lists+-- are plain @ws://HOST:PORT/@, as it records them; the connection point+-- itself is reached as it was named ('endpointFor').+registryDiscoveryAt :: Endpoint -> BackendDiscovery+registryDiscoveryAt ep = BackendDiscovery   { discoverBackends = do       -- First, discover the backend name using _info-      maybeBackendName <- discoverBackendName registryHost registryPort+      maybeBackendName <- either (const Nothing) Just <$> probeBackendAtEp [] ep       case maybeBackendName of         Just discoveredName -> do           -- Create a Backend entry for the discovered backend@@ -195,7 +226,7 @@                 }            -- Try to get additional backends from registry (if it exists)-          registryBackends <- queryRegistry registryHost registryPort discoveredName+          registryBackends <- queryRegistry ep discoveredName            -- Only include discovered backend if not already in registry           -- (prefer registry entry since it has more details)@@ -211,67 +242,119 @@         Nothing ->           -- Connection failed completely           discoverBackends stubDiscovery-  , getBackendInfo   = queryBackend registryHost registryPort+  , getBackendInfo   = queryBackend ep   }+  where+    registryHost = epHost ep+    registryPort = epPort ep +-- | SCAFFOLD-21: how to reach a backend a discovery answered — the+-- connection point as it was named (its scheme, path, CAs) when the+-- backend is at its host and port, else plain @ws://HOST:PORT/@.+endpointFor :: Endpoint -> Backend -> Endpoint+endpointFor ep b+  | backendHost b == epHost ep && backendPort b == epPort ep = ep+  | otherwise = plainAt (backendHost b) (backendPort b)+ -- | Get the backend name at a given host/port via _info -- Returns whatever backend is running there (e.g., "registry-hub", "plexus") -- If that backend has a registry plugin, it can be used to discover other backends getBackendAt :: Text -> Int -> IO (Maybe Text)-getBackendAt = discoverBackendName+getBackendAt host port = getBackendAtEp [] (plainAt host port) --- | Discover the backend name by calling _info (with 2000ms timeout)-discoverBackendName :: Text -> Int -> IO (Maybe Text)-discoverBackendName host port = do-  let cfg = SubstrateConfig-        { substrateHost    = T.unpack host-        , substratePort    = port-        , substratePath    = "/"-        , substrateBackend = "" -- Not used for _info-        , substrateHeaders = []-        }+-- | IDENTITY-16: 'getBackendAt', its _info probe carrying the caller's+-- upgrade headers (the token's cookie, --cookie, --header; see+-- 'Synapse.Transport.mergeUpgradeHeaders'). A backend that refuses+-- anonymous upgrades answers the probe only with them.+getBackendAtWith :: WS.Headers -> Text -> Int -> IO (Maybe Text)+getBackendAtWith headers host port = getBackendAtEp headers (plainAt host port)++-- | SCAFFOLD-21: 'getBackendAtWith' at any address.+getBackendAtEp :: WS.Headers -> Endpoint -> IO (Maybe Text)+getBackendAtEp headers ep = either (const Nothing) Just <$> probeBackendAtEp headers ep++-- | IDENTITY-43: the _info probe, saying why when it fails — so a caller+-- can tell the upgrade's 401 (its session ended) from a backend that is+-- down.+probeBackendAtWith :: WS.Headers -> Text -> Int -> IO (Either Text Text)+probeBackendAtWith headers host port = probeBackendAtEp headers (plainAt host port)++-- | SCAFFOLD-21: 'probeBackendAtWith' at any address. Behind TLS the+-- probe waits longer (a handshake across the internet, not loopback).+probeBackendAtEp :: WS.Headers -> Endpoint -> IO (Either Text Text)+probeBackendAtEp headers ep = do+  let cfg = substrateConfig ep "" headers   -- the backend is not used for _info+      secs = probeSecs ep       timeout = do-        threadDelay 2000000  -- 2 second timeout-        pure (Left $ ConnectionTimeout host port)+        threadDelay (secs * 1000000)+        pure (Left $ ConnectionTimeout (epHost ep) (epPort ep))       rpcCall = do         ST.rpcCallWith cfg "_info" Aeson.Null-          `catch` \(_e :: SomeException) ->-            pure (Left $ NetworkError "Connection failed")+          `catch` \(e :: SomeException) ->+            pure (Left $ NetworkError ("Connection failed: " <> T.pack (show e))) -  -- Race the RPC call against a 2 second timeout+  -- Race the RPC call against the timeout   raceResult <- race timeout rpcCall +  let failed why = do+        -- SCAFFOLD-21: kept, so a caller can say why (a certificate refused)+        modifyIORef' failMemo (Map.insert (addressKey ep) why)+        pure (Left why)   case raceResult of     Left _err ->-      pure Nothing-    Right (Left _err) ->-      pure Nothing+      failed "the _info probe timed out"+    Right (Left err) ->+      failed (T.pack (show err))     Right (Right items) -> do       -- Extract the backend name from subscription response       case [Aeson.fromJSON content | StreamData _ _ _ content <- items] of-        (Aeson.Success (Aeson.Object obj):_) | Just (Aeson.String name) <- KM.lookup "backend" obj ->-          pure (Just name)+        (Aeson.Success v@(Aeson.Object obj):_) | Just (Aeson.String name) <- KM.lookup "backend" obj -> do+          -- AUTH-8: kept for the rest of the process — the view and the+          -- auth block this connection's credential was answered with+          mapM_ (\i -> modifyIORef' infoMemo (Map.insert (addressKey ep) i)) (parseBackendInfo v)+          pure (Right name)         _ ->-          pure Nothing+          failed "the _info probe answered no backend name" +-- | How long the _info probe waits: 2 s on a plain socket (loopback, as+-- ever), 10 s behind TLS.+probeSecs :: Endpoint -> Int+probeSecs ep = if epTls ep then 10 else 2++-- | AUTH-8: what the last successful _info probe at HOST:PORT answered in+-- this process (its view and auth block), when it was probed.+probedInfo :: Text -> Int -> IO (Maybe BackendInfo)+probedInfo host port = probedInfoAt (plainAt host port)++-- | SCAFFOLD-21: 'probedInfo' at any address.+probedInfoAt :: Endpoint -> IO (Maybe BackendInfo)+probedInfoAt ep = Map.lookup (addressKey ep) <$> readIORef infoMemo++-- | SCAFFOLD-21: why the last _info probe at this address failed, in this+-- process (a TLS handshake's refusal, say), if it did.+probeFailureAt :: Endpoint -> IO (Maybe Text)+probeFailureAt ep = Map.lookup (addressKey ep) <$> readIORef failMemo++{-# NOINLINE failMemo #-}+failMemo :: IORef (Map.Map Text Text)+failMemo = unsafePerformIO (newIORef Map.empty)++{-# NOINLINE infoMemo #-}+infoMemo :: IORef (Map.Map Text BackendInfo)+infoMemo = unsafePerformIO (newIORef Map.empty)+ -- | Query the registry for all backends-queryRegistry :: Text -> Int -> Text -> IO [Backend]-queryRegistry host port backendName = do+queryRegistry :: Endpoint -> Text -> IO [Backend]+queryRegistry ep backendName = do   -- Try registry query first-  queryRegistryImpl host port backendName `catch` \(_e :: SomeException) ->+  queryRegistryImpl ep backendName `catch` \(_e :: SomeException) ->     -- Return empty list on error - caller will handle fallback     pure []  -- | Implementation of registry query-queryRegistryImpl :: Text -> Int -> Text -> IO [Backend]-queryRegistryImpl host port backendName = do-  let cfg = SubstrateConfig-        { substrateHost    = T.unpack host-        , substratePort    = port-        , substratePath    = "/"-        , substrateBackend = backendName-        , substrateHeaders = []-        }+queryRegistryImpl :: Endpoint -> Text -> IO [Backend]+queryRegistryImpl ep backendName = do+  let cfg = substrateConfig ep backendName []   -- Call registry.list through the backend   result <- ST.invokeMethod cfg ["registry"] "list" (Aeson.object [])   case result of@@ -284,10 +367,10 @@       pure $ map convertBackend backendInfos  -- | Query for a specific backend by name-queryBackend :: Text -> Int -> Text -> IO (Maybe Backend)-queryBackend host port name = do+queryBackend :: Endpoint -> Text -> IO (Maybe Backend)+queryBackend ep name = do   -- First discover the backend name-  maybeBackendName <- discoverBackendName host port+  maybeBackendName <- getBackendAtEp [] ep   case maybeBackendName of     Just discoveredName -> do       -- Check if the requested name matches the discovered backend@@ -295,29 +378,23 @@         then pure $ Just Backend           { backendName        = discoveredName           , backendDescription = "Backend discovered via _info"-          , backendHost        = host-          , backendPort        = port+          , backendHost        = epHost ep+          , backendPort        = epPort ep           , backendVersion     = Nothing           , backendReachable   = Nothing           }         else do           -- Try to find it in the registry           result <- catch-            (queryBackendImpl host port discoveredName name)+            (queryBackendImpl ep discoveredName name)             (\(_e :: SomeException) -> pure Nothing)           pure result     Nothing -> getBackendInfo stubDiscovery name  -- | Implementation of backend get query-queryBackendImpl :: Text -> Int -> Text -> Text -> IO (Maybe Backend)-queryBackendImpl host port backendName name = do-  let cfg = SubstrateConfig-        { substrateHost    = T.unpack host-        , substratePort    = port-        , substratePath    = "/"-        , substrateBackend = backendName-        , substrateHeaders = []-        }+queryBackendImpl :: Endpoint -> Text -> Text -> IO (Maybe Backend)+queryBackendImpl ep backendName name = do+  let cfg = substrateConfig ep backendName []       params = Aeson.object ["name" Aeson..= name]   result <- ST.invokeMethod cfg ["registry"] "get" params   case result of@@ -345,19 +422,21 @@ -- 300ms allows for WebSocket connection establishment overhead (~150-200ms) -- plus actual RPC round-trip time pingBackend :: Backend -> IO Backend-pingBackend backend = do-  let cfg = SubstrateConfig-        { substrateHost    = T.unpack (backendHost backend)-        , substratePort    = backendPort backend-        , substratePath    = "/"-        , substrateBackend = ""  -- _info has no namespace prefix-        , substrateHeaders = []-        }-      timeout = threadDelay 300000 >> pure (Left $ ConnectionTimeout (backendHost backend) (backendPort backend))+pingBackend = pingBackendAt Nothing++-- | SCAFFOLD-21: ping at the backend's own address — the connection point+-- as it was named when the backend is there ('endpointFor'), which behind+-- TLS is given 5 s rather than 300 ms.+pingBackendAt :: Maybe Endpoint -> Backend -> IO Backend+pingBackendAt via backend = do+  let ep = maybe (plainAt (backendHost backend) (backendPort backend)) (`endpointFor` backend) via+      cfg = substrateConfig ep "" []  -- _info has no namespace prefix+      micros = if epTls ep then 5000000 else 300000+      timeout = threadDelay micros >> pure (Left $ ConnectionTimeout (backendHost backend) (backendPort backend))       rpcCall = ST.rpcCallWith cfg "_info" Aeson.Null         `catch` \(_e :: SomeException) -> pure (Left $ NetworkError "Connection failed") -  -- Race the RPC call against a 300ms timeout+  -- Race the RPC call against the timeout   result <- race timeout rpcCall   let reachable = case result of         Left _          -> False  -- Timeout@@ -370,6 +449,10 @@ pingBackends :: [Backend] -> IO [Backend] pingBackends backends = mapConcurrently pingBackend backends +-- | SCAFFOLD-21: 'pingBackends', the connection point reached as named.+pingBackendsVia :: Endpoint -> [Backend] -> IO [Backend]+pingBackendsVia ep = mapConcurrently (pingBackendAt (Just ep))+ -- ============================================================================ -- Registry Registration -- ============================================================================@@ -387,13 +470,7 @@   -> Int    -- ^ Backend port   -> IO () registerWithRegistry registryHost registryPort registryBackend name host port = do-  let cfg = SubstrateConfig-        { substrateHost    = T.unpack registryHost-        , substratePort    = registryPort-        , substratePath    = "/"-        , substrateBackend = registryBackend-        , substrateHeaders = []-        }+  let cfg = substrateConfig (plainAt registryHost registryPort) registryBackend []       params = Aeson.object         [ "name"     Aeson..= name         , "host"     Aeson..= host@@ -405,3 +482,53 @@     _ <- ST.invokeMethod cfg ["registry"] "register" params       `catch` \(_e :: SomeException) -> pure (Left $ NetworkError "Registry unavailable")     pure ()++-- ============================================================================+-- Registry Endpoint+-- ============================================================================+--+-- SYNAPSE-7: the endpoint helpers synapse-cc 0.3.4 imports+-- (src/SynapseCC/RegistryResolve.hs). They were written with Z2H-6 on+-- the feature/Z2H-6-registry branch (e176373), which was never merged to+-- main, so synapse-cc's main did not build against synapse's. These are+-- that commit's definitions, unchanged and additive: nothing in synapse+-- calls them yet, so no behavior here moves.++-- | Environment variable naming the registry endpoint, shared with+-- plexus-transport's boot-time self-registration.+registryUrlEnvVar :: String+registryUrlEnvVar = "PLEXUS_REGISTRY_URL"++defaultRegistryHost :: Text+defaultRegistryHost = "127.0.0.1"++defaultRegistryPort :: Int+defaultRegistryPort = 4444++-- | Resolve the registry endpoint from @PLEXUS_REGISTRY_URL@+-- (e.g. @ws:\/\/127.0.0.1:4444@ or @host:port@), falling back to+-- @127.0.0.1:4444@. Malformed values fall back to the default rather+-- than failing the invocation.+registryEndpointFromEnv :: IO (Text, Int)+registryEndpointFromEnv = do+  mUrl <- lookupEnv registryUrlEnvVar+  pure $ case mUrl of+    Nothing -> (defaultRegistryHost, defaultRegistryPort)+    Just raw -> parseRegistryUrl (T.strip (T.pack raw))++-- | Parse @[ws://]host[:port]@.+parseRegistryUrl :: Text -> (Text, Int)+parseRegistryUrl raw+  | T.null raw = (defaultRegistryHost, defaultRegistryPort)+  | otherwise =+      let noScheme = case T.breakOn "://" raw of+            (_, rest) | not (T.null rest) -> T.drop 3 rest+            _                             -> raw+          noPath = T.takeWhile (/= '/') noScheme+          (host, portTxt) = case T.breakOnEnd ":" noPath of+            (h, p) | not (T.null h) -> (T.dropEnd 1 h, p)+            _                       -> (noPath, "")+      in case TR.decimal portTxt of+           Right (p, "") | not (T.null host) -> (host, p)+           _ | T.null noPath -> (defaultRegistryHost, defaultRegistryPort)+             | otherwise     -> (noPath, defaultRegistryPort)

@@ -43,6 +43,19 @@     renderMethodHelp   , renderMethodHelpWith +    -- * The method page (SYNAPSE-13)+  , MethodPage(..)+  , methodPage+  , renderMethodPage+  , renderExample+  , synthesiseExample+  , shellQuote+  , flagLabel+  , flagType+  , paramValuesOf+  , serverSourced+  , wrapWords+     -- * Parameter Help   , renderParamHelp   , renderParamHelpWith@@ -56,15 +69,26 @@   , defaultHelpStyle   ) where -import Data.List (intersperse)-import Data.Map.Strict (Map)+import Control.Applicative ((<|>))+import Data.Aeson (Value(..))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+import qualified Data.ByteString.Lazy as LBS+import Data.Char (isAlphaNum)+import Data.List (sortOn) import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe, maybeToList)+import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Scientific (floatingOrInteger) import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as V +import Plexus.Schema.Recursive (MethodExample(..), MethodSchema(..), paramValues) import Synapse.IR.Types-import Synapse.Algebra.Render (deprecationMarker, formatDeprecationLine)+import Synapse.Algebra.Render (deprecationMarker, formatDeprecationLine, fitText)+import Synapse.CLI.Parse (isScalarElement)  -- ============================================================================ -- Configuration@@ -92,33 +116,316 @@ -- Method Help -- ============================================================================ --- | Render complete help for a method+-- | Render complete help for a method: its page ('renderMethodPage'),+-- reached by @synapse <namespace> <method>@, from the IR alone. renderMethodHelp :: IR -> MethodDef -> Text-renderMethodHelp = renderMethodHelpWith defaultHelpStyle+renderMethodHelp ir md = renderMethodPage (methodPage md) ir md --- | Render method help with custom style+-- | Render method help with custom style (the style no longer changes the+-- page; kept for callers of the earlier layout). renderMethodHelpWith :: HelpStyle -> IR -> MethodDef -> Text-renderMethodHelpWith style ir method = T.unlines $-  [ header-  , ""-  ] ++ descSection ++ paramSection+renderMethodHelpWith _ = renderMethodHelp++-- ============================================================================+-- The method page (SYNAPSE-13)+-- ============================================================================++-- | What a method's page needs beside the IR.+data MethodPage = MethodPage+  { mpProgram :: Text               -- ^ synapse and its global options (@synapse -P 4455@)+  , mpTarget  :: Text               -- ^ the backend and path to the method (@menger tickets set_status@)+  , mpSchema  :: Maybe MethodSchema -- ^ the method's schema: long description, examples, values, grant+  , mpCaller  :: Bool               -- ^ AUTH-8: in a caller's view (say what it requires)+  }+  deriving stock (Show, Eq)++-- | A page for a method known only from the IR: reached as+-- @synapse <namespace> <method>@.+methodPage :: MethodDef -> MethodPage+methodPage md = MethodPage+  { mpProgram = "synapse"+  , mpTarget = T.replace "." " " (mdFullPath md)+  , mpSchema = Nothing+  , mpCaller = False+  }++-- | SYNAPSE-13: a method's page in cargo's shape — the description; a+-- blank line and the long description; @Usage:@ with the required flags+-- spelled out; @Options:@ aligned, required first then optional in+-- [brackets], each with its type, description and allowed values;+-- @Example:@ — the schema's examples as command lines, each under its+-- note, else one synthesised from the required options; and, in a caller's+-- view, what it requires and where the caller holds it.+renderMethodPage :: MethodPage -> IR -> MethodDef -> Text+renderMethodPage MethodPage{..} ir md = T.unlines (dropTrailing body)   where-    header = mdFullPath method <> streamingIndicator+    width = 80+    invoke = mpProgram <> " " <> mpTarget -    streamingIndicator-      | mdStreaming method = " [streaming]"-      | otherwise = ""+    body = concat+      [ descLines+      , longLines+      , [""]+      , usageLines+      , optionsBlock+      , exampleBlock+      , requiresBlock+      ] -    descSection = case mdDescription method of-      Just desc -> [desc, ""]+    descLines = case mdDescription md of+      Just d | not (T.null (T.strip d)) -> wrapWords width d+      _ -> [mdName md]++    longText = (mpSchema >>= methodLongDescription) <|> mdLongDescription md+    longLines = case longText of+      Just l | not (T.null (T.strip l)) ->+        "" : concatMap (\p -> if T.null p then [""] else wrapWords width p) (paragraphs l)+      _ -> []++    -- What a caller passes (a server-supplied param, REQ-8, is not a flag).+    (callerParams, serverParams) =+      ( [p | p <- params, not (serverSourced p)]+      , [p | p <- params, serverSourced p] )+    params = sortOn (not . pdRequired) (mdParams md)+    required = [p | p <- callerParams, pdRequired p]+    optional = [p | p <- callerParams, not (pdRequired p)]++    usageLines =+      [ "Usage: " <> T.unwords ([invoke] ++ map usageFlag required ++ ["[OPTIONS]" | not (null optional)]) ]+    usageFlag p = flagOf p <> " <" <> T.toUpper (pdName p) <> ">"++    optionsBlock+      | null callerParams && null serverParams = []+      | otherwise = ["", "Options:"] ++ concatMap optionRows callerParams ++ concatMap serverRows serverParams++    flagCol = 2 + min 28 (maximum (0 : map (T.length . flagText) callerParams ++ map (T.length . pdName) serverParams)) + 2++    flagText = flagLabel ir++    optionRows p = hangAt flagCol ("  " <> flagText p) (descOf p ++ extras p)+    serverRows p = hangAt flagCol ("  " <> pdName p) ["\x2190 " <> sourceLabel p]++    descW = max 20 (width - flagCol)+    descOf p = maybe [] (wrapWords descW) (pdDescription p)+    extras p = concat+      [ maybe [] (\di -> [formatDeprecationLine di]) (pdDeprecation p)+      , listLines p+      , maybe [] (\vs -> wrapWords descW ("[values: " <> T.intercalate ", " vs <> "]")) (valuesOf p)+      , if hsExpandEnums defaultHelpStyle then expandType ir (pdName p) (pdType p) else []+      ]++    listLines p = case listElement (pdType p) of+      Just inner+        | isScalarElement ir inner -> ["Repeat the flag or use commas: " <> flagOf p <> " a,b"]+        | otherwise -> ["Repeat the flag for each element"]       Nothing -> []+    listElement = \case+      RefArray inner -> Just inner+      RefOptional inner -> listElement inner+      _ -> Nothing -    paramSection-      | null (mdParams method) = ["(no parameters)"]-      | otherwise =-          ["Parameters:"] ++-          concatMap (renderParamBlock style ir) (mdParams method)+    -- The schema's hint (x-plexus-values), else the type's own literals.+    valuesOf p = pdValues p <|> schemaValues (pdName p) <|> stringEnumValues ir (pdType p)+    schemaValues name = do+      ms <- mpSchema+      Object o <- methodParams ms+      Object props <- KM.lookup "properties" o+      prop <- KM.lookup (K.fromText name) props+      paramValues prop +    -- Examples: the schema's, else one from the required options.+    examples = case maybe [] methodExamples mpSchema of+      [] -> [MethodExample (synthesiseExample ir md (fmap methodParams mpSchema >>= id)) Nothing]+      es -> es+    exampleBlock =+      -- SYNAPSE-10: where a value may come from, on every method page+      [ ""+      , "A value may be read from a file (--flag @FILE) or stdin (--flag -);"+      , "@@text sends a literal @text."+      , "", if length examples == 1 then "Example:" else "Examples:"]+        ++ concat (zipWith exampleLines [0 :: Int ..] examples)+    exampleLines i ex =+      [ "" | i > 0 ]+        ++ maybe [] (\n -> ["  # " <> n]) (exampleNote ex)+        ++ ["  " <> renderExample mpProgram mpTarget md (exampleParams ex)]++    -- AUTH-8: in a caller's view, the grant and where it is held.+    requiresBlock = case mpSchema of+      Just ms | mpCaller -> maybe [] (\l -> ["", l]) (requiresLine ms)+      _ -> []+    requiresLine ms+      | methodPublic ms = Just "Requires: nothing (public)"+      | otherwise = do+          grant <- methodGrant ms+          let held = case methodHeldOn ms of+                Just hs@(_ : _) -> "you hold it on " <> T.intercalate ", " hs+                _ -> "you hold it nowhere"+          pure $ case methodTarget ms of+            Just t -> "Requires: " <> grant <> " on the scope of --" <> kebab t <> " (" <> held <> ")"+            Nothing -> "Requires: " <> grant <> ", answered from where it is held (" <> held <> ")"++    paragraphs = map (T.unwords . T.words) . splitBlank . T.lines+    splitBlank ls = case break (T.null . T.strip) ls of+      (p, []) -> [T.unlines p]+      (p, _ : rest) -> T.unlines p : "" : splitBlank rest++    dropTrailing = reverse . dropWhile (T.null . T.strip) . reverse++-- | A lead and lines that start in column @col@: the first beside the lead+-- when it fits (two spaces between), else all of them under it.+hangAt :: Int -> Text -> [Text] -> [Text]+hangAt col lead ds = case ds of+  [] -> [lead]+  (d : rest) | T.length lead <= col - 2 -> (T.justifyLeft col ' ' lead <> d) : map (pad <>) rest+  _ -> lead : map (pad <>) ds+  where pad = T.replicate col " "++flagOf :: ParamDef -> Text+flagOf p = "--" <> kebab (pdName p)++-- | SYNAPSE-13: a parameter as an option line shows it — its flag and the+-- type it takes, in [brackets] when optional, ⚠ before a deprecated one+-- (@--id <string>@, @[--snoozed <boolean>]@). SYNAPSE-17's search shows a+-- parameter the same way.+flagLabel :: IR -> ParamDef -> Text+flagLabel ir p =+  let decorated = case pdDeprecation p of+        Just _ -> deprecationMarker <> " " <> flagOf p+        Nothing -> flagOf p+      f = decorated <> " <" <> flagType ir (pdType p) <> ">"+  in if pdRequired p then f else "[" <> f <> "]"++-- | A type as a flag takes it: an optional one as its inner type (the+-- brackets say it is optional), a named one by its own name.+flagType :: IR -> TypeRef -> Text+flagType ir = \case+  RefOptional inner -> flagType ir inner+  RefArray inner -> flagType ir inner <> "[]"+  t@(RefNamed qn) ->+    let full = renderTypeRef ir t+    in if full == qualifiedNameFull qn then qnLocalName qn else full+  t -> renderTypeRef ir t++-- | The values a parameter takes: its schema's hint (@x-plexus-values@),+-- else its type's literals when it is a string enum.+paramValuesOf :: IR -> ParamDef -> Maybe [Text]+paramValuesOf ir p = pdValues p <|> stringEnumValues ir (pdType p)++kebab :: Text -> Text+kebab = T.replace "_" "-"++-- | REQ-8: a param the server supplies (@x-plexus-source@ other than rpc).+serverSourced :: ParamDef -> Bool+serverSourced p = isJust (pdSource p) && sourceLabel p /= "rpc"++sourceLabel :: ParamDef -> Text+sourceLabel p = case pdSource p of+  Just (Object src) ->+    let str k = case KM.lookup k src of { Just (String t) -> Just t; _ -> Nothing }+    in case str "from" of+      Just "auth" -> maybe "auth" ("auth: " <>) (str "resolver")+      Just "cookie" -> "cookie" <> maybe "" (" " <>) (str "key")+      Just "header" -> "header" <> maybe "" (" " <>) (str "key")+      Just "query" -> "query" <> maybe "" (" " <>) (str "key")+      Just "derived" -> "server-derived"+      Just other -> other+      Nothing -> "server"+  _ -> "rpc"++-- | The literals a string-enum type takes, when it is one.+stringEnumValues :: IR -> TypeRef -> Maybe [Text]+stringEnumValues ir = \case+  RefOptional inner -> stringEnumValues ir inner+  RefNamed qn -> case Map.lookup (qualifiedNameFull qn) (irTypes ir) of+    Just TypeDef{tdKind = KindStringEnum vs} | not (null vs) -> Just vs+    _ -> Nothing+  _ -> Nothing++-- | SYNAPSE-13: one example from a method's required options: each the+-- value its description gives after @e.g.@, else the first of its values,+-- else a stand-in by type (@<ID>@ for a string).+synthesiseExample :: IR -> MethodDef -> Maybe Value -> Value+synthesiseExample ir md schemaParams = Object $ KM.fromList+  [ (K.fromText (pdName p), sample p) | p <- mdParams md, pdRequired p, not (serverSourced p) ]+  where+    sample p = fromMaybe (byType p (pdType p)) (fromDesc p <|> fromValues p)+    fromDesc p = do+      d <- pdDescription p+      let (_, after) = T.breakOn "e.g. " d+      guard' (not (T.null after))+      let tok = T.takeWhile (\c -> c `notElem` (" ,;)" :: String)) (T.drop 5 after)+          bare = T.dropAround (`elem` ("'\"`[]" :: String)) tok+      guard' (not (T.null bare))+      pure (String bare)+    fromValues p = do+      Object o <- schemaParams+      Object props <- KM.lookup "properties" o+      prop <- KM.lookup (K.fromText (pdName p)) props+      v : _ <- paramValues prop+      pure (String v)+    byType p = \case+      RefPrimitive "integer" _ -> Number 1+      RefPrimitive "number" _ -> Number 1+      RefPrimitive "boolean" _ -> Bool True+      RefArray inner -> Array (V.singleton (byType p inner))+      RefOptional inner -> byType p inner+      RefNamed qn -> case Map.lookup (qualifiedNameFull qn) (irTypes ir) of+        Just TypeDef{tdKind = KindStringEnum (v : _)} -> String v+        Just TypeDef{tdKind = KindAlias t} -> byType p t+        Just TypeDef{tdKind = KindPrimitive t _} -> byType p (RefPrimitive t Nothing)+        _ -> String ("<" <> T.toUpper (pdName p) <> ">")+      _ -> String ("<" <> T.toUpper (pdName p) <> ">")+    guard' b = if b then Just () else Nothing++-- | SYNAPSE-13: an example's params as a synapse command line: each param+-- its flag (required first, in the method's order), a list its values joined+-- by commas (an element holding one double-quoted, SYNAPSE-2), an object its dotted fields+-- (@--value.type choice@); params a flag cannot carry (a list inside an+-- object, SYNAPSE-9) go whole as @-p '{…}'@, before the backend.+renderExample :: Text -> Text -> MethodDef -> Value -> Text+renderExample program target md params = case params of+  Object o -> case mapM flagsOf (ordered o) of+    Just groups -> T.unwords ([program, target] ++ concat groups)+    Nothing -> whole+  _ -> whole+  where+    whole = T.unwords [program, "-p", shellQuote (TE.decodeUtf8 (LBS.toStrict (Aeson.encode params))), target]+    -- required first, then optional, each in the method's order+    order = zip (map pdName (sortOn (not . pdRequired) (mdParams md))) [0 :: Int ..]+    ordered o = sortOn (\(k, _) -> (fromMaybe maxBound (lookup (K.toText k) order), K.toText k)) (KM.toList o)+    flagsOf (k, v) = flags True ("--" <> kebab (K.toText k)) v+    flags _ _ Null = Just []+    -- an object's fields, its discriminator (@type@) first+    flags _ f (Object o) =+      concat <$> mapM (\(k, v) -> flags False (f <> "." <> kebab (K.toText k)) v)+        (sortOn (\(k, _) -> (K.toText k /= "type", K.toText k)) (KM.toList o))+    flags top f (Array xs)+      | not top = Nothing  -- a list inside an object: not as flags (SYNAPSE-9)+      | V.null xs = Just []+      | otherwise = do+          scalars <- mapM scalar (V.toList xs)+          -- an element holding a comma is double-quoted inside the value+          let element x = if T.isInfixOf "," x || T.isPrefixOf "\"" x || T.null x || T.strip x /= x+                then "\"" <> T.replace "\"" "\"\"" x <> "\""+                else x+          pure [f, shellQuote (T.intercalate "," (map element scalars))]+    flags _ f v = (\x -> [f, shellQuote x]) <$> scalar v+    scalar = \case+      String t -> Just t+      Number n -> Just (either (T.pack . show) (T.pack . show) (floatingOrInteger n :: Either Double Integer))+      Bool b -> Just (if b then "true" else "false")+      _ -> Nothing++-- | A word as the shell reads it: bare when it is plain, else in single+-- quotes.+shellQuote :: Text -> Text+shellQuote t+  | not (T.null t), T.all plain t = t+  | Just inner <- T.stripPrefix "<" t >>= T.stripSuffix ">", not (T.null inner), T.all plain inner = t+  | T.any (== '\'') t, not (T.any (`elem` ("\"$`\\!" :: String)) t) = "\"" <> t <> "\""+  | otherwise = "'" <> T.replace "'" "'\\''" t <> "'"+  where plain c = isAlphaNum c || c `elem` ("_@%+=:,./-" :: String)+ -- | Render a parameter as a block (may be multi-line for complex types). -- -- IR-14: when @pdDeprecation param@ is @Just DeprecationInfo@ the@@ -142,9 +449,9 @@       reqText = if pdRequired param then "(required)" else "(optional)"       headerLine = indent' <> flagName <> " <" <> typeStr <> ">  " <> reqText -      -- Description line+      -- Description, wrapped in its column       descLines = case pdDescription param of-        Just desc -> [indent2 <> desc]+        Just desc -> map (indent2 <>) (wrapWords (80 - T.length indent2) desc)         Nothing -> []        -- Deprecation detail line (IR-14).  Indented one level beyond the@@ -153,12 +460,36 @@         Just di -> [indent2 <> formatDeprecationLine di]         Nothing -> [] +      -- How to pass several elements of a list (SYNAPSE-2)+      listLines = case listElement (pdType param) of+        Just inner+          | isScalarElement ir inner ->+              [indent2 <> "Repeat the flag or use commas: " <> rawFlag <> " a,b"]+          | otherwise -> [indent2 <> "Repeat the flag for each element"]+        Nothing -> []+      listElement = \case+        RefArray inner -> Just inner+        RefOptional inner -> listElement inner+        _ -> Nothing+       -- Type expansion (for enums/unions)       expansionLines = if hsExpandEnums style         then map (indent2 <>) (expandType ir (pdName param) (pdType param))         else [] -  in [""] ++ [headerLine] ++ descLines ++ deprecationLines ++ expansionLines+  in [""] ++ [headerLine] ++ descLines ++ deprecationLines ++ listLines ++ expansionLines++-- | Words wrapped greedily to a width (at least 20).+wrapWords :: Int -> Text -> [Text]+wrapWords w0 = go . T.words+  where+    w = max 20 w0+    go [] = []+    go (x : xs) = line x xs+    line acc [] = [acc]+    line acc (y : ys)+      | T.length acc + 1 + T.length y <= w = line (acc <> " " <> y) ys+      | otherwise = acc : line y ys  -- ============================================================================ -- Parameter Help

@@ -42,19 +42,50 @@ -- -> [("tags", [("", "backend"), ("", "critical"), ("", "urgent")])] -- -> {"tags": ["backend", "critical", "urgent"]} -- @+--+-- For a list of scalars, each flag value is also a comma-separated record+-- (see 'splitListValue'):+--+-- @+-- --tags backend,critical --tags '"a,b"'+-- -> {"tags": ["backend", "critical", "a,b"]}+-- @+--+-- = Command line+--+-- The pairs come from the command line in two passes. 'parsePathAndParams'+-- runs before the method is known and finds the path; 'pairFlags' runs once+-- it is, and uses each parameter's type to decide whether a flag takes the+-- argument after it, so a value may begin with dashes:+--+-- @+-- --summary --body "--- id: X" --limit=3      (summary a boolean)+-- -> [("summary", "true"), ("body", "--- id: X"), ("limit", "3")]+-- @ module Synapse.CLI.Parse-  ( -- * Parsing-    parseParams+  ( -- * Command line+    parsePathAndParams+  , pairFlags++    -- * Parsing+  , parseParams   , ParseError(..) +    -- * List values+  , isScalarElement+  , splitListValue+     -- * Helpers (exposed for testing)   , groupByPrefix   , buildParamValue   ) where +import Control.Monad (foldM) import Data.Aeson (Value(..), object) import qualified Data.Aeson.Key as K+import Data.Either (partitionEithers) import Data.List (find)+import Data.Maybe (fromMaybe) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text)@@ -86,9 +117,144 @@       -- ^ Unknown variant name (param name, provided value, valid variants, suggestions)   | TypeNotFound Text       -- ^ Referenced type not found in IR+  | MalformedListValue Text Text Text+      -- ^ List flag value with broken quoting (param name, flag value, reason)+  | UnexpectedArgument Text+      -- ^ Argument that no flag takes as its value   deriving (Show, Eq)  -- ============================================================================+-- Command Line+-- ============================================================================++-- | Whether a flag written without @=@ takes the argument after it+data FlagArity+  = TakesNext        -- ^ Always, whatever it begins with: the parameter takes a value+  | TakesBoolean     -- ^ Only when it reads as a boolean: the parameter is a boolean+  | TakesUnlessFlag  -- ^ Unless it begins with @--@ (and is not @--@): no parameter is known++-- | Split the arguments after the backend into path segments, (key, value)+-- pairs, the flag arguments the pairs came from, and whether help was asked+-- for.+--+-- This runs before the method is known, so a flag takes the next argument+-- unless that begins with @--@ and is not exactly @--@. That is enough to find+-- the path. Once the method is known, 'pairFlags' pairs the flag arguments+-- again by type; the pairs returned here serve only where there is no method+-- schema (@_self@, @respond@, a method missing from the IR).+--+-- Example: ["echo", "once", "--message", "hello", "--count", "3"]+--       -> (["echo", "once"], [("message", "hello"), ("count", "3")],+--           ["--message", "hello", "--count", "3"], False)+-- Example: ["echo", "once", "--help"]+--       -> (["echo", "once"], [], [], True)+parsePathAndParams :: [Text] -> ([Text], [(Text, Text)], [Text], Bool)+parsePathAndParams = go [] [] [] False+  where+    go path params flags helpReq [] = (reverse path, reverse params, reverse flags, helpReq)+    go path params flags helpReq (x:xs)+      -- --help flag: mark help requested, don't add as param+      | x == "--help" || x == "-h" =+          go path params flags True xs+      -- --key value, --key=value, or a bare --key+      | Just flag <- T.stripPrefix "--" x+      , not (T.null flag) =+          let (key, val, n) = takeFlag (const TakesUnlessFlag) flag xs+              (taken, rest) = splitAt n xs+          in go path ((normalizeKey key, fromMaybe "" val) : params)+                (reverse (x : taken) ++ flags) helpReq rest+      -- Regular path segment - split on dots to support Plexus RPC path syntax (e.g., cone.chat)+      | otherwise =+          let segments = map (T.replace "-" "_") $ filter (not . T.null) $ T.splitOn "." x+          in go (reverse segments ++ path) params flags helpReq xs++-- | Pair a method's flag arguments (from 'parsePathAndParams') by the types+-- of its parameters:+--+-- * @--key=value@: everything after the first @=@, empty or not+-- * a boolean: @true@ when bare; it takes the next argument only when that+--   reads as a boolean (@true@, @false@, @1@, @0@), so @--summary --limit 3@+--   is two flags+-- * any other parameter: the next argument, whatever it begins with+--   (@---@, @--force@, @-5@, @--@)+-- * a flag that names no parameter: as in 'parsePathAndParams'; its key+--   stays as typed, so 'UnknownParam' names it so+--+-- Keys are normalized (kebab-case to snake_case); values never are. An+-- argument that no flag takes is an 'UnexpectedArgument'.+pairFlags :: IR -> MethodDef -> [Text] -> Either [ParseError] [(Text, Text)]+pairFlags ir method args = case partitionEithers (go args) of+  ([], pairs) -> Right pairs+  (errs, _) -> Left errs+  where+    go [] = []+    go (x:xs) = case T.stripPrefix "--" x of+      Just flag | not (T.null flag) ->+        let (typed, val, n) = takeFlag arity flag xs+            key = normalizeKey typed+            pair = case arity key of+              TakesNext -> (key, fromMaybe "" val)+              TakesBoolean -> (key, fromMaybe "true" val)+              TakesUnlessFlag -> (typed, fromMaybe "" val)+        in Right pair : go (drop n xs)+      _ -> Left (UnexpectedArgument x) : go xs++    arity = flagArity ir method++-- | Read one flag (the text after @--@) against the arguments after it:+-- its key as typed, its value ('Nothing' when bare), and how many of those+-- arguments it took (0 or 1).+takeFlag :: (Text -> FlagArity) -> Text -> [Text] -> (Text, Maybe Text, Int)+takeFlag arity flag next+  | (key, eqValue) <- T.breakOn "=" flag, not (T.null eqValue) =+      (key, Just (T.drop 1 eqValue), 0)+  | otherwise = case (arity (normalizeKey flag), next) of+      (TakesNext, val : _) -> (flag, Just val, 1)+      (TakesBoolean, val : _) | isBooleanWord val -> (flag, Just val, 1)+      (TakesUnlessFlag, val : _) | val == "--" || not ("--" `T.isPrefixOf` val) -> (flag, Just val, 1)+      _ -> (flag, Nothing, 0)+  where+    -- The spellings 'inferTypedValue' reads as a boolean+    isBooleanWord val = T.toLower val `elem` ["true", "false", "1", "0"]++-- | How the flag with this (normalized) key takes its value: by the type of+-- the parameter it names, or of the field a dotted key names+flagArity :: IR -> MethodDef -> Text -> FlagArity+flagArity ir method key = case T.splitOn "." key of+  name : fields+    | Just param <- find ((== name) . pdName) (mdParams method) ->+        case foldM (fieldType ir) (pdType param) fields of+          Just ty | isBooleanRef ir ty -> TakesBoolean+          _ -> TakesNext+  _ -> TakesUnlessFlag++-- | The type of a field of a struct, or of any variant of an enum+fieldType :: IR -> TypeRef -> Text -> Maybe TypeRef+fieldType ir ref name = case ref of+  RefOptional inner -> fieldType ir inner name+  RefNamed qn -> case tdKind <$> Map.lookup (qualifiedNameFull qn) (irTypes ir) of+    Just (KindStruct fields) -> fdType <$> find ((== name) . fdName) fields+    Just (KindEnum _ variants) -> fdType <$> find ((== name) . fdName) (concatMap vdFields variants)+    Just (KindAlias target) -> fieldType ir target name+    _ -> Nothing+  _ -> Nothing++-- | Is this a boolean (optional, or a named type that is one)?+isBooleanRef :: IR -> TypeRef -> Bool+isBooleanRef ir = \case+  RefPrimitive typ _ -> typ == "boolean"+  RefOptional inner -> isBooleanRef ir inner+  RefNamed qn -> case tdKind <$> Map.lookup (qualifiedNameFull qn) (irTypes ir) of+    Just (KindPrimitive typ _) -> typ == "boolean"+    Just (KindAlias target) -> isBooleanRef ir target+    _ -> False+  _ -> False++-- | Normalize a flag key from kebab-case to snake_case+normalizeKey :: Text -> Text+normalizeKey = T.replace "-" "_"++-- ============================================================================ -- Main Parsing Function -- ============================================================================ @@ -203,11 +369,18 @@       else buildParamValue ir param{pdType = inner} kvs    RefArray innerType ->-    -- Collect all repeated --key value entries (no comma splitting - use shell separation)-    let values = [val | ("", val) <- kvs]-    in if null values+    -- Collect all repeated --key value entries; for a list of scalars each+    -- entry is itself a comma-separated record (objects/lists/any stay whole)+    let rawValues = [val | ("", val) <- kvs]+        elements val+          | isScalarElement ir innerType =+              either (Left . MalformedListValue (pdName param) val) Right (splitListValue val)+          | otherwise = Right [val]+    in if null rawValues        then Left $ InvalidValue (pdName param) "array requires at least one value"-       else Right $ Array $ V.fromList $ map (buildTypedValue ir innerType) values+       else do+         values <- concat <$> traverse elements rawValues+         Right $ Array $ V.fromList $ map (buildTypedValue ir innerType) values    RefAny ->     -- Dynamic type, try to parse as JSON or use as string@@ -242,7 +415,7 @@    KindAlias target ->     -- Follow the alias-    buildParamValue ir ParamDef{pdName = paramName, pdType = target, pdDescription = Nothing, pdRequired = True, pdDefault = Nothing, pdDeprecation = Nothing} kvs+    buildParamValue ir ParamDef{pdName = paramName, pdType = target, pdDescription = Nothing, pdRequired = True, pdDefault = Nothing, pdDeprecation = Nothing, pdSource = Nothing, pdValues = Nothing} kvs    KindStringEnum allowedValues ->     -- Expect single string value from allowed set@@ -305,6 +478,67 @@   RefArray _ -> inferValue val  -- Best effort for arrays   RefAny -> inferValue val   RefUnknown -> String val++-- ============================================================================+-- List Values+-- ============================================================================++-- | Is this list element type a scalar (string, integer, number, boolean, or+-- a named type that is one of those)? Only lists of scalars split their flag+-- values on commas; objects, lists and untyped values are passed whole.+isScalarElement :: IR -> TypeRef -> Bool+isScalarElement ir = \case+  RefPrimitive typ _ -> typ `elem` scalarTypes+  RefNamed qn -> case Map.lookup (qualifiedNameFull qn) (irTypes ir) of+    Just TypeDef{tdKind = KindPrimitive typ _} -> typ `elem` scalarTypes+    Just TypeDef{tdKind = KindStringEnum _} -> True+    Just TypeDef{tdKind = KindAlias target} -> isScalarElement ir target+    _ -> False+  RefOptional inner -> isScalarElement ir inner+  RefArray _ -> False+  RefAny -> False+  RefUnknown -> False+  where+    scalarTypes = ["string", "integer", "number", "boolean"]++-- | Split one flag value of a scalar list into its elements.+--+-- The value is one comma-separated record. Unquoted fields are trimmed and+-- dropped when empty. A field starting with @"@ runs to its closing quote,+-- keeps its commas and spaces, and reads @""@ inside as one quote.+--+-- @+-- a,b,c           -> ["a", "b", "c"]+-- a, b ,c         -> ["a", "b", "c"]+-- a,,b,           -> ["a", "b"]+-- "a,b","c"       -> ["a,b", "c"]+-- "say ""hi""",b  -> ["say \"hi\"", "b"]+-- "",a            -> ["", "a"]+-- "a,b  or "a"x,b -> Left reason+-- @+splitListValue :: Text -> Either Text [Text]+splitListValue = field+  where+    field t = case T.uncons (T.stripStart t) of+      Just ('"', rest) -> quoted "" rest+      _ ->+        let (raw, rest) = T.breakOn "," t+            val = T.strip raw+        in ([val | not (T.null val)] ++) <$> afterComma rest++    -- Inside quotes: a doubled quote is one quote, a single one closes the field+    quoted acc t = case T.breakOn "\"" t of+      (_, "") -> Left "a quoted element has no closing quote"+      (chunk, close) -> case T.uncons (T.drop 1 close) of+        Just ('"', more) -> quoted (acc <> chunk <> "\"") more+        _ -> case T.uncons (T.stripStart (T.drop 1 close)) of+          Nothing -> Right [acc <> chunk]+          Just (',', more) -> ((acc <> chunk) :) <$> field more+          Just _ -> Left "a closing quote must be followed by a comma or the end"++    afterComma rest = case T.uncons rest of+      Nothing -> Right []+      Just (_, more) -> field more  -- drop the comma  -- ============================================================================ -- Value Inference

@@ -0,0 +1,130 @@+{-# LANGUAGE RecordWildCards #-}+-- | SYNAPSE-10: a parameter's value from a file or stdin.+--+-- A flag's value is one shell argument, and Linux caps an argument at 128 KB+-- (@MAX_ARG_STRLEN@), so @--body "$(cat body.md)"@ fails before synapse+-- starts once the body is large. Here a value names its source instead and+-- synapse reads it after it has started, so the only limit left is the+-- backend's own:+--+-- @+-- --body @body.md      the file's contents (UTF-8), as they are+-- --body -             standard input, read once however many values ask+-- --body @@literal     a value that really begins with @ (one @ is dropped)+-- -p @params.json      the whole params object from a file; -p - from stdin+-- @+--+-- The rule applies to every flag value of every backend, after the flags are+-- paired and before any other transformation, so @--body=\@body.md@ works+-- too and a path parameter read from a file is still expanded afterwards.+-- A file that cannot be read is a refusal naming the flag, the path and the+-- escape — never a value sent as the literal text @\@body.md@.+module Synapse.CLI.Source+  ( SourceEnv(..)+  , SourceError(..)+  , mkSourceEnv+  , expandSources+  , expandValue+  , stdinWasRead+  , renderSourceError+  ) where++import Control.Exception (IOException, try)+import System.IO.Error (ioeGetErrorString)+import qualified Data.ByteString as BS+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TE+import System.FilePath (isRelative, (</>))+import System.IO (Handle, stdin)++-- | What a source needs: where relative paths resolve, what @~/@ means, how+-- stdin is read (a test hands in its own), and stdin's contents once read.+data SourceEnv = SourceEnv+  { seCwd   :: FilePath+  , seHome  :: Maybe FilePath+  , seStdin :: IO BS.ByteString+  , seCache :: IORef (Maybe Text)+  }++-- | A source that could not be read: the flag it was for (empty for @-p@),+-- the path as written, and the system's reason.+data SourceError = SourceUnreadable+  { seKey    :: Text+  , seSource :: Text+  , seWhy    :: Text+  }+  deriving (Show, Eq)++mkSourceEnv :: FilePath -> Maybe FilePath -> IO SourceEnv+mkSourceEnv cwd home = do+  cache <- newIORef Nothing+  pure SourceEnv { seCwd = cwd, seHome = home, seStdin = readToEnd stdin, seCache = cache }++-- | All of a handle, without closing it: 'BS.getContents' semi-closes+-- stdin, and the bidirectional mode's terminal check later throws on a+-- closed handle.+readToEnd :: Handle -> IO BS.ByteString+readToEnd h = go []+  where+    go acc = do+      chunk <- BS.hGetSome h 65536+      if BS.null chunk then pure (BS.concat (reverse acc)) else go (chunk : acc)++-- | Whether some value has taken stdin: the bidirectional JSON mode reads it+-- too, and the two cannot share.+stdinWasRead :: SourceEnv -> IO Bool+stdinWasRead env = maybe False (const True) <$> readIORef (seCache env)++-- | Every flag value through 'expandValue'; the first failure wins.+expandSources :: SourceEnv -> [(Text, Text)] -> IO (Either SourceError [(Text, Text)])+expandSources env = go []+  where+    go acc [] = pure (Right (reverse acc))+    go acc ((k, v) : rest) = do+      r <- expandValue env k v+      case r of+        Left e -> pure (Left e)+        Right v' -> go ((k, v') : acc) rest++-- | One value: @-@ is stdin, @\@\@x@ is the literal @\@x@, @\@path@ is that+-- file, anything else is itself.+expandValue :: SourceEnv -> Text -> Text -> IO (Either SourceError Text)+expandValue env@SourceEnv{..} key val+  | val == "-" = Right <$> readStdinOnce env+  | "@@" `T.isPrefixOf` val = pure (Right (T.drop 1 val))+  | Just path <- T.stripPrefix "@" val, not (T.null path) = do+      r <- try (BS.readFile (resolve path)) :: IO (Either IOException BS.ByteString)+      pure $ case r of+        Left e -> Left SourceUnreadable { seKey = key, seSource = val, seWhy = T.pack (ioeGetErrorString e) }+        Right bytes -> Right (decode bytes)+  | otherwise = pure (Right val)+  where+    resolve p = case (T.unpack p, seHome) of+      ('~' : '/' : rest, Just home) -> home </> rest+      (fp, _) | isRelative fp -> seCwd </> fp+              | otherwise -> fp++readStdinOnce :: SourceEnv -> IO Text+readStdinOnce SourceEnv{..} = do+  cached <- readIORef seCache+  case cached of+    Just t -> pure t+    Nothing -> do+      t <- decode <$> seStdin+      writeIORef seCache (Just t)+      pure t++decode :: BS.ByteString -> Text+decode = TE.decodeUtf8With TE.lenientDecode++-- | The refusal, with the escape for a value that really begins with @.+renderSourceError :: SourceError -> Text+renderSourceError SourceUnreadable{..} =+  flag <> seSource <> ": cannot read " <> T.drop 1 seSource <> " (" <> seWhy <> "). "+    <> "A value that begins with @ is read from that file; write @@" <> T.drop 1 seSource+    <> " to send the text " <> seSource <> " itself."+  where+    flag = if T.null seKey then "-p " else "--" <> T.replace "_" "-" seKey <> " "

@@ -11,8 +11,10 @@ -- @ -- Command line args --   ↓--- parsePathAndParams (extract --key value pairs)+-- parsePathAndParams (find the path and the flag arguments) --   ↓+-- pairFlags (pair --key value / --key=value by parameter type)+--   ↓ -- [(Text, Text)] raw params --   ↓ -- transformParams (THIS MODULE - middleware chain)@@ -190,17 +192,24 @@ -- Environment Variable Expansion -- ============================================================================ --- | Expand environment variables in parameter values+-- | Expand environment variables in path parameter values -- -- Handles:--- - @--value $VAR@ → @--value \<env_value\>@--- - @--message \"Hello $USER\"@ → @--message \"Hello alice\"@+-- - @--path $PROJECT/src@ → @--path \/home\/user\/proj\/src@ --+-- Path parameters only (SYNAPSE-6), as the README has always said. Any+-- other value is sent exactly as it arrived: a shell has already expanded+-- every @$VAR@ the caller left unquoted or double-quoted, so the only+-- @$@ that reaches synapse is one the caller protected on purpose —+-- single quotes, a value read from a file (@--body "$(cat body.md)"@).+-- Expanding it again rewrote text the caller meant literally: a ticket+-- body mentioning @$HOME@ was sent as @\/home\/alice@.+-- -- Simple implementation: only expands $VARNAME format (not ${VAR}). -- Fail-safe: Returns original value if variable not found. envExpansion :: Transformer envExpansion TransformEnv{..} (key, val)-  | T.any (== '$') val = do+  | isPathParam key && T.any (== '$') val = do       let expanded = expandEnvVars teEnv val       pure (key, expanded)   | otherwise = pure (key, val)@@ -282,8 +291,8 @@  -- | Inject "true" for boolean flags that were present but had no value ----- When a user writes @--force@ without a value, parsePathAndParams marks it--- as @("force", "")@. This function looks at the method definition to determine+-- A bare @--force@ is already @("force", "true")@ from @pairFlags@; @--force=@+-- arrives as @("force", "")@. This function looks at the method definition to determine -- which empty-value params are actually booleans, and fills them with "true". -- -- Non-boolean params with empty values are left as-is and will fail validation

@@ -0,0 +1,204 @@+-- | SCAFFOLD-21: where a hub is reached — a host and port, and, for a hub+-- behind TLS (every hosted app: @wss://<app>.menger.sh/ws@), the scheme+-- and the path its socket answers at.+--+-- One value, from the command line (@--url@, or @-H@ / @-P@ with @--tls@+-- and @--path@), carried to every dial: the probe, the call, the stream and+-- its reconnects, the schema, a bidirectional response, @_login@ and the+-- session a call carries. The store keys a session by 'addressKey': a+-- plain @ws://HOST:PORT/@ keeps the @HOST:PORT@ it always had (no stored+-- session moves), anything else is keyed by its whole URL, so a @ws@ and a+-- @wss@ backend on one host, or two paths, never share a session.+module Synapse.Endpoint+  ( Endpoint(..)+  , plainAt+  , isPlain+  , parseUrl+  , normalisePath+  , renderUrl+  , shortUrl+  , addressKey+  , dirName+  , audience+  , cliFlags+  , cliOptions+  , defaultHost+  , defaultPort+  , substrateConfig+  ) where++import qualified Data.ByteString as BS+import Data.Char (isAlphaNum, isDigit, ord, toLower)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Network.WebSockets as WS+import Numeric (showHex)++import Plexus.Client (SubstrateConfig(..), TlsOptions(..))++-- | A hub's address.+data Endpoint = Endpoint+  { epHost    :: !Text+  , epPort    :: !Int+  , epTls     :: !Bool          -- ^ @wss://@: TLS, the certificate verified+  , epPath    :: !Text          -- ^ the socket's path, @/@ when none is given+  , epCaFiles :: ![FilePath]    -- ^ PEM files trusted beside the system's (@--cacert@)+  }+  deriving stock (Eq, Ord, Show)++-- | @ws://HOST:PORT/@ — what @-H@ / @-P@ have always named.+plainAt :: Text -> Int -> Endpoint+plainAt h p = Endpoint { epHost = h, epPort = p, epTls = False, epPath = "/", epCaFiles = [] }++-- | Is this the plain @ws://HOST:PORT/@ every address was before+-- SCAFFOLD-21? (Then everything keyed by it is keyed as it was.)+isPlain :: Endpoint -> Bool+isPlain ep = not (epTls ep) && epPath ep == "/"++-- | Parse @ws://HOST[:PORT][/PATH]@ or @wss://HOST[:PORT][/PATH]@. The+-- port defaults to the scheme's (80, 443); the path to @/@. An IPv6+-- literal is bracketed (@wss://[::1]:8443/ws@). A query or fragment is+-- refused: a Plexus socket is named by its path alone.+parseUrl :: Text -> Either Text Endpoint+parseUrl raw0 = do+  let raw = T.strip raw0+  (tls, rest) <- case T.breakOn "://" raw of+    (scheme, r) | not (T.null r) -> case T.toLower scheme of+      "ws"    -> Right (False, T.drop 3 r)+      "wss"   -> Right (True, T.drop 3 r)+      "http"  -> Left ("--url takes ws:// or wss://, not http:// (the socket of an http page is ws://" <> T.drop 3 r <> ")")+      "https" -> Left ("--url takes ws:// or wss://, not https:// (the socket of an https page is wss://" <> T.drop 3 r <> ")")+      other   -> Left ("--url takes ws:// or wss://, not " <> other <> "://")+    _ -> Left ("--url needs a scheme: ws://" <> raw <> " or wss://" <> raw)+  let (authority, pathPart) = T.breakOn "/" rest+  if T.any (`elem` ['?', '#']) pathPart || T.any (`elem` ['?', '#']) authority+    then Left "--url takes no query or fragment: a socket is named by its path"+    else Right ()+  if T.any (== '@') authority+    then Left "--url takes no user:password@ — a credential goes in --token-file or the stored session"+    else Right ()+  (host, port) <- splitAuthority (if tls then 443 else 80) authority+  pure Endpoint+    { epHost = host+    , epPort = port+    , epTls = tls+    , epPath = normalisePath pathPart+    , epCaFiles = []+    }++-- | @HOST[:PORT]@ or @[V6][:PORT]@.+splitAuthority :: Int -> Text -> Either Text (Text, Int)+splitAuthority dflt a+  | T.null a = Left "--url names no host"+  | Just inner <- T.stripPrefix "[" a =+      case T.breakOn "]" inner of+        (h, r) | not (T.null r), not (T.null h) -> case T.drop 1 r of+          "" -> Right (h, dflt)+          p | Just digits <- T.stripPrefix ":" p -> (,) h <$> port digits+          _ -> Left ("--url: cannot read the host " <> a)+        _ -> Left ("--url: cannot read the host " <> a)+  | otherwise = case T.breakOnEnd ":" a of+      ("", _) -> Right (T.toLower a, dflt)+      (h, p) -> (,) (T.toLower (T.dropEnd 1 h)) <$> port p+  where+    port digits+      | not (T.null digits), T.all isDigit digits, T.length digits <= 5+      , n <- read (T.unpack digits), n >= 1, n <= 65535 = Right n+      | otherwise = Left ("--url: the port '" <> digits <> "' is not a port")++-- | A path as a socket is named by it: a leading @/@, no trailing one+-- (@ws/@ → @/ws@; empty → @/@).+normalisePath :: Text -> Text+normalisePath p =+  let trimmed = T.dropWhileEnd (== '/') (T.dropWhile (== '/') (T.strip p))+  in "/" <> trimmed++-- | The URL, with the port always written (@wss://host:443/ws@) — the form+-- the store keys by.+renderUrl :: Endpoint -> Text+renderUrl ep = scheme ep <> "://" <> hostPart (epHost ep) <> ":" <> T.pack (show (epPort ep)) <> epPath ep++scheme :: Endpoint -> Text+scheme ep = if epTls ep then "wss" else "ws"++hostPart :: Text -> Text+hostPart h = if T.any (== ':') h then "[" <> h <> "]" else h++-- | What a session is kept under: @HOST:PORT@ for a plain address (as+-- every session before SCAFFOLD-21 was), the whole URL otherwise.+addressKey :: Endpoint -> Text+addressKey ep+  | isPlain ep = epHost ep <> ":" <> T.pack (show (epPort ep))+  | otherwise = renderUrl ep++-- | The directory name under @~/.plexus/sessions/@: @HOST_PORT@ for a+-- plain address (unchanged), else @wss_HOST_PORT@ (or @ws_…@) and the path+-- with each @/@ as @_@ — any other byte outside @[A-Za-z0-9.-]@ written+-- @%XX@, so two addresses never share one.+dirName :: Endpoint -> FilePath+dirName ep+  | isPlain ep = T.unpack (epHost ep) <> "_" <> show (epPort ep)+  | otherwise =+      T.unpack (scheme ep) <> "_" <> escape (T.unpack (epHost ep)) <> "_" <> show (epPort ep)+        <> concatMap pathChar (T.unpack (T.dropWhileEnd (== '/') (epPath ep)))+  where+    escape = concatMap safe+    safe c | isAlphaNum c && ord c < 128 || c `elem` ['.', '-'] = [c]+           | otherwise = pct c+    pathChar '/' = "_"+    pathChar c = safe c+    pct c = concatMap (\b -> '%' : hex2 b) (BS.unpack (TE.encodeUtf8 (T.singleton c)))+    hex2 b = let h = map toLower (showHex b "") in if length h < 2 then '0' : h else h++-- | A key proof's audience (IDENTITY-40's @aud@): the server's socket+-- origin, as the server lists the URLs it is dialed at — @ws://HOST:PORT@+-- for a plain address (unchanged), @wss://HOST@ (@:PORT@ when not 443)+-- behind TLS, which is what a hub run with @--public-url https://HOST@+-- accepts (plexus-login's @socket_urls@). The path is not part of it.+audience :: Endpoint -> Text+audience ep+  | epTls ep = "wss://" <> hostPart (epHost ep) <> (if epPort ep == 443 then "" else ":" <> T.pack (show (epPort ep)))+  | otherwise = "ws://" <> epHost ep <> ":" <> T.pack (show (epPort ep))++-- | The global options that reach this address, as synapse's own help and+-- messages write them: @-P 4455@, @-H host -P 4455@, @--url wss://host/ws@+-- (and @--cacert FILE@ for each local CA). Empty for the default address.+cliFlags :: Text -> Int -> Endpoint -> Text+cliFlags defaultHost defaultPort ep+  | isPlain ep = T.unwords $+      (if epHost ep /= defaultHost then ["-H", epHost ep] else [])+        <> (if epPort ep /= defaultPort then ["-P", T.pack (show (epPort ep))] else [])+  | otherwise = T.unwords $ ["--url", shortUrl ep] <> concatMap (\f -> ["--cacert", T.pack f]) (epCaFiles ep)++-- | The URL as a person writes it: the scheme's default port and a bare+-- @/@ left out (@wss://hostdemo.menger.sh/ws@).+shortUrl :: Endpoint -> Text+shortUrl ep = scheme ep <> "://" <> hostPart (epHost ep)+  <> (if epPort ep == dflt then "" else ":" <> T.pack (show (epPort ep)))+  <> (if epPath ep == "/" then "" else epPath ep)+  where dflt = if epTls ep then 443 else 80++-- | The connection point when none is named: the registry's, @ws://127.0.0.1:4444/@.+defaultHost :: Text+defaultHost = "127.0.0.1"++defaultPort :: Int+defaultPort = 4444++-- | 'cliFlags' against the default address — what a message tells the+-- reader to type (@synapse -P 4455 _login …@, @synapse --url wss://h/ws _login …@).+cliOptions :: Endpoint -> Text+cliOptions = cliFlags defaultHost defaultPort++-- | The plexus-protocol config that dials this address for @backend@,+-- carrying @headers@ on the upgrade.+substrateConfig :: Endpoint -> Text -> WS.Headers -> SubstrateConfig+substrateConfig ep backend headers = SubstrateConfig+  { substrateHost    = T.unpack (epHost ep)+  , substratePort    = epPort ep+  , substratePath    = T.unpack (epPath ep)+  , substrateBackend = backend+  , substrateHeaders = headers+  , substrateTls     = if epTls ep then Just (TlsOptions (epCaFiles ep)) else Nothing+  }

@@ -0,0 +1,657 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}++-- | SYNAPSE-17: @synapse _find <backend> [activation…] <words…>@ — a fuzzy+-- search over a backend's methods and parameters, answered in the shape of+-- synapse's help (SYNAPSE-13): grouped, aligned, every line a command.+--+-- * The catalog is the backend's IR (the caller's view of its schema),+--   kept in synapse's IR cache under the root schema's hash: a search+--   costs one schema call — the hash check — when nothing has changed.+-- * A word matches a name exactly, as a prefix (of the name or of one of+--   its @snake_case@ segments), as a subsequence of segment prefixes+--   (@setpar@ → @set_parent@), or with a typo (edit distance ≤ 1 for 4–7+--   letters, ≤ 2 beyond); else as a word (or a word's prefix) of a+--   description. Every word must match.+-- * A hit whose words all match names is a METHOD or a PARAMETER; one that+--   needs a description is MENTIONED IN — unless its method is a named hit+--   already.+module Synapse.Find+  ( -- * The command+    FindOpts(..)+  , findInfo+  , defaultLimit++    -- * The catalog+  , loadCatalog+  , Entry(..)+  , EntryKind(..)+  , catalogEntries+  , narrowPath+  , entryLocation++    -- * Matching+  , MatchKind(..)+  , WordMatch(..)+  , matchName+  , matchDescription+  , typoLimit+  , kindScore++    -- * Search+  , Hit(..)+  , Where(..)+  , Group(..)+  , Only(..)+  , search+  , hitGroup+  , takenAs++    -- * The answer+  , Answer(..)+  , answer++    -- * Rendering+  , FindRender(..)+  , renderFind+  , renderNoMatch+  , nearest+  , hitJson+  ) where++import Control.Exception (SomeException, try)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (asks)+import Data.Aeson (Value, object, (.=))+import Data.Char (isAlphaNum)+import Data.List (sortOn, foldl')+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Options.Applicative++import Synapse.Algebra.Render (fitText, summarize)+import Synapse.CLI.Help (flagLabel, flagType, paramValuesOf, serverSourced, wrapWords)+import Synapse.CLI.Similarity (levenshteinDistance)+import Synapse.IR.Builder (buildIR)+import Synapse.IR.Cache (IRCache, insertIR, irCacheKey, lookupIR)+import Synapse.IR.Types+import Synapse.Monad (SynapseM, SynapseEnv(..))+import Synapse.Schema.Types (psHash)+import Synapse.Transport (fetchSchemaAt)++-- ============================================================================+-- The command+-- ============================================================================++-- | What @_find@ was asked.+data FindOpts = FindOpts+  { foBackend :: Text     -- ^ the backend, e.g. menger+  , foTerms   :: [Text]   -- ^ an activation path (optional), then the words+  , foLimit   :: Int      -- ^ at most this many hits+  , foMethods :: Bool     -- ^ only METHODS+  , foParams  :: Bool     -- ^ only PARAMETERS+  }+  deriving stock (Show, Eq)++defaultLimit :: Int+defaultLimit = 20++findInfo :: ParserInfo FindOpts+findInfo = info (p <**> helper)+  ( fullDesc+ <> header "synapse _find - search a backend's methods and parameters"+ <> progDesc "Every method and parameter whose name or description matches all the words, best first, in help's shape: METHODS, PARAMETERS, MENTIONED IN (a match only in a description). A word may be misspelled (one edit for 4-7 letters, two beyond), a prefix, or an abbreviation of a snake_case name (setpar finds set_parent). Activation names before the words narrow the search (_find menger tickets setpar). Global options (-H, -P, -j) go before _find; -j prints one JSON object per hit."+  )+  where+    p = FindOpts+      <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The hub's name, e.g. menger"))+      <*> some (T.pack <$> strArgument (metavar "WORDS..." <> help "[activation…] then the words to look for"))+      <*> option auto (long "limit" <> metavar "N" <> value defaultLimit <> showDefault <> help "At most N hits")+      <*> switch (long "methods" <> help "Only methods")+      <*> switch (long "params" <> help "Only parameters")++-- ============================================================================+-- The catalog+-- ============================================================================++-- | The backend's IR, as the caller's view of its schema has it: the root+-- schema is fetched (the hash check), and the IR kept under that hash —+-- qualified by the caller's view (AUTH-8) — is used when there is one;+-- else the tree is walked once and the IR kept for next time. A cache that+-- cannot be read or written is no cache.+loadCatalog :: Maybe IRCache -> SynapseM IR+loadCatalog mcache = do+  root <- fetchSchemaAt []+  view <- asks seViewKey+  let key = "find-" <> irCacheKey view (psHash root)+  cached <- case mcache of+    Nothing -> pure Nothing+    Just c -> liftIO (either (const Nothing) id <$> (try (lookupIR c key) :: IO (Either SomeException (Maybe IR))))+  case cached of+    Just ir -> pure ir+    Nothing -> do+      ir <- buildIR [] []+      case mcache of+        Nothing -> pure ()+        Just c -> liftIO (() <$ (try (insertIR c key ir) :: IO (Either SomeException ())))+      pure ir++data EntryKind = MethodEntry | ParamEntry+  deriving stock (Show, Eq, Ord)++-- | One thing a search can find: a method, or one of its parameters.+data Entry = Entry+  { enKind   :: EntryKind+  , enMethod :: MethodDef+  , enParam  :: Maybe ParamDef+  }+  deriving stock (Show, Eq)++-- | Every method of the IR, and every parameter a caller passes (one the+-- server supplies, REQ-8, is not a flag), under the activation path.+catalogEntries :: [Text] -> IR -> [Entry]+catalogEntries path ir =+  concat+    [ Entry MethodEntry m Nothing+        : [Entry ParamEntry m (Just p) | p <- mdParams m, not (serverSourced p)]+    | m <- Map.elems (irMethods ir)+    , under (mdNamespace m)+    ]+  where+    prefix = T.intercalate "." path+    under ns = null path || ns == prefix || (prefix <> ".") `T.isPrefixOf` ns++-- | The leading terms that name an activation (as help's path does), and+-- the words after them; at least one word is always left.+narrowPath :: IR -> [Text] -> ([Text], [Text])+narrowPath ir = go []+  where+    namespaces = Set.fromList (map mdNamespace (Map.elems (irMethods ir)))+    isPath segs =+      let p = T.intercalate "." segs+      in any (\ns -> ns == p || (p <> ".") `T.isPrefixOf` ns) (Set.toList namespaces)+    go acc (t : rest@(_ : _))+      | isPath (acc ++ [t]) = go (acc ++ [t]) rest+    go acc rest = (acc, rest)++-- | Where an entry is: its activation path and method, as typed+-- (@tickets snooze@).+entryLocation :: Entry -> Text+entryLocation = methodLocation . enMethod++methodLocation :: MethodDef -> Text+methodLocation m = T.unwords (filter (not . T.null) [T.replace "." " " (mdNamespace m), mdName m])++-- ============================================================================+-- Matching+-- ============================================================================++-- | How a word matched, best first.+data MatchKind+  = Exact            -- ^ the whole name+  | Prefix           -- ^ the start of the name+  | SegmentExact     -- ^ one @snake_case@ segment of it+  | SegmentPrefix    -- ^ the start of a segment+  | Subsequence      -- ^ prefixes of segments, in order (@setpar@)+  | Typo Int         -- ^ within this many edits of the name or a segment's start+  | InDescription    -- ^ a word of a description, or its start+  deriving stock (Show, Eq)++kindScore :: MatchKind -> Double+kindScore = \case+  Exact -> 1.0+  Prefix -> 0.9+  SegmentExact -> 0.85+  SegmentPrefix -> 0.8+  Subsequence -> 0.6+  Typo d -> 0.55 - 0.1 * fromIntegral (d - 1)+  InDescription -> 0.3++-- | A word's match: how, what it was taken as, and which characters of the+-- text it matched (offset, length).+data WordMatch = WordMatch+  { wmKind  :: MatchKind+  , wmTaken :: Text+  , wmSpans :: [(Int, Int)]+  }+  deriving stock (Show, Eq)++-- | The edits a word of this length may be off by: none under 4 letters,+-- one for 4–7, two beyond.+typoLimit :: Int -> Int+typoLimit n+  | n < 4 = 0+  | n <= 7 = 1+  | otherwise = 2++-- | A name's segments and where each starts (@set_parent@ → set@0, parent@4).+segments :: Text -> [(Int, Text)]+segments name = go 0 (T.unpack name)+  where+    go _ [] = []+    go off s =+      let (seg, rest) = break isSep s+          off' = off + length seg+      in case rest of+           [] -> [(off, T.pack seg) | not (null seg)]+           (_ : rest') -> [(off, T.pack seg) | not (null seg)] ++ go (off' + 1) rest'+    isSep c = c `elem` ("_-." :: String)++-- | Match a word (lower case) against a name.+matchName :: Text -> Text -> Maybe WordMatch+matchName w0 name0+  | T.null w = Nothing+  | w == name = Just (WordMatch Exact name0 [(0, T.length w)])+  | w `T.isPrefixOf` name = Just (WordMatch Prefix w [(0, T.length w)])+  | Just (off, _) <- find' (\(_, s) -> s == w) segs = Just (WordMatch SegmentExact w [(off, T.length w)])+  | Just (off, _) <- find' (\(_, s) -> w `T.isPrefixOf` s) segs = Just (WordMatch SegmentPrefix w [(off, T.length w)])+  | Just spans <- subsequence (T.unpack w) segs = Just (WordMatch Subsequence name0 spans)+  | otherwise = typo+  where+    w = normalise w0+    name = T.toLower name0+    segs = segments name+    find' f = listToMaybe . filter f++    -- prefixes of segments, in order, at least two of them+    subsequence ws ss = case pieces ws ss of+      Just sp@(_ : _ : _) -> Just sp+      _ -> Nothing+    pieces [] _ = Just []+    pieces _ [] = Nothing+    pieces ws ((off, s) : rest) =+      let common = length (takeWhile id (zipWith (==) ws (T.unpack s)))+          tryLen k = ((off, k) :) <$> pieces (drop k ws) rest+          viaThis = foldr (\k acc -> maybe acc Just (tryLen k)) Nothing [common, common - 1 .. 1]+      in case viaThis of+           Just sp -> Just sp+           Nothing -> pieces ws rest++    -- within the limit of the whole name or of a segment's start+    typo+      | k == 0 = Nothing+      | otherwise =+          case sortOn rank candidates of+            ((d, _, off, taken) : _) | d <= k -> Just (WordMatch (Typo d) (orig off (T.length taken)) [(off, T.length taken)])+            _ -> Nothing+      where+        n = T.length w+        k = typoLimit n+        candidates =+          [ (levenshteinDistance w p, T.length c - j, off, p)+          | (off, c) <- (0, name) : segs+          , j <- [max 1 (n - k) .. min (T.length c) (n + k)]+          , let p = T.take j c+          ]+        -- fewest edits; then the whole segment; then the longest+        rank (d, short, _, p) = (d, short, negate (T.length p))+    orig off len = T.take len (T.drop off name0)++-- | A word (lower case) as a word of a description, or a word's start:+-- the matched characters of the text. Words under 3 letters are not+-- looked for in descriptions.+matchDescription :: Text -> Text -> Maybe WordMatch+matchDescription w0 text+  | T.length w < 3 = Nothing+  | null spans = Nothing+  | otherwise = Just (WordMatch InDescription w spans)+  where+    w = normalise w0+    spans = descSpans w text++-- | Where a word starts a word of the text (offset, the word's length).+descSpans :: Text -> Text -> [(Int, Int)]+descSpans w text =+  [ (off, T.length w) | (off, tok) <- tokens text, w `T.isPrefixOf` T.toLower tok ]+  where+    -- a query word with an underscore matches across the text's underscores+    tokens t+      | T.any (== '_') w = wordsBy (\c -> isAlphaNum c || c == '_') t+      | otherwise = wordsBy isAlphaNum t++wordsBy :: (Char -> Bool) -> Text -> [(Int, Text)]+wordsBy keep t = go 0 (T.unpack t)+  where+    go _ [] = []+    go off s@(c : rest)+      | keep c = let (tok, rest') = span keep s+                 in (off, T.pack tok) : go (off + length tok) rest'+      | otherwise = go (off + 1) rest++normalise :: Text -> Text+normalise = T.replace "-" "_" . T.toLower++-- ============================================================================+-- Search+-- ============================================================================++-- | Which text a word matched.+data Where = OnMethodName | OnParamName | OnMethodDescription | OnParamDescription+  deriving stock (Show, Eq)++data Hit = Hit+  { hitEntry :: Entry+  , hitWords :: [(Text, Where, WordMatch)]   -- ^ per query word+  , hitScore :: Double+  }+  deriving stock (Show, Eq)++data Group = Methods | Parameters | Mentioned+  deriving stock (Show, Eq, Ord, Enum, Bounded)++-- | A named hit is a method or a parameter; one that needed a description+-- is mentioned.+hitGroup :: Hit -> Group+hitGroup h+  | not (all named (hitWords h)) = Mentioned+  | enKind (hitEntry h) == MethodEntry = Methods+  | otherwise = Parameters+  where named (_, wh, _) = wh `elem` [OnMethodName, OnParamName]++-- | Which groups to keep.+data Only = OnlyAll | OnlyMethods | OnlyParams | OnlyBoth+  deriving stock (Show, Eq)++-- | Every hit for the words (all must match), best first: by score, then+-- the shorter path, then alphabetically. A mention of a method that is a+-- named hit already (itself or by a parameter) is left out.+search :: Only -> [Entry] -> [Text] -> [Hit]+search only entries ws = filter keep ranked+  where+    hits = mapMaybe (matchEntry (map normalise ws)) entries+    namedMethods = Set.fromList [mdFullPath (enMethod (hitEntry h)) | h <- hits, hitGroup h /= Mentioned]+    keep h = groupWanted (hitGroup h)+      && not (hitGroup h == Mentioned && Set.member (mdFullPath (enMethod (hitEntry h))) namedMethods)+    groupWanted g = case only of+      OnlyAll -> True+      OnlyMethods -> g == Methods+      OnlyParams -> g == Parameters+      OnlyBoth -> g /= Mentioned+    ranked = sortOn (\h -> (negate (hitScore h), T.length (key h), key h)) hits+    key h = entryLocation (hitEntry h) <> maybe "" ((" --" <>) . pdName) (enParam (hitEntry h))++matchEntry :: [Text] -> Entry -> Maybe Hit+matchEntry ws e = do+  matched <- mapM best ws+  let onParam = any (\(_, wh, _) -> wh `elem` [OnParamName, OnParamDescription]) matched+  if enKind e == ParamEntry && not onParam+    then Nothing+    else Just (Hit e matched (sum [kindScore (wmKind m) | (_, _, m) <- matched] / fromIntegral (length matched)))+  where+    m = enMethod e+    methodDescs = filter (not . T.null) [fromMaybe "" (mdDescription m), fromMaybe "" (mdLongDescription m)]+    best w = fmap (\(wh, wm) -> (w, wh, wm)) $ pick $ case enParam e of+      Nothing ->+        [ (OnMethodName, matchName w (mdName m)) ]+          ++ [ (OnMethodDescription, matchDescription w d) | d <- methodDescs ]+      Just p ->+        [ (OnParamName, matchName w (pdName p))+        , (OnMethodName, matchName w (mdName m)) ]+          ++ [ (OnParamDescription, matchDescription w d) | Just d <- [pdDescription p] ]+    -- the best-scoring; on a tie, the first (the parameter's own name)+    pick cs = foldl' better Nothing [(wh, x) | (wh, Just x) <- cs]+    better Nothing c = Just c+    better (Just a@(_, x)) c@(_, y)+      | kindScore (wmKind y) > kindScore (wmKind x) = Just c+      | otherwise = Just a++-- | The query as the top hit took it — a typo or an abbreviation said as+-- the name it matched — when it differs from what was typed.+takenAs :: [Hit] -> Maybe Text+takenAs [] = Nothing+takenAs (h : _)+  | taken == typed = Nothing+  | otherwise = Just (T.unwords taken)+  where+    typed = [w | (w, _, _) <- hitWords h]+    taken = [ case wmKind m of { Typo _ -> wmTaken m; Subsequence -> wmTaken m; _ -> w } | (w, _, m) <- hitWords h ]++-- ============================================================================+-- The answer+-- ============================================================================++-- | What @_find@ says: its page, or one JSON object per hit (@-j@).+data Answer = Answer+  { anMatched :: Bool      -- ^ anything found (else the page is the nearest names)+  , anText    :: Text      -- ^ the page+  , anJson    :: [Value]   -- ^ the hits, at most the limit, best first+  , anScope   :: Text      -- ^ where it looked (@menger tickets@)+  }++-- | The answer to a search: given synapse's command line (@synapse -P+-- 4455@), the backend, whether to embolden, and the IR (the caller's view).+answer :: Text -> Text -> Bool -> FindOpts -> IR -> Answer+answer program backend bold FindOpts{..} ir = Answer+  { anMatched = not (null hits)+  , anText = if null hits then renderNoMatch fr (nearest entries ws) else renderFind fr hits+  , anJson = map (hitJson ir) (take foLimit hits)+  , anScope = T.unwords (backend : path)+  }+  where+    (path, ws) = narrowPath ir foTerms+    entries = catalogEntries path ir+    only = case (foMethods, foParams) of+      (True, True) -> OnlyBoth+      (True, False) -> OnlyMethods+      (False, True) -> OnlyParams+      _ -> OnlyAll+    hits = search only entries ws+    fr = FindRender+      { frProgram = program+      , frBackend = backend+      , frPath = path+      , frQuery = ws+      , frLimit = foLimit+      , frBold = bold+      , frIR = ir+      }++-- ============================================================================+-- Rendering+-- ============================================================================++-- | What a rendering needs beside the hits.+data FindRender = FindRender+  { frProgram :: Text      -- ^ synapse and its global options (@synapse -P 4455@)+  , frBackend :: Text      -- ^ the backend (@menger@)+  , frPath    :: [Text]    -- ^ the activation path the search was narrowed to+  , frQuery   :: [Text]    -- ^ the words, as typed+  , frLimit   :: Int+  , frBold    :: Bool      -- ^ on a terminal: the matched characters in bold+  , frIR      :: IR+  }++width :: Int+width = 80++-- | A description keeps at least this many columns, past the 80 when the+-- columns before it are wide: a line too short to say anything is no help.+minDesc :: Int+minDesc = 36++-- | SYNAPSE-17: the hits in help's shape — a header (how many, for what,+-- as what), METHODS · PARAMETERS · MENTIONED IN with the locations in one+-- column and the flags in the next, the descriptions fitted to the line,+-- how many more the limit held back, and how to see the top hit's options.+renderFind :: FindRender -> [Hit] -> Text+renderFind FindRender{..} hits = T.unlines (dropTrailingBlanks body)+  where+    total = length hits+    shown = take (max 0 frLimit) hits+    scope = T.unwords (frBackend : frPath)+    query = T.unwords frQuery+    header =+      T.pack (show total) <> (if total == 1 then " match" else " matches")+        <> " for '" <> query <> "'"+        <> maybe "" (\t -> " (as '" <> t <> "')") (takenAs hits)+        <> " in " <> scope++    body = concat+      [ [header]+      , concat [ section g [h | h <- shown, hitGroup h == g] | g <- [minBound .. maxBound] ]+      , [ "" | total > length shown ]+      , [ T.pack (show (total - length shown)) <> " more: '--limit " <> T.pack (show total) <> "' shows them all."+        | total > length shown ]+      , case shown of+          (h : _) -> ["", "Run '" <> frProgram <> " " <> frBackend <> " " <> entryLocation (hitEntry h) <> " --help' for its options."]+          [] -> []+      ]++    section _ [] = []+    section g hs = "" : groupTitle g : concatMap row hs++    locW = maximum (0 : map (T.length . entryLocation . hitEntry) shown)+    col1 = 2 + locW + 4+    paramLabels = [flagLabel frIR p | h <- shown, Just p <- [enParam (hitEntry h)]]+    flagW = maximum (0 : map T.length paramLabels)+    col2 = col1 + flagW + 4++    row h = case enParam (hitEntry h) of+      Nothing ->+        let descW = max minDesc (width - col1)+        in [ T.stripEnd ("  " <> locCell h <> descCell h descW (methodText (enMethod (hitEntry h)))) ]+      Just p ->+        let descW = max minDesc (width - col2)+            label = flagLabel frIR p+            flagOff = T.length (fst (T.breakOn "--" label)) + 2+            flagSpans = [ (flagOff + o, l) | (_, OnParamName, m) <- hitWords h, (o, l) <- wmSpans m ]+            flag = styled frBold label flagSpans <> T.replicate (flagW + 4 - T.length label) " "+            values = case paramValuesOf frIR p of+              Just vs@(_ : _) -> map (T.replicate col2 " " <>) (wrapWords descW ("[values: " <> T.intercalate ", " vs <> "]"))+              _ -> []+        in T.stripEnd ("  " <> locCell h <> flag <> descCell h descW (fromMaybe "" (pdDescription p))) : values++    -- the location, the method's matched characters in bold+    locCell h =+      let e = hitEntry h+          loc = entryLocation e+          nameOff = T.length loc - T.length (mdName (enMethod e))+          spans = [ (nameOff + o, l) | (_, OnMethodName, m) <- hitWords h, (o, l) <- wmSpans m ]+      in styled frBold loc spans <> T.replicate (locW + 4 - T.length loc) " "++    -- a named hit's summary; a mention's shows where the word is+    descCell h w text =+      let descWords = [ wd | (wd, wh, _) <- hitWords h, wh `elem` [OnMethodDescription, OnParamDescription] ]+          shownText = if hitGroup h == Mentioned then snippet w descWords text (matchSource h text) else fitText w (summarize text)+          spans = concat [ descSpans (normalise wd) shownText | wd <- descWords ]+      in styled frBold shownText spans++    methodText m = case mdDescription m of+      Just d | not (T.null (T.strip d)) -> d+      _ -> fromMaybe "" (mdLongDescription m)++    -- the text a mention was found in: the one shown, else (a method's)+    -- its long description+    matchSource h shown = case (enParam (hitEntry h), mdLongDescription (enMethod (hitEntry h))) of+      (Nothing, Just long) -> shown <> "\n" <> long+      _ -> shown++groupTitle :: Group -> Text+groupTitle = \case+  Methods -> "METHODS"+  Parameters -> "PARAMETERS"+  Mentioned -> "MENTIONED IN"++-- | A description cut to show a word it was found by (in @source@, the+-- description and what else was searched): the summary when the word is in+-- it, else as much of the summary as fits, then @… word …@.+snippet :: Int -> [Text] -> Text -> Text -> Text+snippet w ws text source+  | null ws = fitText w summary+  | any (\wd -> not (null (descSpans (normalise wd) fitted))) ws = fitted+  | otherwise = case firstToken of+      Nothing -> fitted+      Just tok ->+        let tailT = " \x2026 " <> tok <> " \x2026"+            room = w - T.length tailT+            lead = T.dropWhileEnd (== '\x2026') (fitText room summary)+        in if room >= 12 then T.stripEnd lead <> tailT else fitText w ("\x2026 " <> tok <> " \x2026")+  where+    summary = summarize text+    fitted = fitText w summary+    -- the text's word (as written) where the first of the words is found+    firstToken = listToMaybe+      [ T.dropAround (`elem` ("()[]{},.;:'\"`" :: String)) whole+      | wd <- ws+      , (off, _) <- take 1 (descSpans (normalise wd) source)+      , let whole = wordAt off source+      ]+    wordAt off t =+      let before = T.takeWhileEnd (not . isSpace') (T.take off t)+          after = T.takeWhile (not . isSpace') (T.drop off t)+          isSpace' c = c == ' ' || c == '\n'+      in before <> after++-- | Text with the characters at the spans in bold (when asked).+styled :: Bool -> Text -> [(Int, Int)] -> Text+styled False t _ = t+styled True t spans+  | null marks = t+  | otherwise = T.pack (go 0 (T.unpack t))+  where+    marks = Set.fromList [ i | (o, l) <- spans, i <- [o .. o + l - 1], i >= 0, i < T.length t ]+    go _ [] = []+    go i s@(_ : _)+      | Set.member i marks =+          let (run, rest) = splitAt (runLen i) s+          in "\ESC[1m" ++ run ++ "\ESC[22m" ++ go (i + length run) rest+      | otherwise = let (c : rest) = s in c : go (i + 1) rest+    runLen i = length (takeWhile (`Set.member` marks) [i ..])++dropTrailingBlanks :: [Text] -> [Text]+dropTrailingBlanks = reverse . dropWhile (T.null . T.strip) . reverse++-- | The three methods whose names are nearest the query (by edit distance+-- to the name or to one of its segments).+nearest :: [Entry] -> [Text] -> [Entry]+nearest entries ws = take 3 (sortOn rank candidates)+  where+    methods = [e | e <- entries, enKind e == MethodEntry]+    -- the introspection every hub has (schema, hashes) is never what was meant+    candidates = case filter ((`notElem` ["schema", "hashes"]) . mdName . enMethod) methods of+      [] -> methods+      cs -> cs+    q = T.intercalate "_" (map normalise ws)+    dist e =+      let name = T.toLower (mdName (enMethod e))+      in minimum (levenshteinDistance q name : [levenshteinDistance q s | (_, s) <- segments name])+    rank e = (dist e, T.length (entryLocation e), entryLocation e)++-- | Nothing matched: say so, then the nearest names.+renderNoMatch :: FindRender -> [Entry] -> Text+renderNoMatch FindRender{..} near = T.unlines $+  [ "No match for '" <> T.unwords frQuery <> "' in " <> T.unwords (frBackend : frPath) <> "." ]+  ++ if null near then [] else+       [ "", "Nearest:" ]+       ++ [ T.stripEnd ("  " <> T.justifyLeft (locW + 4) ' ' (entryLocation e) <> fitText (max minDesc (width - (2 + locW + 4))) (summarize (desc e)))+          | e <- near ]+  where+    locW = maximum (0 : map (T.length . entryLocation) near)+    desc e = fromMaybe "" (mdDescription (enMethod e))++-- | One hit as JSON, for @-j@.+hitJson :: IR -> Hit -> Value+hitJson ir h = object $+  [ "kind" .= (case enKind e of { MethodEntry -> "method"; ParamEntry -> "param" } :: Text)+  , "path" .= mdFullPath m+  ]+  ++ case enParam e of+       Just p ->+         [ "param" .= pdName p+         , "type" .= flagType ir (pdType p)+         , "required" .= pdRequired p+         , "description" .= fromMaybe "" (pdDescription p)+         ] ++ maybe [] (\vs -> ["values" .= vs]) (paramValuesOf ir p)+       Nothing -> [ "description" .= fromMaybe "" (mdDescription m) ]+  +++  [ "group" .= (case hitGroup h of { Methods -> "methods"; Parameters -> "parameters"; Mentioned -> "mentioned" } :: Text)+  , "score" .= (fromIntegral (round (hitScore h * 100) :: Int) / 100 :: Double)+  , "matched" .= T.unwords [ case wmKind wm of { Typo _ -> wmTaken wm; Subsequence -> wmTaken wm; _ -> w } | (w, _, wm) <- hitWords h ]+  ]+  where+    e = hitEntry h+    m = enMethod e

@@ -40,7 +40,7 @@ import Synapse.Monad import Synapse.IR.Types hiding (QualifiedName(..), qualifiedNameFull) import Synapse.IR.Types (QualifiedName(..), qualifiedNameFull, synapseVersion)-import Plexus.Schema.Recursive (DeprecationInfo, ParamSchema(..))+import Plexus.Schema.Recursive (DeprecationInfo, ParamSchema(..), paramValues)  -- ============================================================================ -- Building IR@@ -123,6 +123,15 @@       childHashes = fromMaybe Map.empty (irPluginHashes childIR)       allHashes = Map.insert namespace hashInfo childHashes +  -- REQ-5: capture per-plugin PlexusRequest schema (psRequest from wire schema).+  -- HEADERS-1 stub: plexus-protocol's PluginSchema does not yet expose+  -- psRequest (cross-repo patch pending). Treat as always-Nothing so the+  -- synapse binary builds; REQ-5 rendering becomes a no-op until the field+  -- lands in plexus-protocol.+  let _ = schema  -- suppress unused-binding warning when REQ-5 is stubbed+      childRequests = fromMaybe Map.empty (irPluginRequests childIR)+      allRequests = childRequests+   pure $ IR     { irVersion = irVersion emptyIR  -- Use version from emptyIR     , irBackend = irBackend emptyIR  -- Will be set by buildIR@@ -132,6 +141,11 @@     , irMethods = Map.union localMethods (irMethods childIR)     , irPlugins = Map.insert namespace pluginMethods (irPlugins childIR)     , irPluginHashes = Just allHashes  -- V2: Store hash info per plugin+    , irPluginRequests = if Map.null allRequests then Nothing else Just allRequests+      -- AUTH-9: this plugin's default roles, beside its children's.+    , irPluginRoles = case (psRoles schema, irPluginRoles childIR) of+        (Nothing, childRoles) -> childRoles+        (Just roles, childRoles) -> Just (Map.insert namespace roles (fromMaybe Map.empty childRoles))     }  irAlgebra (MethodF method namespace path) = do@@ -147,6 +161,8 @@     , irMethods = Map.singleton fullPath mdef     , irPlugins = Map.singleton namespace [methodName method]     , irPluginHashes = Nothing  -- Methods don't have plugin-level hashes+    , irPluginRequests = Nothing  -- Methods don't carry request schemas+    , irPluginRoles = Nothing  -- Methods don't carry roles     }  -- ============================================================================@@ -389,6 +405,11 @@           -- tags. plexus-protocol defaults this to MethodRoleRpc when           -- the upstream schema omits the field, so pre-IR servers           -- continue to work with no change in behaviour.+        , mdGrant = methodGrant method+        , mdTarget = methodTarget method+        , mdLongDescription = methodLongDescription method+          -- AUTH-9: what the method requires and its doc comment, lifted+          -- for hub-codegen; Nothing from a pre-AUTH schema.         }   in (allTypes, mdef) @@ -467,6 +488,16 @@           (ps:_) -> paramDeprecation ps           []     -> Nothing +      -- REQ-6/REQ-9: extract @x-plexus-source@ from each property's schema.+      -- Carries where the param value comes from (auth, cookie, header,+      -- query, derived, rpc) so downstream renderers and codegen can+      -- emit per-param annotations. Nothing means the schema had no+      -- extension — treated as RPC.+      extractSource :: Value -> Maybe Value+      extractSource propSchema = case propSchema of+        Object po -> KM.lookup "x-plexus-source" po+        _         -> Nothing+       -- Build param defs       params =         [ ParamDef@@ -476,6 +507,8 @@             , pdRequired = K.toText k `elem` required             , pdDefault = extractDefault v             , pdDeprecation = lookupDeprecation (K.toText k)+            , pdSource = extractSource v+            , pdValues = paramValues v             }         | (k, v) <- props         ]

@@ -12,6 +12,7 @@   , newIRCache   , lookupIR   , insertIR+  , irCacheKey   , clearCache   , getCacheStats   , CacheStats(..)@@ -81,7 +82,19 @@     , cacheStats = stats     } --- | Look up IR by hash+-- | AUTH-8: the key an IR is kept under — the plugin hash, qualified by+-- the caller's view when the hub has one (@VIEW_HASH@ joined with @-@, a+-- file name). Callers pass this to 'lookupIR' / 'insertIR' so two+-- callers' views of one hub never share an IR on disk.+irCacheKey :: Maybe Text -> Text -> Text+irCacheKey Nothing hash = hash+irCacheKey (Just v) hash+  | T.null v = hash+  | otherwise = T.map safe v <> "-" <> hash+  where+    safe c = if c `elem` ("/\\:" :: String) then '_' else c++-- | Look up IR by hash (see 'irCacheKey' for a view's) lookupIR :: IRCache -> Text -> IO (Maybe IR) lookupIR IRCache{..} hash   | not (cacheEnabled cacheConfig) = pure Nothing

@@ -62,8 +62,11 @@  import Control.Applicative ((<|>)) import Data.Aeson+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as KM import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic)@@ -130,10 +133,24 @@   , irMethods      :: Map Text MethodDef           -- ^ All methods, keyed by full path (e.g., "cone.chat")   , irPlugins      :: Map Text [Text]              -- ^ Plugin -> method names mapping   , irPluginHashes :: Maybe (Map Text PluginHashInfo)  -- ^ V2: Hash information per plugin+  , irPluginRequests :: Maybe (Map Text Aeson.Value)   -- ^ REQ-5: per-plugin PlexusRequest JSON Schema (Nothing = no request struct)+  , irPluginRoles  :: Maybe (Map Text (Map Text [Text]))+    -- ^ AUTH-9: per-plugin default roles (AUTH-3's @PluginSchema.roles@),+    --   plugin namespace → role → the grants it lists. Omitted from the JSON+    --   when 'Nothing', so an IR from a pre-AUTH schema is unchanged.   }   deriving stock (Show, Eq, Generic)-  deriving anyclass (ToJSON, FromJSON)+  deriving anyclass (FromJSON) +-- | Generic, except that @irPluginRoles@ is left out when 'Nothing' (AUTH-9):+--   an IR built from a schema without roles serializes exactly as before.+instance ToJSON IR where+  toJSON ir = case genericToJSON defaultOptions ir of+    Object o -> Object $ case irPluginRoles ir of+      Nothing -> KM.delete "irPluginRoles" o+      Just _ -> o+    v -> v+ -- | Empty IR for folding emptyIR :: IR emptyIR = IR@@ -145,6 +162,8 @@   , irMethods = Map.empty   , irPlugins = Map.empty   , irPluginHashes = Nothing+  , irPluginRequests = Nothing+  , irPluginRoles = Nothing   }  -- | Merge two IRs (for combining results from tree walk)@@ -162,6 +181,16 @@       (Just ha, Nothing) -> Just ha       (Nothing, Just hb) -> Just hb       (Nothing, Nothing) -> Nothing+  , irPluginRequests = case (irPluginRequests a, irPluginRequests b) of+      (Just ra, Just rb) -> Just (Map.union ra rb)+      (Just ra, Nothing) -> Just ra+      (Nothing, Just rb) -> Just rb+      (Nothing, Nothing) -> Nothing+  , irPluginRoles = case (irPluginRoles a, irPluginRoles b) of+      (Just ra, Just rb) -> Just (Map.union ra rb)+      (Just ra, Nothing) -> Just ra+      (Nothing, Just rb) -> Just rb+      (Nothing, Nothing) -> Nothing   }  -- ============================================================================@@ -273,6 +302,14 @@     --     -- Consumed by hub-codegen (Rust field @md_role@, JSON key @mdRole@)     -- to emit typed-handle clients for @DynamicChild@ methods.+  , mdGrant       :: Maybe Text+    -- ^ AUTH-9: the method's grant (AUTH-3's @MethodSchema.grant@),+    --   @<activation>.<method>@, e.g. @tickets.set_status@.+  , mdTarget      :: Maybe Text+    -- ^ AUTH-9: the param that locates what a call acts on (@MethodSchema.target@).+  , mdLongDescription :: Maybe Text+    -- ^ AUTH-9: the doc comment beside the short description+    --   (@MethodSchema.long_description@).   }   deriving stock (Show, Eq, Generic) @@ -284,7 +321,7 @@ --   names used verbatim as JSON keys; @Maybe@ fields omitted when --   @Nothing@ to match aeson's legacy behaviour). instance ToJSON MethodDef where-  toJSON MethodDef{..} = object+  toJSON MethodDef{..} = object $     [ "mdName"                .= mdName     , "mdFullPath"            .= mdFullPath     , "mdNamespace"           .= mdNamespace@@ -296,6 +333,12 @@     , "mdBidirResponseType"   .= mdBidirResponseType     , "mdBidirResponseSchema" .= mdBidirResponseSchema     , "mdRole"                .= mdRole+    ] <> catMaybes+    -- AUTH-9: present only when the schema says them, so a pre-AUTH+    -- schema's IR is unchanged.+    [ ("mdGrant" .=) <$> mdGrant+    , ("mdTarget" .=) <$> mdTarget+    , ("mdLongDescription" .=) <$> mdLongDescription     ]  instance FromJSON MethodDef where@@ -311,6 +354,9 @@     <*> o .:? "mdBidirResponseType"     <*> o .:? "mdBidirResponseSchema"     <*> o .:? "mdRole" .!= MethodRoleRpc+    <*> o .:? "mdGrant"+    <*> o .:? "mdTarget"+    <*> o .:? "mdLongDescription"  -- | A parameter definition data ParamDef = ParamDef@@ -326,6 +372,18 @@     --   Defaults to 'Nothing' when the schema lacks @param_schemas@, so     --   pre-IR-5 producers and non-deprecated parameters are indistinguishable     --   at the rendering layer.+  , pdSource      :: Maybe Value+    -- ^ REQ-6/REQ-9: @x-plexus-source@ extension annotation, when the wire+    --   schema declared one on this parameter. The value is the raw JSON+    --   object (e.g. @{ "from": "auth", "resolver": "self.db.validate_user" }@+    --   or @{ "from": "cookie", "key": "access_token" }@). Consumers (synapse+    --   renderer, hub-codegen JSDoc) read this to identify where each param+    --   is sourced from. @Nothing@ means the schema lacked the extension —+    --   treat as RPC-sourced.+  , pdValues      :: Maybe [Text]+    -- ^ SYNAPSE-17: the values the parameter takes, as its schema hints them+    --   (@x-plexus-values@). Omitted from the JSON when 'Nothing', so an IR+    --   from a schema without the hint serializes exactly as before.   }   deriving stock (Show, Eq, Generic) @@ -333,14 +391,16 @@ --   deserializing IR JSON that predates IR-14. --   All other fields preserve the derivation defaults. instance ToJSON ParamDef where-  toJSON ParamDef{..} = object+  toJSON ParamDef{..} = object $     [ "pdName"        .= pdName     , "pdType"        .= pdType     , "pdDescription" .= pdDescription     , "pdRequired"    .= pdRequired     , "pdDefault"     .= pdDefault     , "pdDeprecation" .= pdDeprecation+    , "pdSource"      .= pdSource     ]+    ++ maybe [] (\vs -> ["pdValues" .= vs]) pdValues  instance FromJSON ParamDef where   parseJSON = withObject "ParamDef" $ \o -> ParamDef@@ -350,6 +410,8 @@     <*> o .:  "pdRequired"     <*> o .:? "pdDefault"     <*> o .:? "pdDeprecation"+    <*> o .:? "pdSource"+    <*> o .:? "pdValues"  -- ============================================================================ -- Type References

@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++-- | IDENTITY-43: the command lines.+--+-- @+-- synapse _key new [NAME] [--store auto|file|keychain]   -- NAME defaults to "default"; never overwrites+-- synapse _key show [NAME]                                -- key:\<hex\>+-- synapse _key list+-- synapse [-H HOST] -P PORT _login BACKEND                       -- a person: the browser (AUTH-8)+-- synapse [-H HOST] -P PORT _login BACKEND [--key NAME] --as AGENT [--scope role\@SCOPE …] [--ttl SECS]+-- synapse [-H HOST] -P PORT _logout BACKEND [--as AGENT]+-- @+--+-- @_key@ is local and runs here; @_login@ / @_logout@ are parsed here and+-- run by the executable, which knows how to reach a backend.+module Synapse.Identity.Command+  ( -- * _key+    KeyCommand(..)+  , keyCommandInfo+  , runKeyCommand++    -- * _login / _logout+  , LoginOpts(..)+  , loginInfo+  , LogoutOpts(..)+  , logoutInfo+  , splitScopes+  ) where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Options.Applicative+import System.Exit (ExitCode(..))+import System.IO (stderr)++import Synapse.Identity.Proof+import Synapse.Identity.Store++-- ============================================================================+-- _key+-- ============================================================================++data KeyCommand+  = KeyNew Text StorePref+  | KeyShow Text+  | KeyList+  deriving (Eq, Show)++keyCommandInfo :: ParserInfo KeyCommand+keyCommandInfo = info (parser <**> helper)+  ( fullDesc+ <> header "synapse _key - the Ed25519 keys an agent proves who it is with"+ <> progDesc "Kept in the OS keychain when one answers, else ~/.plexus/keys/NAME.key (0600). Read in the order: PLEXUS_KEY (base64 seed), keychain, $CREDENTIALS_DIRECTORY/NAME.key, ~/.plexus/keys/NAME.key."+  )+  where+    parser = hsubparser+      ( command "new" (info newP (progDesc "Make a key (NAME defaults to 'default'); prints key:<hex>. Never overwrites."))+     <> command "show" (info showP (progDesc "Print a key's principal, key:<hex>"))+     <> command "list" (info (pure KeyList) (progDesc "Every key synapse can find, and where"))+      )+    nameArg = T.pack <$> strArgument (metavar "NAME" <> value "default" <> showDefault)+    newP = KeyNew <$> nameArg <*> option storeR+      ( long "store" <> metavar "auto|file|keychain" <> value StoreAuto+     <> help "Where to keep it (default auto: the keychain when it answers, else the file)" )+    showP = KeyShow <$> nameArg+    storeR = eitherReader $ \case+      "auto" -> Right StoreAuto+      "file" -> Right StoreFile+      "keychain" -> Right StoreKeychain+      s -> Left ("--store is auto, file or keychain, not " <> s)++runKeyCommand :: StoreEnv -> KeyCommand -> IO ExitCode+runKeyCommand st = \case+  KeyNew name pref+    | not (validKeyName name) -> bad ("a key name is 1-64 of A-Z a-z 0-9 . _ - (not '" <> name <> "')")+    | otherwise -> keyExists st name >>= \case+        Just src -> bad ("key " <> name <> " already exists (" <> renderKeySource src <> "); synapse never overwrites a key")+        Nothing -> do+          seed <- generateSeed+          writeKey st pref name seed >>= \case+            Left e -> bad e+            Right src -> do+              TIO.putStrLn (principalOf seed)+              TIO.hPutStrLn stderr ("synapse: key " <> name <> " kept in " <> renderKeySource src)+              pure ExitSuccess+  KeyShow name -> lookupKey st name >>= \case+    Left e -> bad e+    Right Nothing -> bad ("no key " <> name <> " (synapse _key new " <> name <> ")")+    Right (Just (seed, _)) -> ExitSuccess <$ TIO.putStrLn (principalOf seed)+  KeyList -> do+    keys <- listKeys st+    rows <- mapM describe keys+    if null rows+      then TIO.hPutStrLn stderr "synapse: no keys (synapse _key new)"+      else mapM_ TIO.putStrLn (align' rows)+    pure ExitSuccess+  where+    bad msg = ExitFailure 1 <$ TIO.hPutStrLn stderr ("synapse: " <> msg)+    describe (name, src) = do+      -- the principal from the store that listed it (PLEXUS_KEY would+      -- answer for every name, so it is not asked here)+      p <- lookupKey st { stEnv = \k -> if k == "PLEXUS_KEY" then pure Nothing else stEnv st k } name+      let principal = case p of+            Right (Just (seed, _)) -> principalOf seed+            Right Nothing -> "?"+            Left e -> "(" <> e <> ")"+      pure (name, principal, renderKeySource src)+    align' rows =+      let w = maximum [T.length n | (n, _, _) <- rows]+      in [T.justifyLeft w ' ' n <> "  " <> p <> "  " <> s | (n, p, s) <- rows]++-- ============================================================================+-- _login / _logout+-- ============================================================================++data LoginOpts = LoginOpts+  { loBackend :: Text+  , loKey     :: Maybe Text   -- ^ AUTH-8: none (and no agent named) is a person signing in through the browser+  , loAs      :: Maybe Text+  , loScope   :: [Text]+  , loTtl     :: Maybe Integer+  } deriving (Eq, Show)++loginInfo :: ParserInfo LoginOpts+loginInfo = info (p <**> helper)+  ( fullDesc+ <> header "synapse _login - sign in; later calls to this backend carry the session by themselves"+ <> progDesc "A person (no --key, no --as): opens the browser to sign in and waits on a loopback port (127.0.0.1) for it to come back (auth.login's browser flow; 5 minutes). An agent (--key and/or --as): proves the key (a plexus-key proof at the upgrade) and asks auth.login for a session (session.login on a hub without auth). Either way the session is kept (keychain, else ~/.plexus/sessions/HOST_PORT/AGENT.json; a person's under the name 'me') and becomes this backend's default. Global options (-H, -P) go before _login."+  )+  where+    p = LoginOpts+      <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The hub's name, e.g. menger"))+      <*> optional (T.pack <$> strOption (long "key" <> short 'k' <> metavar "NAME" <> help "The key to prove (an agent; 'default' when only --as is given)"))+      <*> optional (T.pack <$> strOption (long "as" <> metavar "AGENT" <> help "The agent id to log in as (else SYNAPSE_AS)"))+      <*> (splitScopes <$> many (T.pack <$> strOption (long "scope" <> metavar "ROLE@SCOPE" <> help "The session's ceiling, e.g. editor@MENGER-12 (repeat, or commas); default: the key's own grants")))+      <*> optional (option auto (long "ttl" <> metavar "SECS" <> help "Session lifetime in seconds (the server's default 12 h, at most 24 h)"))++data LogoutOpts = LogoutOpts+  { lgBackend :: Text+  , lgAs      :: Maybe Text+  } deriving (Eq, Show)++logoutInfo :: ParserInfo LogoutOpts+logoutInfo = info (p <**> helper)+  ( fullDesc+ <> header "synapse _logout - end a session (session.logout) and forget it"+  )+  where+    p = LogoutOpts+      <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The hub's name, e.g. menger"))+      <*> optional (T.pack <$> strOption (long "as" <> metavar "AGENT" <> help "Which agent's session (else SYNAPSE_AS, else the backend's default)"))++-- | @--scope a,b --scope c@ → @[a, b, c]@.+splitScopes :: [Text] -> [Text]+splitScopes = filter (not . T.null) . map T.strip . concatMap (T.splitOn ",")

@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings #-}++-- | IDENTITY-43: an agent's key and the proof it logs in with — IDENTITY-40's+-- "The wire", exactly.+--+-- A key is an Ed25519 seed (32 bytes); its principal is+-- @key:\<64 lowercase hex of the public key\>@. A proof is a bearer value+--+-- @+-- plexus-key.\<base64url-nopad of UTF-8 JSON\>+-- {"v":1,"key":"\<64 hex\>","aud":"\<ws url\>","agent":"\<id\>","nonce":"\<b64url\>","ts":\<unix s\>,"sig":"\<b64url\>"}+-- @+--+-- where @sig@ is Ed25519 over the UTF-8 bytes of exactly+-- @plexus-key-login/v1\\n\<aud\>\\n\<agent\>\\n\<nonce\>\\n\<ts\>@ (no trailing+-- newline). The JSON's fields go in that order, compact, so the same+-- inputs give the same proof on every side (Ed25519 signing is+-- deterministic): see the fixed vector in @test/IdentitySpec.hs@.+module Synapse.Identity.Proof+  ( -- * Keys+    Seed+  , seedFromBytes+  , seedBytes+  , generateSeed+  , publicKeyHex+  , principalOf++    -- * The proof+  , canonicalMessage+  , buildProof+  , newNonce+  , wsAudience+  , validAgent+  , validKeyName++    -- * Encodings+  , b64urlNoPad+  , hexText+  , decodeSeedText+  , encodeSeedText+  ) where++import qualified Crypto.PubKey.Ed25519 as Ed+import Crypto.Error (CryptoFailable(..))+import Crypto.Random (getRandomBytes)+import qualified Data.Aeson.Encoding as AE+import Data.Aeson ((.=))+import qualified Data.ByteArray as BA+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Base64.URL as B64U+import qualified Data.ByteString.Lazy as LBS+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Text.Printf (printf)++-- | An Ed25519 seed: the 32 bytes a key is.+newtype Seed = Seed ByteString+  deriving (Eq)++instance Show Seed where+  show _ = "Seed <redacted>"++-- | A seed from its 32 bytes, or why these are not one.+seedFromBytes :: ByteString -> Either Text Seed+seedFromBytes b+  | BS.length b == 32 = Right (Seed b)+  | otherwise = Left $ "a key is 32 bytes, not " <> T.pack (show (BS.length b))++seedBytes :: Seed -> ByteString+seedBytes (Seed b) = b++-- | A new seed from the system's randomness.+generateSeed :: IO Seed+generateSeed = Seed <$> getRandomBytes 32++secretOf :: Seed -> Ed.SecretKey+secretOf (Seed b) = case Ed.secretKey b of+  CryptoPassed sk -> sk+  CryptoFailed e -> error ("Synapse.Identity.Proof: " <> show e)  -- length is checked at construction++publicOf :: Seed -> Ed.PublicKey+publicOf = Ed.toPublic . secretOf++-- | The public key, 64 lowercase hex.+publicKeyHex :: Seed -> Text+publicKeyHex = hexText . BA.convert . publicOf++-- | @key:\<64 hex\>@ — the principal a key is.+principalOf :: Seed -> Text+principalOf s = "key:" <> publicKeyHex s++-- | The bytes the signature covers, as text:+-- @plexus-key-login/v1\\n\<aud\>\\n\<agent\>\\n\<nonce\>\\n\<ts\>@.+canonicalMessage :: Text -> Text -> Text -> Integer -> Text+canonicalMessage aud agent nonce ts =+  T.intercalate "\n" ["plexus-key-login/v1", aud, agent, nonce, T.pack (show ts)]++-- | The proof for this key, audience (the ws URL dialed), agent, nonce (its+-- raw bytes; 32 of them) and time (unix seconds).+buildProof :: Seed -> Text -> Text -> ByteString -> Integer -> Text+buildProof seed aud agent nonceRaw ts =+  let sk = secretOf seed+      pk = Ed.toPublic sk+      nonce = b64urlNoPad nonceRaw+      msg = TE.encodeUtf8 (canonicalMessage aud agent nonce ts)+      sig = Ed.sign sk pk msg+      json = AE.encodingToLazyByteString $ AE.pairs $ mconcat+        [ "v" .= (1 :: Int)+        , "key" .= hexText (BA.convert pk)+        , "aud" .= aud+        , "agent" .= agent+        , "nonce" .= nonce+        , "ts" .= ts+        , "sig" .= b64urlNoPad (BA.convert sig)+        ]+  in "plexus-key." <> b64urlNoPad (LBS.toStrict json)++-- | 32 random bytes for a proof's nonce.+newNonce :: IO ByteString+newNonce = getRandomBytes 32++-- | The URL a proof's @aud@ names: the socket synapse dials,+-- @ws://HOST:PORT@ (SCAFFOLD-21: behind TLS, @wss://HOST@ —+-- 'Synapse.Endpoint.audience' says which for an address).+wsAudience :: Text -> Int -> Text+wsAudience host port = "ws://" <> host <> ":" <> T.pack (show port)++-- | An agent id: 1–64 of @[A-Za-z0-9._-]@.+validAgent :: Text -> Bool+validAgent a = not (T.null a) && T.length a <= 64 && T.all idChar a++-- | A key's name: the same alphabet (it names a file).+validKeyName :: Text -> Bool+validKeyName n = validAgent n && n `notElem` [".", ".."]++idChar :: Char -> Bool+idChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("._-" :: String)++-- | base64url without padding.+b64urlNoPad :: ByteString -> Text+b64urlNoPad = TE.decodeLatin1 . B64U.encodeUnpadded++-- | Lowercase hex.+hexText :: ByteString -> Text+hexText = T.pack . concatMap (printf "%02x") . BS.unpack++-- | A seed as it is kept (base64 of the 32 bytes; @PLEXUS_KEY@'s form).+encodeSeedText :: Seed -> Text+encodeSeedText (Seed b) = TE.decodeLatin1 (B64.encode b)++-- | A kept seed back: standard or url base64, padded or not, surrounding+-- whitespace ignored.+decodeSeedText :: Text -> Either Text Seed+decodeSeedText t =+  let s = TE.encodeUtf8 (T.strip t)+      std = B64.decode s+      url = B64U.decodeUnpadded s+      urlp = B64U.decode s+  in case [b | Right b <- [std, urlp, url]] of+       (b : _) -> seedFromBytes b+       [] -> Left "not base64"

@@ -0,0 +1,521 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}++-- | IDENTITY-43: logging in from a key, and the session every later call+-- carries by itself.+--+-- * 'loginWithKey' opens a connection presenting a fresh proof+--   (@Authorization: Bearer plexus-key.…@) and asks @session.login@ on it.+-- * 'sessionFor' finds the session a call to @HOST:PORT@ goes with — the+--   agent named (@--as@ / @SYNAPSE_AS@) or the backend's default — and, when+--   its @expires_at@ has passed, logs in again from the key it was made+--   from before the call is sent.+-- * 'reattest' does that on demand, when the server refuses the session+--   (a 401 at the upgrade, or the "you have signed out" error): the caller+--   retries once.+--+-- The session found for an address is remembered for the rest of the+-- process, so the discovery probe and the call carry the same token.+module Synapse.Identity.Session+  ( -- * Login / logout+    LoginResult(..)+  , loginWithKey+  , logoutWithToken++    -- * A person (AUTH-8: the loopback flow)+  , loginPerson+  , whoamiWith+  , whoamiM++    -- * The session a call carries+  , ActiveSession(..)+  , sessionFor+  , reattest+  , reattestAgain+  , canReattest+  , bearer++    -- * Recognising an ended session+  , isSessionEndedItem+  , isSessionEndedText+  , isUpgradeRefused++    -- * Within one call+  , markSessionEnded+  , takeSessionEnded+  , notePrinted+  , printedAny+  , noteRefused+  , wasRefused+  , currentCeiling+  ) where++import Control.Exception (SomeException, try)+import Control.Monad (when)+import Data.Aeson (Value(..), object, (.=))+import qualified Data.Aeson.KeyMap as KM+import Data.IORef+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)+import Data.Scientific (toBoundedInteger)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.Time.Clock.POSIX (getPOSIXTime)+import qualified Data.Vector as V+import System.IO (stderr)+import System.IO.Unsafe (unsafePerformIO)++import Control.Monad.Except (catchError)+++import Synapse.Auth (SessionGrant(..), Whoami, isMissingAuth, parseSessionGrant, parseWhoami)+import qualified Synapse.Auth.Loopback as Loopback+import Synapse.Identity.Proof+import Synapse.Identity.Store+import Synapse.Endpoint (Endpoint)+import qualified Synapse.Endpoint as E+import qualified Synapse.Log as Log+import Synapse.Monad+import Synapse.Schema.Types (HubStreamItem, pattern HubData, pattern HubError, pattern HubGuidance)+import Synapse.Transport (invoke)++-- ============================================================================+-- Login+-- ============================================================================++-- | What @session.login@ answered.+data LoginResult = LoginResult+  { lrToken     :: Text+  , lrPrincipal :: Text+  , lrAgent     :: Text+  , lrExpiresAt :: Maybe Integer+  , lrScope     :: [Text]+  } deriving (Eq, Show)++nowSecs :: IO Integer+nowSecs = round <$> getPOSIXTime++-- | Log in to the hub @backend@ at @HOST:PORT@ as @agent@, proving the key:+-- a connection opened with the proof, and on it AUTH-5's @auth.login+-- {flow: {session: {ttl_secs?, ceiling?}}}@ — or, on a hub with no @auth@+-- activation (every hub before AUTH), IDENTITY-42's @session.login {ttl_secs?,+-- scope?}@ on a second connection with a fresh proof (a proof works once).+loginWithKey :: Log.Logger -> Endpoint -> Text -> Seed -> Text -> [Text] -> Maybe Integer -> IO (Either Text LoginResult)+loginWithKey logger ep backend seed agent scope ttl+  | not (validAgent agent) = pure (Left ("an agent id is 1-64 of A-Z a-z 0-9 . _ - (not '" <> agent <> "')"))+  | otherwise = do+      viaAuth <- do+        proof <- freshProof+        let flow = object $+              maybe [] (\t -> ["ttl_secs" .= t]) ttl+              <> (if null scope then [] else ["ceiling" .= scope])+        items <- call logger ep backend (Just proof) "auth" "login" (object ["flow" .= object ["session" .= flow]])+        pure (items >>= grantItem "auth.login")+      case viaAuth of+        Left e | isMissingAuth e -> do+          proof <- freshProof+          let params = object $+                maybe [] (\t -> ["ttl_secs" .= t]) ttl+                <> (if null scope then [] else ["scope" .= scope])+          items <- call logger ep backend (Just proof) "session" "login" params+          pure (items >>= loginItem)+        other -> pure other+  where+    freshProof = do+      nonce <- newNonce+      ts <- nowSecs+      pure (buildProof seed (E.audience ep) agent nonce ts)+    grantItem what items =+      case [g | HubData _ _ _ v <- items, Just g <- [parseSessionGrant v]] of+        (g : _) -> Right LoginResult+          { lrToken = sgToken g+          , lrPrincipal = sgPrincipal g+          , lrAgent = maybe agent id (sgAgent g)+          , lrExpiresAt = sgExpiresAt g+          , lrScope = sgCeiling g+          }+        [] -> Left (answerError items (what <> " answered no session"))+    loginItem items =+      case [o | HubData _ _ _ (Object o) <- items, KM.lookup "type" o == Just (String "login")] of+        (o : _) | Just (String tok) <- KM.lookup "token" o -> Right LoginResult+          { lrToken = tok+          , lrPrincipal = str "principal" o+          , lrAgent = let a = str "agent" o in if T.null a then agent else a+          , lrExpiresAt = KM.lookup "expires_at" o >>= int+          , lrScope = case KM.lookup "scope" o of+              Just (Array xs) -> [s | String s <- V.toList xs]+              _ -> []+          }+        _ -> Left (answerError items "session.login answered no login")++-- | AUTH-8: a person signs in through the browser (the loopback flow,+-- AUTH-1 Q3). synapse listens on 127.0.0.1 (a port the OS picks), asks+-- @auth.login {flow: {browser: {redirect: http://127.0.0.1:PORT/cb}}}@ for+-- @{type: login_url, url, state}@, opens the URL (and says it, for a+-- browser elsewhere), waits up to @secs@ for @GET /cb?code=…&state=…@ with+-- that state, and trades the code: @auth.login {flow: {code: {code,+-- state}}}@ → the session. Every call here is anonymous.+loginPerson :: Log.Logger -> Endpoint -> Text -> Int -> (Text -> IO ()) -> IO (Either Text SessionGrant)+loginPerson logger ep backend secs say =+  Loopback.withLoopback $ \lb -> do+    let redirect = Loopback.loopbackRedirect lb+        browserFlow = object ["flow" .= object ["browser" .= object ["redirect" .= redirect]]]+    first' <- call logger ep backend Nothing "auth" "login" browserFlow+    case first' >>= loginUrl of+      Left e+        | isMissingAuth e -> pure (Left (addressKey ep <> " has no auth activation, so no browser sign-in"+                                     <> " (an agent signs in with its key: _login " <> backend <> " --key NAME --as AGENT)"))+        | otherwise -> pure (Left e)+      Right (url, state) -> do+        opened <- Loopback.openBrowser url+        say $ (if opened then "opening your browser to sign in; if it does not open, visit:"+                         else "to sign in, visit:")+        say ("  " <> url)+        say ("waiting for the browser on " <> redirect <> " (" <> Loopback.durationText secs <> ") \x2026")+        back <- Loopback.awaitCallback lb state secs+        case back of+          Left why -> pure (Left why)+          Right code -> do+            let codeFlow = object ["flow" .= object ["code" .= object ["code" .= code, "state" .= state]]]+            done <- call logger ep backend Nothing "auth" "login" codeFlow+            pure $ done >>= \items ->+              case [g | HubData _ _ _ v <- items, Just g <- [parseSessionGrant v]] of+                (g : _) -> Right g+                [] -> Left (answerError items "auth.login answered no session for the code")+  where+    loginUrl items =+      case [o | HubData _ _ _ (Object o) <- items, KM.lookup "type" o `elem` [Just (String "login_url"), Just (String "url")]] of+        (o : _) | Just (String u) <- KM.lookup "url" o, not (T.null u) ->+          case KM.lookup "state" o of+            Just (String st) | not (T.null st) -> Right (u, st)+            _ -> Left "auth.login gave a sign-in URL with no state; refused (the state is what binds the browser's answer to this sign-in)"+        _ -> Left (answerError items "auth.login answered no sign-in URL")++-- | AUTH-8: who a token is — @auth.whoami@, else (a hub without the auth+-- activation) @session.whoami@; Nothing when neither says.+whoamiWith :: Log.Logger -> Endpoint -> Text -> Text -> IO (Maybe Whoami)+whoamiWith logger ep backend token = do+  a <- call logger ep backend (Just token) "auth" "whoami" (object [])+  case a >>= firstWhoami of+    Right w -> pure (Just w)+    Left _ -> do+      b <- call logger ep backend (Just token) "session" "whoami" (object [])+      pure (either (const Nothing) Just (b >>= firstWhoami))++-- | 'whoamiWith' on the call's own connection (its credential, whatever it+-- is): @auth.whoami@, else @session.whoami@, else Nothing. Never fails.+whoamiM :: SynapseM (Maybe Whoami)+whoamiM = do+  a <- (Just <$> invoke ["auth"] "whoami" (object [])) `catchError` \_ -> pure Nothing+  case a >>= either (const Nothing) Just . firstWhoami of+    Just w -> pure (Just w)+    Nothing -> do+      b <- (Just <$> invoke ["session"] "whoami" (object [])) `catchError` \_ -> pure Nothing+      pure (b >>= either (const Nothing) Just . firstWhoami)++firstWhoami :: [HubStreamItem] -> Either Text Whoami+firstWhoami items = case [w | HubData _ _ _ v <- items, Just w <- [parseWhoami v]] of+  (w : _) -> Right w+  [] -> Left (answerError items "no whoami")++-- | End the session this token is: @auth.logout@ (AUTH-5), else — a hub+-- with no auth activation — @session.logout@.+logoutWithToken :: Log.Logger -> Endpoint -> Text -> Text -> IO (Either Text ())+logoutWithToken logger ep backend token = do+  a <- call logger ep backend (Just token) "auth" "logout" (object [])+  case a >>= ended "auth.logout" of+    Left e | isMissingAuth e -> do+      items <- call logger ep backend (Just token) "session" "logout" (object [])+      pure (items >>= ended "session.logout")+    other -> pure other+  where+    -- an answer with no error is a logout; one that says so, certainly+    ended what is+      | any isLoggedOut is = Right ()+      | null [() | HubError{} <- is] && null (errorEvents is) && not (null [() | HubData{} <- is]) = Right ()+      | otherwise = Left (answerError is (what <> " answered nothing"))+    isLoggedOut = \case+      HubData _ _ _ (Object o) -> KM.lookup "type" o `elem` [Just (String "logged_out"), Just (String "logout")]+      _ -> False+    errorEvents is = [() | HubData _ _ _ (Object o) <- is, KM.lookup "type" o == Just (String "error")]++-- | One @\<ns\>.\<method\>@ call on a fresh connection presenting @cred@+-- as @Authorization: Bearer@ (none: anonymous).+call :: Log.Logger -> Endpoint -> Text -> Maybe Text -> Text -> Text -> Value -> IO (Either Text [HubStreamItem])+call logger ep backend cred ns method params = do+  env0 <- initEnvAt ep backend logger Nothing+  let env = withRequestContext [] (maybe [] (\c -> [bearer c]) cred) env0+  r <- runSynapseM env (invoke [ns] method params)+  pure $ case r of+    Right items -> Right items+    Left (TransportErrorContext ctx)+      | isUpgradeRefused (tcMessage ctx) -> Left (addressKey ep <> " refused the credential at the upgrade (401)")+      | otherwise -> Left (firstLine (tcMessage ctx))+    Left (TransportError m) -> Left (firstLine m)+    Left e -> Left (T.pack (show e))++-- | SCAFFOLD-21: the global options a sign-in at this address is typed+-- with, and the space after them (none for the default address).+loginOpts :: Endpoint -> Text+loginOpts ep = case E.cliOptions ep of+  "" -> ""+  o -> o <> " "++firstLine :: Text -> Text+firstLine = T.strip . T.takeWhile (/= '\n')++-- | The upgrade header a credential travels in.+bearer :: Text -> (Text, Text)+bearer cred = ("Authorization", "Bearer " <> cred)++answerError :: [HubStreamItem] -> Text -> Text+answerError items fallback =+  case [m | HubData _ _ _ (Object o) <- items, KM.lookup "type" o == Just (String "error"), Just (String m) <- [KM.lookup "message" o]]+       <> [e | HubError _ _ e _ <- items]+       <> [T.pack (show g) | HubGuidance _ _ g _ _ _ <- items] of+    (m : _) -> m+    [] -> fallback++str :: KM.Key -> KM.KeyMap Value -> Text+str k o = case KM.lookup k o of+  Just (String s) -> s+  _ -> ""++int :: Value -> Maybe Integer+int = \case+  Number n -> fromIntegral <$> (toBoundedInteger n :: Maybe Int)+  String s | [(i, "")] <- reads (T.unpack s) -> Just i+  _ -> Nothing++-- ============================================================================+-- The session a call carries+-- ============================================================================++data ActiveSession = ActiveSession+  { asEndpoint :: Endpoint+  , asToken :: Text+  , asRec   :: Maybe SessionRec  -- ^ Nothing: PLEXUS_SESSION, nothing to log in again from+  } deriving (Eq, Show)++{-# NOINLINE memo #-}+memo :: IORef (Map.Map Endpoint (Maybe ActiveSession))+memo = unsafePerformIO (newIORef Map.empty)++-- | Addresses already logged in again in this process (at most once each).+{-# NOINLINE reattested #-}+reattested :: IORef [Endpoint]+reattested = unsafePerformIO (newIORef [])++-- | The session a call to @HOST:PORT@ carries, if any: @PLEXUS_SESSION@,+-- else the stored one for the agent asked (or the backend's default agent).+-- One past its @expires_at@ is made again from its key first.+sessionFor :: Log.Logger -> StoreEnv -> Maybe Text -> Endpoint -> IO (Maybe ActiveSession)+sessionFor logger st asked ep = do+  known <- Map.lookup ep <$> readIORef memo+  case known of+    Just s -> pure s+    Nothing -> do+      s <- find+      modifyIORef' memo (Map.insert ep s)+      pure s+  where+    find = do+      envTok <- stEnv st "PLEXUS_SESSION"+      case envTok of+        Just t | not (null t) -> pure (Just (ActiveSession ep (T.strip (T.pack t)) Nothing))+        _ -> do+          agent <- maybe (readDefaultAgent st ep) (pure . Just) asked+          case agent of+            Nothing -> pure Nothing+            Just a -> lookupSession st ep a >>= \case+              Just (Right rec, _) -> do+                now <- nowSecs+                let active = ActiveSession ep (srToken rec) (Just rec)+                if maybe False (<= now + 5) (srExpiresAt rec)+                  then reattestWith logger st active "had expired"+                  else pure (Just active)+              Just (Left tok, _) -> pure (Just (ActiveSession ep tok Nothing))+              Nothing -> do+                when (isJust asked) $ TIO.hPutStrLn stderr $+                  "synapse: no session for " <> a <> " at " <> addressKey ep+                    <> " (synapse " <> loginOpts ep <> "_login <backend> --key NAME --as " <> a <> ")"+                pure Nothing++-- | Can the session in use at this address be made again from its key?+canReattest :: Endpoint -> IO Bool+canReattest ep = do+  s <- Map.lookup ep <$> readIORef memo+  done <- elem ep <$> readIORef reattested+  pure $ case s of+    -- AUTH-8: a person's session (no key) is made again only by signing in+    Just (Just ActiveSession{asRec = Just r}) -> not done && not (T.null (srKey r))+    _ -> False++-- | The server refused the session in use at this address: log in again+-- from its key (once per process). The new session, or Nothing when there+-- was none to remake or the login failed (both said on stderr).+reattest :: Log.Logger -> StoreEnv -> Endpoint -> IO (Maybe ActiveSession)+reattest logger st ep = do+  ok <- canReattest ep+  s <- Map.lookup ep <$> readIORef memo+  case s of+    Just (Just active) | ok -> do+      r <- reattestWith logger st active "has ended"+      pure $ case r of+        Just new | asToken new /= asToken active -> Just new+        _ -> Nothing+    _ -> pure Nothing++-- | SYNAPSE-20: 'reattest' for a call that outlived its session — a long+-- stream across a server restart (menger keeps sessions in memory). Its+-- reconnect loop asks at most once per outage, so the once-per-process+-- mark is lifted first.+reattestAgain :: Log.Logger -> StoreEnv -> Endpoint -> IO (Maybe ActiveSession)+reattestAgain logger st ep = do+  modifyIORef' reattested (filter (/= ep))+  reattest logger st ep++reattestWith :: Log.Logger -> StoreEnv -> ActiveSession -> Text -> IO (Maybe ActiveSession)+reattestWith logger st active why = case asRec active of+  Nothing -> pure (Just active)+  Just rec | T.null (srKey rec) -> do+    -- AUTH-8: a person's session: there is no key to make it again from+    TIO.hPutStrLn stderr $ "synapse: the session for " <> srAgent rec <> " at "+      <> addressKey (asEndpoint active) <> " " <> why+      <> "; sign in again: synapse " <> loginOpts (asEndpoint active) <> "_login " <> srBackend rec+    pure (Just active)+  Just rec -> do+    let ep = asEndpoint active+        who = srAgent rec <> " at " <> addressKey ep+    modifyIORef' reattested (ep :)+    -- SYNAPSE-15: one process at a time signs this agent in again; one+    -- that waited finds the session another has just made, and takes it+    withSessionLock st ep (srAgent rec) $ do+      fresher <- storedFresher st active rec+      case fresher of+        Just active' -> do+          modifyIORef' memo (Map.insert ep (Just active'))+          pure (Just active')+        Nothing -> mint ep who rec+  where+    mint ep who rec = do+      key <- lookupKey st (srKey rec)+      case key of+        Right (Just (seed, _)) -> do+          r <- loginWithKey logger ep (srBackend rec) seed (srAgent rec) (srScope rec) (srTtl rec)+          case r of+            Right lr -> do+              let rec' = rec { srToken = lrToken lr+                             , srPrincipal = if T.null (lrPrincipal lr) then srPrincipal rec else lrPrincipal lr+                             , srExpiresAt = lrExpiresAt lr+                             }+                  active' = active { asToken = lrToken lr, asRec = Just rec' }+              -- SYNAPSE-15: a session that cannot be kept is a warning; the+              -- call goes on with the one it holds+              kept <- try (writeSession st ep rec')+              case kept of+                Right _ -> pure ()+                Left (e :: SomeException) -> TIO.hPutStrLn stderr $+                  "synapse: warning: could not keep the new session for " <> who+                    <> " (" <> T.pack (show e) <> "); this call goes on with it"+              modifyIORef' memo (Map.insert ep (Just active'))+              TIO.hPutStrLn stderr $ "synapse: the session for " <> who <> " " <> why+                <> "; signed in again from key " <> srKey rec+              pure (Just active')+            Left e -> do+              TIO.hPutStrLn stderr $ "synapse: the session for " <> who <> " " <> why+                <> " and signing in again from key " <> srKey rec <> " failed: " <> e+              pure (Just active)+        Right Nothing -> do+          TIO.hPutStrLn stderr $ "synapse: the session for " <> who <> " " <> why+            <> ", and key " <> srKey rec <> " is in no store to sign in again from"+          pure (Just active)+        Left e -> do+          TIO.hPutStrLn stderr $ "synapse: the session for " <> who <> " " <> why <> "; key " <> srKey rec <> ": " <> e+          pure (Just active)++-- | SYNAPSE-15: the agent's stored session, read again under its lock,+-- when another process has replaced the one this call holds with one that+-- is still live — then this call takes it instead of signing in again.+storedFresher :: StoreEnv -> ActiveSession -> SessionRec -> IO (Maybe ActiveSession)+storedFresher st active rec = do+  stored <- try (lookupSession st (asEndpoint active) (srAgent rec))+  now <- nowSecs+  pure $ case stored of+    Right (Just (Right r, _))+      | srToken r /= asToken active+      , not (T.null (srToken r))+      , maybe True (> now + 5) (srExpiresAt r)+      -> Just active { asToken = srToken r, asRec = Just r }+    Right _ -> Nothing+    Left (_ :: SomeException) -> Nothing++-- ============================================================================+-- Recognising an ended session+-- ============================================================================++-- | The in-band error a hub answers a call whose session has ended with.+isSessionEndedItem :: HubStreamItem -> Bool+isSessionEndedItem = \case+  HubData _ _ _ (Object o)+    | KM.lookup "type" o == Just (String "error")+    , Just (String m) <- KM.lookup "message" o -> isSessionEndedText m+  HubError _ _ e _ -> isSessionEndedText e+  _ -> False++isSessionEndedText :: Text -> Bool+isSessionEndedText m = any (`T.isInfixOf` T.toLower m)+  ["you have signed out", "your sign-in has expired"]++-- | A transport failure that is the upgrade's 401.+isUpgradeRefused :: Text -> Bool+isUpgradeRefused m = any (`T.isInfixOf` m) ["responseCode = 401", " 401 ", "(401)", "Unauthorized"]++-- ============================================================================+-- Within one call: was the session refused before anything was shown?+-- ============================================================================++{-# NOINLINE endedRef #-}+endedRef :: IORef (Maybe Text)+endedRef = unsafePerformIO (newIORef Nothing)++{-# NOINLINE printedRef #-}+printedRef :: IORef Bool+printedRef = unsafePerformIO (newIORef False)++-- | Hold back the server's refusal (its words) for the retry.+markSessionEnded :: Text -> IO ()+markSessionEnded = writeIORef endedRef . Just++-- | Was the session refused, and the refusal held back? Its words; resets.+takeSessionEnded :: IO (Maybe Text)+takeSessionEnded = atomicModifyIORef' endedRef (\b -> (Nothing, b))++notePrinted :: IO ()+notePrinted = writeIORef printedRef True++printedAny :: IO Bool+printedAny = readIORef printedRef++-- | AUTH-8: a refusal was shown (the call exits non-zero).+{-# NOINLINE refusedRef #-}+refusedRef :: IORef Bool+refusedRef = unsafePerformIO (newIORef False)++noteRefused :: IO ()+noteRefused = writeIORef refusedRef True++wasRefused :: IO Bool+wasRefused = readIORef refusedRef++-- | AUTH-8: the ceiling of the session this process carries, as asked at+-- login (@editor\@MENGER-12@ each) — what a refusal that names none is+-- said to be within. Empty when no stored session is carried.+currentCeiling :: IO [Text]+currentCeiling = do+  m <- readIORef memo+  pure $ case [srScope r | Just ActiveSession{asRec = Just r} <- Map.elems m] of+    (c : _) -> c+    [] -> []