packages feed

plexus-synapse 3.15.0 → 3.17.3

raw patch · 54 files changed

+5653/−1156 lines, 54 filesdep +zlibdep ~aesondep ~plexus-protocol

Dependencies added: zlib

Dependency ranges changed: aeson, plexus-protocol

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2025-2026 hypermemetic <hypermemetic@proton.me>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
app/Main.hs view
@@ -15,7 +15,7 @@ -- is passed through for method invocation. module Main where -import Control.Monad (filterM, when)+import Control.Monad (filterM, unless, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (asks) import Data.Aeson@@ -40,7 +40,14 @@   import Synapse.Schema.Types-import Synapse.Monad (SynapseM, SynapseEnv(..), SynapseError(..), BackendErrorType(..), TransportContext(..), TransportErrorCategory(..), initEnvAt, runSynapseM, throwNav, throwTransport, throwParse, throwBackend, withRequestContext, withViewKey)+import Synapse.Monad (SynapseM, SynapseEnv(..), SynapseError(..), BackendErrorType(..), TransportContext(..), TransportErrorCategory(..), initEnvAt, runSynapseM, throwNav, throwTransport, throwParse, throwBackend, withRequestContext, withViewKey, SchemaSource(..), withSchemaSource, isCached)+import qualified Synapse.SchemaStore as SS+import qualified Synapse.Hold as Hold+import Plexus.Client (SubstrateConfig(..), TlsOptions(..))+import Plexus.Auth (Refusal(..))+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import System.IO.Unsafe (unsafePerformIO)+import Data.Maybe (fromMaybe, isNothing) import qualified Synapse.Self as Self   ( CredentialRef(..)   , ResolveError(..)@@ -62,7 +69,9 @@ 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 Synapse.IR.Types (IR, irMethods, irRefusals, MethodDef)+import qualified Synapse.IR.Types as IRT+import Plexus.Schema.Recursive (DeprecationInfo) import qualified Data.Map.Strict as Map import qualified Synapse.CLI.Template as TemplateIR import Synapse.Deprecation (emitActivationWarning, emitMethodWarning)@@ -77,7 +86,7 @@ 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.Backend.Discovery (Backend(..), BackendDiscovery(..), registryDiscoveryAt, endpointFor, pingBackendsVia, getBackendAt, getBackendAtEp, probeBackendAtEp, registerWithRegistry, probedInfoAt, probeFailureAt, probedNameAt, rememberInfo) import Synapse.Endpoint (Endpoint(..), plainAt, isPlain, parseUrl, normalisePath, cliOptions) import qualified Synapse.Endpoint as E import Control.Applicative ((<|>))@@ -88,6 +97,7 @@ import qualified Synapse.Identity.Proof as Proof import qualified Synapse.Identity.Session as Session import qualified Synapse.Reconnect as Reconnect+import qualified Synapse.Output as Output import qualified Synapse.Identity.Store as Store import System.Exit (ExitCode(..), exitWith) import qualified Synapse.Find as Find@@ -130,6 +140,9 @@   , 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)+  , soNoHold        :: Bool          -- ^ SYNAPSE-28: no connection held between runs+  , soHoldFor       :: Maybe Text    -- ^ SYNAPSE-28: how long the holder waits with nothing to do (10m)+  , soOutput        :: Maybe FilePath  -- ^ SYNAPSE-39: -o FILE, the answer written to FILE whole (- = stdout)   }   deriving Show @@ -269,7 +282,13 @@ -- | 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+probeWithSession' waits opts ep = probedNameAt ep >>= \case+  -- SYNAPSE-28: this run has asked already+  Just name -> pure (Just name)+  Nothing -> probeWithSession'' waits opts ep++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@@ -378,8 +397,18 @@ -- ============================================================================  main :: IO ()-main = do+-- SYNAPSE-26: a closed stdout ends the run, 141, whatever it was printing+main = Reconnect.exitOnClosedOutput $ do   args0 <- execParser argsInfo+  -- SYNAPSE-28: the connection holder a run started (synapse _hold …)+  when (argBackend args0 == Just "_hold") $ runHold (argPath args0)+  -- SYNAPSE-39: -o FILE — stdout is FILE's temporary file from here on,+  -- renamed into place when the run ends with 0+  Output.withOutputFile (soOutput (argOpts args0)) (runArgs args0)++-- | The run, once the arguments are read (and stdout is where -o put it).+runArgs :: Args -> IO ()+runArgs args0 = do   -- 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@@ -403,6 +432,26 @@   when (argBackend args == Just "_login") $ runLogin opts (argPath args)   when (argBackend args == Just "_logout") $ runLogout opts (argPath args) +  -- SYNAPSE-28: every request of this run goes over one connection — the+  -- holder's, kept between runs, or (--no-hold) this process's own+  installCallRouter opts++  -- SYNAPSE-28: a call to a backend the cache knows is sent at once — no+  -- probe, no schema fetch; they run only when the call fails in a way+  -- the schema explains+  case argBackend args of+    Just b | sendsFirst args b -> sendFirst args b+    _ -> pure ()+  slowPath args++-- | The run as it always went: the probe, the backend found, the schema+-- fetched (SYNAPSE-28: once each, on the run's one connection, and kept+-- for the next run).+slowPath :: Args -> IO ()+slowPath args = do+  let opts = argOpts args+      ep = soEndpoint opts+   -- Initialize logger (default: ErrorS, only show errors)   logger <- makeLoggerFromOpts opts @@ -688,7 +737,7 @@              else " - " <> backendDescription b   TIO.putStrLn $ "  " <> nameField <> hostPort <> status <> desc --- | Run a Hub command with backend discovery+-- | Run a Service command with backend discovery runWithDiscovery :: BackendDiscovery -> Text -> Args -> IO () runWithDiscovery discovery backendName args = do   let opts = argOpts args@@ -725,7 +774,7 @@             Right () -> exitSuccess         Just _ ->           -- Match confirmed-          run backendName at args+          run Fresh backendName at args     Nothing -> do       -- Backend not found in registry - check if this was a direct connection attempt       -- where the protocol handshake failed@@ -754,7 +803,7 @@             Right () -> exitSuccess         Just _ -> do           -- Backend discovered successfully - should not reach here, but proceed-          run backendName ep args+          run Fresh 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@@ -786,16 +835,48 @@       _ -> 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+-- | SYNAPSE-28: how a run gets its schemas.+data RunMode+  = Fresh+    -- ^ from the server (the probe has run), kept in the cache for the next run+  | Cached SS.Store (Maybe SS.Plan) (IO ())+    -- ^ from the cache alone, the call sent first; the action is the run+    -- again from the server, for when the cache could not answer or the+    -- server refused what it said (it exits)++-- | Run a Service command with specified backend and connection details+run :: RunMode -> Text -> Endpoint -> Args -> IO ()+run mode 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+  -- SYNAPSE-28: where this run's schemas come from and go+  source <- case mode of+    Cached st plan _ -> pure (FromCache st, plan)+    Fresh -> do+      st <- storeAt opts ep backend+      case st of+        Just store -> do+          SS.writeRoute (soEndpoint opts) backend ep+          probedInfoAt ep >>= mapM_ (SS.writeInfo store)+        Nothing -> pure ()+      pure (FromServer st, Nothing)+  let mkEnv = uncurry withSchemaSource source <$> (withView ep =<< buildEnv ep backend logger opts)+  env <- mkEnv   rendererCfg <- defaultRendererConfig   Log.logDebug logger Log.SubsystemCLI "Running dispatch..."   result <- runSynapseM env (dispatch args rendererCfg)+  -- SYNAPSE-28: the cache could not answer for the call, or the server+  -- refused it before it ran (a method or flag the cache did not know):+  -- ask the server and run it again+  stale <- takeStale+  case mode of+    Cached st _ again | stale || isStaleError result || isMiss result -> do+      Log.logInfo logger Log.SubsystemCLI $ "The cache could not answer (" <> staleWhy result <> "); asking " <> Store.addressKey ep+      -- what misled the call is forgotten; a miss forgets nothing+      when (not (isMiss result)) $ SS.forget st+      again+    _ -> pure ()   -- 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.@@ -809,7 +890,7 @@     new <- Session.reattest logger st ep     case new of       Just _ -> do-        env' <- withView ep =<< buildEnv ep backend logger opts+        env' <- mkEnv         runSynapseM env' (dispatch args rendererCfg)       Nothing -> do         mapM_ (\m -> hPutStrLn stderr ("Error: " <> T.unpack m)) ended@@ -822,8 +903,165 @@       -- AUTH-8: a refusal was shown — the call did not happen       refused' <- Session.wasRefused       if refused' then exitWith (ExitFailure refusedExit) else exitSuccess+  where+    isStaleError = \case+      Left (StaleSchema _) -> True+      _ -> False+    isMiss = \case+      Left (CacheMiss _) -> True+      _ -> False+    staleWhy = \case+      Left (StaleSchema why) -> why+      Left (CacheMiss why) -> why+      _ -> "the server refused what it said" --- | AUTH-8: the exit status of a call the hub refused (sysexits' EX_NOPERM).+-- | SYNAPSE-28: the cache this run reads and fills — the agent's view of+-- the backend at the address; none when the call carries a credential of+-- its own (-t, --token-file, a cookie or header, PLEXUS_SESSION), whose+-- view is no agent's.+storeAt :: SynapseOpts -> Endpoint -> Text -> IO (Maybe SS.Store)+storeAt opts ep backend = do+  explicit <- explicitCredential opts+  if explicit then pure Nothing else do+    st <- Store.systemStoreEnv+    asked <- askedAgent opts+    agent <- maybe (Store.readDefaultAgent st ep) (pure . Just) asked+    Just <$> SS.storeFor ep (fromMaybe "anonymous" agent) backend++-- | SYNAPSE-28: does the call bring its own credential?+explicitCredential :: SynapseOpts -> IO Bool+explicitCredential opts = do+  (cookies, headers) <- collectRequestContext opts+  envSession <- lookupEnv "PLEXUS_SESSION"+  pure $ isJust (soToken opts) || isJust (soTokenFile opts)+    || not (null cookies) || not (null headers)+    || maybe False (not . null) envSession++-- | SYNAPSE-28: may this call be sent first? A call to a named backend+-- (not a meta-command), and not a mode that is about the schema itself.+sendsFirst :: Args -> Text -> Bool+sendsFirst args b =+  not ("_" `T.isPrefixOf` b || "-" `T.isPrefixOf` b)+    && not (soSchema o || soGenerate o || soEmitIR o || soNoCache o)+    && isNothing (soRpc o) && isNothing (argFind args)+  where o = argOpts args++-- | SYNAPSE-28: send the call from the cache — where the backend is, its+-- _info and the method's plan as the last run left them — with no probe+-- and no schema fetch. Returns (to the run as it always went) when the+-- cache has not got what the call needs; otherwise it exits.+sendFirst :: Args -> Text -> IO ()+sendFirst args backend = do+  let opts = argOpts args+      (pathSegs, _, _, helpRequested) = parsePathAndParams (argPath args)+  route <- SS.readRoute (soEndpoint opts) backend+  case route of+    Nothing -> pure ()+    Just ep -> do+      mst <- storeAt opts ep backend+      case mst of+        Nothing -> pure ()+        Just st -> do+          info <- SS.readInfo st+          plan <- SS.readPlan st pathSegs+          case info of+            -- an anonymous view is the door, never sent first; help and+            -- listings are read from the server (they show what is new)+            Just i | infoView i /= Just Anonymous, infoBackend i == backend+                   , not (null pathSegs), not helpRequested -> do+              rememberInfo ep i+              run (Cached st plan (slowPath args)) backend ep args+            _ -> pure ()++-- | SYNAPSE-28: the cache cannot answer for the call: ask the server.+stale :: Text -> SynapseM a+stale why = throwError (StaleSchema why)++-- | SYNAPSE-28: the server refused a call sent from the cache before it+-- ran, in a way the schema explains — a method it does not have (under+-- the AUTH gate, an unlisted method is one only admin holds), or params it+-- cannot read (a field missing, unknown, or of another type). The item is+-- held back, and the call is run again from the server's schema.+{-# NOINLINE staleRef #-}+staleRef :: IORef Bool+staleRef = unsafePerformIO (newIORef False)++markStale :: IO ()+markStale = writeIORef staleRef True++takeStale :: IO Bool+takeStale = do+  v <- readIORef staleRef+  writeIORef staleRef False+  pure v++isStaleItem :: ServiceStreamItem -> Bool+isStaleItem item = case itemRefusal item of+  Just r -> refusalRoles r == ["admin"]+  Nothing -> case item of+    ServiceError _ _ msg _ -> any (`T.isInfixOf` msg)+      [ "Method not found", "Activation not found", "Unknown method", "method not found"+      , "errCode = -32601", "missing field", "unknown field", "invalid type", "unknown variant" ]+    _ -> False++-- | SYNAPSE-28: route every call through the connection holder for its+-- address and agent (started by the first run), or — with --no-hold, a+-- credential of the call's own, or no holder to be had — over one+-- connection of this process's own.+installCallRouter :: SynapseOpts -> IO ()+installCallRouter opts = do+  noHoldEnv <- lookupEnv "SYNAPSE_NO_HOLD"+  holdForEnv <- lookupEnv "SYNAPSE_HOLD_FOR"+  holdFor <- case soHoldFor opts <|> fmap T.pack holdForEnv of+    Nothing -> pure Hold.defaultHoldFor+    Just w -> case Reconnect.parseDuration w of+      Just secs -> pure secs+      Nothing -> do+        hPutStrLn stderr $ "synapse: --hold-for takes a duration (10m, 90s, 1h, 0), not '" <> T.unpack w <> "'"+        exitWith (ExitFailure 2)+  explicit <- explicitCredential opts+  let off = soNoHold opts || maybe False (`elem` ["1", "true", "yes", "on"]) noHoldEnv+              || explicit || holdFor <= 0+  st <- Store.systemStoreEnv+  asked <- askedAgent opts+  let version = T.pack (showVersion Meta.version)+      cp = soEndpoint opts+      viaRegistry = Store.addressKey cp == Store.addressKey (plainAt defaultHost defaultPort)+      socketFor cfg = do+        let ep = endpointOfConfig cfg+        -- the run's own address is held — or, reached through the+        -- registry, whatever it names; a registry the run only glances at+        -- (the auto-registration's probe) is not+        if not viaRegistry && Store.addressKey ep /= Store.addressKey cp then pure Nothing else do+          agent <- maybe (Store.readDefaultAgent st ep) (pure . Just) asked+          Just <$> Hold.socketPathFor version (E.dirName ep) (fromMaybe "anonymous" agent)+  _ <- Hold.installRouter Hold.RouterOpts+         { Hold.roHold = if off then Nothing else Just socketFor+         , Hold.roHoldFor = holdFor }+  pure ()++-- | The address a plexus-protocol config dials.+endpointOfConfig :: SubstrateConfig -> Endpoint+endpointOfConfig c = Endpoint+  { epHost = T.pack (substrateHost c)+  , epPort = substratePort c+  , epTls = isJust (substrateTls c)+  , epPath = T.pack (substratePath c)+  , epCaFiles = maybe [] tlsCaFiles (substrateTls c)+  }++-- | SYNAPSE-28: @synapse _hold --socket PATH --hold-for SECS@ — the+-- connection holder (a run starts it; it exits when idle).+runHold :: [Text] -> IO ()+runHold rest = case rest of+  ["--socket", path, "--hold-for", secs]+    | Just d <- (readMaybe (T.unpack secs) :: Maybe Double) ->+        Hold.runHolder Hold.HoldOpts { Hold.hoSocket = T.unpack path, Hold.hoHoldFor = d }+  _ -> do+    hPutStrLn stderr "synapse _hold --socket PATH --hold-for SECS (started by synapse itself)"+    exitWith (ExitFailure 2)++-- | AUTH-8: the exit status of a call the service refused (sysexits' EX_NOPERM). refusedExit :: Int refusedExit = 77 @@ -910,13 +1148,30 @@                 then do                   ir <- buildIR soGeneratorInfo pathSegs                   liftIO $ LBS.putStrLn $ encode ir+                  -- SYNAPSE-CC-8: a site the IR cannot type is named on+                  -- stderr, and the run exits 65 (EX_DATAERR): no generator+                  -- may run on it. The IR is still on stdout.+                  let refusals = irRefusals ir+                  unless (null refusals) $ liftIO $ do+                    TIO.hPutStrLn stderr $ "synapse: refused \x2014 " <> T.pack (show (length refusals))+                      <> " site" <> (if length refusals == 1 then "" else "s")+                      <> " the IR cannot type (irRefusals); nothing was dropped:"+                    let w = maximum (map (T.length . irSite) refusals)+                        kw = maximum (map (T.length . irKeyword) refusals)+                    mapM_ (\r -> TIO.hPutStrLn stderr $ "  " <> T.justifyLeft w ' ' (irSite r) <> "  "+                                  <> T.justifyLeft kw ' ' (irKeyword r) <> "  " <> irDetail r) refusals+                    exitWith (ExitFailure 65)                  else do                   -- Mode 5: Normal navigation                   info <- currentInfo                   let anonymous = (info >>= infoView) == Just Anonymous+                  -- SYNAPSE-28: sent first, from the cache — what the cache+                  -- cannot answer is asked of the server (StaleSchema)+                  cached <- asks isCached+                  plan <- asks sePlan                   if null pathSegs-                    then do+                    then if cached then stale "a listing" else 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.@@ -931,7 +1186,11 @@                       -- 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+                      view <- case plan of+                       Just p -> pure (ViewMethod (SS.plMethod p) (SS.plPath p))+                       Nothing -> navigate pathSegs `catchError` \e -> case e of+                        NavError (NotFound {}) | cached -> stale "a path the cache does not know"+                        NavError (MethodNotTerminal {}) | cached -> stale "a path the cache does not know"                         NavError (NotFound {}) | anonymous -> do                           root <- (Just <$> navigate []) `catchError` \_ -> pure Nothing                           showAnonymous info (root >>= viewSchema)@@ -940,6 +1199,7 @@                             exitWith (ExitFailure refusedExit)                         _ -> throwError e                       case view of+                        ViewPlugin {} | cached -> stale "a listing"                         -- Landed on a plugin: show help                         ViewPlugin schema _ -> showPluginHelp info pathSegs schema @@ -954,20 +1214,46 @@                           -- 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 ()+                          -- SYNAPSE-28: the activation's deprecation, from the+                          -- plan when there is one+                          let namespacePath = init path+                              parentDeprecation :: SynapseM (Maybe DeprecationInfo)+                              parentDeprecation = case plan of+                                Just p -> pure (SS.plDeprecation p)+                                Nothing+                                  | null namespacePath -> pure Nothing+                                  | otherwise -> psDeprecation <$> fetchSchemaAt namespacePath+                              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+                                  dep <- parentDeprecation                                   liftIO $ emitActivationWarning                                     soNoDeprecationWarnings                                     activationNs-                                    (psDeprecation parentPlugin)+                                    dep+                              -- SYNAPSE-28: what the next call of this path+                              -- reads in place of the activation's schema+                              keepPlan :: Maybe IR -> SynapseM ()+                              keepPlan mir = do+                                src <- asks seSchemaSource+                                let store = case src of+                                      FromCache st -> Just st+                                      FromServer st -> st+                                    current = case plan of+                                      Just p -> isJust (SS.plIR p) || isNothing mir+                                      Nothing -> False+                                case store of+                                  Just st | not current -> do+                                    dep <- parentDeprecation+                                    liftIO $ SS.writePlan st pathSegs SS.Plan+                                      { SS.plMethod = method, SS.plPath = path, SS.plDeprecation = dep+                                      , SS.plIR = SS.planIR fullPath <$> mir }+                                  _ -> pure ()                            -- Optimization: Skip IR construction for parameter-less methods                           -- IR is only needed for:@@ -980,14 +1266,17 @@                            -- Fast path: parameter-less method with no help requested                           if not needsIR-                            then fireDeprecationWarnings >> invokeMethod sourceEnv method path (object [])+                            then fireDeprecationWarnings >> keepPlan Nothing >> invokeMethod sourceEnv method path (object [])                             else do                               -- Build IR for this method's namespace-                              ir <- buildIR soGeneratorInfo (init path)+                              -- (SYNAPSE-28: the plan's, when it has one)+                              ir <- case plan >>= SS.plIR of+                                Just planned -> pure planned+                                Nothing -> buildIR soGeneratorInfo (init path)                                -- If --help was explicitly requested, show help and exit                               if helpRequested-                                then do+                                then if cached then stale "help" else do                                   case Map.lookup fullPath (irMethods ir) of                                     Just methodDef -> do                                       page <- pageFor info pathSegs method@@ -1016,6 +1305,7 @@                                               -- 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 _ | cached -> stale "a flag the cache does not know"                                                 Left errs -> do                                                   liftIO $ mapM_ (hPutStrLn stderr . renderParseError) errs                                                   throwParse "Parameter parsing failed"@@ -1025,9 +1315,11 @@                                               paramsWithDefaults <- liftIO $ injectSmartDefaults transformEnv ir methodDef paramsWithBools                                               case parseParams ir methodDef paramsWithDefaults of                                                 Right p -> pure p+                                                Left _ | cached -> stale "a flag the cache does not know"                                                 Left errs -> do                                                   liftIO $ mapM_ (hPutStrLn stderr . renderParseError) errs                                                   throwParse "Parameter parsing failed"+                                            Nothing | cached -> stale "a method the cache's IR lacks"                                             Nothing ->                                               -- Fallback to flat object if method not in IR                                               pure $ buildParamsObject inlineParams@@ -1041,7 +1333,7 @@                                       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+                                      then if cached then stale "help" else do                                         -- Render help from IR                                         case Map.lookup fullPath (irMethods ir) of                                           Just methodDef -> do@@ -1053,7 +1345,7 @@                                             -- 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+                                      else fireDeprecationWarnings >> keepPlan (Just ir) >> invokeMethod sourceEnv method path params   where     -- AUTH-8: what the _info probe at this address answered (view, auth)     currentInfo :: SynapseM (Maybe BackendInfo)@@ -1177,13 +1469,19 @@       -- for 'run' to log in again and retry.       ep <- asks seEndpoint       armed <- liftIO $ Session.canReattest ep+      cachedRun <- asks isCached       let printer item = do             shown <- Session.printedAny-            if armed && not shown && Session.isSessionEndedItem item+            held <- readIORef staleRef+            -- SYNAPSE-28: a call sent from the cache that the server refused+            -- as the schema explains is held back, and run again+            if held then pure ()+            else if cachedRun && not shown && isStaleItem item then markStale+            else if armed && not shown && Session.isSessionEndedItem item               then Session.markSessionEnded (endedMessage item)               else do                 case item of-                  HubData{} -> Session.notePrinted+                  ServiceData{} -> Session.notePrinted                   _ -> pure ()                 printResult soJson soRaw rendererCfg' item       -- SYNAPSE-20: a stream that resumed after a gap says so — on -j as a@@ -1212,6 +1510,9 @@               Just _ -> do                 env' <- buildEnv ep backendName' logger' soOpts                 pure (Just (mergeUpgradeHeaders (seToken env') (seCookies env') (seHeaders env')))+      -- SYNAPSE-39: a stream has no end to wait for — with -o, its items+      -- go to FILE itself, each as it comes+      when (methodStreaming method) $ liftIO Output.streaming       -- Use bidirectional streaming handler       invokeStreamingWithBidir         (Reconnect.callShape method)@@ -1224,8 +1525,8 @@         (handleBidirRequest bidirMode Nothing)      endedMessage item = case item of-      HubData _ _ _ (Object o) | Just (String m) <- KM.lookup "message" o -> m-      HubError _ _ e _ -> e+      ServiceData _ _ _ (Object o) | Just (String m) <- KM.lookup "message" o -> m+      ServiceError _ _ e _ -> e       _ -> "your session has ended"      -- Extract default values from JSON Schema properties@@ -1273,7 +1574,7 @@           pure $ Right $ toJSON detailedMethod      -- Invoke raw JSON-RPC request-    invokeRawRpc :: Value -> SynapseM [HubStreamItem]+    invokeRawRpc :: Value -> SynapseM [ServiceStreamItem]     invokeRawRpc rpcReq = do       case rpcReq of         Object o -> case (KM.lookup "method" o, KM.lookup "params" o) of@@ -1345,14 +1646,21 @@       , "                      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):"+      , "Where the service 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;"+      , "  --url wss://HOST/ws a service 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"       , ""+      , "A connection held between runs (SYNAPSE-28):"+      , "  the first call to a backend starts a holder that keeps the signed-in socket"+      , "  open ($XDG_RUNTIME_DIR/synapse/, one per address and agent); later calls cost"+      , "  one round trip. It exits after --hold-for (10m) with nothing to do; --no-hold"+      , "  dials a connection of the run's own. A call is sent from the schema cache"+      , "  (~/.cache/synapse/schemas) and checked against the server only when it fails"+      , ""       , "Meta-commands:"       , ""       , "  synapse _key new|show|list [NAME]"@@ -1419,6 +1727,10 @@     "Parse error: " <> T.unpack msg   ValidationError msg ->     "Validation error: " <> T.unpack msg+  StaleSchema msg ->+    "The schema cache could not answer: " <> T.unpack msg+  CacheMiss msg ->+    "The schema cache could not answer: " <> T.unpack msg   BackendError errorType backends ->     case errorType of       BackendNotFound name ->@@ -1582,28 +1894,39 @@ -- 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 :: Bool -> Bool -> RendererConfig -> ServiceStreamItem -> 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+    -- SYNAPSE-39: under -o the -j line goes with FILE when the run fails,+    -- so the refusal is said on stderr too+    toFile <- Output.active+    if json then LBS.putStrLn (encode item) else pure ()+    if not json || toFile then do       ceiling' <- Session.currentCeiling       TIO.hPutStr stderr (renderRefusal ceiling' r)-  Nothing -> printResult' json raw cfg item+    else pure ()+  Nothing -> do+    -- SYNAPSE-39: an error's -j line goes with FILE too; say it on stderr+    toFile <- Output.active+    case item of+      ServiceError _ _ err _ | json, toFile -> hPutStrLn stderr $ "Error: " <> T.unpack err+      _ -> pure ()+    printResult' json raw cfg item -printResult' :: Bool -> Bool -> RendererConfig -> HubStreamItem -> IO ()+printResult' :: Bool -> Bool -> RendererConfig -> ServiceStreamItem -> IO () printResult' True _ _ item = LBS.putStrLn $ encode item printResult' _ True _ item = case item of   -- Raw mode: just output the content-  HubData _ _ _ dat -> do+  ServiceData _ _ _ dat -> do     LBS.putStrLn $ encode dat     hFlush stdout-  HubProgress _ _ msg _ -> do+  ServiceProgress _ _ msg _ -> do     TIO.putStr msg     TIO.putStr "\r"     hFlush stdout-  HubError _ _ err _ ->+  ServiceError _ _ err _ ->     hPutStrLn stderr $ "Error: " <> T.unpack err   _ -> pure () printResult' _ _ cfg item = do@@ -1617,14 +1940,14 @@           hFlush stdout     Nothing -> case item of       -- Fallback to pretty-printed content-      HubData _ _ _ dat -> do+      ServiceData _ _ _ dat -> do         TIO.putStrLn $ prettyValue dat         hFlush stdout-      HubProgress _ _ msg _ -> do+      ServiceProgress _ _ msg _ -> do         TIO.putStr msg         TIO.putStr "\r"         hFlush stdout-      HubError _ _ err _ ->+      ServiceError _ _ err _ ->         hPutStrLn stderr $ "Error: " <> T.unpack err       _ -> pure () @@ -1637,7 +1960,7 @@ argsInfo :: ParserInfo Args argsInfo = info (argsParser <**> versionOption <**> helper)   ( fullDesc- <> header "synapse - Algebraic CLI for Hub"+ <> header "synapse - Algebraic CLI for Service"  <> 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))))@@ -1651,7 +1974,7 @@   where     backendParser = optional $ T.pack <$> argument str       ( metavar "BACKEND"-     <> help "Backend name (e.g., plexus, registry-hub)" )+     <> help "Backend name (e.g., plexus, menger)" )      restParser = many $ T.pack <$> argument str       ( metavar "PATH... [--param value ...]"@@ -1667,7 +1990,7 @@    <> 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" )+   <> help "The service'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" )@@ -1740,6 +2063,15 @@   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)" )+  soNoHold <- switch+    ( long "no-hold"+   <> help "Hold no connection between runs: this run dials its own (one, shared by all its requests) and closes it (else SYNAPSE_NO_HOLD=1)" )+  soHoldFor <- optional $ T.pack <$> strOption+    ( long "hold-for" <> metavar "DURATION"+   <> help "How long the connection holder keeps the signed-in socket open with nothing to do (10m, 90s, 1h; else SYNAPSE_HOLD_FOR, else 10m)" )+  soOutput <- optional $ strOption+    ( long "output" <> short 'o' <> metavar "FILE"+   <> help "Write the answer to FILE, not stdout: whole, in the same form (-j lines with -j), renamed into place when the call succeeds (a failed call leaves no FILE); 0600; a stream's items appended as they come; - is stdout" )   pure SynapseOpts     { soHost = maybe defaultHost id soHostFlag     , soPort = maybe defaultPort id soPortFlag@@ -1785,3 +2117,9 @@             '=':vv -> vv             _      -> ""   in (T.pack k, T.pack v)++-- | SYNAPSE-CC-8: a refusal's parts, as @-i@ prints them.+irSite, irKeyword, irDetail :: IRT.Refusal -> T.Text+irSite = IRT.rfSite+irKeyword = IRT.rfKeyword+irDetail = IRT.rfDetail
+ bench/IRBench.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++-- | SYNAPSE-CC-8: the IR builder alone, over menger's schemas of 2026-10-29.+--+-- The gzipped fixture is decoded once; then the IR is built @N@ times+-- (default 20) from the in-memory schemas — 'buildIR''s fold, no network —+-- and each build is forced by encoding it. Prints the median and p90 per+-- build, the CPU time per build (every thread) and the bytes allocated+-- per build, for the whole tree (7.1 MB of+-- schema) and for @tickets@ alone (its 2.68 MB schema and its children).+--+-- > cabal bench ir-bench                       # 20 runs+-- > cabal run ir-bench -- 50                   # 50 runs+-- > cabal run ir-bench -- --dump ir.json       # write the whole IR once, and stop+module Main where++import Control.Exception (evaluate)+import Control.Monad (forM, when)+import Data.Aeson (encode)+import qualified Data.ByteString.Lazy as BL+import Data.List (sort)+import GHC.Clock (getMonotonicTime)+import GHC.Stats (getRTSStats, getRTSStatsEnabled, RTSStats(..))+import System.Environment (getArgs)+import System.CPUTime (getCPUTime)+import System.Mem (performMajorGC)+import Text.Printf (printf)++import Data.Text (Text)++import IRFixture+import Synapse.Monad (SynapseEnv)++main :: IO ()+main = do+  args <- getArgs+  schemas <- loadSchemas menger20261029+  env <- envWithSchemas "menger" schemas+  case args of+    ["--dump", out] -> buildFixtureIR env [] >>= BL.writeFile out . encode+    _ -> do+      let n = case args of { [k] -> read k; _ -> 20 :: Int }+      printf "ir-bench: %d schemas, %d builds each\n" (length schemas) n+      bench env n "whole tree " []+      bench env n "tickets    " ["tickets"]++bench :: SynapseEnv -> Int -> String -> [Text] -> IO ()+bench env n label path = do+  _ <- buildOnce                                  -- warm: the memo, the code+  stats <- getRTSStatsEnabled+  performMajorGC+  a0 <- if stats then allocated_bytes <$> getRTSStats else pure 0+  c0 <- getCPUTime+  times <- forM [1 .. n] $ \_ -> do+    t0 <- getMonotonicTime+    _ <- buildOnce+    t1 <- getMonotonicTime+    pure (t1 - t0)+  c1 <- getCPUTime+  a1 <- if stats then allocated_bytes <$> getRTSStats else pure 0+  let cpuMs = fromIntegral (c1 - c0) / 1e9 / fromIntegral n :: Double+  let sorted = sort times+      at q = sorted !! min (n - 1) (floor (q * fromIntegral n :: Double))+      perBuild = fromIntegral (a1 - a0) / fromIntegral n / (1024 * 1024) :: Double+  printf "%s median %7.1f ms  p90 %7.1f ms  min %7.1f ms  cpu %7.1f ms  alloc %8.1f MB/build\n"+    label (1000 * at 0.5) (1000 * at 0.9) (1000 * head sorted) cpuMs perBuild+  when (not stats) $ putStrLn "  (allocation: run with +RTS -T)"+  where+    buildOnce = buildFixtureIR env path >>= evaluate . BL.length . encode
plexus-synapse.cabal view
@@ -1,11 +1,19 @@ cabal-version:      3.0 name:               plexus-synapse-version:            3.15.0+version:            3.17.3 synopsis:           Schema-driven CLI for Plexus RPC servers+description:        Synapse is the command-line frontend for Plexus RPC. It discovers a+                    server's methods at runtime and builds its commands, help text,+                    parameter validation and output rendering from the schema, with no+                    code generation or static configuration. license:            MIT-author:-maintainer:+license-file:       LICENSE+author:             hypermemetic+maintainer:         hypermemetic@proton.me+copyright:          (c) 2025-2026 hypermemetic+category:           Network build-type:         Simple+tested-with:        GHC == 9.8.4, GHC == 9.12.4  flag build-examples   description: Build example programs (schema-discovery)@@ -33,11 +41,13 @@     Synapse.Algebra.Recursion     Synapse.Transport     Synapse.Reconnect+    Synapse.Output     Synapse.Cache     Synapse.Deprecation     Synapse.Renderer     Synapse.IR.Types     Synapse.IR.Builder+    Synapse.IR.Read     Synapse.IR.Cache     Synapse.Bidir     Synapse.CLI.Help@@ -74,10 +84,12 @@     Synapse.Identity.Command     Synapse.Auth     Synapse.Auth.Loopback+    Synapse.Hold+    Synapse.SchemaStore   build-depends:     base >= 4.17 && < 5,-    -- SCAFFOLD-21: substrateTls (wss)-    plexus-protocol >= 0.5.2,+    -- SYNAPSE-28: setCallRouter, substrateRpcSub, unsubscribe+    plexus-protocol >= 0.5.5,     aeson >= 2.0 && < 2.3,     aeson-pretty >= 0.8 && < 0.9,     text >= 2.0 && < 2.2,@@ -148,6 +160,8 @@     OverloadedStrings     RecordWildCards     LambdaCase+  -- SYNAPSE-28: the holder (synapse _hold) serves many runs at once+  ghc-options:      -threaded  executable schema-discovery   main-is:          SchemaDiscovery.hs@@ -277,7 +291,7 @@   -- 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.+  -- values and examples; an older service's schema still rendered.   type:             exitcode-stdio-1.0   main-is:          RenderSpec.hs   build-depends:@@ -537,10 +551,10 @@   -- 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.+  -- service in miniature (test/MockService.hs) on ports of their own.   type:             exitcode-stdio-1.0   main-is:          AuthSpec.hs-  other-modules:    MockHub+  other-modules:    MockService   build-depends:     base >= 4.17 && < 5,     plexus-protocol,@@ -564,11 +578,11 @@ 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+  -- the mock service'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+  other-modules:    MockService   build-depends:     base >= 4.17 && < 5,     plexus-synapse,@@ -594,13 +608,16 @@   -- 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.+  -- back, the window run out — against a flaky service on ports of its own.   type:             exitcode-stdio-1.0   main-is:          ReconnectSpec.hs   build-depends:     base >= 4.17 && < 5,     plexus-protocol,     plexus-synapse,+    directory >= 1.3 && < 1.4,+    filepath >= 1.4 && < 1.6,+    unix >= 2.7 && < 2.9,     aeson >= 2.2 && < 2.3,     text >= 2.0 && < 2.2,     network >= 3.1 && < 3.3,@@ -612,6 +629,99 @@     OverloadedStrings   ghc-options:      -threaded +test-suite hold-test+  -- SYNAPSE-28: a call costs one round trip and the server's time — the+  -- multiplexer and the holder carry every call on one connection (counted+  -- at the mock service), a stream abandoned is unsubscribed, the holder exits+  -- idle; and the built synapse, end to end: cold fills the cache on one+  -- connection, warm opens none and fetches nothing, --no-hold opens one,+  -- a renamed method falls back and answers.+  type:             exitcode-stdio-1.0+  main-is:          HoldSpec.hs+  other-modules:    MockService+  build-tool-depends: plexus-synapse:synapse+  build-depends:+    base >= 4.17 && < 5,+    plexus-protocol,+    plexus-synapse,+    aeson >= 2.2 && < 2.3,+    async >= 2.2 && < 2.3,+    bytestring >= 0.11 && < 0.13,+    directory >= 1.3 && < 1.4,+    filepath >= 1.4 && < 1.6,+    network >= 3.1 && < 3.3,+    process >= 1.6 && < 1.7,+    temporary >= 1.3 && < 1.4,+    text >= 2.0 && < 2.2,+    vector >= 0.12 && < 0.14,+    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 pipe-test+  -- SYNAPSE-26: a closed stdout is not an outage — the built synapse, its+  -- stdout a pipe whose reader closes early (… | head -1): a write sent+  -- once and exit 141, a stream ended (unsubscribed) and exit 141, with no+  -- reconnect; a socket dropping with stdout open still reconnects (a read+  -- resent, a write that went out exit 75).+  type:             exitcode-stdio-1.0+  main-is:          PipeSpec.hs+  other-modules:    MockService+  build-tool-depends: plexus-synapse:synapse+  build-depends:+    base >= 4.17 && < 5,+    aeson >= 2.2 && < 2.3,+    bytestring >= 0.11 && < 0.13,+    directory >= 1.3 && < 1.4,+    filepath >= 1.4 && < 1.6,+    network >= 3.1 && < 3.3,+    process >= 1.6 && < 1.7,+    temporary >= 1.3 && < 1.4,+    text >= 2.0 && < 2.2,+    vector >= 0.12 && < 0.14,+    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 output-test+  -- SYNAPSE-39: synapse -o FILE — the built synapse against the mock+  -- service: an answer in FILE is what stdout would have had (plain and+  -- -j) and stdout is empty; a failed call leaves no FILE and nothing+  -- beside it, with its own exit code; a stream's items land as they come;+  -- FILE is 0600; -o - is stdout; a FILE that cannot be made: exit 73,+  -- nothing sent.+  type:             exitcode-stdio-1.0+  main-is:          OutputSpec.hs+  other-modules:    MockService+  build-tool-depends: plexus-synapse:synapse+  build-depends:+    base >= 4.17 && < 5,+    aeson >= 2.2 && < 2.3,+    bytestring >= 0.11 && < 0.13,+    directory >= 1.3 && < 1.4,+    filepath >= 1.4 && < 1.6,+    network >= 3.1 && < 3.3,+    process >= 1.6 && < 1.7,+    temporary >= 1.3 && < 1.4,+    text >= 2.0 && < 2.2,+    unix >= 2.7 && < 2.9,+    vector >= 0.12 && < 0.14,+    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@@ -633,11 +743,11 @@ 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+  -- run, in front of the mock service), 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+  other-modules:    MockService   build-depends:     base >= 4.17 && < 5,     plexus-protocol,@@ -661,3 +771,76 @@   default-extensions:     OverloadedStrings   ghc-options:      -threaded++benchmark ir-bench+  -- SYNAPSE-CC-8: the IR builder alone, over menger's 2026-10-29 schemas+  -- (test/fixtures/ir-coverage, gzipped): decoded once, then the IR built+  -- 20 times from memory — median, p90, bytes allocated per build.+  type:             exitcode-stdio-1.0+  main-is:          IRBench.hs+  other-modules:    IRFixture+  build-depends:+    base >= 4.17 && < 5,+    plexus-synapse,+    aeson >= 2.2 && < 2.3,+    bytestring >= 0.11 && < 0.13,+    containers >= 0.6 && < 0.8,+    katip >= 0.8 && < 0.9,+    text >= 2.0 && < 2.2,+    zlib >= 0.6 && < 0.8+  hs-source-dirs:   bench test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -O2 -threaded -rtsopts "-with-rtsopts=-T"++test-suite ir-coverage-test+  -- SYNAPSE-CC-8 (IR 2.1): every schema read whole or refused by name —+  -- one fixture per evidence row (test/fixtures/ir-coverage), menger's+  -- 2026-10-29 schemas whole (exactly 21 refusals, the IR equal to its+  -- golden, every construct 2.0 typed serialized as before), a 3.16.0+  -- plan discarded, and the built synapse's -i against a service with a+  -- bare object: exit 65.+  type:             exitcode-stdio-1.0+  main-is:          IRCoverageSpec.hs+  other-modules:    IRFixture, MockService+  build-tool-depends: plexus-synapse:synapse+  build-depends:+    base >= 4.17 && < 5,+    plexus-protocol,+    plexus-synapse,+    aeson >= 2.2 && < 2.3,+    aeson-pretty >= 0.8 && < 0.9,+    bytestring >= 0.11 && < 0.13,+    containers >= 0.6 && < 0.8,+    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,+    vector >= 0.12 && < 0.14,+    websockets >= 0.13 && < 0.14,+    zlib >= 0.6 && < 0.8,+    hspec >= 2.10 && < 2.12+  hs-source-dirs:   test+  default-language: GHC2021+  default-extensions:+    OverloadedStrings+  ghc-options:      -threaded++-- NAMING-9: the naming gate (scripts/naming-gate.sh) in the suite. The+-- spec counts the gate's lines and shows the first; it never diffs them.+-- Its heap is capped (-M6G; +RTS -M... -RTS overrides it), so no regression+-- of that can take the machine (2026-10-29: an hspec diff reached 7.3 GB).+test-suite naming-gate+  type:             exitcode-stdio-1.0+  main-is:          NamingGateSpec.hs+  build-depends:+    base >= 4.17 && < 5,+    process >= 1.6 && < 1.7,+    hspec >= 2.10 && < 2.12+  hs-source-dirs:   test+  default-language: GHC2021+  ghc-options:      -threaded -rtsopts "-with-rtsopts=-M6G"
src/Synapse/Algebra/Recursion.hs view
@@ -76,7 +76,8 @@  import Synapse.Schema.Types (Path, PluginSchema(..), MethodSchema(..), ChildSummary(..)) import Synapse.Schema.Functor (SchemaF(..), Fix(..), SchemaTree)-import Synapse.Monad (SynapseM, runSynapseM)+import Synapse.Monad (SynapseM, SynapseError(..), runSynapseM)+import Control.Monad.Except (throwError) import Synapse.Transport (fetchSchemaAt)  -- ============================================================================@@ -167,6 +168,13 @@       fb <- traverse go fa    -- recursively process (sequential)       alg fb                  -- fold one step +-- | SYNAPSE-28: the cache has not got it, or misled the call.+cacheCannotAnswer :: SynapseError -> Bool+cacheCannotAnswer = \case+  CacheMiss _ -> True+  StaleSchema _ -> True+  _ -> False+ -- | Parallel monadic hylomorphism specialized for SchemaF -- -- Like hyloM but processes child schemas in parallel using mapConcurrently.@@ -185,13 +193,18 @@             (\child -> do               result <- runSynapseM env (go child)               case result of+                -- SYNAPSE-28: a run sending from the cache asks the server+                -- for what the cache lacks; it never skips it+                Left err | cacheCannotAnswer err -> pure (Left err)                 Left err -> do                   hPutStrLn stderr $ "[synapse] warning: skipping plugin (fetch failed): " ++ show err-                  pure Nothing-                Right val -> pure (Just val)+                  pure (Right Nothing)+                Right val -> pure (Right (Just val))             )             children-          alg (PluginF schema path (catMaybes childResults))+          case [e | Left e <- childResults] of+            (e : _) -> throwError e+            [] -> alg (PluginF schema path (catMaybes [v | Right v <- childResults]))         MethodF method ns path ->           -- Methods are leaves, just apply algebra           alg (MethodF method ns path)
src/Synapse/Auth.hs view
@@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} --- | AUTH-8: what synapse shows of a hub's auth — pure, so every render is+-- | AUTH-8: what synapse shows of a service's auth — pure, so every render is -- tested from fixtures. ----- * The anonymous page: a hub whose @_info@ says @view: anonymous@ shows+-- * The anonymous page: a service 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@).+--   CEILING@, from @auth.whoami@ (or, on a service 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.+-- a service without a gate answers none of it, and nothing here is shown. module Synapse.Auth   ( -- * Who the caller is     Whoami(..)@@ -57,8 +57,8 @@   { 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+  , whoMemberships :: [(Text, Text)]  -- ^ (role, scope); scope "" when the service names none+  , whoCeiling     :: [Text]          -- ^ as the service 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@@ -134,7 +134,7 @@ -- | @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+-- service 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@@ -175,7 +175,7 @@ -- ============================================================================  data AnonPage = AnonPage-  { apBackend :: Text              -- ^ the hub's name+  { apBackend :: Text              -- ^ the service'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@@@ -206,7 +206,7 @@       ]     rank m = (fromMaybe 3 (lookup m (zip ["login", "signup", "providers"] [0 :: Int ..])), m) --- | The page an anonymous caller sees for a hub (AUTH-8):+-- | The page an anonymous caller sees for a service (AUTH-8): -- -- @ -- menger v1.0.0@@ -250,7 +250,7 @@ --   you hold it on  MENGER (within MENGER-12) -- @ ----- The ceiling is the refusal's own when the hub names one, else the one+-- The ceiling is the refusal's own when the service 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@@ -304,7 +304,7 @@         }   _ -> Nothing --- | Is this error the hub saying it has no @auth@ activation (or no such+-- | Is this error the service 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)
src/Synapse/Auth/Loopback.hs view
@@ -5,12 +5,12 @@ -- | 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+-- synapse listens on @127.0.0.1:<a port the OS picks>@, asks the service 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+-- back with @GET /cb?code=…&state=…@. The state must be the one the service -- 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 code then goes back to the service (@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@@ -60,7 +60,7 @@ loopbackPort :: Loopback -> Int loopbackPort = lbPort --- | Where the hub sends the browser back: @http://127.0.0.1:<port>/cb@.+-- | Where the service 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"
src/Synapse/Backend/Discovery.hs view
@@ -13,13 +13,13 @@ -- -- @ -- ┌─────────────┐     ┌──────────────────┐     ┌─────────────────┐--- │   synapse   │────▶│  Hub Directory   │────▶│  Backend Hubs   │+-- │   synapse   │────▶│  Service Directory   │────▶│  Backend Services   │ -- │   (CLI)     │     │  (port 4444)     │     │  (discovered)   │ -- └─────────────┘     └──────────────────┘     └─────────────────┘ --                             │ --                             ▼ --                     Returns list of:---                     - Hub name+--                     - Service name --                     - Connection info (host:port or https URL) --                     - Description --                     - Schema hash@@ -58,6 +58,8 @@   , probedInfo   , probedInfoAt   , probeFailureAt+  , probedNameAt+  , rememberInfo      -- * Health Checks   , pingBackend@@ -102,7 +104,7 @@ -- Backend Type -- ============================================================================ --- | A discovered backend hub+-- | A discovered backend service data Backend = Backend   { backendName        :: Text       -- ^ e.g., "plexus"   , backendDescription :: Text       -- ^ Human-readable description@@ -205,7 +207,7 @@ 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+-- address (a service 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@@ -257,7 +259,7 @@   | 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")+-- Returns whatever backend is running there (e.g., "menger", "plexus") -- If that backend has a registry plugin, it can be used to discover other backends getBackendAt :: Text -> Int -> IO (Maybe Text) getBackendAt host port = getBackendAtEp [] (plainAt host port)@@ -312,6 +314,8 @@           -- 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)+          -- SYNAPSE-28: and the name, so the run asks it once+          modifyIORef' nameMemo (Map.insert (addressKey ep) name)           pure (Right name)         _ ->           failed "the _info probe answered no backend name"@@ -335,6 +339,22 @@ probeFailureAt :: Endpoint -> IO (Maybe Text) probeFailureAt ep = Map.lookup (addressKey ep) <$> readIORef failMemo +-- | SYNAPSE-28: the name the _info probe at this address answered in this+-- process, if it has been asked — the run asks once, where it asked three+-- times (once anonymously, on a connection of its own: 0.7 s of the 0.9 s+-- before a call to app.menger.sh began).+probedNameAt :: Endpoint -> IO (Maybe Text)+probedNameAt ep = Map.lookup (addressKey ep) <$> readIORef nameMemo++-- | SYNAPSE-28: what a run that sends first knows of the address without+-- asking — the _info its cache kept.+rememberInfo :: Endpoint -> BackendInfo -> IO ()+rememberInfo ep i = modifyIORef' infoMemo (Map.insert (addressKey ep) i)++{-# NOINLINE nameMemo #-}+nameMemo :: IORef (Map.Map Text Text)+nameMemo = unsafePerformIO (newIORef Map.empty)+ {-# NOINLINE failMemo #-} failMemo :: IORef (Map.Map Text Text) failMemo = unsafePerformIO (newIORef Map.empty)@@ -369,8 +389,10 @@ -- | Query for a specific backend by name queryBackend :: Endpoint -> Text -> IO (Maybe Backend) queryBackend ep name = do-  -- First discover the backend name-  maybeBackendName <- getBackendAtEp [] ep+  -- First discover the backend name (SYNAPSE-28: as this run's probe+  -- answered it, when it has asked; an anonymous probe of its own otherwise)+  known <- probedNameAt ep+  maybeBackendName <- maybe (getBackendAtEp [] ep) (pure . Just) known   case maybeBackendName of     Just discoveredName -> do       -- Check if the requested name matches the discovered backend
src/Synapse/Bidir.hs view
@@ -17,6 +17,10 @@ -- - @--bidir-respond@: Prints request to stdout as JSON, returns Nothing so the --   agent can respond via a separate @synapse \<backend\> respond@ invocation --+-- Under @-o FILE@ (SYNAPSE-39) stdout is FILE, renamed into place only when+-- the call ends: every prompt and request line goes to stderr instead, to+-- be seen while the call waits.+-- -- = Protocol -- -- When a @StreamRequest@ arrives, the handler:@@ -45,6 +49,8 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.IO as TIO import System.IO (hClose, hFlush, hIsTerminalDevice, stderr, stdin, stdout)++import Synapse.Output (promptHandle) import System.Process (createProcess, proc, std_in, std_out, StdStream(..), waitForProcess) import System.Exit (ExitCode(..)) @@ -113,8 +119,8 @@           Just True  -> " [Y/n]"           Just False -> " [y/N]"           Nothing    -> " [y/n]"-    TIO.putStr $ confirmMessage <> defaultHint <> ": "-    hFlush stdout+    promptHandle >>= \h -> TIO.hPutStr h $ confirmMessage <> defaultHint <> ": "+    promptHandle >>= hFlush     input <- TIO.getLine     let confirmed = case T.toLower (T.strip input) of           ""    -> case confirmDefault of@@ -129,8 +135,8 @@     let hint = case promptPlaceholder of           Just ph -> " (" <> ph <> ")"           Nothing -> ""-    TIO.putStr $ promptMessage <> hint <> ": "-    hFlush stdout+    promptHandle >>= \h -> TIO.hPutStr h $ promptMessage <> hint <> ": "+    promptHandle >>= hFlush     input <- TIO.getLine     let response = if T.null input           then case promptDefault of@@ -140,10 +146,10 @@     pure $ Value response    Select{..} -> do-    TIO.putStrLn selectMessage+    promptHandle >>= \h -> TIO.hPutStrLn h selectMessage     mapM_ printOption (zip [1..] selectOptions)-    TIO.putStr "Select (enter number): "-    hFlush stdout+    promptHandle >>= \h -> TIO.hPutStr h "Select (enter number): "+    promptHandle >>= hFlush     input <- TIO.getLine     case reads (T.unpack input) of       [(n, "")] | n >= 1 && n <= length selectOptions ->@@ -156,10 +162,10 @@       let desc = case optionDescription of             Just d  -> " - " <> d             Nothing -> ""-      TIO.putStrLn $ "  " <> T.pack (show idx) <> ") " <> optionLabel <> desc+      promptHandle >>= \h -> TIO.hPutStrLn h $ "  " <> T.pack (show idx) <> ") " <> optionLabel <> desc  -- | JSON protocol handling for piped mode--- Outputs request as a JSON line to stdout, reads a JSON response line from stdin+-- Outputs request as a JSON line to stdout (stderr under -o, SYNAPSE-39), reads a JSON response line from stdin handleJson :: Text -> Request Value -> IO (Response Value) handleJson requestId req = do   let jsonReq = encode $ object@@ -167,8 +173,8 @@         , "request_id" .= requestId         , "request"    .= req         ]-  LBS.putStrLn jsonReq-  hFlush stdout+  promptHandle >>= \h -> LBS.hPutStrLn h jsonReq+  promptHandle >>= hFlush   inputLine <- TIO.getLine   case eitherDecode (LBS.fromStrict $ T.encodeUtf8 inputLine) of     Left err -> do@@ -257,8 +263,8 @@         Just schema -> baseFields ++ ["response_schema" .= schema]         Nothing     -> baseFields       jsonReq = encode $ object allFields-  LBS.putStrLn jsonReq-  hFlush stdout+  promptHandle >>= \h -> LBS.hPutStrLn h jsonReq+  promptHandle >>= hFlush   pure Nothing  -- | Get a human-readable name for the request type
src/Synapse/CLI/Help.hs view
@@ -186,7 +186,11 @@     (callerParams, serverParams) =       ( [p | p <- params, not (serverSourced p)]       , [p | p <- params, serverSourced p] )-    params = sortOn (not . pdRequired) (mdParams md)+    -- SYNAPSE-CC-8: what the server injects is in mdInjected, shown as before+    params = sortOn (not . pdRequired) (mdParams md ++ map injectedRow (mdInjected md))+    injectedRow ip = ParamDef+      { pdName = ipName ip, pdType = RefUnknown, pdDescription = ipDescription ip, pdRequired = False+      , pdDefault = Nothing, pdDeprecation = Nothing, pdSource = Just (ipSource ip), pdValues = Nothing }     required = [p | p <- callerParams, pdRequired p]     optional = [p | p <- callerParams, not (pdRequired p)] @@ -537,10 +541,21 @@    RefOptional inner -> renderTypeRef ir inner <> "?" -  RefAny -> "any"+  RefJson -> "any"    RefUnknown -> "unknown" +  -- SYNAPSE-CC-8: help says what it said of these under IR 2.0 (a map was+  -- an object, a tuple an array of any, a child's return unknown), so every+  -- help page is unchanged+  RefMap _ -> "object"++  RefTuple _ -> "any[]"++  RefRefined inner _ -> renderTypeRef ir inner++  RefChild _ -> "unknown"+ -- | Expand a type into CLI flag examples -- -- For discriminated unions, shows each variant with its fields.@@ -570,10 +585,13 @@ expandTypeDef :: IR -> Text -> TypeDef -> [Text] expandTypeDef ir prefix TypeDef{..} = case tdKind of   -- Discriminated union: show each variant-  KindEnum discriminator variants+  KindEnum discriminator variants Internal     | length variants > 1 -> expandEnum ir prefix discriminator variants     | otherwise -> [] +  -- SYNAPSE-CC-8: an external or untagged union has no flag form+  KindEnum {} -> []+   -- Struct: could expand fields, but typically too verbose   KindStruct _fields -> [] @@ -619,7 +637,7 @@ getStringEnumValues ir (RefNamed qn) =   let name = qualifiedNameFull qn   in case Map.lookup name (irTypes ir) of-    Just TypeDef{tdKind = KindEnum "value" variants} ->+    Just TypeDef{tdKind = KindEnum "value" variants _} ->       Just $ map vdName variants     _ -> Nothing getStringEnumValues _ _ = Nothing
src/Synapse/CLI/Parse.hs view
@@ -234,7 +234,7 @@   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 (KindEnum _ variants _) -> fdType <$> find ((== name) . fdName) (concatMap vdFields variants)     Just (KindAlias target) -> fieldType ir target name     _ -> Nothing   _ -> Nothing@@ -382,7 +382,7 @@          values <- concat <$> traverse elements rawValues          Right $ Array $ V.fromList $ map (buildTypedValue ir innerType) values -  RefAny ->+  RefJson ->     -- Dynamic type, try to parse as JSON or use as string     case lookup "" kvs of       Just val -> Right $ inferValue val@@ -394,10 +394,27 @@       Just val -> Right $ inferValue val       Nothing -> Left $ InvalidValue (pdName param) "unknown type needs value" +  -- SYNAPSE-CC-8: a map, a tuple or a child's client: the value as JSON+  RefMap _ -> wholeJson+  RefTuple _ -> wholeJson+  RefChild _ -> wholeJson+  RefRefined inner _ -> buildParamValue ir param { pdType = inner } kvs+  where+    wholeJson = case lookup "" kvs of+      Just val -> Right $ inferValue val+      Nothing -> Left $ InvalidValue (pdName param) "pass the value as JSON (or the whole params with -p)"+ -- | Build value from a TypeDef buildFromTypeDef :: IR -> Text -> TypeDef -> [(Text, Text)] -> Either ParseError Value buildFromTypeDef ir paramName TypeDef{..} kvs = case tdKind of-  KindEnum discriminator variants ->+  -- SYNAPSE-CC-8: an external or untagged union has no flag form: its value+  -- goes as JSON (--name '{…}', or -p)+  KindEnum _ _ repr | repr /= Internal ->+    case lookup "" kvs of+      Just val -> Right $ inferValue val+      Nothing -> Left $ InvalidValue paramName "pass the value as JSON (or the whole params with -p)"++  KindEnum discriminator variants _ ->     -- Find which variant based on discriminator value     case lookup discriminator kvs of       Just variantName ->@@ -476,8 +493,12 @@       _ -> String val   RefOptional inner -> buildTypedValue ir inner val   RefArray _ -> inferValue val  -- Best effort for arrays-  RefAny -> inferValue val+  RefJson -> inferValue val   RefUnknown -> String val+  RefMap _ -> inferValue val+  RefTuple _ -> inferValue val+  RefRefined inner _ -> buildTypedValue ir inner val+  RefChild _ -> String val  -- ============================================================================ -- List Values@@ -496,8 +517,12 @@     _ -> False   RefOptional inner -> isScalarElement ir inner   RefArray _ -> False-  RefAny -> False+  RefJson -> False   RefUnknown -> False+  RefMap _ -> False+  RefTuple _ -> False+  RefRefined inner _ -> isScalarElement ir inner+  RefChild _ -> False   where     scalarTypes = ["string", "integer", "number", "boolean"]
src/Synapse/CLI/Support.hs view
@@ -137,8 +137,12 @@   RefArray innerType -> canCLIRepresentWithReason ir innerType    -- Any/Unknown require JSON-  RefAny -> Left ReasonAny+  RefJson -> Left ReasonAny   RefUnknown -> Left ReasonUnknown+  RefMap _ -> Left ReasonAny+  RefTuple _ -> Left ReasonNested+  RefRefined inner _ -> canCLIRepresentWithReason ir inner+  RefChild _ -> Left ReasonUnknown    -- Named types: look up and check   RefNamed qn -> canCLIRepresentNamed ir (qualifiedNameFull qn)@@ -167,7 +171,10 @@       _ -> Left ReasonNested    -- Enums: check based on discriminator type-  KindEnum discriminator variants+  -- SYNAPSE-CC-8: an external or untagged union is read whole now; it was+  -- an empty enum before, and representable as one+  KindEnum _ _ repr | repr /= Internal -> Right ()+  KindEnum discriminator variants _     -- String enums (discriminator is "value") are representable     | discriminator == "value" -> Right ()     -- Discriminated unions: all variants must be representable@@ -245,8 +252,12 @@   RefPrimitive _ _ -> True   RefOptional inner -> canCLIRepresentWithDepth ir depth inner   RefArray innerType -> canCLIRepresentWithDepth ir depth innerType-  RefAny -> False+  RefJson -> False   RefUnknown -> False+  RefMap _ -> False+  RefTuple _ -> False+  RefRefined inner _ -> canCLIRepresentWithDepth ir depth inner+  RefChild _ -> False   RefNamed qn -> canCLIRepresentNamedWithDepth ir (depth - 1) (qualifiedNameFull qn)  -- | Check named type with depth@@ -259,8 +270,9 @@         KindPrimitive _ _ -> True         KindAlias target -> canCLIRepresentWithDepth ir depth target         KindStruct fields -> all (canCLIRepresentFieldWithDepth ir (depth - 1)) fields-        KindEnum "value" _ -> True  -- String enum-        KindEnum _ variants -> all (canCLIRepresentVariantWithDepth ir (depth - 1)) variants+        KindEnum "value" _ _ -> True  -- String enum+        KindEnum _ _ repr | repr /= Internal -> True+        KindEnum _ variants _ -> all (canCLIRepresentVariantWithDepth ir (depth - 1)) variants  -- | Check field with depth canCLIRepresentFieldWithDepth :: IR -> Int -> FieldDef -> Bool
src/Synapse/CLI/Template.hs view
@@ -153,7 +153,7 @@   RefNamed qn ->     let name = qualifiedNameFull qn     in case Map.lookup name (irTypes ir) of-      Just typeDef@TypeDef{tdKind = KindEnum _ variants} ->+      Just typeDef@TypeDef{tdKind = KindEnum _ variants _} ->         -- Union type: generate sections for ALL variants (exhaustive)         -- No blank lines between sections to avoid whitespace in output         let variantNames = map vdName variants@@ -272,8 +272,13 @@   RefOptional inner -> typeRefToMustache ir indent inner    -- Any/Unknown: fall back to current value-  RefAny -> "{{.}}"+  RefJson -> "{{.}}"   RefUnknown -> "{{.}}"+  -- SYNAPSE-CC-8: as the 2.0 IR carried them (object, array of any)+  RefMap _ -> "{{.}}"+  RefTuple _ -> typeRefToMustache ir indent (RefArray RefJson)+  RefRefined inner _ -> typeRefToMustache ir indent inner+  RefChild _ -> "{{.}}"  -- ============================================================================ -- Type Definition to Mustache@@ -283,7 +288,7 @@ typeDefToMustache :: IR -> Int -> TypeDef -> Text typeDefToMustache ir indent TypeDef{..} = case tdKind of   -- Discriminated union: render ALL variants as sections (exhaustive)-  KindEnum _discriminator variants ->+  KindEnum _discriminator variants _ ->     T.intercalate "\n" $ map (variantToMustache ir indent) variants    -- Struct: render each field@@ -376,7 +381,7 @@         let displayFields = filter (not . isInternalField) fields             fieldRefs = map (\f -> fdName f <> "={{" <> fieldName <> "." <> fdName f <> "}}") displayFields         in T.intercalate " " fieldRefs-      Just TypeDef{tdKind = KindEnum _ _} ->+      Just TypeDef{tdKind = KindEnum {}} ->         "{{{" <> fieldName <> "}}}"  -- Nested union: use triple braces for unescaped JSON       _ ->         "{{" <> fieldName <> "}}"@@ -395,8 +400,17 @@     -- For optional primitives, simple section     _ -> "{{#" <> fieldName <> "}}{{.}}{{/" <> fieldName <> "}}" +  -- SYNAPSE-CC-8: as the 2.0 IR carried them (object, array of arrays)+  RefMap _ ->+    if isContentField field+    then "{{{" <> fieldName <> "}}}"+    else "{{" <> fieldName <> "}}"+  RefTuple _ -> "{{#" <> fieldName <> "}}{{.}}{{/" <> fieldName <> "}}"+  RefRefined inner _ -> generateFieldValue ir inner fieldName field+  RefChild _ -> "{{" <> fieldName <> "}}"+   -- Fallback: use triple braces for content fields-  RefAny ->+  RefJson ->     if isContentField field     then "{{{" <> fieldName <> "}}}"     else "{{" <> fieldName <> "}}"
src/Synapse/Endpoint.hs view
@@ -1,4 +1,4 @@--- | SCAFFOLD-21: where a hub is reached — a host and port, and, for a hub+-- | SCAFFOLD-21: where a service is reached — a host and port, and, for a service -- behind TLS (every hosted app: @wss://<app>.menger.sh/ws@), the scheme -- and the path its socket answers at. --@@ -37,7 +37,7 @@  import Plexus.Client (SubstrateConfig(..), TlsOptions(..)) --- | A hub's address.+-- | A service's address. data Endpoint = Endpoint   { epHost    :: !Text   , epPort    :: !Int@@ -154,7 +154,7 @@ -- | 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@+-- behind TLS, which is what a service run with @--public-url https://HOST@ -- accepts (plexus-login's @socket_urls@). The path is not part of it. audience :: Endpoint -> Text audience ep
src/Synapse/Find.hs view
@@ -108,7 +108,7 @@   )   where     p = FindOpts-      <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The hub's name, e.g. menger"))+      <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The service'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")@@ -127,10 +127,12 @@ loadCatalog mcache = do   root <- fetchSchemaAt []   view <- asks seViewKey-  let key = "find-" <> irCacheKey view (psHash root)+  -- SYNAPSE-CC-8: the key names the IR version, so an IR an older synapse+  -- kept (3.16.0's 2.0) is never read as this one's+  let key = "find-ir" <> currentIrVersion <> "-" <> 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))))+    Just c -> liftIO (either (const Nothing) (>>= current) <$> (try (lookupIR c key) :: IO (Either SomeException (Maybe IR))))   case cached of     Just ir -> pure ir     Nothing -> do@@ -611,7 +613,7 @@ 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+    -- the introspection every service has (schema, hashes) is never what was meant     candidates = case filter ((`notElem` ["schema", "hashes"]) . mdName . enMethod) methods of       [] -> methods       cs -> cs@@ -655,3 +657,9 @@   where     e = hitEntry h     m = enMethod e++-- | SYNAPSE-CC-8: a cached IR of this synapse's version, else none.+current :: IR -> Maybe IR+current ir+  | irVersion ir == currentIrVersion = Just ir+  | otherwise = Nothing
+ src/Synapse/Hold.hs view
@@ -0,0 +1,691 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | SYNAPSE-28: a call costs one round trip and the server's time.+--+-- Every call synapse makes goes through plexus-protocol's+-- 'ST.setCallRouter' hook to one of two places:+--+-- * __the holder__ — a process of synapse's own (@synapse _hold@), one per+--   backend address and agent, in the manner of ssh's ControlMaster. It+--   keeps the signed-in WebSocket open between runs and listens on a unix+--   socket (@$XDG_RUNTIME_DIR/synapse/ADDRESS\@AGENT-VERSION.sock@, 0600,+--   in a 0700 directory). A run hands it each request and reads the reply+--   back, so a warm call costs local IPC and one round trip. The first run+--   starts it; it exits after @--hold-for@ (10 minutes) with nothing to do.+-- * __the multiplexer__ in this process ('Mux') — what the holder itself+--   runs, and what a run uses with @--no-hold@ or when no holder can be+--   had: one connection per address and credential, every call of the+--   run on it (JSON-RPC carries many by id), never one per call.+--+-- Either way a failure reads as it did before: a lost connection is+-- 'LostConnection' (with whether the request had gone out), a failed dial+-- the error call 'Plexus.Client.connect' makes — so SYNAPSE-20's rules+-- (a read sent again, a write never resent blind, exit 69 and 75) and the+-- re-login from the key hold unchanged on top of it. A credential that+-- changed (a session made again from the key) is a new connection in the+-- holder, beside the old one until it is idle; the holder never signs in+-- by itself.+module Synapse.Hold+  ( -- * The multiplexer+    Mux+  , newMux+  , muxCall+  , muxActive+  , muxConnections++    -- * The holder+  , HoldOpts(..)+  , runHolder+  , socketPathFor+  , defaultHoldFor++    -- * Through the holder+  , holderCall+  , HolderGone(..)++    -- * The router+  , RouterOpts(..)+  , installRouter+  , routedCall+  ) where++import Control.Concurrent (forkIO, threadDelay, myThreadId)+import Control.Concurrent.Async (async, cancel, waitCatch, withAsync)+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Exception+import Control.Monad (forever, unless, void, when)+import Data.Aeson hiding (Key)+import qualified Data.Aeson.KeyMap as KM+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as LBS+import qualified Data.CaseInsensitive as CI+import Data.IORef+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as T+import Foreign.C.Types (CInt(..))+import GHC.Clock (getMonotonicTime)+import qualified Network.Socket as N+import qualified Network.Socket.ByteString as NB+import qualified Streaming.Prelude as S+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getTemporaryDirectory, removeFile)+import System.Environment (getExecutablePath, lookupEnv)+import System.Exit (exitSuccess)+import System.FilePath ((</>), takeDirectory)+import System.IO (hClose, IOMode(..), openFile)+import System.Posix.Files (setFileMode, getFileStatus, fileID, fileOwner, fileMode)+import Data.Bits ((.&.))+import System.Posix.IO (closeFd, createFile)+import System.Posix.Signals (installHandler, sigTERM, sigHUP, Handler(..))+import System.Posix.User (getRealUserID)+import System.Process (CreateProcess(..), StdStream(..), createProcess, proc)+import System.Timeout (timeout)+import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock_)++import Plexus.Client (SubstrateConfig(..), SubstrateConnection, LostConnection(..), TlsOptions(..), connect, disconnect, connectionLost, substrateRpcSub, unsubscribe)+import qualified Plexus.Transport as ST+import Plexus.Types (PlexusStreamItem(..))++-- ============================================================================+-- The multiplexer+-- ============================================================================++-- | Where and as whom: a config with its backend left out (the backend+-- names methods; it does not change the connection).+type ConnKey = SubstrateConfig++keyOf :: SubstrateConfig -> ConnKey+keyOf c = c { substrateBackend = "" }++-- | One connection and the calls on it.+data Upstream = Upstream+  { upConn     :: SubstrateConnection+  , upInflight :: TVar Int+  , upLastUsed :: IORef Double+  , upSerial   :: Int+  }++-- | Connections by address and credential, shared by every call.+data Mux = Mux+  { muxUps     :: MVar (Map.Map ConnKey [Upstream])+  , muxDialing :: MVar (Map.Map ConnKey (MVar ()))+  , muxBusy    :: TVar Int        -- ^ calls under way+  , muxLast    :: IORef Double    -- ^ when the last call ended (or began)+  , muxSerial  :: IORef Int       -- ^ connections opened (for tests, and the holder's log)+  , muxShared  :: MVar (Map.Map (ConnKey, Text, BS.ByteString) (MVar (Either SomeException [PlexusStreamItem])))+    -- ^ schema and _info reads under way, each asked once however many wait+  }++newMux :: IO Mux+newMux = do+  now <- getMonotonicTime+  Mux <$> newMVar Map.empty <*> newMVar Map.empty <*> newTVarIO 0 <*> newIORef now <*> newIORef 0 <*> newMVar Map.empty++-- | Calls under way, and when the last one ended.+muxActive :: Mux -> IO (Int, Double)+muxActive m = (,) <$> readTVarIO (muxBusy m) <*> readIORef (muxLast m)++-- | How many connections this multiplexer has opened.+muxConnections :: Mux -> IO Int+muxConnections = readIORef . muxSerial++-- | Calls one connection carries before another is opened beside it+-- (menger refuses past 256 open calls on one connection, ACCESS-29).+perConnection :: Int+perConnection = 200++-- | One call on the shared connection for its address and credential —+-- dialed when there is none (one dial at a time per key), dropped when it+-- is found dead. A call this side abandons (its thread cancelled, or its+-- consumer failing) is unsubscribed, so a held connection never fills up+-- with streams no one reads.+muxCall :: Mux -> SubstrateConfig -> ST.CallRoute+muxCall mux cfg onSub method params onItem+  | shareable method params = shared mux cfg onSub method params onItem+  | otherwise = muxCall' mux cfg onSub method params onItem++-- | A read every run asks the same of, and asks first: a schema+-- (@<backend>.call@ of @….schema@) or @_info@. Twenty runs starting at once+-- (a cold cache) wait on one answer — menger's @tickets@ schema is 2.6 MB —+-- where each would otherwise fetch its own.+shareable :: Text -> Value -> Bool+shareable method params = method == "_info" || case params of+  Object o | ".call" `T.isSuffixOf` method, Just (String m) <- KM.lookup "method" o -> ".schema" `T.isSuffixOf` m+  _ -> False++-- | The read asked once: the first asks it, the rest are given what it was+-- answered (or how it failed), each told it was taken first.+shared :: Mux -> SubstrateConfig -> ST.CallRoute+shared mux cfg onSub method params onItem = do+  let key = (keyOf cfg, method, LBS.toStrict (encode params))+  mine <- newEmptyMVar+  existing <- modifyMVar (muxShared mux) $ \m -> case Map.lookup key m of+    Just w -> pure (m, Just w)+    Nothing -> pure (Map.insert key mine m, Nothing)+  case existing of+    Just waiting -> readMVar waiting >>= \case+      Right items -> onSub >> mapM_ onItem items+      -- the first run went away (its call cancelled): ask for this one+      Left e | Just (_ :: SomeAsyncException) <- fromException e -> muxCall' mux cfg onSub method params onItem+      Left e -> throwIO e+    Nothing -> do+      acc <- newIORef []+      r <- try (muxCall' mux cfg onSub method params (\i -> modifyIORef' acc (i :) >> onItem i))+      items <- reverse <$> readIORef acc+      modifyMVar_ (muxShared mux) (pure . Map.delete key)+      putMVar mine (either Left (const (Right items)) r)+      either throwIO pure r++muxCall' :: Mux -> SubstrateConfig -> ST.CallRoute+muxCall' mux cfg onSub method params onItem = do+  now <- getMonotonicTime+  writeIORef (muxLast mux) now+  bracket_ (atomically (modifyTVar' (muxBusy mux) (+ 1)))+           (do atomically (modifyTVar' (muxBusy mux) (subtract 1))+               getMonotonicTime >>= writeIORef (muxLast mux)) $+    attempt True+  where+    key = keyOf cfg+    attempt again = do+      up <- acquire mux key cfg+      r <- try (onUpstream up) `finally` release up+      case r of+        -- the connection had died idle: nothing was sent, so once more on a+        -- fresh one (plexus-protocol's freshIfUnsent, here)+        Left (LostConnection _ False) | again -> drop' mux key up >> attempt False+        Left e -> do+          gone <- connectionLost (upConn up)+          when (isJust gone) $ drop' mux key up+          throwIO e+        Right () -> pure ()+    onUpstream up = do+      sub <- newIORef Nothing+      finished <- newIORef False+      let onS sid = writeIORef sub (Just sid) >> onSub+          deliver i = do+            case i of+              StreamDone{} -> writeIORef finished True+              StreamError{} -> writeIORef finished True+              _ -> pure ()+            onItem i+      S.mapM_ deliver (substrateRpcSub (upConn up) onS method params)+        `onException` do+          s <- readIORef sub+          f <- readIORef finished+          case s of+            Just sid | not f -> unsubscribe (upConn up) (method <> "_unsub") sid+                                  `catch` \(_ :: SomeException) -> pure ()+            _ -> pure ()++-- | A live connection for the key with room on it, or a new one.+acquire :: Mux -> ConnKey -> SubstrateConfig -> IO Upstream+acquire mux key cfg = do+  picked <- pick+  case picked of+    Just up -> pure up+    Nothing -> do+      lock <- modifyMVar (muxDialing mux) $ \m -> case Map.lookup key m of+        Just l -> pure (m, l)+        Nothing -> do+          l <- newMVar ()+          pure (Map.insert key l m, l)+      withMVar lock $ \() -> do+        again <- pick+        case again of+          Just up -> pure up+          Nothing -> do+            conn <- connect cfg { substrateBackend = "" }+            n <- atomicModifyIORef' (muxSerial mux) (\k -> (k + 1, k + 1))+            inflight <- newTVarIO 1+            used <- newIORef =<< getMonotonicTime+            let up = Upstream conn inflight used n+            modifyMVar_ (muxUps mux) (pure . Map.insertWith (flip (++)) key [up])+            pure up+  where+    pick = do+      ups <- Map.findWithDefault [] key <$> readMVar (muxUps mux)+      alive <- filterAlive ups+      when (length alive /= length ups) $+        modifyMVar_ (muxUps mux) (pure . Map.adjust (const alive) key)+      let try' [] = pure Nothing+          try' (u : us) = do+            ok <- atomically $ do+              n <- readTVar (upInflight u)+              if n < perConnection then True <$ writeTVar (upInflight u) (n + 1) else pure False+            if ok then pure (Just u) else try' us+      try' alive+    filterAlive = fmap concat . mapM (\u -> do+      g <- connectionLost (upConn u)+      pure [u | not (isJust g)])++release :: Upstream -> IO ()+release up = do+  atomically (modifyTVar' (upInflight up) (subtract 1))+  getMonotonicTime >>= writeIORef (upLastUsed up)++drop' :: Mux -> ConnKey -> Upstream -> IO ()+drop' mux key up = do+  modifyMVar_ (muxUps mux) (pure . Map.adjust (filter ((/= upSerial up) . upSerial)) key)+  disconnect (upConn up) `catch` \(_ :: SomeException) -> pure ()++-- | Close the connections nothing uses: idle ones for an address whose+-- credential has since changed (a session made again), and any idle for+-- longer than @maxIdle@.+sweep :: Mux -> Double -> IO ()+sweep mux maxIdle = do+  now <- getMonotonicTime+  ups <- readMVar (muxUps mux)+  -- per address, the credential used last is kept+  stamped <- mapM (\(k, us) -> do+                     ls <- mapM (readIORef . upLastUsed) us+                     pure (k, us, if null ls then 0 else maximum ls)) (Map.toList ups)+  let place k = (substrateHost k, substratePort k, substratePath k, substrateTls k)+      latest = Map.fromListWith max [(place k, t) | (k, _, t) <- stamped]+  mapM_ (\(k, us, t) -> mapM_ (\u -> do+           n <- readTVarIO (upInflight u)+           l <- readIORef (upLastUsed u)+           let superseded = Map.lookup (place k) latest > Just t && now - l > 5+           when (n == 0 && (superseded || now - l > maxIdle)) $ drop' mux k u) us) stamped++-- ============================================================================+-- The wire between a run and its holder+-- ============================================================================+--+-- One request per unix connection, a line of JSON each way:+--+--   run → holder   {"host","port","path","tls","ca","headers","method","params"}+--   holder → run   {"t":"taken"}            the request is read; it goes out now+--                  {"t":"sub"}              the server took the call+--                  {"t":"item","i":ITEM}    each item, as the server sent it+--                  {"t":"end"}              the call ended+--                  {"t":"lost","why","sent"} the connection went (LostConnection)+--                  {"t":"error","why"}      any other failure (a refused dial)+--+-- A run that goes away mid-call closes its socket; the holder cancels the+-- call (unsubscribing it).++encodeRequest :: SubstrateConfig -> Text -> Value -> Value+encodeRequest c method params = object+  [ "host" .= substrateHost c, "port" .= substratePort c, "path" .= substratePath c+  , "tls" .= isJust (substrateTls c)+  , "ca" .= maybe [] tlsCaFiles (substrateTls c)+  , "headers" .= [ [latin1 (CI.original k), latin1 v] | (k, v) <- substrateHeaders c ]+  , "method" .= method, "params" .= params ]+  where latin1 = T.pack . BS8.unpack++decodeRequest :: Value -> Maybe (SubstrateConfig, Text, Value)+decodeRequest = \case+  Object o -> do+    String host <- KM.lookup "host" o+    port <- num =<< KM.lookup "port" o+    String path <- KM.lookup "path" o+    Bool tls <- KM.lookup "tls" o+    ca <- resultMaybe . fromJSON =<< KM.lookup "ca" o+    hs <- resultMaybe . fromJSON =<< KM.lookup "headers" o+    String method <- KM.lookup "method" o+    let params = maybe Null id (KM.lookup "params" o)+        bytes = BS8.pack . T.unpack+    headers <- mapM (\case { [k, v] -> Just (CI.mk (bytes k), bytes v); _ -> Nothing }) (hs :: [[Text]])+    pure ( SubstrateConfig+             { substrateHost = T.unpack host, substratePort = port, substratePath = T.unpack path+             , substrateBackend = "", substrateHeaders = headers+             , substrateTls = if tls then Just (TlsOptions ca) else Nothing }+         , method, params )+  _ -> Nothing+  where+    num = \case+      Number n -> Just (round n)+      _ -> Nothing+    resultMaybe = \case+      Success a -> Just a+      Error _ -> Nothing++-- | Lines from a socket.+data LineReader = LineReader N.Socket (IORef BS.ByteString)++newLineReader :: N.Socket -> IO LineReader+newLineReader s = LineReader s <$> newIORef BS.empty++-- | The next line, or Nothing at the end.+readLine :: LineReader -> IO (Maybe BS.ByteString)+readLine (LineReader s buf) = go+  where+    go = do+      b <- readIORef buf+      case BS8.elemIndex '\n' b of+        Just i -> do+          writeIORef buf (BS.drop (i + 1) b)+          pure (Just (BS.take i b))+        Nothing -> do+          chunk <- NB.recv s 65536 `catch` \(_ :: IOException) -> pure BS.empty+          if BS.null chunk+            then pure Nothing+            else writeIORef buf (b <> chunk) >> go++sendLine :: N.Socket -> Value -> IO ()+sendLine s v = NB.sendAll s (LBS.toStrict (encode v) <> "\n")++-- ============================================================================+-- The holder+-- ============================================================================++data HoldOpts = HoldOpts+  { hoSocket  :: FilePath+  , hoHoldFor :: Double   -- ^ seconds with nothing to do before it exits+  }++-- | Ten minutes.+defaultHoldFor :: Double+defaultHoldFor = 600++-- | Serve the socket until idle for 'hoHoldFor', then remove it and exit.+runHolder :: HoldOpts -> IO ()+runHolder HoldOpts{..} = do+  mux <- newMux+  clients <- newTVarIO (0 :: Int)+  lastSeen <- newIORef =<< getMonotonicTime+  lsock <- N.socket N.AF_UNIX N.Stream N.defaultProtocol+  privateDir (takeDirectory hoSocket)+  removeIfExists hoSocket+  N.bind lsock (N.SockAddrUnix hoSocket)+  setFileMode hoSocket 0o600+  N.listen lsock 128+  ours <- fileID <$> getFileStatus hoSocket+  done <- newEmptyMVar+  let shutdown = do+        withLock (hoSocket <> ".lock") $ do+          N.close lsock `catch` \(_ :: SomeException) -> pure ()+          -- only our own socket: another holder may have replaced it+          st <- try (getFileStatus hoSocket)+          case st of+            Right s | fileID s == ours -> removeIfExists hoSocket+            Left (_ :: SomeException) -> pure ()+            _ -> pure ()+        -- what was taken before the close is finished first+        atomically $ readTVar clients >>= \n -> check (n == 0)+        void (tryPutMVar done ())+  main' <- myThreadId+  _ <- installHandler sigTERM (Catch (void (forkIO shutdown))) Nothing+  _ <- installHandler sigHUP (Catch (void (forkIO shutdown))) Nothing+  _ <- forkIO $ forever $ do+    r <- try (N.accept lsock)+    case r of+      Left (_ :: SomeException) -> threadDelay 100000+      Right (s, _) -> do+        atomically (modifyTVar' clients (+ 1))+        getMonotonicTime >>= writeIORef lastSeen+        void $ forkIO $+          serveClient mux s `finally` do+            N.close s `catch` \(_ :: SomeException) -> pure ()+            getMonotonicTime >>= writeIORef lastSeen+            atomically (modifyTVar' clients (subtract 1))+  _ <- forkIO $ forever $ do+    threadDelay 1000000+    sweep mux hoHoldFor+    n <- readTVarIO clients+    (busy, lastCall) <- muxActive mux+    seen <- readIORef lastSeen+    now <- getMonotonicTime+    when (n == 0 && busy == 0 && now - max seen lastCall >= hoHoldFor) shutdown+  _ <- pure main'+  takeMVar done+  exitSuccess++-- | One run's request: read it, say it is taken, relay the call, say how+-- it ended. The run closing its end cancels the call.+serveClient :: Mux -> N.Socket -> IO ()+serveClient mux s = do+  rd <- newLineReader s+  line <- timeout 30000000 (readLine rd)+  case line >>= id >>= decodeStrict of+    Nothing -> pure ()+    Just v -> case decodeRequest v of+      Nothing -> sendLine s (object ["t" .= ("error" :: Text), "why" .= ("synapse holder: a request it cannot read" :: Text)])+      Just (cfg, method, params) -> do+        sendLine s (object ["t" .= ("taken" :: Text)])+        let call = muxCall mux cfg+              (sendLine s (object ["t" .= ("sub" :: Text)]))+              method params+              (\i -> sendLine s (object ["t" .= ("item" :: Text), "i" .= i]))+        withAsync call $ \a -> do+          -- the run going away (its end closed) ends the call+          watcher <- async $ do+            _ <- readLine rd+            cancel a+          r <- waitCatch a+          cancel watcher+          let reply = case r of+                Right () -> object ["t" .= ("end" :: Text)]+                Left e | Just (LostConnection why sent) <- fromException e ->+                  object ["t" .= ("lost" :: Text), "why" .= why, "sent" .= sent]+                Left e -> object ["t" .= ("error" :: Text), "why" .= errorText e]+          sendLine s reply `catch` \(_ :: SomeException) -> pure ()++-- | An exception as the run should rethrow it: an error call's message as+-- it is ('connect' reports a failed dial as one), anything else shown.+errorText :: SomeException -> Text+errorText e = case fromException e of+  Just (ErrorCall m) -> T.pack m+  Nothing -> T.pack (show e)++-- ============================================================================+-- A run's side+-- ============================================================================++-- | The holder went away before it took the request: nothing was sent.+data HolderGone = HolderGone Text+  deriving Show++instance Exception HolderGone++-- | One call through the holder at the socket. Throws 'HolderGone' when+-- the holder cannot be reached or closes before taking the request (the+-- request did not go out); after that, what the holder reports.+holderCall :: FilePath -> SubstrateConfig -> ST.CallRoute+holderCall path cfg onSub method params onItem = do+  s <- N.socket N.AF_UNIX N.Stream N.defaultProtocol+  flip finally (N.close s `catch` \(_ :: SomeException) -> pure ()) $ do+    c <- try (N.connect s (N.SockAddrUnix path))+    case c of+      Left (e :: SomeException) -> throwIO (HolderGone (T.pack (show e)))+      Right () -> pure ()+    sent <- try (sendLine s (encodeRequest cfg method params))+    case sent of+      Left (e :: SomeException) -> throwIO (HolderGone (T.pack (show e)))+      Right () -> pure ()+    rd <- newLineReader s+    let loop taken = do+          line <- readLine rd+          case line >>= decodeStrict of+            Nothing+              | taken -> throwIO (LostConnection "the connection holder went away" True)+              | otherwise -> throwIO (HolderGone "the holder closed before taking the request")+            Just (Object o) -> case KM.lookup "t" o of+              Just (String "taken") -> loop True+              Just (String "sub") -> onSub >> loop True+              Just (String "item") -> do+                case fromJSON <$> KM.lookup "i" o of+                  Just (Success i) -> onItem i+                  _ -> pure ()+                loop True+              Just (String "end") -> pure ()+              Just (String "lost") ->+                let why = case KM.lookup "why" o of { Just (String w) -> w; _ -> "the connection was lost" }+                    wasSent = KM.lookup "sent" o /= Just (Bool False)+                in throwIO (LostConnection why wasSent)+              Just (String "error") ->+                throwIO (ErrorCall (case KM.lookup "why" o of { Just (String w) -> T.unpack w; _ -> "the holder failed" }))+              _ -> loop taken+            Just _ -> loop taken+    loop False++-- | The holder's socket for an address and agent:+-- @$XDG_RUNTIME_DIR/synapse/DIR\@AGENT-VERSION.sock@ (a temporary+-- directory of the user's own without one). A name too long for a unix+-- socket is shortened to a hash of itself.+socketPathFor :: Text -> FilePath -> Text -> IO FilePath+socketPathFor version addrDir agent = do+  base <- runtimeDir+  let name = addrDir <> "@" <> T.unpack (safe agent) <> "-" <> T.unpack version <> ".sock"+      full = base </> name+  pure $ if length full < 100 then full else base </> (show (fnv (T.pack name)) <> ".sock")+  where+    safe = T.map (\ch -> if ch `elem` ("/\\\0" :: String) then '_' else ch)+    -- a stable hash of the name (polynomial, mod 2^61-1): only its length matters here+    fnv :: Text -> Integer+    fnv = T.foldl' (\h ch -> (h * 131 + fromIntegral (fromEnum ch)) `mod` 2305843009213693951) 7++runtimeDir :: IO FilePath+runtimeDir = do+  x <- lookupEnv "XDG_RUNTIME_DIR"+  case x of+    Just d | not (null d) -> pure (d </> "synapse")+    _ -> do+      uid <- getRealUserID+      tmp <- getTemporaryDirectory+      pure (tmp </> ("synapse-" <> show uid))++-- | Start the holder for the socket unless one answers there, under the+-- socket's lock (so parallel first runs start one), and wait for it.+ensureHolder :: FilePath -> Double -> IO Bool+ensureHolder path holdFor = do+  privateDir (takeDirectory path)+  withLock (path <> ".lock") $ do+    up <- answers path+    if up then pure True else do+      removeIfExists path+      exe <- getExecutablePath+      devnull <- openFile "/dev/null" ReadWriteMode+      logH <- openFile (path <> ".log") WriteMode+      setFileMode (path <> ".log") 0o600+      procfs <- doesDirectoryExist "/proc/self/fd"+      let args = ["_hold", "--socket", path, "--hold-for", show holdFor]+          -- the holder keeps nothing of the run's but its own socket: every+          -- descriptor past stderr is closed before it starts. close_fds+          -- closes each one the limit allows (a million here: 0.3 s); on+          -- Linux, a shell closes only those /proc says are open, then execs+          spawn+            | procfs = (proc "/bin/sh" (["-c", closeOpenFds, "synapse-hold", exe] ++ args)) { close_fds = False }+            | otherwise = (proc exe args) { close_fds = True }+      _ <- createProcess spawn+        { std_in = UseHandle devnull, std_out = UseHandle devnull, std_err = UseHandle logH+        , new_session = True }+      hClose devnull+      hClose logH+      let wait (0 :: Int) = pure False+          wait n = do+            ok <- answers path+            if ok then pure True else threadDelay 5000 >> wait (n - 1)+      wait 600   -- 3 s++-- | A shell's start for the holder: close every descriptor past stderr+-- that is open, then exec the holder (the arguments after @$0@).+closeOpenFds :: String+closeOpenFds = concat+  [ "for f in /proc/$$/fd/*; do n=${f##*/}; "+  , "case $n in 0|1|2|*[!0-9]*) ;; *) eval \"exec $n>&-\" 2>/dev/null ;; esac; done; "+  , "exec \"$@\"" ]++-- | Does something accept on the socket?+answers :: FilePath -> IO Bool+answers path = do+  s <- N.socket N.AF_UNIX N.Stream N.defaultProtocol+  r <- try (N.connect s (N.SockAddrUnix path))+  N.close s `catch` \(_ :: SomeException) -> pure ()+  pure (either (\(_ :: SomeException) -> False) (const True) r)++-- ============================================================================+-- The router+-- ============================================================================++data RouterOpts = RouterOpts+  { roHold    :: Maybe (SubstrateConfig -> IO (Maybe FilePath))+    -- ^ the holder's socket for a call's address (and the run's agent), or+    -- Nothing for an address this run does not hold (a registry it only+    -- glances at); Nothing at all: this process's multiplexer alone+    -- (@--no-hold@)+  , roHoldFor :: Double+  }++-- | Route every call of this process: through the holder for its address+-- (started when there is none), else on this process's own shared+-- connection.+installRouter :: RouterOpts -> IO Mux+installRouter ro = do+  mux <- newMux+  broken <- newIORef False+  paths <- newIORef Map.empty+  ST.setCallRouter (\cfg -> Just (routedCall ro mux broken paths cfg))+  pure mux++routedCall :: RouterOpts -> Mux -> IORef Bool -> IORef (Map.Map ConnKey (Maybe FilePath)) -> SubstrateConfig -> ST.CallRoute+routedCall ro mux broken paths cfg onSub method params onItem = do+  b <- readIORef broken+  held <- case roHold ro of+    Just socketFor | not b -> do+      known <- Map.lookup (keyOf cfg) <$> readIORef paths+      p <- maybe (socketFor cfg) pure known+      modifyIORef' paths (Map.insert (keyOf cfg) p)+      pure p+    _ -> pure Nothing+  -- the socket's directory must be this user's alone (0700, owned by it)+  ours <- maybe (pure False) (dirIsOurs . takeDirectory) held+  case held of+    Just path | ours -> do+      let via = holderCall path cfg onSub method params onItem+      r <- try via+      case r of+        Right () -> pure ()+        Left (HolderGone _) -> do+          ok <- ensureHolder path (roHoldFor ro)+          if not ok then local' else do+            r' <- try via+            case r' of+              Right () -> pure ()+              Left (HolderGone _) -> local'+    _ -> muxCall mux cfg onSub method params onItem+  where+    -- no holder to be had: this process's own connection, for the rest of it+    local' = do+      writeIORef broken True+      muxCall mux cfg onSub method params onItem++-- ============================================================================+-- Files+-- ============================================================================++foreign import ccall safe "sys/file.h flock" c_flock :: CInt -> CInt -> IO CInt++-- | Hold an advisory lock on the file for the action.+withLock :: FilePath -> IO a -> IO a+withLock lockPath act = do+  opened <- try (createFile lockPath 0o600)+  case opened of+    Left (_ :: SomeException) -> act+    Right fd -> flip finally (closeFd fd) $ do+      throwErrnoIfMinus1RetryMayBlock_ "flock" (c_flock (fromIntegral fd) 2) (pure ())+      act++-- | The directory exists, is this user's, and no one else may enter it.+dirIsOurs :: FilePath -> IO Bool+dirIsOurs dir = do+  r <- try $ do+    privateDir dir+    st <- getFileStatus dir+    uid <- getRealUserID+    pure (fileOwner st == uid && (fileMode st .&. 0o077) == 0)+  pure (either (\(_ :: SomeException) -> False) id r)++privateDir :: FilePath -> IO ()+privateDir dir = do+  existed <- doesDirectoryExist dir+  createDirectoryIfMissing True dir+  unless existed $ setFileMode dir 0o700++removeIfExists :: FilePath -> IO ()+removeIfExists p = removeFile p `catch` \(_ :: SomeException) -> pure ()
src/Synapse/IR/Builder.hs view
@@ -4,33 +4,39 @@ -- | IR Builder - walks schema tree and constructs the IR -- -- Uses the existing schema walker with a custom algebra that:--- 1. Extracts types from $defs in methodParams and methodReturns--- 2. Deduplicates types by content hash (prefer parent namespace, then shortest)+-- 1. Reads types from $defs in methodParams, methodReturns and methodInput+--    — whole, or refused by name (SYNAPSE-CC-8: "Synapse.IR.Read")+-- 2. Deduplicates types by content hash, placing each shared type in the+--    namespace that refers to it most (SYNAPSE-CC-8) -- 3. Infers streaming from return type structure--- 4. Builds method definitions with type references+-- 4. Builds method definitions with type references; server-injected params+--    go to 'mdInjected', never 'mdParams' module Synapse.IR.Builder   ( -- * Building IR     buildIR+  , buildIRRaw+  , finalizeIR      -- * Extraction (for testing)   , extractTypesFromSchema   , extractMethodDef+  , extractMethodDefR   , schemaToTypeRef   ) where -import Control.Monad (forM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (asks) import Data.Aeson (Value(..)) import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM-import Data.List (minimumBy)+import Data.List (minimumBy, nub, sortOn) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe, mapMaybe, catMaybes)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Ord (comparing)+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Vector as V import Data.Time.Clock (getCurrentTime) import Data.Time.Format (formatTime, defaultTimeLocale) @@ -40,6 +46,7 @@ import Synapse.Monad import Synapse.IR.Types hiding (QualifiedName(..), qualifiedNameFull) import Synapse.IR.Types (QualifiedName(..), qualifiedNameFull, synapseVersion)+import Synapse.IR.Read import Plexus.Schema.Recursive (DeprecationInfo, ParamSchema(..), paramValues)  -- ============================================================================@@ -88,11 +95,26 @@         , gmIrVersion = irVersion emptyIR         } -  pure $ deduplicateTypes raw+  pure $ finalizeIR raw     { irBackend = backend     , irMetadata = Just metadata     } +-- | The walk's IR before 'finalizeIR' (for the bench: its phases apart).+buildIRRaw :: Path -> SynapseM IR+buildIRRaw = walkSchemaPar irAlgebra++-- | SYNAPSE-CC-8: the walk's IR made whole — shared types deduplicated and+--   placed where they are referred to most, every ref that names no type+--   turned to 'RefUnknown' (and refused, unless the type it names was), the+--   refusals deduplicated and sorted by site.+finalizeIR :: IR -> IR+finalizeIR raw =+  let placed = deduplicateTypes raw+      refusedTypes = Set.fromList (map rfSite (irRefusals placed))+      (fixed, dangling) = unknownWhereUnnamed refusedTypes placed+  in fixed { irRefusals = sortOn rfSite (nub (irRefusals placed ++ dangling)) }+ -- | Algebra for building IR from schema tree -- -- At each node:@@ -107,7 +129,7 @@       pathPrefix = namespace  -- Same as namespace    -- Extract types and methods from this plugin-  let (localTypes, localMethods) = extractFromPlugin namespace pathPrefix schema+  let (localTypes, localMethods, localRefusals) = extractFromPlugin namespace pathPrefix schema    -- Merge with children   let childIR = foldr mergeIR emptyIR childIRs@@ -146,12 +168,13 @@     , irPluginRoles = case (psRoles schema, irPluginRoles childIR) of         (Nothing, childRoles) -> childRoles         (Just roles, childRoles) -> Just (Map.insert namespace roles (fromMaybe Map.empty childRoles))+    , irRefusals = localRefusals <> irRefusals childIR     }  irAlgebra (MethodF method namespace path) = do   -- Single method node (shouldn't happen in normal walk, but handle it)   let fullPath = T.intercalate "." path-  let (types, mdef) = extractMethodDef namespace fullPath method+  let ((types, mdef), refusals) = extractMethodDefR namespace fullPath method   pure $ IR     { irVersion = irVersion emptyIR  -- Use version from emptyIR     , irBackend = irBackend emptyIR  -- Will be set by buildIR@@ -163,10 +186,11 @@     , irPluginHashes = Nothing  -- Methods don't have plugin-level hashes     , irPluginRequests = Nothing  -- Methods don't carry request schemas     , irPluginRoles = Nothing  -- Methods don't carry roles+    , irRefusals = refusals     }  -- ============================================================================--- Type Deduplication+-- Type Deduplication and Placement -- ============================================================================  -- | Deduplicate types by content hash@@ -177,7 +201,7 @@ -- Strategy: -- 1. Hash each TypeDef by its structure (name + kind, ignoring namespace) -- 2. Group duplicates--- 3. Pick canonical: prefer parent namespace, then shortest namespace+-- 3. Pick canonical: the namespace that refers to it most (SYNAPSE-CC-8) -- 4. Update all RefNamed references to point to canonical qualified name deduplicateTypes :: IR -> IR deduplicateTypes ir =@@ -187,26 +211,27 @@         | (fullName, td) <- Map.toList (irTypes ir)         ] +      -- only types with copies in several namespaces need their references counted+      contested = Set.fromList+        [ (tdNamespace td, tdName td) | group <- Map.elems typesByHash, length group > 1, (_, td) <- group ]+      counts = refCounts contested ir+       -- Pick canonical version for each group-      canonical = Map.fromList-        [ (hash, selectCanonical group)-        | (hash, group) <- Map.toList typesByHash-        ]+      canonical = Map.map (selectCanonical counts) typesByHash        -- Build redirect map: old qualified name -> canonical qualified name       redirects = Map.fromList         [ (oldName, canonicalName)-        | group <- Map.elems typesByHash-        , let canonicalName = fst (selectCanonical group)+        | (hash, group) <- Map.toList typesByHash+        , let canonicalName = fst (canonical Map.! hash)         , (oldName, _) <- group         , oldName /= canonicalName         ]        -- Keep only canonical types and update their internal type references-      canonicalPairs = [canon | canon <- Map.elems canonical]       dedupedTypesWithUpdatedRefs = Map.fromList         [ (qualName, updateTypeDefRefs redirects td)-        | (qualName, td) <- canonicalPairs+        | (qualName, td) <- Map.elems canonical         ]        -- Update all method references@@ -221,49 +246,59 @@ hashTypeStructure TypeDef{..} =   tdName <> "::" <> T.pack (show (normalizeTypeKind tdKind))   where-    -- Normalize a TypeKind by stripping namespaces from all RefNamed types-    normalizeTypeKind :: TypeKind -> TypeKind-    normalizeTypeKind = \case-      KindStruct fields -> KindStruct (map normalizeField fields)-      KindEnum disc variants -> KindEnum disc (map normalizeVariant variants)-      KindStringEnum vals -> KindStringEnum vals-      KindAlias target -> KindAlias (normalizeTypeRef target)-      KindPrimitive t f -> KindPrimitive t f--    normalizeField :: FieldDef -> FieldDef-    normalizeField fd = fd { fdType = normalizeTypeRef (fdType fd) }+    normalizeTypeKind = mapKindRefs normalizeTypeRef+    normalizeTypeRef = mapRef $ \case+      RefNamed qn -> RefNamed qn { qnNamespace = "" }+      other -> other -    normalizeVariant :: VariantDef -> VariantDef-    normalizeVariant vd = vd { vdFields = map normalizeField (vdFields vd) }+-- | SYNAPSE-CC-8: how often each type is named, by full name — in every+--   method's params, returns, input and bidirectional type, and every type's+--   fields, before deduplication. A namespace names only its own copy, so a+--   copy's count is how much its namespace refers to it.+refCounts :: Set.Set (Text, Text) -> IR -> Map (Text, Text) Int+refCounts contested ir+  | Set.null contested = Map.empty+  | otherwise = Map.fromListWith (+) [ (n, 1 :: Int) | n <- names, Set.member n contested ]+  where+    names = concatMap methodNames (Map.elems (irMethods ir))+         ++ concatMap (kindNames . tdKind) (Map.elems (irTypes ir))+    methodNames md = concatMap refKeys+      (map pdType (mdParams md) ++ [mdReturns md] ++ maybe [] pure (mdInput md) ++ maybe [] pure (mdBidirType md))+    kindNames = \case+      KindStruct fs -> concatMap (refKeys . fdType) fs+      KindEnum _ vs _ -> concatMap (\v -> concatMap (refKeys . fdType) (vdFields v) ++ maybe [] refKeys (vdRef v)) vs+      KindAlias t -> refKeys t+      KindStringEnum _ -> []+      KindPrimitive _ _ -> []+    refKeys = \case+      RefNamed qn -> [(qnNamespace qn, qnLocalName qn)]+      t -> concatMap refKeys (typeRefChildren t) -    normalizeTypeRef :: TypeRef -> TypeRef-    normalizeTypeRef = \case-      RefNamed qn ->-        -- Strip namespace: keep only local name-        RefNamed qn { qnNamespace = "" }-      RefArray inner -> RefArray (normalizeTypeRef inner)-      RefOptional inner -> RefOptional (normalizeTypeRef inner)-      other -> other+-- | A name as 'irTypes' keys it (the root's types are @.Name@).+qualifiedNameFull' :: QualifiedName -> Text+qualifiedNameFull' qn = qnNamespace qn <> "." <> qnLocalName qn  -- | Select the canonical version from a group of duplicate types--- Strategy: prefer parent namespace, then shortest namespace-selectCanonical :: [(Text, TypeDef)] -> (Text, TypeDef)-selectCanonical dups =+-- (SYNAPSE-CC-8): the copy in the namespace that refers to it most. A tie+-- goes to the namespace that is an ancestor of every other tied one, then+-- the shortest name, then alphabetical order. The protocol root @""@ is+-- never chosen when a generated namespace has a copy.+selectCanonical :: Map (Text, Text) Int -> [(Text, TypeDef)] -> (Text, TypeDef)+selectCanonical counts dups =   case dups of     [] -> error "selectCanonical: empty list"     [single] -> single-    multiple -> minimumBy compareNamespacePreference multiple-  where-    -- Compare two (fullName, typedef) pairs-    compareNamespacePreference (_, td1) (_, td2) =-      let ns1 = tdNamespace td1-          ns2 = tdNamespace td2-          -- Check if one is parent of the other-          isParent n1 n2 = n2 `T.isPrefixOf` n1 && T.length n1 > T.length n2-      in case (isParent ns1 ns2, isParent ns2 ns1) of-           (True, False) -> GT  -- ns2 is parent of ns1, prefer ns2-           (False, True) -> LT  -- ns1 is parent of ns2, prefer ns1-           _ -> compare (T.length ns1) (T.length ns2)  -- Fallback: shortest wins+    multiple ->+      let generated = filter ((/= "") . tdNamespace . snd) multiple+          candidates = if null generated then multiple else generated+          countOf (_, td) = Map.findWithDefault 0 (tdNamespace td, tdName td) counts+          best = maximum (map countOf candidates)+          tied = filter ((== best) . countOf) candidates+          nsOf = tdNamespace . snd+          ancestorOfAll c = all (\o -> nsOf o == nsOf c || (nsOf c <> ".") `T.isPrefixOf` nsOf o) tied+      in case filter ancestorOfAll tied of+           (c : _) -> c+           [] -> minimumBy (comparing (\c -> (T.length (nsOf c), nsOf c))) tied  -- | Parse a qualified name from a full name string (e.g., "cone.UUID" -> QualifiedName "cone" "UUID") parseQualifiedName :: Text -> Maybe QualifiedName@@ -282,9 +317,8 @@   { mdParams = map (updateParamRefs redirects) (mdParams md)   , mdReturns = updateTypeRef redirects (mdReturns md)   , mdBidirType = fmap (updateTypeRef redirects) (mdBidirType md)-  , mdBidirResponseType = mdBidirResponseType md  -- Preserve as-is-  , mdBidirResponseSchema = mdBidirResponseSchema md  -- Preserve as-is-  -- mdRole: left unchanged via record-update syntax+  , mdInput = fmap (updateTypeRef redirects) (mdInput md)+  -- mdRole, mdBidirResponse*: left unchanged via record-update syntax   }  -- | Update type references in a parameter@@ -295,100 +329,162 @@  -- | Recursively update a TypeRef to use canonical names updateTypeRef :: Map Text Text -> TypeRef -> TypeRef-updateTypeRef redirects = \case+updateTypeRef redirects = mapRef $ \case   RefNamed qn ->-    let fullName = qualifiedNameFull qn+    let fullName = qualifiedNameFull' qn         canonicalName = Map.findWithDefault fullName fullName redirects     in case parseQualifiedName canonicalName of          Just qn' -> RefNamed qn'          Nothing -> RefNamed qn  -- Fallback if parse fails-  RefArray inner ->-    RefArray (updateTypeRef redirects inner)-  RefOptional inner ->-    RefOptional (updateTypeRef redirects inner)   other -> other  -- | Update all type references in a TypeDef updateTypeDefRefs :: Map Text Text -> TypeDef -> TypeDef-updateTypeDefRefs redirects td = td { tdKind = updateTypeKind (tdKind td) }+updateTypeDefRefs redirects td = td { tdKind = mapKindRefs (updateTypeRef redirects) (tdKind td) }++-- | Apply a function to every ref, bottom up.+mapRef :: (TypeRef -> TypeRef) -> TypeRef -> TypeRef+mapRef f = go   where-    updateTypeKind :: TypeKind -> TypeKind-    updateTypeKind = \case-      KindStruct fields ->-        KindStruct (map updateField fields)-      KindEnum disc variants ->-        KindEnum disc (map updateVariant variants)-      KindAlias target ->-        KindAlias (updateTypeRef redirects target)-      KindStringEnum vals ->-        KindStringEnum vals-      KindPrimitive t f ->-        KindPrimitive t f+    go = \case+      RefArray t -> f (RefArray (go t))+      RefOptional t -> f (RefOptional (go t))+      RefMap t -> f (RefMap (go t))+      RefTuple ts -> f (RefTuple (map go ts))+      RefRefined t r -> f (RefRefined (go t) r)+      other -> f other -    updateField :: FieldDef -> FieldDef-    updateField fd = fd { fdType = updateTypeRef redirects (fdType fd) }+-- | Apply a ref transformation to every ref a kind holds.+mapKindRefs :: (TypeRef -> TypeRef) -> TypeKind -> TypeKind+mapKindRefs g = \case+  KindStruct fields -> KindStruct (map field fields)+  KindEnum disc variants repr -> KindEnum disc (map variant variants) repr+  KindAlias target -> KindAlias (g target)+  KindStringEnum vals -> KindStringEnum vals+  KindPrimitive t f -> KindPrimitive t f+  where+    field fd = fd { fdType = g (fdType fd) }+    variant vd = vd { vdFields = map field (vdFields vd), vdRef = fmap g (vdRef vd) } -    updateVariant :: VariantDef -> VariantDef-    updateVariant vd = vd { vdFields = map updateField (vdFields vd) }+-- ============================================================================+-- Refs that name no type+-- ============================================================================ +-- | SYNAPSE-CC-8: every 'RefNamed' that names no type becomes 'RefUnknown'.+--   One that names a type the reader refused needs nothing more (the type's+--   refusal names it); any other is refused at its own site.+unknownWhereUnnamed :: Set.Set Text -> IR -> (IR, [Refusal])+unknownWhereUnnamed refused ir =+  let known = Map.keysSet (irTypes ir)+      fix site t = case t of+        RefNamed qn+          | Set.member (qualifiedNameFull' qn) known -> (t, [])+          | Set.member (qualifiedNameFull' qn) refused -> (RefUnknown, [])+          | otherwise -> (RefUnknown, [Refusal site "$ref" Nothing ("names " <> qualifiedNameFull' qn <> ", which no $defs defines")])+        RefArray i -> let (i', rs) = fix (site <> "[]") i in (RefArray i', rs)+        RefOptional i -> let (i', rs) = fix (site <> "?") i in (RefOptional i', rs)+        RefMap i -> let (i', rs) = fix (site <> "{}") i in (RefMap i', rs)+        RefRefined i r -> let (i', rs) = fix site i in (RefRefined i' r, rs)+        RefTuple ts ->+          let rs' = zipWith (\n x -> fix (site <> "." <> T.pack (show n)) x) [0 :: Int ..] ts+          in (RefTuple (map fst rs'), concatMap snd rs')+        _ -> (t, [])+      fixField site fd = let (t, rs) = fix (site <> "." <> fdName fd) (fdType fd) in (fd { fdType = t }, rs)+      fixKind site = \case+        KindStruct fs -> let r = map (fixField site) fs in (KindStruct (map fst r), concatMap snd r)+        KindEnum d vs repr ->+          let fixV v =+                let vsite = site <> "." <> vdName v+                    fr = map (fixField vsite) (vdFields v)+                    (ref', rr) = case vdRef v of+                      Nothing -> (Nothing, [])+                      Just x -> let (x', rs) = fix vsite x in (Just x', rs)+                in (v { vdFields = map fst fr, vdRef = ref' }, concatMap snd fr ++ rr)+              r = map fixV vs+          in (KindEnum d (map fst r) repr, concatMap snd r)+        KindAlias t -> let (t', rs) = fix site t in (KindAlias t', rs)+        k -> (k, [])+      fixType name td = let (k, rs) = fixKind name (tdKind td) in (td { tdKind = k }, rs)+      fixMethod md =+        let path = mdFullPath md+            ps = [ let (t, rs) = fix (siteParam path (pdName p)) (pdType p) in (p { pdType = t }, rs) | p <- mdParams md ]+            (ret, rr) = fix (siteReturns path) (mdReturns md)+            (inp, ri) = case mdInput md of+              Nothing -> (Nothing, [])+              Just x -> let (x', rs) = fix (siteInput path) x in (Just x', rs)+        in (md { mdParams = map fst ps, mdReturns = ret, mdInput = inp }, concatMap snd ps ++ rr ++ ri)+      types' = Map.mapWithKey fixType (irTypes ir)+      methods' = Map.map fixMethod (irMethods ir)+  in ( ir { irTypes = Map.map fst types', irMethods = Map.map fst methods' }+     , concatMap snd (Map.elems types') ++ concatMap snd (Map.elems methods') )+ -- ============================================================================ -- Extraction from Plugin -- ============================================================================  -- | Extract all types and methods from a plugin schema -- Types are namespace-qualified to avoid collisions (e.g., "cone.ListResult")-extractFromPlugin :: Text -> Text -> PluginSchema -> (Map Text TypeDef, Map Text MethodDef)+extractFromPlugin :: Text -> Text -> PluginSchema -> (Map Text TypeDef, Map Text MethodDef, [Refusal]) extractFromPlugin namespace pathPrefix schema =-  let methods = psMethods schema-      results = map (extractMethodDef namespace pathPrefix) methods-      allTypes = Map.unions (map fst results)-      allMethods = Map.fromList-        [ (mdFullPath m, m)-        | (_, m) <- results-        ]-  in (allTypes, allMethods)+  let -- every method's documents share one namespace's $defs: read once+      docs = [ o | m <- psMethods schema, Just (Object o) <- [methodParams m, methodReturns m, methodInput m] ]+      shared = sharedDoc namespace docs+      ((defs, results), refusals) = runRead $ do+        ds <- readDefs shared+        rs <- traverse (methodDefRead (Just shared) namespace pathPrefix) (psMethods schema)+        pure (ds, rs)+      allTypes = Map.unions (defs : map fst results)+      allMethods = Map.fromList [ (mdFullPath m, m) | (_, m) <- results ]+  in (allTypes, allMethods, refusals) --- | Extract types and method def from a single method+-- | Extract types and method def from a single method (its refusals dropped:+--   'extractMethodDefR' keeps them). extractMethodDef :: Text -> Text -> MethodSchema -> (Map Text TypeDef, MethodDef)-extractMethodDef namespace pathPrefix method =+extractMethodDef namespace pathPrefix = fst . extractMethodDefR namespace pathPrefix++-- | Extract types and method def from a single method, and every site the+--   reader refused on the way.+extractMethodDefR :: Text -> Text -> MethodSchema -> ((Map Text TypeDef, MethodDef), [Refusal])+extractMethodDefR = extractMethodDefIn Nothing++-- | 'extractMethodDefR', its $defs read from a namespace's shared document+--   when one is given (and so not read here), else from its own documents.+extractMethodDefIn :: Maybe Doc -> Text -> Text -> MethodSchema -> ((Map Text TypeDef, MethodDef), [Refusal])+extractMethodDefIn shared namespace pathPrefix = runRead . methodDefRead shared namespace pathPrefix++methodDefRead :: Maybe Doc -> Text -> Text -> MethodSchema -> SchemaRead (Map Text TypeDef, MethodDef)+methodDefRead shared namespace pathPrefix method = do   let name = methodName method       fullPath = if T.null pathPrefix                  then namespace <> "." <> name                  else pathPrefix <> "." <> name -      -- Extract types from params (namespace-qualified).-      -- Also pass methodParamSchemas so per-param deprecation info-      -- (IR-14) flows from ParamSchema.paramDeprecation onto the IR-      -- ParamDef.pdDeprecation.-      (paramTypes, params) =-        extractParams namespace (methodParams method) (methodParamSchemas method)--      -- Extract types from returns (namespace-qualified)-      (returnTypes, returnRef, streaming) = extractReturns namespace name (methodReturns method)+  -- Params: what a client sends, and what the server injects (SYNAPSE-CC-8).+  -- Per-param deprecation (IR-14) flows from methodParamSchemas.+  (paramTypes, params, injected) <-+    readParams shared namespace fullPath (methodParams method) (methodParamSchemas method) -      -- Combine all types-      allTypes = Map.union paramTypes returnTypes+  -- Returns: a child's is its client (SYNAPSE-CC-8's RefChild); an rpc+  -- method's is read whole, and its absence is refused.+  RootRead returnTypes returnRef streaming <- case methodRole method of+    MethodRoleRpc -> case methodReturns method of+      Just v -> readRoot shared namespace (siteReturns fullPath) (name <> "Result") v+      Nothing -> do+        refuse (siteReturns fullPath) "returns" Nothing "an rpc method with no returns schema"+        pure (RootRead Map.empty RefUnknown False)+    _child -> do+      defs <- case (shared, methodReturns method) of+        (Nothing, Just (Object o)) -> readDefs (docOf namespace o)+        _ -> pure Map.empty+      pure (RootRead defs (RefChild fullPath) False) -      -- Detect bidirectional type parameter T.-      ---      -- When the schema reports bidirectional: true we know the method uses a-      -- BidirChannel.  The 'request_type' field (if present) holds the JSON-      -- Schema for T.  We currently emit:-      --   - Nothing           → not bidirectional-      --   - Just RefAny       → bidirectional with T=Value (StandardBidirChannel,-      --                         the default case; request_type is the StandardRequest schema)-      --   - Just (RefNamed …) → bidirectional with a specific named T-      --                         (future: when request_type references a named type)-      ---      -- NOTE: The substrate schema as of this implementation always uses-      -- StandardBidirChannel (T=Value), so mdBidirType is always Nothing or-      -- Just RefAny.  A future change to MethodSchema / hub-macro that emits a-      -- structured "bidir_type" field (distinct from the full request_type schema)-      -- should be handled here.-      bidirTypeRef = inferBidirType method-      bidirResponseSchema = methodResponseType method+  -- Input: reserved for BIDIR-6; read when a server says it.+  inputRead <- traverse (readRoot shared namespace (siteInput fullPath) (name <> "Input")) (methodInput method) -      mdef = MethodDef+  let allTypes = Map.unions [paramTypes, returnTypes, maybe Map.empty rrTypes inputRead]+  pure+    ( allTypes+    , MethodDef         { mdName = name         , mdFullPath = fullPath         , mdNamespace = namespace@@ -396,91 +492,58 @@         , mdStreaming = streaming         , mdParams = params         , mdReturns = returnRef-        , mdBidirType = bidirTypeRef+        , mdBidirType = inferBidirType method         , mdBidirResponseType = Nothing  -- TODO: could extract from response_type title-        , mdBidirResponseSchema = bidirResponseSchema+        , mdBidirResponseSchema = methodResponseType method         , mdRole = methodRole method-          -- IR-12: lift MethodSchema.role onto the IR so hub-codegen's-          -- typed-handle codegen (IR-9) sees DynamicChild/StaticChild-          -- 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.+          -- IR-12: lift MethodSchema.role onto the IR so service-codegen's+          -- typed-handle codegen (IR-9) sees DynamicChild/StaticChild tags.         , 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.+          -- for service-codegen; Nothing from a pre-AUTH schema.+        , mdInjected = injected+        , mdInput = rrRef <$> inputRead         }-  in (allTypes, mdef)+    )  -- | Infer the bidirectional type parameter from a MethodSchema. -- -- Returns: --   Nothing    – method is not bidirectional---   Just RefAny – method is bidirectional with default T=Value (StandardBidirChannel)---   Just tr    – method is bidirectional with specific T type (future)+--   Just RefJson – method is bidirectional with default T=Value (StandardBidirChannel)+--+-- TODO: When the activation macro emits a structured "bidir_type", read it here. inferBidirType :: MethodSchema -> Maybe TypeRef inferBidirType method   | not (methodBidirectional method) = Nothing-  -- Method is bidirectional.  Inspect request_type to determine T.-  | otherwise = case methodRequestType method of-      Nothing ->-        -- bidirectional: true but no request_type schema → treat as T=Value-        Just RefAny-      Just _ ->-        -- request_type is present.  For now we always emit RefAny (T=Value)-        -- because the schema emits the full StandardRequest schema rather than-        -- a dedicated "bidir_type" field identifying T.-        ---        -- TODO: When the hub-macro is extended to emit a structured-        -- "bidir_type": { "$ref": "#/$defs/MyType" } field in the schema JSON,-        -- parse it here with schemaToTypeRef and return the resulting TypeRef.-        Just RefAny+  | otherwise = Just RefJson  -- StandardBidirChannel's T = serde_json::Value  -- ============================================================================ -- Parameter Extraction -- ============================================================================ --- | Extract types and param defs from method params schema.------ The third argument carries optional per-parameter metadata--- ('ParamSchema') emitted by IR-5 producers. When present, each entry's--- 'paramDeprecation' is lifted onto the resulting 'ParamDef.pdDeprecation'--- by matching parameter name. Absent entries (pre-IR-5 producers, or--- non-deprecated params) leave 'pdDeprecation' as 'Nothing'.--- Types are namespace-qualified to avoid collisions.-extractParams-  :: Text+-- | The params schema read: its types, the params a client sends, and the+--   params the server injects (@x-plexus-source@ other than rpc — they are+--   not read as types: the server supplies them).+readParams+  :: Maybe Doc+  -> Text+  -> Text   -> Maybe Value   -> Maybe [ParamSchema]-  -> (Map Text TypeDef, [ParamDef])-extractParams _ Nothing _ = (Map.empty, [])-extractParams namespace (Just val) paramSchemas = case val of-  Object o -> extractParamsFromObject namespace o paramSchemas-  _ -> (Map.empty, [])--extractParamsFromObject-  :: Text-  -> KM.KeyMap Value-  -> Maybe [ParamSchema]-  -> (Map Text TypeDef, [ParamDef])-extractParamsFromObject namespace o paramSchemas =-  let -- Extract $defs (namespace-qualified)-      defs = extractDefs namespace o--      -- Extract properties+  -> SchemaRead (Map Text TypeDef, [ParamDef], [InjectedParam])+readParams shared namespace fullPath (Just (Object o)) paramSchemas = do+  let doc = maybe (docOf namespace o) id shared       props = case KM.lookup "properties" o of         Just (Object p) -> KM.toList p         _ -> []--      -- Get required list       required = case KM.lookup "required" o of-        Just (Array arr) -> [t | String t <- V.toList arr]+        Just (Array arr) -> [t | String t <- foldr (:) [] arr]         _ -> [] -      -- Look up per-parameter deprecation by name from the structured-      -- ParamSchema list (IR-5). 'Nothing' when either the list is absent-      -- or the named parameter isn't in it.+      -- IR-14: per-parameter deprecation by name from the structured list.       lookupDeprecation :: Text -> Maybe DeprecationInfo       lookupDeprecation pname = case paramSchemas of         Nothing -> Nothing@@ -488,311 +551,61 @@           (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-            { pdName = K.toText k-            , pdType = schemaToTypeRef namespace v-            , pdDescription = extractDescription v-            , pdRequired = K.toText k `elem` required-            , pdDefault = extractDefault v-            , pdDeprecation = lookupDeprecation (K.toText k)-            , pdSource = extractSource v-            , pdValues = paramValues v-            }-        | (k, v) <- props-        ]-  in (defs, params)---- ============================================================================--- Return Type Extraction--- ============================================================================---- | Extract types, return ref, and streaming flag from returns schema-extractReturns :: Text -> Text -> Maybe Value -> (Map Text TypeDef, TypeRef, Bool)-extractReturns _ _ Nothing = (Map.empty, RefUnknown, False)-extractReturns namespace methodName (Just val) = case val of-  Object o ->-    let -- Extract $defs-        defs = extractDefs namespace o--        -- Get the type name from title or generate from method name-        typeName = case KM.lookup "title" o of-          Just (String t) -> t-          _ -> methodName <> "Result"--        -- Check for oneOf (discriminated union)-        (typeDef, streaming) = case KM.lookup "oneOf" o of-          Just (Array variants) ->-            let variantDefs = mapMaybe (extractVariant namespace) (V.toList variants)-                discriminator = inferDiscriminator variantDefs-                nonErrorVariants = filter (\v -> vdName v /= "error") variantDefs-                isStream = length nonErrorVariants > 1-            in ( Just $ TypeDef-                   { tdName = typeName-                   , tdNamespace = namespace-                   , tdDescription = extractDescription val-                   , tdKind = KindEnum discriminator variantDefs-                   }-               , isStream-               )-          _ ->-            -- Not a union, just a regular type-            (Nothing, False)--        -- Add the return type to defs if it's a union-        allDefs = case typeDef of-          Just td -> Map.insert (tdFullName td) td defs-          Nothing -> defs--        -- Return type reference uses QualifiedName-        typeRef = RefNamed QualifiedName-          { qnNamespace = namespace-          , qnLocalName = typeName+  defs <- maybe (readDefs doc) (const (pure Map.empty)) shared+  entries <- traverse (\(k, v) -> readParam doc (K.toText k) v) props+  let params = [ p { pdRequired = pdName p `elem` required, pdDeprecation = lookupDeprecation (pdName p) } | Left p <- entries ]+      injected = [ i | Right i <- entries ]+  pure (defs, params, injected)+  where+    readParam doc pname v = case sourceOf v of+      Just src | injectedSource src -> pure $ Right InjectedParam+        { ipName = pname, ipSource = src, ipDescription = descriptionOfValue v }+      src -> do+        t <- readType doc (siteParam fullPath pname) v+        pure $ Left ParamDef+          { pdName = pname+          , pdType = t+          , pdDescription = descriptionOfValue v+          , pdRequired = False+          , pdDefault = defaultOfValue v+          , pdDeprecation = Nothing+          , pdSource = src+          , pdValues = paramValues v           }--    in (allDefs, typeRef, streaming)-  _ -> (Map.empty, RefUnknown, False)---- | Extract a variant from a oneOf element-extractVariant :: Text -> Value -> Maybe VariantDef-extractVariant namespace (Object o) = case KM.lookup "properties" o of-  Just (Object props) ->-    -- Find the discriminator value (look for "type" with const)-    let discriminatorValue = case KM.lookup "type" props of-          Just (Object typeObj) -> case KM.lookup "const" typeObj of-            Just (String s) -> Just s-            _ -> Nothing-          _ -> Nothing--        -- Extract fields (excluding the discriminator)-        fields =-          [ FieldDef-              { fdName = K.toText k-              , fdType = schemaToTypeRef namespace v-              , fdDescription = extractDescription v-              , fdRequired = True  -- In variants, fields are typically required-              , fdDefault = Nothing-              }-          | (k, v) <- KM.toList props-          , K.toText k /= "type"  -- Exclude discriminator-          ]-    in case discriminatorValue of-         Just dv -> Just $ VariantDef-           { vdName = dv-           , vdDescription = extractDescription (Object o)-           , vdFields = fields-           }-         Nothing -> Nothing-  _ -> Nothing-extractVariant _ _ = Nothing---- | Infer the discriminator field name from variants-inferDiscriminator :: [VariantDef] -> Text-inferDiscriminator _ = "type"  -- Convention: always "type"---- | Extract const value from a simple string variant--- Matches schema like: { "const": "pending", "type": "string", "description": "..." }-extractStringConst :: Value -> Maybe Text-extractStringConst (Object o) =-  case (KM.lookup "const" o, KM.lookup "type" o) of-    (Just (String c), Just (String "string")) -> Just c-    _ -> Nothing-extractStringConst _ = Nothing+readParams _ _ _ _ _ = pure (Map.empty, [], []) --- ============================================================================--- Type Extraction from $defs--- ============================================================================+-- | REQ-6/REQ-9: a param's @x-plexus-source@.+sourceOf :: Value -> Maybe Value+sourceOf (Object po) = KM.lookup "x-plexus-source" po+sourceOf _ = Nothing --- | Extract type definitions from $defs or definitions (draft-07 compatibility)--- Types are namespace-qualified to avoid collisions-extractDefs :: Text -> KM.KeyMap Value -> Map Text TypeDef-extractDefs namespace o =-  let defs = case KM.lookup "$defs" o of-        Just (Object d) -> d-        _ -> case KM.lookup "definitions" o of-          Just (Object d) -> d-          _ -> KM.empty-  in Map.fromList $ mapMaybe (extractTypeDef namespace) (KM.toList defs)+-- | A source the server fills (as REQ-8's help reads it): an object whose+--   @from@ is anything but @rpc@.+injectedSource :: Value -> Bool+injectedSource (Object src) = KM.lookup "from" src /= Just (String "rpc")+injectedSource _ = False --- | Extract a type definition from a $defs entry-extractTypeDef :: Text -> (K.Key, Value) -> Maybe (Text, TypeDef)-extractTypeDef namespace (k, v) = case v of-  Object o ->-    let name = K.toText k-        desc = extractDescription v-        kind = inferTypeKind namespace o-        td = TypeDef name namespace desc kind-    in Just (tdFullName td, td)+descriptionOfValue :: Value -> Maybe Text+descriptionOfValue (Object o) = case KM.lookup "description" o of+  Just (String s) -> Just s   _ -> Nothing---- | Infer the kind of a type from its JSON Schema-inferTypeKind :: Text -> KM.KeyMap Value -> TypeKind-inferTypeKind namespace o-  -- Check for oneOf (enum)-  | Just (Array variants) <- KM.lookup "oneOf" o =-      -- First check if this is a simple string enum (all variants are {const: X, type: "string"})-      let maybeStringValues = mapMaybe extractStringConst (V.toList variants)-      in if length maybeStringValues == V.length variants && not (null maybeStringValues)-         then KindStringEnum maybeStringValues-         else let variantDefs = mapMaybe (extractVariant namespace) (V.toList variants)-              in KindEnum "type" variantDefs--  -- Check for enum (simple string enum)-  | Just (Array values) <- KM.lookup "enum" o =-      let stringValues = [ asText v | v <- V.toList values ]-      in KindStringEnum stringValues--  -- Check for object with properties (struct)-  | Just (Object props) <- KM.lookup "properties" o =-      let required = case KM.lookup "required" o of-            Just (Array arr) -> [t | String t <- V.toList arr]-            _ -> []-          fields =-            [ FieldDef-                { fdName = K.toText k-                , fdType = schemaToTypeRef namespace v-                , fdDescription = extractDescription v-                , fdRequired = K.toText k `elem` required-                , fdDefault = extractDefault v-                }-            | (k, v) <- KM.toList props-            ]-      in KindStruct fields--  -- Check for primitive types-  | Just typeVal <- KM.lookup "type" o =-      case typeVal of-        String t -> KindPrimitive t (extractFormat o)-        Array ts ->-          -- Nullable type like ["string", "null"]-          let nonNull = [t | String t <- V.toList ts, t /= "null"]-          in case nonNull of-               [t] -> KindPrimitive t (extractFormat o)-               _ -> KindPrimitive "any" Nothing-        _ -> KindPrimitive "any" Nothing--  -- Default to unknown-  | otherwise = KindPrimitive "any" Nothing+descriptionOfValue _ = Nothing -  where-    asText (String s) = s-    asText _ = "unknown"+defaultOfValue :: Value -> Maybe Value+defaultOfValue (Object o) = KM.lookup "default" o+defaultOfValue _ = Nothing  -- ============================================================================--- Schema to TypeRef Conversion+-- Standalone helpers -- ============================================================================ --- | Convert a JSON Schema value to a TypeRef------ Distinguishes between:--- - RefAny: Schema present but no type constraints (intentionally dynamic, e.g. serde_json::Value)--- - RefUnknown: No schema at all (schema gap, should warn)------ Type references via $ref are namespace-qualified (e.g., "cone.ConeInfo")+-- | Convert a JSON Schema value to a TypeRef (its refusals dropped), with+--   refs qualified by the namespace. schemaToTypeRef :: Text -> Value -> TypeRef-schemaToTypeRef namespace (Object o)-  -- Check for $ref - namespace-qualify the reference-  | Just (String ref) <- KM.lookup "$ref" o =-      RefNamed QualifiedName-        { qnNamespace = namespace-        , qnLocalName = extractRefName ref-        }--  -- Check for array-  | Just (String "array") <- KM.lookup "type" o =-      case KM.lookup "items" o of-        Just items -> RefArray (schemaToTypeRef namespace items)-        Nothing -> RefArray RefAny  -- array without items = any[]--  -- Check for nullable-  | Just (Array types) <- KM.lookup "type" o =-      let nonNull = [t | t@(String s) <- V.toList types, s /= "null"]-          hasNull = any (\case String "null" -> True; _ -> False) (V.toList types)-      in case nonNull of-           [String "array"] ->-             -- Nullable array: type: ["array", "null"] with items-             let inner = case KM.lookup "items" o of-                           Just items -> RefArray (schemaToTypeRef namespace items)-                           Nothing -> RefArray RefAny-             in if hasNull then RefOptional inner else inner-           [String t] ->-             let base = RefPrimitive t (extractFormat o)-             in if hasNull then RefOptional base else base-           _ -> RefAny  -- Multiple non-null types = any--  -- Check for anyOf (often used for optional refs) - namespace-qualify refs-  | Just (Array options) <- KM.lookup "anyOf" o =-      let refs = mapMaybe extractRefFromOption (V.toList options)-      in case refs of-           [r] -> RefOptional (RefNamed QualifiedName-                    { qnNamespace = namespace-                    , qnLocalName = r-                    })-           _ -> RefAny  -- Complex anyOf = any--  -- Check for primitive type-  | Just (String t) <- KM.lookup "type" o =-      RefPrimitive t (extractFormat o)--  -- Schema object present but no type constraint = intentionally dynamic (RefAny)-  -- This happens with serde_json::Value which emits {"description": "...", "default": null}-  | otherwise = RefAny---- JSON Schema `true` is the "accept anything" schema - intentionally dynamic--- This is used when schemars emits a field like `input: true` for serde_json::Value-schemaToTypeRef _ (Bool True) = RefAny---- Null, false, or non-JSON-Schema values = schema gap (should warn)-schemaToTypeRef _ _ = RefUnknown---- | Extract ref name from a $ref string like "#/$defs/Position"-extractRefName :: Text -> Text-extractRefName ref = case T.splitOn "/" ref of-  parts | not (null parts) -> last parts-  _ -> ref---- | Extract ref from anyOf option (for optional types)-extractRefFromOption :: Value -> Maybe Text-extractRefFromOption (Object o) = case KM.lookup "$ref" o of-  Just (String ref) -> Just (extractRefName ref)-  _ -> Nothing-extractRefFromOption _ = Nothing---- ============================================================================--- Helpers--- ============================================================================---- | Extract description from a schema-extractDescription :: Value -> Maybe Text-extractDescription (Object o) = case KM.lookup "description" o of-  Just (String s) -> Just s-  _ -> Nothing-extractDescription _ = Nothing---- | Extract default value from a schema-extractDefault :: Value -> Maybe Value-extractDefault (Object o) = KM.lookup "default" o-extractDefault _ = Nothing---- | Extract format from a schema object-extractFormat :: KM.KeyMap Value -> Maybe Text-extractFormat o = case KM.lookup "format" o of-  Just (String s) -> Just s-  _ -> Nothing+schemaToTypeRef namespace v = fst (runRead (readType (docOf namespace KM.empty) namespace v))  -- | Extract types from a full schema (for standalone use) -- Types are namespace-qualified extractTypesFromSchema :: Text -> Value -> Map Text TypeDef-extractTypesFromSchema namespace (Object o) = extractDefs namespace o+extractTypesFromSchema namespace (Object o) = fst (runRead (readDefs (docOf namespace o))) extractTypesFromSchema _ _ = Map.empty
src/Synapse/IR/Cache.hs view
@@ -83,9 +83,9 @@     }  -- | 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+-- the caller's view when the service 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.+-- callers' views of one service never share an IR on disk. irCacheKey :: Maybe Text -> Text -> Text irCacheKey Nothing hash = hash irCacheKey (Just v) hash
+ src/Synapse/IR/Read.hs view
@@ -0,0 +1,732 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE UnboxedTuples #-}++-- | SYNAPSE-CC-8 (IR 2.1): the schema reader. Every JSON Schema the IR+-- builder meets in a type position is read whole here, or refused by name.+--+-- The reader is pure: @'SchemaRead' a@ is a value and the refusals met on the+-- way. There is no 'Data.Maybe.mapMaybe' that can drop a union member: a+-- union is a string enum, a tagged enum (tagged by whichever property every+-- member gives a string @const@ — RETURNS-13's @discriminatorOf@), an+-- externally tagged enum, an untagged union of named types, or a nullable;+-- anything else is a 'Refusal' naming the type, the keyword and the first+-- member it could not read, and the type is left out.+--+-- A schema in a type position uses only the closed keyword list+-- ('knownKeywords'); any other keyword is refused by name. A dynamic value+-- (a @serde_json::Value@) is the JSON type, 'RefJson' — @true@, @{}@,+-- annotations only, @type@ naming all six JSON types, or a @$ref@ to @Json@;+-- it is refused. Maps, tuples and bounds the format does not imply are+-- carried ('RefMap', 'RefTuple', 'RefRefined').+module Synapse.IR.Read+  ( -- * The reader+    SchemaRead+  , runRead+  , refuse+    -- * Documents+  , Doc+  , docOf+  , sharedDoc+  , readDefs+  , readRoot+  , RootRead(..)+    -- * Type positions+  , readType+    -- * Sites+  , siteParam+  , siteReturns+  , siteInput+    -- * The vocabulary+  , knownKeywords+  , isJsonSchema+  ) where++import Control.Monad (forM, when, zipWithM)+import Data.Aeson (Value(..))+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+import Data.List (nub, nubBy, sortOn)+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Scientific (Scientific, toBoundedInteger)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V++import Synapse.IR.Types++-- ============================================================================+-- The reader+-- ============================================================================++-- | What a read carries along: the refusals met (in reverse), and the named+--   roots already read (a namespace's methods mostly return one event+--   union: it is read once, then found again when its schema is the same).+data ReadState = ReadState+  { rsRefusals :: ![Refusal]+  , rsRoots    :: !(Map Text (Value, Maybe TypeKind))+  }++-- | A value, and the refusals met reading it.+newtype SchemaRead a = SchemaRead { unRead :: ReadState -> (# a, ReadState #) }++instance Functor SchemaRead where+  fmap f (SchemaRead g) = SchemaRead $ \s -> case g s of (# a, s' #) -> (# f a, s' #)++instance Applicative SchemaRead where+  pure a = SchemaRead $ \s -> (# a, s #)+  SchemaRead f <*> SchemaRead g = SchemaRead $ \s -> case f s of+    (# h, s1 #) -> case g s1 of+      (# a, s2 #) -> (# h a, s2 #)++instance Monad SchemaRead where+  SchemaRead g >>= k = SchemaRead $ \s -> case g s of (# a, s1 #) -> unRead (k a) s1++-- | The value and every refusal, in the order met.+runRead :: SchemaRead a -> (a, [Refusal])+runRead (SchemaRead g) = case g (ReadState [] Map.empty) of+  (# a, s #) -> (a, reverse (rsRefusals s))++-- | Name a site the IR cannot type.+refuse :: Text -> Text -> Maybe Int -> Text -> SchemaRead ()+refuse site kw variant detail = SchemaRead $ \s ->+  (# (), s { rsRefusals = Refusal site kw variant detail : rsRefusals s } #)++-- | A named root read before. One name in one namespace is one type: the+--   first schema read under it is the type, as the first of a name in+--   @$defs@ is (and as IR 2.0 kept it), so a later root of the same name is+--   not read again (comparing the schemas cost more than the read).+rootSeen :: Text -> Value -> SchemaRead (Maybe (Maybe TypeKind))+rootSeen site _ = SchemaRead $ \s -> case Map.lookup site (rsRoots s) of+  Just (_, k) -> (# Just k, s #)+  _ -> (# Nothing, s #)++rootRead :: Text -> Value -> Maybe TypeKind -> SchemaRead ()+rootRead site v k = SchemaRead $ \s -> (# (), s { rsRoots = Map.insert site (v, k) (rsRoots s) } #)++-- | Refuse, and stand 'RefUnknown' where the type would be.+unknownAt :: Text -> Text -> Maybe Int -> Text -> SchemaRead TypeRef+unknownAt site kw variant detail = RefUnknown <$ refuse site kw variant detail++-- ============================================================================+-- Documents+-- ============================================================================++-- | One JSON Schema document (a method's @params@, @returns@ or @input@):+--   the namespace its types land in, and its @$defs@ by name.+data Doc = Doc+  { docNamespace :: Text+  , docDefs      :: KM.KeyMap Value+  }++docOf :: Text -> KM.KeyMap Value -> Doc+docOf ns o = Doc ns $ case KM.lookup "$defs" o of+  Just (Object d) -> d+  _ -> case KM.lookup "definitions" o of+    Just (Object d) -> d+    _ -> KM.empty++-- | One namespace's documents as one: every @$defs@ entry of them, the+--   first of each name winning (as the types the builder kept always did).+--   Read once, a namespace's definitions are read once, not once a method.+sharedDoc :: Text -> [KM.KeyMap Value] -> Doc+sharedDoc ns docs = Doc ns (foldl (\acc o -> KM.union acc (docDefs (docOf ns o))) KM.empty docs)++-- | The definition a @$ref@ names, in this document.+lookupDef :: Doc -> Text -> Maybe Value+lookupDef doc ref = KM.lookup (K.fromText (refName ref)) (docDefs doc)++refName :: Text -> Text+refName ref = case T.splitOn "/" ref of+  parts@(_:_) -> last parts+  [] -> ref++qualified :: Doc -> Text -> TypeRef+qualified doc ref = RefNamed QualifiedName { qnNamespace = docNamespace doc, qnLocalName = refName ref }++typeSite :: Doc -> Text -> Text+typeSite doc name = docNamespace doc <> "." <> name++siteParam :: Text -> Text -> Text+siteParam path name = path <> "(" <> name <> ")"++siteReturns :: Text -> Text+siteReturns path = path <> " returns"++siteInput :: Text -> Text+siteInput path = path <> " input"++-- ============================================================================+-- The vocabulary+-- ============================================================================++-- | The keywords a schema in a type position may use (SYNAPSE-CC-8's closed+--   list). Any other is refused by name.+knownKeywords :: Set.Set Text+knownKeywords = Set.fromList+  [ "type", "$ref", "properties", "required", "additionalProperties", "items", "prefixItems"+  , "oneOf", "anyOf", "enum", "const", "format"+  , "minimum", "maximum", "exclusiveMinimum", "exclusiveMaximum"+  , "minLength", "maxLength", "pattern", "minItems", "maxItems"+  , "default", "description", "title", "examples", "deprecated"+  , "$schema", "$defs", "definitions"+  , "x-plexus-source", "x-plexus-values"+  ]++-- | Refuse each keyword outside the list; 'True' when there were none.+keywordsOk :: Text -> KM.KeyMap Value -> SchemaRead Bool+keywordsOk site o+  | KM.foldrWithKey (\k _ acc -> Set.member (K.toText k) knownKeywords && acc) True o = pure True+  | otherwise = do+      let bad = [ k | k <- map K.toText (KM.keys o), not (Set.member k knownKeywords) ]+      mapM_ (\k -> refuse site k Nothing ("`" <> k <> "` is not a keyword synapse reads")) bad+      pure False++-- | The JSON type (a @serde_json::Value@), as a schema says it: annotations+--   only (@{}@, a description, a default), or @type@ naming all six JSON+--   types (@["null", "boolean", "number", "string", "array", "object"]@, in+--   any order) and nothing else that types. @true@ says it too, and a+--   @$ref@ to a definition named @Json@ ('isJsonRef').+isJsonSchema :: KM.KeyMap Value -> Bool+isJsonSchema o = not (any (`KM.member` o) structural) || allSix+  where+    structural = ["type", "$ref", "properties", "additionalProperties", "items", "prefixItems", "oneOf", "anyOf", "enum", "const"]+    allSix = case KM.lookup "type" o of+      Just (Array ts) ->+        Set.fromList [ t | String t <- V.toList ts ] == jsonTypes+          && not (any (`KM.member` o) (filter (/= "type") structural))+      _ -> False++jsonTypes :: Set.Set Text+jsonTypes = Set.fromList ["null", "boolean", "number", "string", "array", "object"]++jsonValue :: Value -> Bool+jsonValue = \case+  Bool True -> True+  Object o -> isJsonSchema o+  _ -> False++-- | A @$ref@ to the definition named @Json@: the JSON type.+isJsonRef :: Text -> Bool+isJsonRef ref = refName ref == "Json"++-- ============================================================================+-- Type positions+-- ============================================================================++-- | The type of a schema in a type position (a field, a param, an element),+--   at a site.+readType :: Doc -> Text -> Value -> SchemaRead TypeRef+readType doc site = \case+  Bool True -> pure RefJson+  Object o -> do+    ok <- keywordsOk site o+    if not ok then pure RefUnknown+      else if isJsonSchema o then pure RefJson+      else readTypeObject doc site o+  _ -> unknownAt site "type" Nothing "not a schema"++readTypeObject :: Doc -> Text -> KM.KeyMap Value -> SchemaRead TypeRef+readTypeObject doc site o+  | Just (String ref) <- KM.lookup "$ref" o = pure (if isJsonRef ref then RefJson else qualified doc ref)+  | Just (kw, members) <- unionOf o = readInlineUnion doc site kw members+  | Just (Array ts) <- KM.lookup "type" o =+      let types = [ t | String t <- V.toList ts ]+          nonNull = filter (/= "null") types+          hasNull = "null" `elem` types+      in case nonNull of+           [t] -> do+             base <- readTyped doc (if hasNull then site <> "?" else site) t o+             pure (if hasNull then RefOptional base else base)+           [] -> pure (RefPrimitive "null" Nothing)+           _ -> unknownAt site "type" Nothing "a type list that is neither one type (with null or without) nor the JSON type (all six)"+  | Just (String t) <- KM.lookup "type" o = readTyped doc site t o+  | KM.member "enum" o || KM.member "const" o = pure (RefPrimitive (literalType o) Nothing)+  | KM.member "items" o || KM.member "prefixItems" o = readTyped doc site "array" o+  | otherwise = readTyped doc site "object" o++-- | The JSON type of an enum's or const's values (a string, for a string enum).+literalType :: KM.KeyMap Value -> Text+literalType o = case concat [ maybe [] V.toList (arr (KM.lookup "enum" o)), maybe [] pure (KM.lookup "const" o) ] of+  (Number _ : _) -> "number"+  (Bool _ : _) -> "boolean"+  _ -> "string"+  where arr (Just (Array a)) = Just a+        arr _ = Nothing++-- | A schema of one JSON type.+readTyped :: Doc -> Text -> Text -> KM.KeyMap Value -> SchemaRead TypeRef+readTyped doc site t o = case t of+  "array"+    | Just (Array prefix) <- KM.lookup "prefixItems" o -> readTuple doc site (V.toList prefix) o+    | Just items <- KM.lookup "items" o -> do+        inner <- readType doc (site <> "[]") items+        refined site (RefArray inner) (itemBounds o)+    | otherwise -> RefArray <$> unknownAt (site <> "[]") "items" Nothing "an array with no items"+  "object"+    | KM.member "properties" o ->+        unknownAt site "properties" Nothing "an object with properties in a type position has no name: give it one in $defs"+    | Just ap <- KM.lookup "additionalProperties" o, ap /= Bool False ->+        RefMap <$> readType doc (site <> "{}") ap+    | otherwise -> unknownAt site "type" Nothing "an object with neither properties nor additionalProperties"+  _ -> do+    let base = RefPrimitive t (formatOf o)+    refined site base (scalarBounds (formatOf o) o)++-- | @prefixItems@ with @minItems = maxItems = n@: a tuple of n.+readTuple :: Doc -> Text -> [Value] -> KM.KeyMap Value -> SchemaRead TypeRef+readTuple doc site prefix o+  | intAt "minItems" o == Just n, intAt "maxItems" o == Just n, noExtra =+      RefTuple <$> zipWithM (\i v -> readType doc (site <> "." <> T.pack (show i)) v) [0 :: Int ..] prefix+  | otherwise = unknownAt site "prefixItems" Nothing+      "prefixItems is read only as a tuple: minItems = maxItems = its length, no further items"+  where+    n = length prefix+    noExtra = case KM.lookup "items" o of+      Nothing -> True+      Just (Bool False) -> True+      _ -> False++formatOf :: KM.KeyMap Value -> Maybe Text+formatOf o = case KM.lookup "format" o of+  Just (String s) -> Just s+  _ -> Nothing++intAt :: Text -> KM.KeyMap Value -> Maybe Int+intAt k o = case KM.lookup (K.fromText k) o of+  Just (Number n) -> toBoundedInteger n+  _ -> Nothing++numAt :: Text -> KM.KeyMap Value -> Maybe Scientific+numAt k o = case KM.lookup (K.fromText k) o of+  Just (Number n) -> Just n+  _ -> Nothing++-- | Wrap a ref in its bounds, when it has any.+refined :: Text -> TypeRef -> Refinements -> SchemaRead TypeRef+refined _ t r+  | isNoRefinements r = pure t+  | otherwise = pure (RefRefined t r)++-- | An array's bounds (a tuple's are its length).+itemBounds :: KM.KeyMap Value -> Refinements+itemBounds o = noRefinements+  { rnMinItems = intAt "minItems" o+  , rnMaxItems = intAt "maxItems" o+  }++-- | A scalar's bounds, less those its format already says.+scalarBounds :: Maybe Text -> KM.KeyMap Value -> Refinements+scalarBounds fmt o+  | not (any (`KM.member` o) ["minimum", "maximum", "exclusiveMinimum", "exclusiveMaximum", "minLength", "maxLength", "pattern"]) = noRefinements+  | otherwise = Refinements+  { rnMinimum = numAt "minimum" o `unlessEq` impliedMin+  , rnMaximum = numAt "maximum" o `unlessEq` impliedMax+  , rnExclusiveMinimum = numAt "exclusiveMinimum" o+  , rnExclusiveMaximum = numAt "exclusiveMaximum" o+  , rnMinLength = intAt "minLength" o+  , rnMaxLength = intAt "maxLength" o+  , rnPattern = case KM.lookup "pattern" o of { Just (String p) -> Just p; _ -> Nothing }+  , rnMinItems = Nothing+  , rnMaxItems = Nothing+  }+  where+    (impliedMin, impliedMax) = formatBounds fmt+    unlessEq (Just v) (Just implied) | v == implied = Nothing+    unlessEq v _ = v++-- | The bounds an integer format implies (schemars writes them out).+formatBounds :: Maybe Text -> (Maybe Scientific, Maybe Scientific)+formatBounds = \case+  Just "uint8"  -> (Just 0, Just 255)+  Just "uint16" -> (Just 0, Just 65535)+  Just "uint32" -> (Just 0, Just 4294967295)+  Just "uint64" -> (Just 0, Just 18446744073709551615)+  Just "uint128" -> (Just 0, Nothing)+  Just "uint"   -> (Just 0, Nothing)+  Just "int8"   -> (Just (-128), Just 127)+  Just "int16"  -> (Just (-32768), Just 32767)+  Just "int32"  -> (Just (-2147483648), Just 2147483647)+  Just "int64"  -> (Just (-9223372036854775808), Just 9223372036854775807)+  _ -> (Nothing, Nothing)++-- ============================================================================+-- Unions+-- ============================================================================++-- | A schema's union: its keyword and members.+unionOf :: KM.KeyMap Value -> Maybe (Text, [Value])+unionOf o = case (KM.lookup "oneOf" o, KM.lookup "anyOf" o) of+  (Just (Array ms), _) -> Just ("oneOf", V.toList ms)+  (_, Just (Array ms)) -> Just ("anyOf", V.toList ms)+  _ -> Nothing++-- | A union in a type position: only a nullable (or a string enum, which a+--   ref carries as a string) has a form there; any other union has no name.+readInlineUnion :: Doc -> Text -> Text -> [Value] -> SchemaRead TypeRef+readInlineUnion doc site kw members+  | Just inner <- nullableMember members = RefOptional <$> readType doc (site <> "?") inner+  | Just _ <- stringEnumValues members = pure (RefPrimitive "string" Nothing)+  | otherwise = unknownAt site kw Nothing+      "a union in a type position has no name: give it one in $defs"++-- | @[X, {"type": "null"}]@ (either order) is a nullable @X@.+nullableMember :: [Value] -> Maybe Value+nullableMember [a, b]+  | isNullSchema a = Just b+  | isNullSchema b = Just a+nullableMember _ = Nothing++isNullSchema :: Value -> Bool+isNullSchema (Object o) = KM.lookup "type" o == Just (String "null")+isNullSchema _ = False++-- | Every member a string literal (@{"const": "a"}@ or @{"enum": ["a", …]}@,+--   of type string): the literals, in schema order.+stringEnumValues :: [Value] -> Maybe [Text]+stringEnumValues [] = Nothing+stringEnumValues members = concat <$> traverse stringLiterals members++stringLiterals :: Value -> Maybe [Text]+stringLiterals (Object m)+  | stringTyped, Just (String c) <- KM.lookup "const" m = Just [c]+  | stringTyped, Just (Array vs) <- KM.lookup "enum" m, not (V.null vs) = traverse asString (V.toList vs)+  where+    stringTyped = case KM.lookup "type" m of+      Nothing -> True+      Just (String "string") -> True+      _ -> False+    asString (String s) = Just s+    asString _ = Nothing+stringLiterals _ = Nothing++-- | A named union's kind, read whole or refused.+readUnionKind :: Doc -> Text -> Text -> [Value] -> SchemaRead (Maybe TypeKind)+readUnionKind doc site kw members+  | Just inner <- nullableMember members = Just . KindAlias . RefOptional <$> readType doc (site <> "?") inner+  | Just values <- stringEnumValues members = pure (Just (KindStringEnum values))+  | Just shapes <- traverse (variantShape doc maxDepth) members+  , Just tag <- discriminatorOf shapes = Just <$> taggedEnum doc site tag shapes+  | Just vs <- traverse externalMember members = Just <$> externalEnum doc site vs+  | Just refs <- traverse refOnly members, not (null refs) = pure $ Just KindEnum+      { keDiscriminator = ""+      , keRepr = Untagged+      , keVariants =+          [ VariantDef { vdName = refName r, vdDescription = d, vdFields = [], vdRef = Just (qualified doc r) }+          | (r, d) <- refs ]+      }+  | otherwise = do+      let (i, why) = firstUnreadable doc members+      Nothing <$ refuse site kw (Just i) why++-- | The first member a union could not be read past, and why.+firstUnreadable :: Doc -> [Value] -> (Int, Text)+firstUnreadable doc members = case members of+  [] -> (0, "an empty union")+  (m0 : _)+    | isJust (stringLiterals m0) -> pick (isJust . stringLiterals) "is not a string, as the members before it are"+    | Just s0 <- variantShape doc maxDepth m0 ->+        let tags = map fst (variantConsts s0)+            fits m = case variantShape doc maxDepth m of+              Just s -> any (`elem` tags) (map fst (variantConsts s))+              Nothing -> False+        in pick fits "shares no string-const property with the others and is not a string"+    | otherwise -> (0, "variant 0 is neither a string, an object nor a $ref to one")+  where+    pick ok why = case [ i | (i, m) <- zip [0 :: Int ..] members, not (ok m) ] of+      (i : _) -> (i, "variant " <> T.pack (show i) <> " " <> why)+      [] -> (0, "no string-const property tells the variants apart")++-- | @{"$ref": X}@ (a description beside it) as a member: X and the description.+refOnly :: Value -> Maybe (Text, Maybe Text)+refOnly (Object m)+  | Just (String r) <- KM.lookup "$ref" m+  , all (`elem` ["$ref", "description", "title"]) (map K.toText (KM.keys m)) =+      Just (r, descriptionOf (Object m))+refOnly _ = Nothing++-- ============================================================================+-- Tagged enums (RETURNS-13's rules, ported from 873e791)+-- ============================================================================++-- | One member of a union, its references resolved.+data VariantShape = VariantShape+  { vsProps    :: [(Text, Value)]   -- ^ Its own properties, the tag among them+  , vsRequired :: [Text]+  , vsWrapped  :: Maybe Value       -- ^ The struct a newtype variant wraps (a @$ref@ beside the tag)+  , vsDesc     :: Maybe Text+  }++maxDepth :: Int+maxDepth = 8++-- | A union member as a variant: an object schema, or a @$ref@ to one.+variantShape :: Doc -> Int -> Value -> Maybe VariantShape+variantShape doc depth member@(Object m)+  | Just (String ref) <- KM.lookup "$ref" m+  , not (KM.member "properties" m)+  , depth > 0 = do+      target <- lookupDef doc ref+      shape <- variantShape doc (depth - 1) target+      pure shape { vsDesc = descriptionOf member <|>. vsDesc shape }+  | Just (Object props) <- KM.lookup "properties" m = Just VariantShape+      { vsProps    = [ (K.toText k, v) | (k, v) <- KM.toList props ]+      , vsRequired = requiredOf m+      , vsWrapped  = KM.lookup "$ref" m+      , vsDesc     = descriptionOf member+      }+variantShape _ _ _ = Nothing++(<|>.) :: Maybe a -> Maybe a -> Maybe a+(<|>.) (Just a) _ = Just a+(<|>.) Nothing b = b++-- | The string @const@s a variant gives its own properties (a one-value+--   @enum@ counts, as draft-07 tooling writes it).+variantConsts :: VariantShape -> [(Text, Text)]+variantConsts s =+  [ (k, c)+  | (k, Object p) <- vsProps s+  , Just c <- [constOf p]+  ]+  where+    constOf p = case (KM.lookup "const" p, KM.lookup "enum" p) of+      (Just (String c), _) -> Just c+      (_, Just (Array vs)) | [String c] <- V.toList vs -> Just c+      _ -> Nothing++-- | The tag: the property every variant gives a @const@, no two variants+--   the same one. Should several qualify, the one first in the first+--   variant's @required@ (schemars lists the tag first).+discriminatorOf :: [VariantShape] -> Maybe Text+discriminatorOf [] = Nothing+discriminatorOf shapes@(first : _) =+  case sortOn rank candidates of+    [] -> Nothing+    (k : _) -> Just k+  where+    consts = map variantConsts shapes+    candidates =+      [ k+      | (k, _) <- variantConsts first+      , Just values <- [traverse (lookup k) consts]+      , length (nub values) == length values+      ]+    rank k = fromMaybe maxBound (lookup k (zip (vsRequired first) [0 :: Int ..]))++taggedEnum :: Doc -> Text -> Text -> [VariantShape] -> SchemaRead TypeKind+taggedEnum doc site tag shapes = do+  variants <- forM shapes $ \s -> do+    let name = fromMaybe "" (lookup tag (variantConsts s))+        vsite = site <> "." <> name+    own <- fieldsOf doc vsite (vsRequired s) [ kv | kv@(k, _) <- vsProps s, k /= tag ]+    wrapped <- case vsWrapped s of+      Nothing -> pure []+      Just w -> wrappedFields doc vsite w+    pure VariantDef+      { vdName = name+      , vdDescription = vsDesc s+      , vdFields = nubBy (\a b -> fdName a == fdName b) (own ++ wrapped)+      , vdRef = Nothing+      }+  pure KindEnum { keDiscriminator = tag, keVariants = variants, keRepr = Internal }++-- | The fields of the struct a newtype variant wraps, flattened (RETURNS-13's+--   @vsWrapped@); refused when it wraps no struct.+wrappedFields :: Doc -> Text -> Value -> SchemaRead [FieldDef]+wrappedFields doc site = go maxDepth+  where+    go depth (String ref)+      | depth > 0, Just (Object t) <- lookupDef doc ref = case () of+          _ | Just (String r') <- KM.lookup "$ref" t, not (KM.member "properties" t) -> go (depth - 1) (String r')+            | KM.member "properties" t -> fieldsOf doc site (requiredOf t) (propsOf t)+            | KM.lookup "type" t == Just (String "object") -> pure []+            | otherwise -> notStruct+    go _ _ = notStruct+    notStruct = [] <$ refuse site "$ref" Nothing "a newtype variant wraps no struct whose fields it could carry"++-- | An externally tagged member: one property, required, and not a const.+externalMember :: Value -> Maybe (Text, Value, Maybe Text)+externalMember (Object m)+  | Just (Object props) <- KM.lookup "properties" m+  , [(k, v)] <- KM.toList props+  , requiredOf m == [K.toText k]+  , not (isConstSchema v) = Just (K.toText k, v, descriptionOf (Object m))+externalMember _ = Nothing++isConstSchema :: Value -> Bool+isConstSchema (Object p) = KM.member "const" p+isConstSchema _ = False++externalEnum :: Doc -> Text -> [(Text, Value, Maybe Text)] -> SchemaRead TypeKind+externalEnum doc site members = do+  variants <- forM members $ \(name, v, desc) -> do+    let vsite = site <> "." <> name+    case v of+      Object inner | KM.member "properties" inner, isNothing (KM.lookup "$ref" inner) -> do+        _ <- keywordsOk vsite inner+        fields <- fieldsOf doc vsite (requiredOf inner) (propsOf inner)+        pure VariantDef { vdName = name, vdDescription = desc, vdFields = fields, vdRef = Nothing }+      _ -> do+        t <- readType doc vsite v+        pure VariantDef { vdName = name, vdDescription = desc, vdFields = [], vdRef = Just t }+  pure KindEnum { keDiscriminator = "", keVariants = variants, keRepr = External }++-- ============================================================================+-- Structs and fields+-- ============================================================================++propsOf :: KM.KeyMap Value -> [(Text, Value)]+propsOf o = case KM.lookup "properties" o of+  Just (Object p) -> [ (K.toText k, v) | (k, v) <- KM.toList p ]+  _ -> []++requiredOf :: KM.KeyMap Value -> [Text]+requiredOf o = case KM.lookup "required" o of+  Just (Array arr) -> [ t | String t <- V.toList arr ]+  _ -> []++fieldsOf :: Doc -> Text -> [Text] -> [(Text, Value)] -> SchemaRead [FieldDef]+fieldsOf doc site required props = forM props $ \(k, v) -> do+  t <- readType doc (site <> "." <> k) v+  pure FieldDef+    { fdName = k+    , fdType = t+    , fdDescription = descriptionOf v+    , fdRequired = k `elem` required+    , fdDefault = defaultOf v+    }++descriptionOf :: Value -> Maybe Text+descriptionOf (Object o) = case KM.lookup "description" o of+  Just (String s) -> Just s+  _ -> Nothing+descriptionOf _ = Nothing++defaultOf :: Value -> Maybe Value+defaultOf (Object o) = KM.lookup "default" o+defaultOf _ = Nothing++-- ============================================================================+-- Named types+-- ============================================================================++-- | Every @$defs@ entry of a document, as types of its namespace. A type the+--   reader refuses is left out (its uses then name no type, and the builder+--   turns them to 'RefUnknown').+readDefs :: Doc -> SchemaRead (Map Text TypeDef)+readDefs doc = do+  -- the definition named Json, when it is the JSON type, is 'RefJson'+  -- wherever it is named: it is no type of the namespace's own+  defs <- forM [ kv | kv@(k, v) <- KM.toList (docDefs doc), not (K.toText k == "Json" && jsonValue v) ] $ \(k, v) -> do+    let name = K.toText k+    fmap (\td -> (tdFullName td, td)) <$> readNamed doc name v+  pure (Map.fromList [ d | Just d <- defs ])++-- | One named type: its kind, read whole, or 'Nothing' and a refusal.+readNamed :: Doc -> Text -> Value -> SchemaRead (Maybe TypeDef)+readNamed doc name v = fmap (TypeDef name (docNamespace doc) (descriptionOf v)) <$> readKind doc (typeSite doc name) v++readKind :: Doc -> Text -> Value -> SchemaRead (Maybe TypeKind)+readKind doc site = \case+  Bool True -> pure (Just (KindAlias RefJson))+  Object o -> do+    ok <- keywordsOk site o+    if not ok then pure Nothing+      else if isJsonSchema o then pure (Just (KindAlias RefJson))+      else readKindObject doc site o+  _ -> Nothing <$ refuse site "type" Nothing "not a schema"++readKindObject :: Doc -> Text -> KM.KeyMap Value -> SchemaRead (Maybe TypeKind)+readKindObject doc site o+  | Just (kw, members) <- unionOf o =+      if KM.member "properties" o+        then Nothing <$ refuse site kw Nothing "a struct with a union flattened into it has no IR form"+        else readUnionKind doc site kw members+  | Just (Array values) <- KM.lookup "enum" o =+      case traverse asString (V.toList values) of+        Just vs | not (null vs) -> pure (Just (KindStringEnum vs))+        _ -> Nothing <$ refuse site "enum" Nothing "an enum of values that are not all strings"+  | KM.member "properties" o = do+      when (maybe False (\ap -> ap /= Bool False) (KM.lookup "additionalProperties" o)) $+        refuse site "additionalProperties" Nothing "a map beside properties (a flattened map) has no IR form"+      fields <- fieldsOf doc site (requiredOf o) (propsOf o)+      wrapped <- case KM.lookup "$ref" o of+        Nothing -> pure []+        Just w -> wrappedFields doc site w+      pure (Just (KindStruct (nubBy (\a b -> fdName a == fdName b) (fields ++ wrapped))))+  | Just (String ref) <- KM.lookup "$ref" o = pure (Just (KindAlias (if isJsonRef ref then RefJson else qualified doc ref)))+  | Just (String t) <- KM.lookup "type" o, t `notElem` ["array", "object"] =+      let r = scalarBounds (formatOf o) o+      in pure $ Just $ if isNoRefinements r+           then KindPrimitive t (formatOf o)+           else KindAlias (RefRefined (RefPrimitive t (formatOf o)) r)+  | KM.member "const" o, not (KM.member "type" o) || KM.lookup "type" o == Just (String "string")+  , Just vs <- stringLiterals (Object o) = pure (Just (KindStringEnum vs))+  | otherwise = do+      t <- readTypeObject doc site o+      pure $ case t of+        RefUnknown -> Nothing+        _ -> Just (KindAlias t)+  where+    asString (String s) = Just s+    asString _ = Nothing++-- ============================================================================+-- A document's root+-- ============================================================================++-- | What a document's root (a method's @returns@ or @input@) reads as.+data RootRead = RootRead+  { rrTypes     :: Map Text TypeDef   -- ^ its @$defs@, and the root's own type when it is named+  , rrRef       :: TypeRef            -- ^ the root as a ref+  , rrStreaming :: Bool               -- ^ a union of more than one non-error variant+  }++-- | A document's root: a titled (or else @fallback@-named) struct, enum or+--   union is a type of its own; anything else is the plain ref.+readRoot :: Maybe Doc -> Text -> Text -> Text -> Value -> SchemaRead RootRead+readRoot shared namespace site fallback = \case+  Object o -> do+    let doc = maybe (docOf namespace o) id shared+        name = case KM.lookup "title" o of+          Just (String t) | not (T.null t) -> t+          _ -> fallback+        named = isJust (unionOf o) && isNothing (nullableMember (maybe [] snd (unionOf o)))+             || KM.member "properties" o+             || KM.member "enum" o+    defs <- maybe (readDefs doc) (const (pure Map.empty)) shared+    if named+      then do+        let body = Object (KM.delete "$defs" (KM.delete "definitions" o))+            tsite = typeSite doc name+        seen <- rootSeen tsite body+        kind <- case seen of+          Just k -> pure k+          Nothing -> do+            k <- readKind doc tsite body+            rootRead tsite body k+            pure k+        let ref = RefNamed QualifiedName { qnNamespace = namespace, qnLocalName = name }+        case kind of+          Just k -> do+            let td = TypeDef name namespace (descriptionOf (Object o)) k+            pure RootRead+              { rrTypes = Map.insert (tdFullName td) td defs+              , rrRef = ref+              , rrStreaming = streams k+              }+          Nothing -> pure RootRead { rrTypes = defs, rrRef = RefUnknown, rrStreaming = False }+      else do+        ref <- readType doc site (Object (KM.delete "$defs" (KM.delete "definitions" o)))+        pure RootRead { rrTypes = defs, rrRef = ref, rrStreaming = False }+  other -> do+    ref <- readType (Doc namespace KM.empty) site other+    pure RootRead { rrTypes = Map.empty, rrRef = ref, rrStreaming = False }+  where+    streams = \case+      KindEnum _ vs Internal -> length (filter ((/= "error") . vdName) vs) > 1+      _ -> False
src/Synapse/IR/Types.hs view
@@ -48,12 +48,22 @@   , MethodDef(..)   , MethodRole(..)   , ParamDef(..)+  , InjectedParam(..) +    -- * IR 2.1 (SYNAPSE-CC-8)+  , Refusal(..)+  , Refinements(..)+  , noRefinements+  , isNoRefinements+  , EnumRepr(..)+  , currentIrVersion+     -- * Type References   , QualifiedName(..)   , qualifiedNameFull   , TypeRef(..)   , typeRefName+  , typeRefChildren      -- * Utilities   , isStreaming@@ -62,6 +72,8 @@  import Control.Applicative ((<|>)) import Data.Aeson+import Data.Char (toLower)+import Data.Scientific (Scientific) import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as KM import Data.Map.Strict (Map)@@ -138,23 +150,141 @@     -- ^ 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.+  , irRefusals     :: [Refusal]+    -- ^ SYNAPSE-CC-8 (IR 2.1): every site the builder could not type, each+    --   named. Omitted from the JSON when empty. Non-empty: @synapse -i@+    --   exits 65 and no generator may run on the IR.   }   deriving stock (Show, Eq, Generic)-  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.+-- | Generic, except that @irPluginRoles@ is left out when 'Nothing' (AUTH-9)+--   and @irRefusals@ when empty (SYNAPSE-CC-8): an IR built from a schema+--   without them serializes exactly as before. instance ToJSON IR where   toJSON ir = case genericToJSON defaultOptions ir of-    Object o -> Object $ case irPluginRoles ir of+    Object o -> Object $ dropRefusals $ case irPluginRoles ir of       Nothing -> KM.delete "irPluginRoles" o       Just _ -> o     v -> v+    where+      dropRefusals o+        | null (irRefusals ir) = KM.delete "irRefusals" o+        | otherwise = o +instance FromJSON IR where+  parseJSON = withObject "IR" $ \o -> IR+    <$> o .:  "irVersion"+    <*> o .:  "irBackend"+    <*> o .:? "irHash"+    <*> o .:? "irMetadata"+    <*> o .:  "irTypes"+    <*> o .:  "irMethods"+    <*> o .:  "irPlugins"+    <*> o .:? "irPluginHashes"+    <*> o .:? "irPluginRequests"+    <*> o .:? "irPluginRoles"+    <*> o .:? "irRefusals" .!= []++-- | The IR format this synapse writes (SYNAPSE-CC-8). A cache holding any+--   other is discarded and built again.+currentIrVersion :: Text+currentIrVersion = "2.1"++-- ============================================================================+-- IR 2.1: refusals, injected params, refinements+-- ============================================================================++-- | SYNAPSE-CC-8: a site the builder could not type. Nothing was dropped: the+--   site is named here, and where it stood the IR says 'RefUnknown' (or the+--   type is left out and its uses say 'RefUnknown').+--+--   Sites are written as service-codegen's report and PYTHON-3's walk write them:+--   @<ns.Type>[.<variant>].<field>@ · @<method path>(<param>)@ ·+--   @<method path> returns@, with the suffixes @[]@ (element), @?@+--   (optional), @{}@ (map value) and @.N@ (tuple element).+data Refusal = Refusal+  { rfSite    :: Text        -- ^ where, e.g. @tickets.Reply@ or @.call(params)@+  , rfKeyword :: Text        -- ^ the keyword it could not read: @oneOf@, @anyOf@, @returns@, @type@, @items@, @allOf@, …+  , rfVariant :: Maybe Int   -- ^ for a union, the index of the first member it could not read+  , rfDetail  :: Text        -- ^ why+  }+  deriving stock (Show, Eq, Ord, Generic)+  deriving anyclass (ToJSON, FromJSON)++-- | SYNAPSE-CC-8: a parameter the server supplies (its @x-plexus-source@ is+--   anything but @rpc@) — not a parameter a client sends, so not in+--   'mdParams'. The source is kept verbatim.+data InjectedParam = InjectedParam+  { ipName        :: Text+  , ipSource      :: Value          -- ^ e.g. @{"from": "auth", "resolver": "self.access.verify"}@+  , ipDescription :: Maybe Text+  }+  deriving stock (Show, Eq, Generic)+  deriving anyclass (ToJSON, FromJSON)++-- | SYNAPSE-CC-8: the bounds of a 'RefRefined' — only those the base's+--   format does not already imply. Each is left out of the JSON when absent.+data Refinements = Refinements+  { rnMinimum          :: Maybe Scientific   -- ^ @minimum@+  , rnMaximum          :: Maybe Scientific   -- ^ @maximum@+  , rnExclusiveMinimum :: Maybe Scientific   -- ^ @exclusiveMinimum@+  , rnExclusiveMaximum :: Maybe Scientific   -- ^ @exclusiveMaximum@+  , rnMinLength        :: Maybe Int          -- ^ @minLength@+  , rnMaxLength        :: Maybe Int          -- ^ @maxLength@+  , rnPattern          :: Maybe Text         -- ^ @pattern@+  , rnMinItems         :: Maybe Int          -- ^ @minItems@+  , rnMaxItems         :: Maybe Int          -- ^ @maxItems@+  }+  deriving stock (Show, Eq, Ord, Generic)++-- | The JSON Schema keyword each field is: @rnMinimum@ is @minimum@.+refinementOptions :: Options+refinementOptions = defaultOptions+  { omitNothingFields = True+  , fieldLabelModifier = \f -> case drop 2 f of+      (c : rest) -> toLower c : rest+      [] -> f+  }++instance ToJSON Refinements where+  toJSON = genericToJSON refinementOptions++instance FromJSON Refinements where+  parseJSON = genericParseJSON refinementOptions++noRefinements :: Refinements+noRefinements = Refinements Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++isNoRefinements :: Refinements -> Bool+isNoRefinements = (== noRefinements)++-- | SYNAPSE-CC-8: how an enum's variants are told apart on the wire.+--   'Internal' (the tag is a property of each variant, named by+--   @keDiscriminator@) is the default and is left out of the JSON.+data EnumRepr+  = Internal    -- ^ @{"<tag>": "variant", …fields}@+  | External    -- ^ @{"variant": {…fields}}@ (serde's default); @keDiscriminator@ is @""@+  | Untagged    -- ^ the variant's own shape (serde's untagged); each variant names its type in @vdRef@+  deriving stock (Show, Eq, Ord, Generic)++instance ToJSON EnumRepr where+  toJSON = \case+    Internal -> String "internal"+    External -> String "external"+    Untagged -> String "untagged"++instance FromJSON EnumRepr where+  parseJSON = withText "EnumRepr" $ \case+    "internal" -> pure Internal+    "external" -> pure External+    "untagged" -> pure Untagged+    other -> fail ("unknown keRepr: " <> T.unpack other)+  omittedField = Just Internal+ -- | Empty IR for folding emptyIR :: IR emptyIR = IR-  { irVersion = "2.0"  -- Bumped: TypeRef now uses structured QualifiedName+  { irVersion = currentIrVersion  -- 2.1: SYNAPSE-CC-8 (2.0: TypeRef uses structured QualifiedName)   , irBackend = ""  -- Will be set by buildIR   , irHash = Nothing   , irMetadata = Nothing@@ -164,6 +294,7 @@   , irPluginHashes = Nothing   , irPluginRequests = Nothing   , irPluginRoles = Nothing+  , irRefusals = []   }  -- | Merge two IRs (for combining results from tree walk)@@ -191,6 +322,7 @@       (Just ra, Nothing) -> Just ra       (Nothing, Just rb) -> Just rb       (Nothing, Nothing) -> Nothing+  , irRefusals = irRefusals a <> irRefusals b   }  -- ============================================================================@@ -217,8 +349,9 @@       { ksFields :: [FieldDef]       -- ^ Struct fields       }   | KindEnum-      { keDiscriminator :: Text      -- ^ Field that discriminates (e.g., "type")+      { keDiscriminator :: Text      -- ^ Field that discriminates (e.g., "type"); @""@ when not 'Internal'       , keVariants :: [VariantDef]   -- ^ Possible variants+      , keRepr :: EnumRepr           -- ^ SYNAPSE-CC-8: internal (omitted), external or untagged       }   | KindStringEnum       { kseValues :: [Text]          -- ^ String literal values (e.g., ["pending", "completed"])@@ -231,8 +364,15 @@       , kpFormat :: Maybe Text       -- ^ Optional format hint (e.g., "uuid", "int64")       }   deriving stock (Show, Eq, Generic)-  deriving anyclass (ToJSON, FromJSON)+  deriving anyclass (FromJSON) +-- | Generic, except that @keRepr@ is left out when 'Internal' (SYNAPSE-CC-8):+--   an enum IR 2.0 already carried serializes exactly as before.+instance ToJSON TypeKind where+  toJSON k = case genericToJSON defaultOptions k of+    Object o | KM.lookup "keRepr" o == Just (String "internal") -> Object (KM.delete "keRepr" o)+    v -> v+ -- | A field in a struct data FieldDef = FieldDef   { fdName        :: Text           -- ^ Field name@@ -249,10 +389,16 @@   { vdName        :: Text           -- ^ Variant name (the discriminator value)   , vdDescription :: Maybe Text     -- ^ Documentation   , vdFields      :: [FieldDef]     -- ^ Fields specific to this variant+  , vdRef         :: Maybe TypeRef  -- ^ SYNAPSE-CC-8: an untagged variant's type (omitted when absent)   }   deriving stock (Show, Eq, Generic)-  deriving anyclass (ToJSON, FromJSON)+  deriving anyclass (FromJSON) +instance ToJSON VariantDef where+  toJSON v = case genericToJSON defaultOptions v of+    Object o | vdRef v == Nothing -> Object (KM.delete "vdRef" o)+    j -> j+ -- ============================================================================ -- Method Definitions -- ============================================================================@@ -271,11 +417,11 @@     -- BidirChannel<StandardRequest<T>, StandardResponse<T>>.     --     -- Populated from the "bidirectional" / "request_type" fields in the-    -- MethodSchema (emitted by the hub-macro when #[bidirectional] is set).+    -- MethodSchema (emitted by plexus-macros when #[bidirectional] is set).     --     -- - Nothing  → method is not bidirectional, OR uses the default     --              T = serde_json::Value (StandardBidirChannel)-    -- - Just RefAny → bidirectional with T=Value (explicit marker)+    -- - Just RefJson → bidirectional with T=Value (explicit marker)     -- - Just (RefNamed ...) → bidirectional with a specific named T type     --     -- NOTE: The substrate schema currently emits 'bidirectional: true' but@@ -300,7 +446,7 @@     -- 'plexus_core::MethodRole'. Defaults to 'MethodRoleRpc' when the     -- upstream schema omits @role@ (pre-IR servers).     ---    -- Consumed by hub-codegen (Rust field @md_role@, JSON key @mdRole@)+    -- Consumed by service-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@),@@ -310,12 +456,18 @@   , mdLongDescription :: Maybe Text     -- ^ AUTH-9: the doc comment beside the short description     --   (@MethodSchema.long_description@).+  , mdInjected    :: [InjectedParam]+    -- ^ SYNAPSE-CC-8: the params the server supplies (@x-plexus-source@+    --   other than rpc), out of 'mdParams'. Omitted from the JSON when empty.+  , mdInput       :: Maybe TypeRef+    -- ^ SYNAPSE-CC-8, reserved for BIDIR-6: @MethodSchema.input@ as a type.+    --   Omitted from the JSON when absent; no server sends it yet.   }   deriving stock (Show, Eq, Generic)  -- | Manual JSON instances so @mdRole@ defaults to 'MethodRoleRpc' when --   deserializing pre-IR-12 IR JSON (same back-compat posture as the---   Rust @#[serde(default)]@ on @MethodDef.md_role@ in hub-codegen).+--   Rust @#[serde(default)]@ on @MethodDef.md_role@ in service-codegen). -- --   All other fields preserve the generic derivation defaults (field --   names used verbatim as JSON keys; @Maybe@ fields omitted when@@ -339,6 +491,9 @@     [ ("mdGrant" .=) <$> mdGrant     , ("mdTarget" .=) <$> mdTarget     , ("mdLongDescription" .=) <$> mdLongDescription+      -- SYNAPSE-CC-8: present only when there are any+    , if null mdInjected then Nothing else Just ("mdInjected" .= mdInjected)+    , ("mdInput" .=) <$> mdInput     ]  instance FromJSON MethodDef where@@ -357,6 +512,8 @@     <*> o .:? "mdGrant"     <*> o .:? "mdTarget"     <*> o .:? "mdLongDescription"+    <*> o .:? "mdInjected" .!= []+    <*> o .:? "mdInput"  -- | A parameter definition data ParamDef = ParamDef@@ -377,7 +534,7 @@     --   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+    --   renderer, service-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]@@ -438,11 +595,34 @@   | RefPrimitive Text (Maybe Text)  -- ^ Primitive type with optional format   | RefArray TypeRef                -- ^ Array of some type   | RefOptional TypeRef             -- ^ Optional (nullable) type-  | RefAny                          -- ^ Intentionally dynamic (serde_json::Value) - accepts any JSON-  | RefUnknown                      -- ^ Unknown type (schema gap) - should warn+  | RefJson                         -- ^ SYNAPSE-CC-8: the JSON type (a @serde_json::Value@): any JSON value, typed — @JsonValue@ / @Json@ / @serde_json::Value@+  | RefUnknown                      -- ^ Not typed: only at a site 'irRefusals' names (SYNAPSE-CC-8)+  | RefMap TypeRef                  -- ^ SYNAPSE-CC-8: an object with @additionalProperties: V@ and no properties; keys are strings+  | RefTuple [TypeRef]              -- ^ SYNAPSE-CC-8: @prefixItems@ with @minItems = maxItems@ = its length+  | RefRefined TypeRef Refinements  -- ^ SYNAPSE-CC-8: a bound the base's format does not imply+  | RefChild Text                   -- ^ SYNAPSE-CC-8: a static or dynamic child's return: that child's client, by its full path   deriving stock (Show, Eq, Generic)-  deriving anyclass (ToJSON, FromJSON)+  deriving anyclass (ToJSON) +-- | Generic, except that an IR older than 2.1 wrote a @serde_json::Value@+--   as @{"tag": "RefAny"}@: it reads as 'RefJson'.+instance FromJSON TypeRef where+  parseJSON v = genericParseJSON defaultOptions v <|> legacyAny v+    where+      legacyAny = withObject "TypeRef" $ \o -> case (KM.lookup "tag" o, KM.member "contents" o) of+        (Just (String "RefAny"), _) -> pure RefJson+        _ -> fail "not a TypeRef"++-- | The refs directly inside a ref.+typeRefChildren :: TypeRef -> [TypeRef]+typeRefChildren = \case+  RefArray t -> [t]+  RefOptional t -> [t]+  RefMap t -> [t]+  RefTuple ts -> ts+  RefRefined t _ -> [t]+  _ -> []+ -- | Get the name from a type reference (if it's a named ref) typeRefName :: TypeRef -> Maybe Text typeRefName (RefNamed qn) = Just (qualifiedNameFull qn)@@ -461,7 +641,7 @@ -- (more than 1 success variant + error variant) inferStreaming :: TypeDef -> Bool inferStreaming td = case tdKind td of-  KindEnum _ variants ->+  KindEnum _ variants _ ->     let nonErrorVariants = filter (not . isErrorVariant) variants     in length nonErrorVariants > 1   _ -> False
src/Synapse/Identity/Command.hs view
@@ -127,11 +127,11 @@ 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."+ <> 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 service 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"))+      <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The service'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")))@@ -149,7 +149,7 @@   )   where     p = LogoutOpts-      <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The hub's name, e.g. menger"))+      <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The service'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]@.
src/Synapse/Identity/Session.hs view
@@ -78,7 +78,7 @@ 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.Schema.Types (ServiceStreamItem, pattern ServiceData, pattern ServiceError, pattern ServiceGuidance) import Synapse.Transport (invoke)  -- ============================================================================@@ -97,10 +97,10 @@ nowSecs :: IO Integer nowSecs = round <$> getPOSIXTime --- | Log in to the hub @backend@ at @HOST:PORT@ as @agent@, proving the key:+-- | Log in to the service @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?,+-- {flow: {session: {ttl_secs?, ceiling?}}}@ — or, on a service with no @auth@+-- activation (every service 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@@ -128,7 +128,7 @@       ts <- nowSecs       pure (buildProof seed (E.audience ep) agent nonce ts)     grantItem what items =-      case [g | HubData _ _ _ v <- items, Just g <- [parseSessionGrant v]] of+      case [g | ServiceData _ _ _ v <- items, Just g <- [parseSessionGrant v]] of         (g : _) -> Right LoginResult           { lrToken = sgToken g           , lrPrincipal = sgPrincipal g@@ -138,7 +138,7 @@           }         [] -> Left (answerError items (what <> " answered no session"))     loginItem items =-      case [o | HubData _ _ _ (Object o) <- items, KM.lookup "type" o == Just (String "login")] of+      case [o | ServiceData _ _ _ (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@@ -181,19 +181,19 @@             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+              case [g | ServiceData _ _ _ 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+      case [o | ServiceData _ _ _ (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+-- | AUTH-8: who a token is — @auth.whoami@, else (a service 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@@ -215,12 +215,12 @@       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+firstWhoami :: [ServiceStreamItem] -> Either Text Whoami+firstWhoami items = case [w | ServiceData _ _ _ 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+-- | End the session this token is: @auth.logout@ (AUTH-5), else — a service -- with no auth activation — @session.logout@. logoutWithToken :: Log.Logger -> Endpoint -> Text -> Text -> IO (Either Text ()) logoutWithToken logger ep backend token = do@@ -234,16 +234,16 @@     -- 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 ()+      | null [() | ServiceError{} <- is] && null (errorEvents is) && not (null [() | ServiceData{} <- 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")]+      ServiceData _ _ _ (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")]+    errorEvents is = [() | ServiceData _ _ _ (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 :: Log.Logger -> Endpoint -> Text -> Maybe Text -> Text -> Text -> Value -> IO (Either Text [ServiceStreamItem]) call logger ep backend cred ns method params = do   env0 <- initEnvAt ep backend logger Nothing   let env = withRequestContext [] (maybe [] (\c -> [bearer c]) cred) env0@@ -270,11 +270,11 @@ bearer :: Text -> (Text, Text) bearer cred = ("Authorization", "Bearer " <> cred) -answerError :: [HubStreamItem] -> Text -> Text+answerError :: [ServiceStreamItem] -> 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+  case [m | ServiceData _ _ _ (Object o) <- items, KM.lookup "type" o == Just (String "error"), Just (String m) <- [KM.lookup "message" o]]+       <> [e | ServiceError _ _ e _ <- items]+       <> [T.pack (show g) | ServiceGuidance _ _ g _ _ _ <- items] of     (m : _) -> m     [] -> fallback @@ -456,13 +456,13 @@ -- Recognising an ended session -- ============================================================================ --- | The in-band error a hub answers a call whose session has ended with.-isSessionEndedItem :: HubStreamItem -> Bool+-- | The in-band error a service answers a call whose session has ended with.+isSessionEndedItem :: ServiceStreamItem -> Bool isSessionEndedItem = \case-  HubData _ _ _ (Object o)+  ServiceData _ _ _ (Object o)     | KM.lookup "type" o == Just (String "error")     , Just (String m) <- KM.lookup "message" o -> isSessionEndedText m-  HubError _ _ e _ -> isSessionEndedText e+  ServiceError _ _ e _ -> isSessionEndedText e   _ -> False  isSessionEndedText :: Text -> Bool
src/Synapse/Identity/Store.hs view
@@ -379,7 +379,7 @@   , srKey       :: Text           -- ^ the key's name in the key store   , srScope     :: [Text]         -- ^ as asked at login (empty: the key's own)   , srTtl       :: Maybe Integer  -- ^ as asked at login-  , srBackend   :: Text           -- ^ the hub's name (its @<name>.call@)+  , srBackend   :: Text           -- ^ the service's name (its @<name>.call@)   } deriving (Eq, Show)  instance ToJSON SessionRec where
src/Synapse/Monad.hs view
@@ -28,6 +28,9 @@   , withRequestContext   , withViewKey   , viewQualified+  , SchemaSource(..)+  , withSchemaSource+  , isCached      -- * Errors   , SynapseError(..)@@ -65,15 +68,17 @@ import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Map.Strict as Map import Synapse.Schema.Types import Synapse.Backend.Discovery (Backend(..))+import Synapse.SchemaStore (Store, Plan) import Synapse.Endpoint (Endpoint(..), plainAt) import qualified Synapse.Log as Log import qualified Katip  -- | Environment for Synapse operations data SynapseEnv = SynapseEnv-  { seEndpoint :: !Endpoint                   -- ^ Where the hub is reached (SCAFFOLD-21: ws or wss, its path)+  { seEndpoint :: !Endpoint                   -- ^ Where the service is reached (SCAFFOLD-21: ws or wss, its path)   , seBackend :: !Text                        -- ^ Backend name (first CLI argument)   , seCache   :: !(IORef (HashMap PluginHash PluginSchema))  -- ^ Schema cache   , seVisited :: !(IORef (HashSet PluginHash))               -- ^ Cycle detection@@ -82,8 +87,25 @@   , seCookies :: ![(Text, Text)]              -- ^ SAFE-S04/REQ-5: extra cookies for WS upgrade   , seHeaders :: ![(Text, Text)]              -- ^ SAFE-S04/REQ-5: extra headers for WS upgrade   , seViewKey :: !(Maybe Text)                -- ^ AUTH-8: the caller's view (its hash, else its kind); qualifies every cache key+  , seSchemaSource :: !SchemaSource           -- ^ SYNAPSE-28: where a schema comes from (the server, or the cache alone)+  , seFetched :: !(IORef (Map.Map Path PluginSchema))  -- ^ SYNAPSE-28: each path fetched once a run+  , sePlan    :: !(Maybe Plan)                -- ^ SYNAPSE-28: the call's plan, when the cache had one   } +-- | SYNAPSE-28: where this run's schemas come from.+data SchemaSource+  = FromServer (Maybe Store)   -- ^ fetched, and kept in the store when there is one+  | FromCache Store            -- ^ the store alone: what it lacks is 'StaleSchema', never a fetch++-- | SYNAPSE-28: the run sends first, from the cache.+isCached :: SynapseEnv -> Bool+isCached env = case seSchemaSource env of+  FromCache _ -> True+  FromServer _ -> False++withSchemaSource :: SchemaSource -> Maybe Plan -> SynapseEnv -> SynapseEnv+withSchemaSource src plan env = env { seSchemaSource = src, sePlan = plan }+ -- | Errors that can occur during Synapse operations data SynapseError   = NavError NavError@@ -92,6 +114,13 @@   | ParseError Text   | ValidationError Text   | BackendError BackendErrorType [Backend]+  | StaleSchema Text+    -- ^ SYNAPSE-28: the cache misled the call (a method or flag it does not+    -- know, or the server refused what it said): forget it, ask the server,+    -- run the call again+  | CacheMiss Text+    -- ^ SYNAPSE-28: the cache has not got what the call needs (a schema it+    -- never fetched): ask the server, and keep what it says   deriving stock (Show, Eq)  -- | Backend-specific error types@@ -146,26 +175,27 @@   env <- defaultEnv backend logger   runSynapseM env action --- | The hub's host.+-- | The service's host. seHost :: SynapseEnv -> Text seHost = epHost . seEndpoint --- | The hub's port.+-- | The service's port. sePort :: SynapseEnv -> Int sePort = epPort . seEndpoint  -- | Initialize environment with given host/port/backend/logger/token, for a--- hub at plain @ws://HOST:PORT/@ ('initEnvAt' for any address).+-- service at plain @ws://HOST:PORT/@ ('initEnvAt' for any address). -- Extra cookies/headers default to empty; use 'withRequestContext' to add -- them after construction (SAFE-S04/REQ-5). initEnv :: Text -> Int -> Text -> Log.Logger -> Maybe Text -> IO SynapseEnv initEnv host port = initEnvAt (plainAt host port) --- | SCAFFOLD-21: 'initEnv' for a hub at any address (@wss://…/ws@ too).+-- | SCAFFOLD-21: 'initEnv' for a service at any address (@wss://…/ws@ too). initEnvAt :: Endpoint -> Text -> Log.Logger -> Maybe Text -> IO SynapseEnv initEnvAt ep backend logger token = do   cache <- newIORef HM.empty   visited <- newIORef HS.empty+  fetched <- newIORef Map.empty   pure SynapseEnv     { seEndpoint = ep     , seBackend = backend@@ -176,6 +206,9 @@     , seCookies = []     , seHeaders = []     , seViewKey = Nothing+    , seSchemaSource = FromServer Nothing+    , seFetched = fetched+    , sePlan = Nothing     }  -- | Augment a SynapseEnv with extra cookies and headers for the WS upgrade.@@ -255,8 +288,8 @@   liftIO $ modifyIORef' cacheRef (HM.insert key schema)  -- | AUTH-8: a cache key under the caller's view — @VIEW/HASH@, or the hash--- alone on a hub with no view (as before AUTH). Two callers' views of one--- hub never share an entry, even where the hub gave a schema one hash in+-- alone on a service with no view (as before AUTH). Two callers' views of one+-- service never share an entry, even where the service gave a schema one hash in -- both. viewQualified :: Maybe Text -> Text -> Text viewQualified Nothing hash = hash
+ src/Synapse/Output.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | SYNAPSE-39: @synapse -o FILE@ — the call's answer written to a file,+-- whole, never to a pipe.+--+-- The run's stdout itself is pointed at a temporary file beside FILE (made+-- 0600 and exclusive, as 'openBinaryTempFile' makes it), so every printer+-- writes there unchanged and in the same form it would have had on a pipe+-- (@-j@ lines with @-j@, the rendered answer without). When the run ends+-- with 0 the temporary file is renamed over FILE: a reader never sees half+-- an answer. When it ends with anything else, the temporary file is+-- removed and so is an older FILE — no stale answer is left to be read as+-- this one — and the run's own code stands (75, 77, 69…).+--+-- A stream ('streaming', told when the call turns out to be one) has no+-- end to wait for: its temporary file is renamed to FILE at once, and each+-- item is in FILE when it is printed (stdout is line-buffered and every+-- printer flushes). A stream that fails keeps what it wrote; one that wrote+-- nothing leaves no FILE.+--+-- A FILE that cannot be made (no such directory, a directory) is said at+-- once and the run exits 'exitCannotCreate' before anything is sent. A write to it that fails+-- later (a full disk) is no outage and no answer of the service's: the+-- printer's failure ends the call (SYNAPSE-26's marking in+-- 'Synapse.Reconnect'), and the run exits 'exitCannotWrite', saying so —+-- at once, past the runtime's last flush, which would fail on what is left+-- in stdout's buffer and make the exit 1.+--+-- What must be seen while the call waits goes to stderr under @-o@, not+-- FILE: a two-way request's prompt ('promptHandle'), and under @-j@ an error+-- or a refusal — FILE goes with the failed run, so its line alone would be+-- lost. A SIGTERM or SIGHUP ends the run as a failed one (143, 129): the+-- temporary file is removed. A SIGKILL can leave it behind.+module Synapse.Output+  ( withOutputFile+  , streaming+  , active+  , promptHandle+  , exitCannotCreate+  , exitCannotWrite+  ) where++import Control.Exception (SomeException, IOException, catch, fromException, throwIO, try)+import Control.Monad (when)+import Data.IORef+import GHC.IO.Exception (IOException(..))+import GHC.IO.Handle (hDuplicateTo)+import System.Directory (removeFile, renameFile, doesFileExist)+import System.Exit (ExitCode(..), exitWith)+import System.FilePath (takeDirectory, takeFileName)+import System.IO+import System.IO.Unsafe (unsafePerformIO)+import System.Posix.Files (setFileMode, fileSize, getFileStatus)+import System.Posix.Process (exitImmediately)+import System.Posix.Signals (Handler(..), installHandler, sigHUP, sigTERM)+import System.Directory (doesDirectoryExist)++import Synapse.Reconnect (isStdoutFailure)++-- | sysexits' EX_CANTCREAT: FILE could not be made.+exitCannotCreate :: Int+exitCannotCreate = 73++-- | sysexits' EX_IOERR: a write to FILE failed.+exitCannotWrite :: Int+exitCannotWrite = 74++data Out = Out+  { oFile      :: FilePath+  , oTmp       :: FilePath+  , oStreaming :: IORef Bool+  }++{-# NOINLINE current #-}+current :: IORef (Maybe Out)+current = unsafePerformIO (newIORef Nothing)++-- | Run the program with its stdout in FILE (@Nothing@ or @-@: stdout as+-- it is).+withOutputFile :: Maybe FilePath -> IO a -> IO a+withOutputFile Nothing act = act+withOutputFile (Just "-") act = act+withOutputFile (Just file) act = do+  let dir = case takeDirectory file of { "" -> "."; d -> d }+  isDir <- doesDirectoryExist file+  opened <- if isDir then pure (Left "is a directory") else+    either (Left . reason) Right <$> try (openBinaryTempFile dir (takeFileName file <> ".tmp"))+  case opened of+    Left why -> do+      hPutStrLn stderr ("synapse: cannot write " <> file <> ": " <> why)+      exitWith (ExitFailure exitCannotCreate)+    Right (tmp, h) -> do+      setFileMode tmp 0o600+      enc <- hGetEncoding stdout+      hFlush stdout+      hDuplicateTo h stdout+      hClose h+      -- the form a pipe would have had: the same encoding, and each line+      -- out as it is printed+      maybe (hSetBinaryMode stdout True) (hSetEncoding stdout) enc+      hSetBuffering stdout LineBuffering+      st <- newIORef False+      let out = Out file tmp st+      writeIORef current (Just out)+      -- a run told to stop is a failed one: no FILE, no temporary file+      let stopped n = Catch $ do+            finish out (ExitFailure n) `catch` \(_ :: SomeException) -> pure ()+            hFlush stderr `catch` \(_ :: SomeException) -> pure ()+            exitImmediately (ExitFailure n)+      _ <- installHandler sigTERM (stopped 143) Nothing+      _ <- installHandler sigHUP (stopped 129) Nothing+      r <- try act+      let code = case r of+            Right _ -> ExitSuccess+            Left e | Just (c :: ExitCode) <- fromException e -> c+                   | otherwise -> ExitFailure 1+      flushed <- try (hFlush stdout)+      case flushed of+        Left (e :: IOException) -> do+          finish out (ExitFailure exitCannotWrite)+          cannotWrite file e+        Right () -> finish out code+      case r of+        Right a -> pure a+        Left e+          | Just (ioe :: IOException) <- fromException e, isStdoutFailure e -> cannotWrite file ioe+          | otherwise -> throwIO e++-- | The run's ending, in FILE: renamed into place, or taken away.+finish :: Out -> ExitCode -> IO ()+finish out code = do+  s <- readIORef (oStreaming out)+  if s+    then when (code /= ExitSuccess) $ do+      -- a stream keeps what came; one that brought nothing leaves no FILE+      size <- (fileSize <$> getFileStatus (oFile out)) `catch` \(_ :: SomeException) -> pure 1+      when (size == 0) $ quietly (removeFile (oFile out))+    else if code == ExitSuccess+      then renameFile (oTmp out) (oFile out) `catch` \(e :: IOException) -> do+        quietly (removeFile (oTmp out))+        cannotWrite (oFile out) e+      else do+        quietly (removeFile (oTmp out))+        exists <- doesFileExist (oFile out)+        when exists $ quietly (removeFile (oFile out))++-- | Whether @-o FILE@ holds stdout.+active :: IO Bool+active = maybe False (const True) <$> readIORef current++-- | Where a prompt goes that must be seen while the call waits: stderr+-- under @-o@ (stdout is FILE), else stdout.+promptHandle :: IO Handle+promptHandle = do+  a <- active+  pure (if a then stderr else stdout)++-- | The call is a stream: FILE is its temporary file from now on, each+-- item in it as it is printed.+streaming :: IO ()+streaming = do+  m <- readIORef current+  case m of+    Nothing -> pure ()+    Just out -> do+      s <- readIORef (oStreaming out)+      when (not s) $ do+        hFlush stdout+        renameFile (oTmp out) (oFile out)+        writeIORef (oStreaming out) True++cannotWrite :: FilePath -> IOException -> IO a+cannotWrite file e = do+  hPutStrLn stderr ("synapse: cannot write " <> file <> ": " <> reason e)+  hFlush stderr `catch` \(_ :: SomeException) -> pure ()+  exitImmediately (ExitFailure exitCannotWrite)+  exitWith (ExitFailure exitCannotWrite)++reason :: IOException -> String+reason e = case ioe_description e of+  "" -> show (ioe_type e)+  d -> d++quietly :: IO () -> IO ()+quietly a = a `catch` \(_ :: SomeException) -> pure ()
src/Synapse/Reconnect.hs view
@@ -20,6 +20,23 @@ --   lost — and the caller is told it resumed (@-j@ prints a --   @{"type":"reconnected"}@ line); -- * when the window runs out, it exits 'exitUnreachable' with the reason.+--+-- SYNAPSE-26: a closed stdout is not an outage. GHC's runtime ignores+-- SIGPIPE, so a write to a stdout whose reader has gone (@… | head -1@)+-- raises an EPIPE, and the transport reports anything raised in a call as+-- a network error — which "broken pipe" made an outage, and a write was+-- sent again for as long as the pipe stayed closed. Whatever the call's+-- callbacks raise is marked where it is raised, and the call ends there,+-- never retried. Those callbacks are the caller's side of the call: the+-- printer (each item, the @-j@ reconnected line, the stderr lines) and the+-- answering of a two-way request (the prompt or @--bidir-cmd@ that+-- answers it; sending the answer, @<backend>.respond@, reports its own+-- failure as a value and raises nothing). A closed stdout (or stderr) exits+-- 'exitOutputClosed' (141, what a shell says of a filter the pipe closed+-- on) saying nothing, with the stream unsubscribed and the socket closed+-- as the transport unwinds; any other failure there is reported as+-- before, once. A socket's own broken pipe — the peer gone — is never+-- raised in a callback, and is still an outage. module Synapse.Reconnect   ( -- * The window     setReconnectWindow@@ -44,12 +61,20 @@   , giveUp   , reportEnding +    -- * A closed stdout+  , isClosedOutput+  , isStdoutFailure+  , exitOnClosedOutput+     -- * Exit codes   , exitUnreachable   , exitWriteUnknown+  , exitOutputClosed   ) where  import Control.Concurrent (threadDelay)+import Control.Exception (SomeAsyncException, SomeException, catch, fromException, throwIO)+import GHC.IO.Exception (IOException(..), IOErrorType(..)) import Data.Aeson (Value(..)) import qualified Data.Aeson.KeyMap as KM import Data.Char (isDigit)@@ -61,8 +86,9 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import GHC.Clock (getMonotonicTime) import System.Exit (ExitCode(..), exitWith)-import System.IO (hFlush, stderr)+import System.IO (hFlush, stderr, stdout) import System.IO.Unsafe (unsafePerformIO)+import System.Posix.Process (exitImmediately)  import Plexus.Schema.Recursive (MethodSchema(..)) import qualified Plexus.Types as PT@@ -167,8 +193,8 @@ tooMany msg = any (`T.isInfixOf` T.toLower msg) ["responsecode = 429", "too many requests"]  -- | SCAFFOLD-21: a proxy in front (the edge before a hosted app) answering--- the upgrade 502, 503 or 504 — it is up, the hub behind it is not (a--- promote's restart). Nothing was sent; the hub comes back behind it.+-- the upgrade 502, 503 or 504 — it is up, the service behind it is not (a+-- promote's restart). Nothing was sent; the service comes back behind it. gatewayDown :: Text -> Bool gatewayDown msg = any (`T.isInfixOf` T.toLower msg)   ["responsecode = 502", "responsecode = 503", "responsecode = 504"]@@ -183,7 +209,7 @@     -- the server's connection limits (ACCESS-29) answer 429 at the upgrade:     -- nothing was sent, and it passes   , "responsecode = 429", "too many requests"-    -- SCAFFOLD-21: the proxy in front answers while the hub behind is away+    -- SCAFFOLD-21: the proxy in front answers while the service behind is away   , "responsecode = 502", "responsecode = 503", "responsecode = 504"   ] @@ -210,7 +236,7 @@   | "ConnectionRefused" `T.isInfixOf` why = "connection refused"   | "ConnectionTimeout" `T.isInfixOf` why = "connection timed out"   | Just code <- find (\c -> ("responseCode = " <> c) `T.isInfixOf` why) ["502", "503", "504"] =-      "the proxy in front answered " <> code <> ": the hub behind it is away"+      "the proxy in front answered " <> code <> ": the service behind it is away"   | otherwise = why  -- | An outage under way: when it began, how many tries, the next pause.@@ -270,6 +296,7 @@   | Failed PT.TransportError   -- ^ not an outage (or no window): reported as before   | GaveUp Double Text         -- ^ the window ran out: its length, the last reason   | WriteUnknown Text          -- ^ a write went out and its connection went before the answer+  | OutputClosed               -- ^ SYNAPSE-26: stdout's reader closed the pipe; nothing is tried again   deriving (Eq, Show)  -- | Run a call, one attempt at a time, through any outage within the@@ -294,7 +321,14 @@   window <- reconnectWindow   began <- (floor <$> getPOSIXTime) :: IO Integer   everDelivered <- newIORef False-  let sinceFor n+  -- SYNAPSE-26: what the printer raised, marked where it was raised — the+  -- transport reports it as a network error, and it is no outage+  printerFailed <- newIORef Nothing+  let printing :: IO () -> IO ()+      printing act = act `catch` \(e :: SomeException) -> case fromException e of+        Just (_ :: SomeAsyncException) -> throwIO e+        Nothing -> writeIORef printerFailed (Just e) >> throwIO e+      sinceFor n         | n > (0 :: Int), csSince shape, Object o <- params0, unset (KM.lookup "since" o) = Just began         | otherwise = Nothing       -- a default the schema filled in (null) is no since of the caller's@@ -307,9 +341,7 @@       go n outage = goAuth n outage False       goAuth n outage reauthed = do         taken <- newIORef False-        let subscribed = do-              writeIORef taken True-              case outage of+        let subscribed = writeIORef taken True >> printing (case outage of                 Just o -> do                   now <- getMonotonicTime                   say $ "reconnected to " <> whereTo <> " after " <> renderDuration (now - oStart o)@@ -317,16 +349,26 @@                   if csStream shape || before                     then onResume (Resumed (now - oStart o) (oAttempts o) (sinceFor n))                     else pure ()-                Nothing -> pure ()-            item i = writeIORef everDelivered True >> onItem i+                Nothing -> pure ())+            item i = writeIORef everDelivered True >> printing (onItem i)         r <- attempt (paramsFor n) subscribed item+        failed <- readIORef printerFailed         t <- readIORef taken         -- a try the server took had the connection back: a new loss is a         -- new outage, with the whole window again         let outage' = if t then Nothing else outage-        case r of-          Right () -> pure Finished-          Left e+        case (failed, r) of+          -- the printer's failure ends the call, whatever the transport made of it+          (Just pe, _)+            | Just (code :: ExitCode) <- fromException pe -> throwIO code+            | isClosedOutput pe -> pure OutputClosed+            -- SYNAPSE-39: any other failed write to stdout (-o's FILE on a+            -- full disk) is no outage and no failure of the call's: it is+            -- the run's, raised to it+            | isStdoutFailure pe -> throwIO pe+          (Just _, Left e) -> pure (Failed e)+          (_, Right ()) -> pure Finished+          (Nothing, Left e)             | Just _ <- outage', not reauthed, upgradeRefused e -> do                 -- the server came back without the session: once per                 -- outage, sign in again and try at once@@ -390,6 +432,52 @@ -- --------------------------------------------------------------------------- -- Endings +-- | SYNAPSE-26: 128 + SIGPIPE — what a shell says of a filter whose+-- output pipe closed (GHC ignores the signal, so synapse exits with it).+exitOutputClosed :: Int+exitOutputClosed = 141++-- | SYNAPSE-26: an EPIPE (or any vanished resource) raised writing to+-- stdout or stderr: its reader has gone. Told apart from a socket's own by+-- the handle the 'IOException' carries — a socket's carries none — as+-- GHC's top handler tells it (#2699).+isClosedOutput :: SomeException -> Bool+isClosedOutput e = case fromException e of+  Just IOError { ioe_type = ResourceVanished, ioe_handle = Just h } -> h == stdout || h == stderr+  _ -> False++-- | SYNAPSE-39: a write to stdout that failed — the pipe's reader gone+-- ('isClosedOutput'), or -o's FILE on a full disk. Raised by the printer,+-- never an outage.+isStdoutFailure :: SomeException -> Bool+isStdoutFailure e = case fromException e of+  Just IOError { ioe_handle = Just h } -> h == stdout+  _ -> False++-- | SYNAPSE-26: run a program, and exit 'exitOutputClosed' quietly when+-- its stdout's reader went — raised while it ran, or at the last flush.+-- A run that was ending with a code of its own keeps it (a write of+-- unknown outcome's 75, a refusal's 77, a spent window's 69): 141 only+-- ever replaces a success. Every other ending is the program's.+exitOnClosedOutput :: IO a -> IO a+exitOnClosedOutput act = (act >>= \a -> flushOr ExitSuccess >> pure a) `catch` \(e :: SomeException) ->+  case fromException e of+    Just (code :: ExitCode) -> flushOr code >> throwIO code+    _ | isClosedOutput e -> closed (ExitFailure exitOutputClosed)+      | otherwise -> throwIO e+  where+    flushOr code = hFlush stdout `catch` \(e :: SomeException) ->+      if isClosedOutput e+        then closed (if code == ExitSuccess then ExitFailure exitOutputClosed else code)+        else throwIO e+    -- at once: what is left in stdout's buffer has nowhere to go, and the+    -- runtime's own last flush would fail on it again+    closed :: ExitCode -> IO b+    closed code = do+      hFlush stderr `catch` \(_ :: SomeException) -> pure ()+      exitImmediately code+      exitWith code+ -- | sysexits' EX_UNAVAILABLE: the backend stayed away for the whole window. exitUnreachable :: Int exitUnreachable = 69@@ -412,6 +500,7 @@   Finished -> pure (Right ())   Failed e -> pure (Left e)   GaveUp window why -> giveUp whereTo window why+  OutputClosed -> exitWith (ExitFailure exitOutputClosed)   WriteUnknown why -> do     say $ "connection to " <> whereTo <> " lost before an answer (" <> why       <> ") — the write may have happened; check before sending it again"
src/Synapse/Renderer.hs view
@@ -77,11 +77,11 @@ import qualified Text.Mustache.Types as MT  import Synapse.Schema.Types-  ( HubStreamItem-  , pattern HubData-  , pattern HubProgress-  , pattern HubError-  , pattern HubDone+  ( ServiceStreamItem+  , pattern ServiceData+  , pattern ServiceProgress+  , pattern ServiceError+  , pattern ServiceDone   )  -- ============================================================================@@ -242,20 +242,20 @@ -- ============================================================================  -- | Render a stream item using templates-renderItem :: RendererConfig -> HubStreamItem -> IO (Maybe Text)+renderItem :: RendererConfig -> ServiceStreamItem -> IO (Maybe Text) renderItem cfg item = case rcMode cfg of   ModeJson -> pure Nothing  -- Caller should use JSON   ModeRaw  -> pure Nothing  -- Caller should extract content   ModeTemplate -> case item of-    HubData _ _ contentType content ->+    ServiceData _ _ contentType content ->       renderValue cfg contentType content-    HubProgress _ _ msg _ ->+    ServiceProgress _ _ msg _ ->       pure $ Just msg-    HubError _ _ err _ ->+    ServiceError _ _ err _ ->       pure $ Just $ "Error: " <> err-    HubDone _ _ ->+    ServiceDone _ _ ->       pure Nothing-    _ -> pure Nothing  -- Handle other variants (e.g., HubGuidance)+    _ -> pure Nothing  -- Handle other variants (e.g., ServiceGuidance)  -- | Render a value using template for content type renderValue :: RendererConfig -> Text -> Value -> IO (Maybe Text)
src/Synapse/Schema/Types.hs view
@@ -14,7 +14,7 @@     -- * Query helpers   , pluginChildren   , childNamespaces-  , isHubActivation+  , isParentActivation   , isLeafActivation      -- * Navigation Types@@ -25,15 +25,15 @@     -- * Stream Types   , StreamMeta(..) -    -- * Hub Protocol Types-    -- | Re-exported from Plexus.Types with Hub naming-  , HubStreamItem-  , pattern HubData-  , pattern HubProgress-  , pattern HubError-  , pattern HubDone-  , pattern HubGuidance-  , pattern HubRequest+    -- * Service Protocol Types+    -- | Re-exported from Plexus.Types with Service naming+  , ServiceStreamItem+  , pattern ServiceData+  , pattern ServiceProgress+  , pattern ServiceError+  , pattern ServiceDone+  , pattern ServiceGuidance+  , pattern ServiceRequest      -- * Bidirectional Types (re-exported)   , Request(..)@@ -57,7 +57,7 @@   , SchemaResult(..)   , pluginChildren   , childNamespaces-  , isHubActivation+  , isParentActivation   , isLeafActivation   ) @@ -99,35 +99,35 @@   deriving stock (Show, Eq, Generic)  -- ============================================================================--- Hub Protocol Types (re-exported from Plexus.Types with Hub naming)+-- Service Protocol Types (re-exported from Plexus.Types with Service naming) -- ============================================================================ --- | Hub stream item - the universal transport envelope for streaming responses+-- | Service stream item - the universal transport envelope for streaming responses -- -- This is a type alias for 'PlexusStreamItem' from the protocol layer,--- renamed to use Hub terminology at the application level.-type HubStreamItem = PlexusStreamItem+-- renamed to use Service terminology at the application level.+type ServiceStreamItem = PlexusStreamItem  -- | Pattern synonym for data events-pattern HubData :: Text -> Provenance -> Text -> Value -> HubStreamItem-pattern HubData hash prov contentType content = StreamData hash prov contentType content+pattern ServiceData :: Text -> Provenance -> Text -> Value -> ServiceStreamItem+pattern ServiceData hash prov contentType content = StreamData hash prov contentType content  -- | Pattern synonym for progress events-pattern HubProgress :: Text -> Provenance -> Text -> Maybe Double -> HubStreamItem-pattern HubProgress hash prov msg pct = StreamProgress hash prov msg pct+pattern ServiceProgress :: Text -> Provenance -> Text -> Maybe Double -> ServiceStreamItem+pattern ServiceProgress hash prov msg pct = StreamProgress hash prov msg pct  -- | Pattern synonym for error events-pattern HubError :: Text -> Provenance -> Text -> Bool -> HubStreamItem-pattern HubError hash prov err recoverable = StreamError hash prov err recoverable+pattern ServiceError :: Text -> Provenance -> Text -> Bool -> ServiceStreamItem+pattern ServiceError hash prov err recoverable = StreamError hash prov err recoverable  -- | Pattern synonym for done events-pattern HubDone :: Text -> Provenance -> HubStreamItem-pattern HubDone hash prov = StreamDone hash prov+pattern ServiceDone :: Text -> Provenance -> ServiceStreamItem+pattern ServiceDone hash prov = StreamDone hash prov  -- | Pattern synonym for guidance events-pattern HubGuidance :: Text -> Provenance -> GuidanceErrorType -> GuidanceSuggestion -> Maybe [Text] -> Maybe Value -> HubStreamItem-pattern HubGuidance hash prov errType suggestion methods schema = StreamGuidance hash prov errType suggestion methods schema+pattern ServiceGuidance :: Text -> Provenance -> GuidanceErrorType -> GuidanceSuggestion -> Maybe [Text] -> Maybe Value -> ServiceStreamItem+pattern ServiceGuidance hash prov errType suggestion methods schema = StreamGuidance hash prov errType suggestion methods schema  -- | Pattern synonym for bidirectional request events-pattern HubRequest :: Text -> Provenance -> Text -> Request Value -> Maybe Int -> HubStreamItem-pattern HubRequest hash prov reqId reqData timeout = StreamRequest hash prov reqId reqData timeout+pattern ServiceRequest :: Text -> Provenance -> Text -> Request Value -> Maybe Int -> ServiceStreamItem+pattern ServiceRequest hash prov reqId reqData timeout = StreamRequest hash prov reqId reqData timeout
+ src/Synapse/SchemaStore.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | SYNAPSE-28: what a call needs from a backend's schema, kept on disk so+-- a call sends first and checks only on failure.+--+-- Under @$XDG_CACHE_HOME/synapse/schemas@ (@~/.cache/synapse/schemas@):+--+-- @+-- routes/CONNECTION-POINT/BACKEND.json      where BACKEND is reached from there+-- ADDRESS/AGENT/BACKEND/info.json           its _info, as this agent was answered+-- ADDRESS/AGENT/BACKEND/PATH\@VERSION-HASH.json   an activation's schema (PATH: _root, tickets, tickets.inputs …)+-- ADDRESS/AGENT/BACKEND/PATH.pin            the file PATH resolves to now+-- ADDRESS/AGENT/BACKEND/plans/METHOD.json   one method's call plan: its schema, its+--                                           activation's deprecation, the IR its flags parse by+-- @+--+-- A schema is per agent because a caller's view of it is (AUTH-8). Old+-- versions stay beside the pin (SYNAPSE-29 adds pinning by version and+-- pruning); a plan is what a warm call reads — a few kilobytes, where+-- menger's @tickets@ schema is 2.6 MB.+module Synapse.SchemaStore+  ( Store(..)+  , storeFor+  , schemasRoot++    -- * Routes+  , readRoute+  , writeRoute++    -- * _info+  , readInfo+  , writeInfo++    -- * Schemas+  , readSchema+  , writeSchema++    -- * Plans+  , Plan(..)+  , planKey+  , readPlan+  , writePlan+  , planIR++    -- * Forgetting+  , forget+  ) where++import Control.Exception (SomeException, catch, try)+import Control.Monad (forM_, when)+import Data.Aeson+import qualified Data.Aeson.KeyMap as KM+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Char (isAlphaNum)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import System.Directory (doesDirectoryExist, getHomeDirectory, listDirectory, removeFile)+import System.Environment (lookupEnv)+import System.FilePath ((</>), takeExtension, takeFileName)++import Plexus.Auth (BackendInfo, parseBackendInfo)+import Plexus.Schema.Recursive (PluginSchema(..), MethodSchema, DeprecationInfo)+import Synapse.Endpoint (Endpoint(..), dirName)+import Synapse.Identity.Store (writePrivateFile)+import Synapse.IR.Types++-- | One backend's cache, as one agent sees it at one address.+newtype Store = Store { storeDir :: FilePath }+  deriving (Eq, Show)++-- | @$XDG_CACHE_HOME/synapse/schemas@, else @~/.cache/synapse/schemas@.+schemasRoot :: IO FilePath+schemasRoot = do+  x <- lookupEnv "XDG_CACHE_HOME"+  base <- case x of+    Just d | not (null d) -> pure d+    _ -> (</> ".cache") <$> getHomeDirectory+  pure (base </> "synapse" </> "schemas")++storeFor :: Endpoint -> Text -> Text -> IO Store+storeFor ep agent backend = do+  root <- schemasRoot+  pure (Store (root </> dirName ep </> safe agent </> safe backend))++-- | A name as a file name: what is not @[A-Za-z0-9._-]@ becomes @_@.+safe :: Text -> FilePath+safe t = case T.unpack (T.map (\c -> if isAlphaNum c || c `elem` ("._-" :: String) then c else '_') t) of+  "" -> "_"+  "." -> "_"+  ".." -> "__"+  s -> s++readJson :: FromJSON a => FilePath -> IO (Maybe a)+readJson p = do+  r <- try (BS.readFile p)+  pure $ case r of+    Left (_ :: SomeException) -> Nothing+    Right bs -> decodeStrict bs++-- | Written whole and renamed into place (0600), so a reader never sees+-- half a file; a cache that cannot be written is no failure of the call.+writeJson :: ToJSON a => FilePath -> a -> IO ()+writeJson p v = writePrivateFile p (LBS.toStrict (encode v)) `catch` \(_ :: SomeException) -> pure ()++-- ---------------------------------------------------------------------------+-- Routes++routePath :: Endpoint -> Text -> IO FilePath+routePath cp backend = do+  root <- schemasRoot+  pure (root </> "routes" </> dirName cp </> (safe backend <> ".json"))++-- | Where the backend was found from this connection point (itself, or a+-- registry's entry): the address calls go to.+readRoute :: Endpoint -> Text -> IO (Maybe Endpoint)+readRoute cp backend = do+  p <- routePath cp backend+  v <- readJson p+  pure $ case v of+    Just (Object o)+      | Just (String h) <- KM.lookup "host" o+      , Just (Number port) <- KM.lookup "port" o+      , Just (Bool tls) <- KM.lookup "tls" o+      , Just (String path) <- KM.lookup "path" o+      -> Just Endpoint { epHost = h, epPort = round port, epTls = tls, epPath = path+                       , epCaFiles = if h == epHost cp && round port == epPort cp then epCaFiles cp else [] }+    _ -> Nothing++writeRoute :: Endpoint -> Text -> Endpoint -> IO ()+writeRoute cp backend at = do+  p <- routePath cp backend+  writeJson p (object ["host" .= epHost at, "port" .= epPort at, "tls" .= epTls at, "path" .= epPath at])++-- ---------------------------------------------------------------------------+-- _info++readInfo :: Store -> IO (Maybe BackendInfo)+readInfo st = (>>= parseBackendInfo) <$> readJson (storeDir st </> "info.json")++writeInfo :: Store -> BackendInfo -> IO ()+writeInfo st = writeJson (storeDir st </> "info.json")++-- ---------------------------------------------------------------------------+-- Schemas++pathName :: [Text] -> FilePath+pathName [] = "_root"+pathName segs = safe (T.intercalate "." segs)++readSchema :: Store -> [Text] -> IO (Maybe PluginSchema)+readSchema st segs = do+  pin <- try (BS.readFile (storeDir st </> (pathName segs <> ".pin")))+  case pin of+    Left (_ :: SomeException) -> pure Nothing+    Right f -> readJson (storeDir st </> takeFileName (T.unpack (T.strip (TE.decodeUtf8 f))))++-- | Kept as @PATH\@VERSION-HASH.json@ and pinned.+writeSchema :: Store -> [Text] -> PluginSchema -> IO ()+writeSchema st segs schema = do+  let file = pathName segs <> "@" <> safe (psVersion schema) <> "-" <> safe (psHash schema) <> ".json"+  writeJson (storeDir st </> file) schema+  writePrivateFile (storeDir st </> (pathName segs <> ".pin")) (TE.encodeUtf8 (T.pack file))+    `catch` \(_ :: SomeException) -> pure ()++-- ---------------------------------------------------------------------------+-- Plans++-- | What a warm call reads instead of its activation's schema.+data Plan = Plan+  { plMethod      :: MethodSchema+  , plPath        :: [Text]                  -- ^ the method's path as navigation resolved it+  , plDeprecation :: Maybe DeprecationInfo   -- ^ its activation's+  , plIR          :: Maybe IR                -- ^ the method and the types its params name; Nothing when it takes none+  } deriving (Eq, Show)++instance ToJSON Plan where+  toJSON Plan{..} = object+    [ "method" .= plMethod, "path" .= plPath, "deprecation" .= plDeprecation, "ir" .= plIR ]++instance FromJSON Plan where+  parseJSON = withObject "Plan" $ \o -> Plan+    <$> o .: "method" <*> o .: "path" <*> o .:? "deprecation" <*> o .:? "ir"++-- | The plan's file name for the path as the command line gave it.+planKey :: [Text] -> FilePath+planKey segs = pathName segs <> ".json"++-- | SYNAPSE-CC-8: a plan whose IR another synapse wrote (an older IR+-- version: 3.16.0's 2.0) is not this one's; it is read as no plan, so the+-- call asks the server and writes a plan of its own.+readPlan :: Store -> [Text] -> IO (Maybe Plan)+readPlan st segs = do+  plan <- readJson (storeDir st </> "plans" </> planKey segs)+  pure $ case plan of+    Just p | maybe False ((/= currentIrVersion) . irVersion) (plIR p) -> Nothing+    other -> other++writePlan :: Store -> [Text] -> Plan -> IO ()+writePlan st segs = writeJson (storeDir st </> "plans" </> planKey segs)++-- | The IR a plan keeps: the one method, and the types its params reach.+planIR :: Text -> IR -> IR+planIR fullPath ir = ir+  { irMethods = Map.filterWithKey (\k _ -> k == fullPath) (irMethods ir)+  , irTypes = Map.restrictKeys (irTypes ir) reached+  , irPlugins = Map.empty+  }+  where+    roots = [pdType p | Just md <- [Map.lookup fullPath (irMethods ir)], p <- mdParams md]+    reached = go Set.empty (concatMap names roots)+    go seen [] = seen+    go seen (n : rest)+      | n `Set.member` seen = go seen rest+      | otherwise = go (Set.insert n seen) (more n ++ rest)+    more n = maybe [] (kindNames . tdKind) (Map.lookup n (irTypes ir))+    kindNames = \case+      KindStruct fs -> concatMap (names . fdType) fs+      KindEnum _ vs _ -> concatMap (\v -> concatMap (names . fdType) (vdFields v) ++ maybe [] names (vdRef v)) vs+      KindAlias t -> names t+      _ -> []+    names = \case+      RefNamed qn -> [qualifiedNameFull qn, qnLocalName qn]+      t -> concatMap names (typeRefChildren t)++-- ---------------------------------------------------------------------------+-- Forgetting++-- | A call the cache misled (a method renamed, a parameter changed): its+-- plans and pins go, so every call after it reads what the server says+-- now. The schema files stay (the versions SYNAPSE-29 pins between).+forget :: Store -> IO ()+forget st = do+  let dir = storeDir st+  ok <- doesDirectoryExist dir+  when ok $ do+    fs <- listDirectory dir `catch` \(_ :: SomeException) -> pure []+    forM_ [f | f <- fs, takeExtension f == ".pin"] $ \f -> rm (dir </> f)+    let plans = dir </> "plans"+    pk <- doesDirectoryExist plans+    when pk $ do+      ps <- listDirectory plans `catch` \(_ :: SomeException) -> pure []+      forM_ ps $ \f -> rm (plans </> f)+  where+    rm p = removeFile p `catch` \(_ :: SomeException) -> pure ()
src/Synapse/Self/Debugger.hs view
@@ -262,7 +262,7 @@           TIO.putStrLn "This usually means:"           TIO.putStrLn "  1. Method schema is incompatible with synapse client"           TIO.putStrLn "  2. Schema format differs from expected structure"-          TIO.putStrLn "  3. Method was generated by incompatible macro (hub_methods vs plexus-derive)"+          TIO.putStrLn "  3. Method was generated by incompatible macro (the old methods macro vs plexus-derive)"           TIO.putStrLn ""           TIO.putStrLn "Try testing with raw WebSocket to verify method works:"           TIO.putStrLn $ "  echo '{\"jsonrpc\":\"2.0\",\"id\":1,\"method\":\"" <> method <> "\",\"params\":{...}}' | websocat ws://" <> T.pack host <> ":" <> T.pack (show port)
src/Synapse/Self/Examples.hs view
@@ -39,8 +39,12 @@     "'[" <> generateExampleValue ir inner <> "]'"   RefOptional inner ->     generateExampleValue ir inner-  RefAny -> "{}"+  RefJson -> "{}"   RefUnknown -> "<value>"+  RefMap _ -> "{}"+  RefTuple ts -> "'[" <> T.intercalate "," (map (generateExampleValue ir) ts) <> "]'"+  RefRefined inner _ -> generateExampleValue ir inner+  RefChild _ -> "<value>"  -- | Generate example for a named type definition generateNamedTypeExample :: IR -> TypeDef -> Text@@ -51,7 +55,7 @@     [] -> "\"value\""    -- Discriminated unions - show first variant as JSON-  KindEnum disc variants -> case variants of+  KindEnum disc variants _ -> case variants of     (v:_) -> formatVariantExample ir disc v     [] -> "{}"
src/Synapse/Transport.hs view
@@ -26,7 +26,10 @@   ) where  import Control.Monad.IO.Class (liftIO)+import Control.Monad.Except (throwError) import Data.IORef (newIORef, readIORef, modifyIORef')+import qualified Data.Map.Strict as Map+import qualified Synapse.SchemaStore as Store import Control.Monad.Reader (asks) import Data.Aeson (Value) import qualified Data.ByteString.Char8 as BS8@@ -120,8 +123,37 @@ transportErrorToCategory (PT.ConnectionLost _ _) = UnknownTransportError  -- | Fetch schema at a specific path+--+-- SYNAPSE-28: each path once a run (navigation, the deprecation check and+-- the IR all ask for the method's activation); from the cache alone when+-- the run sends first ('FromCache' — what it lacks is 'StaleSchema'), and+-- kept in the cache when it is fetched. fetchSchemaAt :: Path -> SynapseM PluginSchema fetchSchemaAt path = do+  memo <- asks seFetched+  known <- liftIO $ Map.lookup path <$> readIORef memo+  case known of+    Just schema -> pure schema+    Nothing -> do+      src <- asks seSchemaSource+      schema <- case src of+        FromCache st -> do+          cached <- liftIO $ Store.readSchema st path+          maybe (throwError (CacheMiss ("no cached schema at " <> showPath path))) pure cached+        FromServer st -> do+          schema <- fetchSchemaFromServer path+          liftIO $ mapM_ (\s -> Store.writeSchema s path schema) st+          pure schema+      liftIO $ modifyIORef' memo (Map.insert path schema)+      pure schema++-- | A path as a message names it.+showPath :: Path -> Text+showPath [] = "the root"+showPath p = T.intercalate "." p++fetchSchemaFromServer :: Path -> SynapseM PluginSchema+fetchSchemaFromServer path = do   logger <- getLogger   cfg <- getConfig   Log.logDebug logger Log.SubsystemSchema $@@ -148,7 +180,7 @@     Right schema -> pure schema  -- | Invoke a method and return stream items-invoke :: Path -> Text -> Value -> SynapseM [HubStreamItem]+invoke :: Path -> Text -> Value -> SynapseM [ServiceStreamItem] invoke namespacePath method params = do   logger <- getLogger   cfg <- getConfig@@ -187,7 +219,7 @@     getPort _ c = substratePort c  -- | Invoke with raw method path-invokeRaw :: Text -> Value -> SynapseM [HubStreamItem]+invokeRaw :: Text -> Value -> SynapseM [ServiceStreamItem] invokeRaw method params = do   cfg <- getConfig   result <- liftIO $ ST.invokeRaw cfg method params@@ -215,7 +247,7 @@     getPort _ c = substratePort c  -- | Invoke a method with streaming output - calls callback for each item-invokeStreaming :: Path -> Text -> Value -> (HubStreamItem -> IO ()) -> SynapseM ()+invokeStreaming :: Path -> Text -> Value -> (ServiceStreamItem -> IO ()) -> SynapseM () invokeStreaming namespacePath method params onItem = do   cfg <- getConfig   result <- liftIO $ ST.invokeMethodStreaming cfg namespacePath method params onItem@@ -253,7 +285,7 @@   -> Path   -> Text   -> Value-  -> (HubStreamItem -> IO ())                              -- ^ Handler for non-request items+  -> (ServiceStreamItem -> IO ())                              -- ^ Handler for non-request items   -> (Text -> PT.Request Value -> IO (Maybe (PT.Response Value)))  -- ^ Handler for bidirectional requests   -> SynapseM () invokeStreamingWithBidir shape refreshAuth onResume namespacePath method params onItem onBidirRequest = do
test/AuthSpec.hs view
@@ -5,16 +5,16 @@ -- | AUTH-8: synapse shows each caller its own server. -- -- * plexus-protocol parses AUTH-2..5's new shapes — and their absence:---   every field is optional, today's hubs answer none of it;+--   every field is optional, today's services answer none of it; -- * the renders: the anonymous page, the caller's header and the grant --   columns, the refusal block — each pinned to the ticket's transcript; -- * the loopback's request parsing and state check, and the listener --   itself on 127.0.0.1;--- * the flows end to end against 'MockHub' (a hub in miniature on a port+-- * the flows end to end against 'MockService' (a service in miniature on a port --   of its own): a person's browser sign-in, an agent's auth.login and its---   fallback to session.login on a hub without auth, whoami.+--   fallback to session.login on a service without auth, whoami. ----- @SYNAPSE_MOCK_HUB=today|anonymous|caller@ runs the mock hub instead of+-- @SYNAPSE_MOCK_SERVICE=today|anonymous|caller@ runs the mock service instead of -- the tests (it prints its port), for transcripts by hand. module Main (main) where @@ -45,15 +45,15 @@ import qualified Synapse.Identity.Session as Session import qualified Synapse.Log as Log -import MockHub+import MockService  main :: IO () main = do-  serve <- lookupEnv "SYNAPSE_MOCK_HUB"+  serve <- lookupEnv "SYNAPSE_MOCK_SERVICE"   case serve of-    Just "today" -> serveMockHub todaysHub-    Just "anonymous" -> serveMockHub (Scenario AnonymousView True False mockState False)-    Just "caller" -> serveMockHub (Scenario CallerView True False mockState False)+    Just "today" -> serveMockService todaysService+    Just "anonymous" -> serveMockService (Scenario AnonymousView True False mockState False)+    Just "caller" -> serveMockService (Scenario CallerView True False mockState False)     _ -> do       setEnv "SYNAPSE_NO_BROWSER" "1"       hspec spec@@ -314,9 +314,9 @@     it "gives up after its time" $ withLoopback $ \lb ->       awaitCallback lb "s_ok" 1 `shouldReturn` Left "no answer from the browser within 1 second" -  describe "against a hub (MockHub)" $ do+  describe "against a service (MockService)" $ do     it "a person signs in through the browser: login_url, the loopback, the code, a session" $-      withMockHub (Scenario AnonymousView True False mockState False) $ \port -> do+      withMockService (Scenario AnonymousView True False mockState False) $ \port -> do         lg <- logger         r <- Session.loginPerson lg (plainAt "127.0.0.1" port) "menger" 10 (const (pure ()))         fmap (\g -> (sgToken g, sgName g, sgPrincipal g)) r@@ -324,32 +324,32 @@         fmap (fmap renderCallerHeader . sgWhoami) r           `shouldBe` Right (Just "you are Ada Lovelace (oidc:workos/user_01M4\x2026) \x00B7 admin on *")     it "a browser that comes back with another state signs no one in" $-      withMockHub (Scenario AnonymousView True False "s_forged" False) $ \port -> do+      withMockService (Scenario AnonymousView True False "s_forged" False) $ \port -> do         lg <- logger         r <- Session.loginPerson lg (plainAt "127.0.0.1" port) "menger" 10 (const (pure ()))         either ("state" `T.isInfixOf`) (const False) r `shouldBe` True-    it "a hub with no auth activation says so for a person" $-      withMockHub todaysHub $ \port -> do+    it "a service with no auth activation says so for a person" $+      withMockService todaysService $ \port -> do         lg <- logger         r <- Session.loginPerson lg (plainAt "127.0.0.1" port) "menger" 10 (const (pure ()))         either ("no auth activation" `T.isInfixOf`) (const False) r `shouldBe` True-    it "an agent asks auth.login for a session where the hub has auth" $-      withMockHub (Scenario CallerView True False mockState False) $ \port -> do+    it "an agent asks auth.login for a session where the service has auth" $+      withMockService (Scenario CallerView True False mockState False) $ \port -> do         lg <- logger         seed <- generateSeed         r <- Session.loginWithKey lg (plainAt "127.0.0.1" port) "menger" seed "worker-1" ["editor@MENGER-12"] (Just 3600)         fmap (\l -> (Session.lrToken l, Session.lrScope l)) r `shouldBe` Right ("mgs_agent_auth", ["editor@MENGER-12"])-    it "an agent falls back to session.login on today's hub" $-      withMockHub todaysHub $ \port -> do+    it "an agent falls back to session.login on today's service" $+      withMockService todaysService $ \port -> do         lg <- logger         seed <- generateSeed         r <- Session.loginWithKey lg (plainAt "127.0.0.1" port) "menger" seed "worker-1" ["editor@MENGER-12"] Nothing         fmap (\l -> (Session.lrToken l, Session.lrScope l)) r `shouldBe` Right ("mgs_agent_session", ["editor@MENGER-12"])     it "whoami: auth.whoami where there is one, nothing where neither answers" $ do-      withMockHub (Scenario CallerView True False mockState False) $ \port -> do+      withMockService (Scenario CallerView True False mockState False) $ \port -> do         lg <- logger         Session.whoamiWith lg (plainAt "127.0.0.1" port) "menger" "mgs_x" `shouldReturn` Just worker-      withMockHub todaysHub $ \port -> do+      withMockService todaysService $ \port -> do         lg <- logger         w <- Session.whoamiWith lg (plainAt "127.0.0.1" port) "menger" "mgs_x"         isJust w `shouldBe` False
test/BidirIntegrationSpec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -8,7 +9,7 @@ -- - Methods with bidirectional flag are detected -- - Schema-driven dispatch logic ----- This test requires a running Hub backend on localhost:4444+-- This test requires a running Service backend on localhost:4444 -- with at least one method marked as bidirectional. module Main where @@ -53,9 +54,9 @@       case irResult of         Left err -> do           putStrLn $ "Failed to build IR: " <> show err-          putStrLn "Is the Hub backend running?"+          putStrLn "Is the Service backend running?"           hspec $ describe "Bidirectional Integration Tests" $-            it "connects to Hub backend" $+            it "connects to Service backend" $               expectationFailure $ "Could not connect: " <> show err          Right ir -> withArgs [] $ hspec $ bidirIntegrationSpec ir@@ -112,7 +113,7 @@       let bidirMethods = filter (isJust . mdBidirType) (Map.elems $ irMethods ir)       forM_ bidirMethods $ \method ->         case mdBidirType method of-          Just RefAny -> pure ()  -- Standard bidir with T=Value+          Just RefJson -> pure ()  -- Standard bidir with T=Value           Just other ->             -- Future: when custom bidir types are supported, this is valid             putStrLn $ "  Note: " <> T.unpack (mdFullPath method) <>@@ -145,7 +146,7 @@       forM_ bidirMethods $ \method ->         case mdBidirType method of           Nothing -> pure ()-          Just RefAny -> pure ()  -- RefAny doesn't need resolution+          Just RefJson -> pure ()  -- RefAny doesn't need resolution           Just (RefNamed qn) -> do             let typeName = qualifiedNameFull qn             case Map.lookup typeName (irTypes ir) of@@ -261,7 +262,7 @@         isJust (mdBidirType method) `shouldBe` True        it (T.unpack methodPath <> " has standard bidir type (RefAny)") $-        mdBidirType method `shouldBe` Just RefAny+        mdBidirType method `shouldSatisfy` (\case { Just RefJson -> True; _ -> False })        it (T.unpack methodPath <> " is a streaming method") $         mdStreaming method `shouldBe` True
test/CLISpec.hs view
@@ -18,7 +18,7 @@     it "substrate"            $ ["substrate"]                              `has` ["echo", "solar", "health"]     it "echo"              $ ["substrate", "echo"]                      `has` ["echo", "Echo messages back"]     it "solar"             $ ["substrate", "solar"]                     `has` ["solar", "Solar system model"]-    it "health"            $ ["substrate", "health"]                    `has` ["health", "Check hub health"]+    it "health"            $ ["substrate", "health"]                    `has` ["health", "health and uptime"]     it "solar earth"       $ ["substrate", "solar", "earth"]            `has` ["earth", "planet"]     it "solar earth luna"  $ ["substrate", "solar", "earth", "luna"]    `has` ["luna", "Moon"]
test/DeprecationSpec.hs view
@@ -67,7 +67,7 @@   , methodDeprecation    = Nothing   , methodParamSchemas   = Nothing   , methodRole           = MethodRoleRpc-  , methodLongDescription = Nothing, methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False, methodGroup = Nothing, methodExamples = []+  , methodLongDescription = Nothing, methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False, methodGroup = Nothing, methodExamples = [], methodInput = Nothing   }  deprecatedMethod :: MethodSchema
test/EndpointSpec.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} --- | SCAFFOLD-21: where a hub is reached — @--url@ and @-H@ / @-P@ with+-- | SCAFFOLD-21: where a service is reached — @--url@ and @-H@ / @-P@ with -- @--tls@ / @--path@ read into one 'Endpoint', and every key derived from -- it: the session store's (a plain address keyed exactly as before), the -- key proof's audience, the options a message tells the reader to type.@@ -75,7 +75,7 @@   describe "audience (a key proof's aud)" $ do     it "is ws://HOST:PORT for a plain address, as before" $       audience (plainAt "127.0.0.1" 4455) `shouldBe` "ws://127.0.0.1:4455"-    it "is the wss origin a hub run with --public-url https://HOST accepts — no path, no :443" $ do+    it "is the wss origin a service run with --public-url https://HOST accepts — no path, no :443" $ do       audience (Endpoint "hostdemo.menger.sh" 443 True "/ws" []) `shouldBe` "wss://hostdemo.menger.sh"       audience (Endpoint "localhost" 8443 True "/ws" []) `shouldBe` "wss://localhost:8443"
test/FindSpec.hs view
@@ -4,14 +4,14 @@ -- -- * the matcher: exact, prefix, a typo at both thresholds, a snake_case --   subsequence, every word required, and the ranking;--- * the renders, against the mock hub's catalog (menger's tickets and+-- * the renders, against the mock service's catalog (menger's tickets and --   deployments as its schema had them on 2026-10-15, test/fixtures): --   each of the ticket's examples piped (no colour codes) and on a --   terminal (the matched characters bold); -- * a caller's view: a method outside it is never a hit; -- * the IR cache: a second search costs one schema call, the hash check. ----- @SYNAPSE_MOCK_HUB=catalog|catalog-caller@ serves the catalog hub instead+-- @SYNAPSE_MOCK_SERVICE=catalog|catalog-caller@ serves the catalog service instead -- of running the tests (it prints its port), for transcripts by hand. module Main (main) where @@ -35,15 +35,15 @@ import qualified Synapse.Log as Log import Synapse.Monad (initEnv, runSynapseM, withViewKey) -import MockHub+import MockService  main :: IO () main = do-  serve <- lookupEnv "SYNAPSE_MOCK_HUB"+  serve <- lookupEnv "SYNAPSE_MOCK_SERVICE"   dump <- lookupEnv "SYNAPSE_FIND_DUMP"   case (serve, dump) of-    (Just "catalog", _) -> serveMockHub (catalogHub NoView)-    (Just "catalog-caller", _) -> serveMockHub (catalogHub CallerView)+    (Just "catalog", _) -> serveMockService (catalogService NoView)+    (Just "catalog-caller", _) -> serveMockService (catalogService CallerView)     (_, Just _) -> dumpAll     _ -> hspec spec @@ -51,9 +51,9 @@ -- Fixtures -- ============================================================================ --- | The catalog as a view of the mock hub has it (no cache).+-- | The catalog as a view of the mock service has it (no cache). catalog :: ViewMode -> IO IR-catalog v = withMockHub (catalogHub v) $ \port -> do+catalog v = withMockService (catalogService v) $ \port -> do   logger <- Log.makeLogger Katip.ErrorS   env0 <- initEnv "127.0.0.1" port "menger" logger Nothing   let env = withViewKey (if v == CallerView then Just "v-9a77" else Nothing) env0@@ -105,6 +105,7 @@   , mdReturns = RefUnknown, mdBidirType = Nothing, mdBidirResponseType = Nothing   , mdBidirResponseSchema = Nothing, mdRole = MethodRoleRpc   , mdGrant = Nothing, mdTarget = Nothing, mdLongDescription = Nothing+  , mdInjected = [], mdInput = Nothing   }  synthetic :: IR@@ -178,7 +179,7 @@     it "summarize does not stop inside a quote" $       summarize "Run `a. b` then stop. More" `shouldBe` "Run `a. b` then stop" -  describe "the pages, piped and on a terminal (the mock hub's catalog)" $ do+  describe "the pages, piped and on a terminal (the mock service's catalog)" $ do     mapM_ (\(typed, file, fo, boldBit) -> do       it ("_find menger " <> typed <> ", piped: as pinned, no colour codes") $ do         ir <- catalog NoView@@ -233,15 +234,17 @@       exists <- doesDirectoryExist dir       if exists then removeDirectoryRecursive dir else pure ()       cache <- newIRCache (CacheConfig True 100 True dir)-      withMockHub (catalogHub NoView) $ \port -> do+      withMockService (catalogService NoView) $ \port -> do         logger <- Log.makeLogger Katip.ErrorS         env <- initEnv "127.0.0.1" port "menger" logger Nothing         before <- readIORef schemaCalls         Right first <- runSynapseM env (loadCatalog (Just cache))         middle <- readIORef schemaCalls-        -- a fresh cache on the same directory: from disk, as the next process reads it+        -- a fresh cache on the same directory: from disk, as the next process+        -- reads it (SYNAPSE-28: and a fresh env — a run fetches each path once)         cache' <- newIRCache (CacheConfig True 100 True dir)-        Right second <- runSynapseM env (loadCatalog (Just cache'))+        env' <- initEnv "127.0.0.1" port "menger" logger Nothing+        Right second <- runSynapseM env' (loadCatalog (Just cache'))         after <- readIORef schemaCalls         (middle - before) `shouldSatisfy` (>= 3)         (after - middle) `shouldBe` 1
+ test/HoldSpec.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | SYNAPSE-28: a call costs one round trip and the server's time.+--+-- * The multiplexer: every call of a process on one connection, in+--   sequence and twenty at once; a stream it abandons is unsubscribed.+-- * The holder: runs hand it their requests; however many, the service sees+--   one connection; a run that goes away mid-stream ends its call; the+--   holder exits when idle and removes its socket.+-- * The CLI, end to end against the mock service (the built synapse, with a+--   home, a cache and a runtime directory of the test's own): a cold call+--   answers and fills the cache, on one connection; a warm call opens no+--   connection, probes nothing and fetches no schema; @--no-hold@ opens+--   exactly one; a method the service renamed falls back to the probe and the+--   fetch, then answers; a method the service no longer has is refused after+--   the fallback, as it always was.+module Main (main) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.Async (mapConcurrently, async, cancel)+import Control.Exception (SomeException, try, fromException)+import Control.Monad (forM_, replicateM_, void)+import Data.Maybe (isJust)+import Data.Aeson (Value(..))+import qualified Data.Aeson.KeyMap as KM+import Data.IORef+import qualified Data.Text as T+import System.Directory (doesFileExist, createDirectoryIfMissing, findExecutable)+import System.Environment (getEnvironment)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (CreateProcess(..), proc, readCreateProcessWithExitCode)+import Test.Hspec++import Plexus.Client (SubstrateConfig(..), LostConnection(..), defaultConfig)+import Plexus.Types (PlexusStreamItem(..))+import qualified Synapse.Hold as Hold++import MockService++main :: IO ()+main = hspec $ do+  describe "the multiplexer" $ do+    it "carries every call of a process on one connection, in sequence and twenty at once" $+      withMockService todaysService $ \port -> do+        before <- readIORef connectionsAccepted+        mux <- Hold.newMux+        let cfg = serviceAt port+        replicateM_ 5 $ do+          items <- collect (Hold.muxCall mux cfg) "menger.call" (getTicket "MENGER-12")+          items `shouldSatisfy` any isTicket+        rs <- mapConcurrently (\_ -> collect (Hold.muxCall mux cfg) "menger.call" (getTicket "MENGER-12")) [1 .. 20 :: Int]+        all (any isTicket) rs `shouldBe` True+        after <- readIORef connectionsAccepted+        (after - before) `shouldBe` 1+        Hold.muxConnections mux `shouldReturn` 1++    it "asks a schema once however many wait for it, and gives each the answer" $+      withMockService todaysService $ \port -> do+        mux <- Hold.newMux+        s0 <- readIORef schemaCalls+        rs <- mapConcurrently (\_ -> collect (Hold.muxCall mux (serviceAt port)) "menger.call"+                (Object (KM.fromList [("method", String "tickets.schema")]))) [1 .. 20 :: Int]+        s1 <- readIORef schemaCalls+        (s1 - s0) `shouldSatisfy` (< 20)+        all (== head rs) rs `shouldBe` True+        all (any isSchema) rs `shouldBe` True++    it "unsubscribes a stream it abandons" $+      withMockService todaysService $ \port -> do+        writeIORef unsubscribes []+        mux <- Hold.newMux+        got <- newEmptyFlag+        a <- async $ Hold.muxCall mux (serviceAt port) (pure ()) "menger.call" (watch) (\_ -> setFlag got)+        waitFlag got+        cancel a+        threadDelay 200000+        us <- readIORef unsubscribes+        length us `shouldBe` 1++  describe "the holder" $ do+    it "serves many runs' requests on one connection" $+      withSystemTempDirectory "hold" $ \dir -> withMockService todaysService $ \port -> do+        let sock = dir </> "h.sock"+        _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 30) `catchAll` const (pure ())+        waitFor (doesFileExist sock)+        before <- readIORef connectionsAccepted+        let call = collect (Hold.holderCall sock (serviceAt port)) "menger.call" (getTicket "MENGER-12")+        replicateM_ 3 (call >>= (`shouldSatisfy` any isTicket))+        rs <- mapConcurrently (const call) [1 .. 20 :: Int]+        all (any isTicket) rs `shouldBe` True+        after <- readIORef connectionsAccepted+        (after - before) `shouldBe` 1++    it "relays each item as the service sent it, and the end" $+      withSystemTempDirectory "hold" $ \dir -> withMockService todaysService $ \port -> do+        let sock = dir </> "h.sock"+        _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 30) `catchAll` const (pure ())+        waitFor (doesFileExist sock)+        direct <- Hold.newMux+        viaMux <- collect (Hold.muxCall direct (serviceAt port)) "menger.call" (getTicket "MENGER-12")+        viaHolder <- collect (Hold.holderCall sock (serviceAt port)) "menger.call" (getTicket "MENGER-12")+        viaHolder `shouldBe` viaMux++    it "ends the call of a run that goes away mid-stream" $+      withSystemTempDirectory "hold" $ \dir -> withMockService todaysService $ \port -> do+        writeIORef unsubscribes []+        let sock = dir </> "h.sock"+        _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 30) `catchAll` const (pure ())+        waitFor (doesFileExist sock)+        got <- newEmptyFlag+        a <- async $ Hold.holderCall sock (serviceAt port) (pure ()) "menger.call" watch (\_ -> setFlag got)+        waitFlag got+        cancel a+        waitFor ((== 1) . length <$> readIORef unsubscribes)++    it "says a dial it could not make as connect does, so the run reads an outage" $+      withSystemTempDirectory "hold" $ \dir -> do+        let sock = dir </> "h.sock"+        _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 30) `catchAll` const (pure ())+        waitFor (doesFileExist sock)+        r <- try (collect (Hold.holderCall sock (serviceAt 1)) "menger.call" (getTicket "X"))+        case r of+          Left (e :: SomeException) -> do+            show e `shouldContain` "Connection failed"+            (fromException e :: Maybe LostConnection) `shouldSatisfy` (\x -> case x of { Nothing -> True; Just _ -> False })+          Right _ -> expectationFailure "a call to a closed port answered"++    it "carries a bidirectional request and its answer" $+      withSystemTempDirectory "hold" $ \dir -> withMockService todaysService $ \port -> do+        let sock = dir </> "h.sock"+        _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 30) `catchAll` const (pure ())+        waitFor (doesFileExist sock)+        answered <- newIORef Nothing+        let onItem i = case i of+              StreamRequest {} -> void $ collect (Hold.holderCall sock (serviceAt port)) "menger.respond"+                (Object (KM.fromList [ ("request_id", String "req-1")+                                     , ("response_data", Object (KM.fromList [("type", String "confirmed"), ("value", Bool True)])) ]))+              StreamData _ _ "tickets.ask" v -> writeIORef answered (Just v)+              _ -> pure ()+        Hold.holderCall sock (serviceAt port) (pure ()) "menger.call" (Object (KM.fromList [("method", String "tickets.ask")])) onItem+        readIORef answered >>= (`shouldSatisfy` isJust)++    it "exits when idle, and takes its socket with it" $+      withSystemTempDirectory "hold" $ \dir -> do+        let sock = dir </> "h.sock"+        _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 1) `catchAll` const (pure ())+        waitFor (doesFileExist sock)+        waitFor (not <$> doesFileExist sock)++  describe "a socket per address and agent" $ do+    it "names the address, the agent and the version" $ do+      p <- Hold.socketPathFor "3.17.1" "wss_app.menger.sh_443_ws" "builder"+      p `shouldContain` "wss_app.menger.sh_443_ws@builder-3.17.1.sock"+      q <- Hold.socketPathFor "3.17.1" "wss_app.menger.sh_443_ws" "pipeline"+      q `shouldNotBe` p+    it "stays short enough for a unix socket" $ do+      p <- Hold.socketPathFor "3.17.1" (replicate 120 'h') "builder"+      length p `shouldSatisfy` (< 108)++  describe "the CLI, sending first" $ do+    synapse <- runIO (findExecutable "synapse")+    case synapse of+      Nothing -> it "(the synapse executable is not on PATH)" $ pendingWith "cabal test puts it there"+      Just exe -> cliSpec exe++cliSpec :: FilePath -> Spec+cliSpec exe = do+  it "is this build" $ do+    (_, out, _) <- readCreateProcessWithExitCode (proc exe ["--version"]) ""+    out `shouldStartWith` "3.17"++  it "answers cold, fills the cache, and opens one connection for the probe, the schema and the call" $+    withRun $ \run _ -> do+      c0 <- readIORef connectionsAccepted+      (code, out, err) <- run ["tickets", "get", "--id", "MENGER-12"]+      (code, err) `shouldBe` (ExitSuccess, "")+      out `shouldContain` "MENGER-12"+      c1 <- readIORef connectionsAccepted+      (c1 - c0) `shouldBe` 1++  it "answers warm with no new connection, no probe and no schema fetch" $+    withRun $ \run _ -> do+      _ <- run ["tickets", "get", "--id", "MENGER-12"]+      c0 <- readIORef connectionsAccepted+      i0 <- readIORef infoCalls+      s0 <- readIORef schemaCalls+      forM_ [1 .. 3 :: Int] $ \_ -> do+        (code, out, _) <- run ["tickets", "get", "--id", "MENGER-12"]+        code `shouldBe` ExitSuccess+        out `shouldContain` "MENGER-12"+      c1 <- readIORef connectionsAccepted+      i1 <- readIORef infoCalls+      s1 <- readIORef schemaCalls+      (c1 - c0, i1 - i0, s1 - s0) `shouldBe` (0, 0, 0)++  it "with --no-hold, opens exactly one connection a run" $+    withRun $ \run runWith -> do+      _ <- run ["tickets", "get", "--id", "MENGER-12"]+      c0 <- readIORef connectionsAccepted+      (code, out, _) <- runWith ["--no-hold"] ["tickets", "get", "--id", "MENGER-12"]+      code `shouldBe` ExitSuccess+      out `shouldContain` "MENGER-12"+      c1 <- readIORef connectionsAccepted+      (c1 - c0) `shouldBe` 1++  it "falls back to the probe and the fetch for a method the service renamed, then answers" $+    withRun $ \run _ -> do+      _ <- run ["tickets", "get", "--id", "MENGER-12"]+      writeIORef renamedGet True+      s0 <- readIORef schemaCalls+      (code, out, err) <- run ["tickets", "fetch", "--id", "MENGER-12"]+      writeIORef renamedGet False+      (code, err) `shouldBe` (ExitSuccess, "")+      out `shouldContain` "MENGER-12"+      s1 <- readIORef schemaCalls+      (s1 - s0) `shouldSatisfy` (> 0)++  it "asks the server when it refuses a method the cache still has, and says it is gone" $+    withRun $ \run _ -> do+      _ <- run ["tickets", "get", "--id", "MENGER-12"]+      writeIORef renamedGet True+      (code, out, err) <- run ["tickets", "get", "--id", "MENGER-12"]+      writeIORef renamedGet False+      code `shouldBe` ExitFailure 1+      err `shouldContain` "Command not found: 'get'"+      out `shouldNotContain` "Method not found"+      -- and the call after it is warm again, for what the service has now+      writeIORef renamedGet True+      (code', out', _) <- run ["tickets", "fetch", "--id", "MENGER-12"]+      writeIORef renamedGet False+      code' `shouldBe` ExitSuccess+      out' `shouldContain` "MENGER-12"+  it "says a refusal once and exits 77, asking nothing more (a write is never sent twice for it)" $+    withRunOn (Scenario CallerView False True mockState False) $ \run _ -> do+      _ <- run ["tickets", "get", "--id", "MENGER-12"]+      (code0, _, _) <- run ["tickets", "set_status", "--id", "IDENTITY-1"]+      code0 `shouldBe` ExitFailure 77+      s0 <- readIORef schemaCalls+      i0 <- readIORef infoCalls+      (code, _, err) <- run ["tickets", "set_status", "--id", "IDENTITY-1"]+      code `shouldBe` ExitFailure 77+      err `shouldContain` "refused: needs tickets.set_status on IDENTITY"+      s1 <- readIORef schemaCalls+      i1 <- readIORef infoCalls+      (s1 - s0, i1 - i0) `shouldBe` (0, 0)+  where+    withRun = withRunOn todaysService+    -- a run of the built synapse against a fresh mock service, with a home,+    -- cache and runtime directory of its own (no keychain, a short hold)+    withRunOn sc act = withSystemTempDirectory "synapse28" $ \dir -> withMockService sc $ \port -> do+      forM_ ["home", "cache", "run"] $ \d -> createDirectoryIfMissing True (dir </> d)+      env0 <- getEnvironment+      let env = [ (k, v) | (k, v) <- env0, k `notElem` ["HOME", "XDG_CACHE_HOME", "XDG_RUNTIME_DIR", "SYNAPSE_AS", "PLEXUS_SESSION"] ]+              ++ [ ("HOME", dir </> "home"), ("XDG_CACHE_HOME", dir </> "cache"), ("XDG_RUNTIME_DIR", dir </> "run")+                 , ("PLEXUS_KEYCHAIN", "off"), ("SYNAPSE_HOLD_FOR", "3s") ]+          run' extra args = readCreateProcessWithExitCode+            (proc exe (extra ++ ["--url", "ws://127.0.0.1:" <> show port <> "/ws", "menger"] ++ args)) { env = Just env } ""+      writeIORef renamedGet False+      act (run' []) run'++-- ---------------------------------------------------------------------------++serviceAt :: Int -> SubstrateConfig+serviceAt port = (defaultConfig "menger") { substratePort = port, substratePath = "/ws" }++getTicket :: T.Text -> Value+getTicket i = Object (KM.fromList [("method", String "tickets.get"), ("params", Object (KM.fromList [("id", String i)]))])++watch :: Value+watch = Object (KM.fromList [("method", String "tickets.watch")])++collect :: (IO () -> T.Text -> Value -> (PlexusStreamItem -> IO ()) -> IO ()) -> T.Text -> Value -> IO [PlexusStreamItem]+collect route method params = do+  acc <- newIORef []+  route (pure ()) method params (\i -> modifyIORef' acc (i :))+  reverse <$> readIORef acc++isSchema :: PlexusStreamItem -> Bool+isSchema (StreamData _ _ "tickets.schema" _) = True+isSchema _ = False++isTicket :: PlexusStreamItem -> Bool+isTicket (StreamData _ _ "tickets.get" _) = True+isTicket _ = False++catchAll :: IO a -> (SomeException -> IO a) -> IO a+catchAll act h = try act >>= either h pure++waitFor :: IO Bool -> IO ()+waitFor cond = go (100 :: Int)+  where+    go 0 = expectationFailure "timed out waiting"+    go n = cond >>= \ok -> if ok then pure () else threadDelay 50000 >> go (n - 1)++newtype Flag = Flag (IORef Bool)++newEmptyFlag :: IO Flag+newEmptyFlag = Flag <$> newIORef False++setFlag :: Flag -> IO ()+setFlag (Flag r) = writeIORef r True++waitFlag :: Flag -> IO ()+waitFlag (Flag r) = waitFor (readIORef r)
test/IR12MethodRoleSpec.hs view
@@ -16,7 +16,7 @@ -- --   * A synthesised 'MethodDef' whose 'mdRole' is 'MethodRoleDynamicChild' --     round-trips through JSON and emits the exact @kind@/@list_method@---     shape consumed by hub-codegen (whose Rust @MethodRole@ enum uses+--     shape consumed by service-codegen (whose Rust @MethodRole@ enum uses --     @#[serde(tag = \"kind\", rename_all = \"snake_case\")]@). module Main where @@ -48,7 +48,7 @@   , mdDescription         = Just "Fetch a planet child by name."   , mdStreaming           = False   , mdParams              = []-  , mdReturns             = RefAny+  , mdReturns             = RefJson   , mdBidirType           = Nothing   , mdBidirResponseType   = Nothing   , mdBidirResponseSchema = Nothing@@ -56,6 +56,8 @@   , mdGrant               = Nothing   , mdTarget              = Nothing   , mdLongDescription     = Nothing+  , mdInjected            = []+  , mdInput               = Nothing   }  -- | Build a JSON @MethodSchema@ with an optional @role@ key. Passing@@ -171,12 +173,12 @@         Right md -> mdRole md `shouldBe` mdRole original      it "pre-IR-12 MethodDef JSON (no mdRole) decodes with default Rpc" $ do-      -- Matches hub-codegen's Rust-side #[serde(default)] posture.+      -- Matches service-codegen's Rust-side #[serde(default)] posture.       case eitherDecode (encode preIrMethodDefJson) :: Either String MethodDef of         Left e -> expectationFailure $ "decode failed: " <> e         Right md -> mdRole md `shouldBe` MethodRoleRpc -  -- AUTH-9: what a method requires reaches hub-codegen through the IR.+  -- AUTH-9: what a method requires reaches service-codegen through the IR.   describe "AUTH-9: grant, target, long_description and roles in the IR" $ do     let schemaWith extra = object $           [ "name" .= ("set_status" :: String)
+ test/IRCoverageSpec.hs view
@@ -0,0 +1,512 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}++-- | SYNAPSE-CC-8 (IR 2.1): every schema read whole, or refused by name.+--+-- One fixture per evidence row (test/fixtures/ir-coverage; make-fixtures.py+-- writes them, menger's types copied verbatim from its 2026-10-29 schemas),+-- then menger's 2026-10-29 schemas whole: exactly the 21 refusals of the+-- walk, the IR equal to its golden, every construct IR 2.0 already typed+-- serialized as before; and the built synapse's @-i@ against a service+-- with a bare object: the IR on stdout, the site on stderr, exit 65.+module Main where++import Control.Monad (forM_, unless, when)+import qualified Codec.Compression.GZip as GZ+import Data.Aeson (Value(..), eitherDecode, encode, toJSON)+import qualified Data.Aeson as Aeson+import Data.Aeson.Encode.Pretty (Config(..), defConfig, encodePretty')+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.IORef (writeIORef)+import Data.List (isInfixOf, sort)+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable)+import System.Environment (getEnvironment, lookupEnv)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (CreateProcess(..), proc, readCreateProcessWithExitCode)+import Test.Hspec++import Synapse.IR.Types+import Synapse.SchemaStore (Plan(..), Store(..), readPlan, writePlan)+import Plexus.Schema.Recursive (MethodSchema(..))++import IRFixture+import MockService++main :: IO ()+main = hspec $ do+  describe "unions read whole" $ do+    it "a oneOf of an enum and consts is one string enum, in schema order" $ do+      ir <- irOf "transition-field.json" ["tickets"]+      kindOf ir "tickets.TransitionField" `shouldBe` Just (KindStringEnum ["status", "kind", "archive"])+      irRefusals ir `shouldBe` []+      ir' <- irOf "answer-source.json" ["tickets"]+      kindOf ir' "tickets.AnswerSource" `shouldBe` Just (KindStringEnum ["app", "api", "system"])+      irRefusals ir' `shouldBe` []++    it "a union tagged kind: six variants, the tag out of their fields, rationale optional" $ do+      ir <- irOf "reply.json" ["tickets"]+      irRefusals ir `shouldBe` []+      case kindOf ir "tickets.Reply" of+        Just (KindEnum disc vs Internal) -> do+          disc `shouldBe` "kind"+          map vdName vs `shouldBe` ["answered", "changes_requested", "commented", "unqueued", "ended", "archived"]+          let answered = head vs+          sort (map fdName (vdFields answered)) `shouldBe` sort ["input", "value", "source", "at_unix", "rationale"]+          [ fdRequired f | f <- vdFields answered, fdName f == "rationale" ] `shouldBe` [False]+          [ fdRequired f | f <- vdFields answered, fdName f == "input" ] `shouldBe` [True]+          [ fdType f | f <- vdFields answered, fdName f == "at_unix" ] `shouldBe` [RefPrimitive "integer" (Just "int64")]+        other -> expectationFailure ("Reply: " <> show other)++    it "a union tagged event" $ do+      ir <- irOf "hash-event.json" ["tickets"]+      irRefusals ir `shouldBe` []+      case kindOf ir "tickets.HashEvent" of+        Just (KindEnum "event" [v] Internal) -> do+          vdName v `shouldBe` "hash"+          map fdName (vdFields v) `shouldBe` ["value"]+        other -> expectationFailure ("HashEvent: " <> show other)++    it "an externally tagged union: browser, code, password, session" $ do+      ir <- irOf "login-flow.json" ["auth"]+      irRefusals ir `shouldBe` []+      case kindOf ir "auth.LoginFlow" of+        Just (KindEnum "" vs External) -> do+          map vdName vs `shouldBe` ["browser", "code", "password", "session"]+          let session = last vs+          [ fdType f | f <- vdFields session, fdName f == "ttl_secs" ]+            `shouldBe` [RefOptional (RefPrimitive "integer" (Just "uint64"))]+          [ (fdName f, fdRequired f) | f <- vdFields (head vs) ] `shouldBe` [("redirect", True)]+        other -> expectationFailure ("LoginFlow: " <> show other)+      -- its JSON says external, and IR 2.0's internal enums say nothing+      encode (toJSON (KindEnum "" [] External)) `shouldSatisfy` (contains "\"keRepr\":\"external\"")+      encode (toJSON (KindEnum "type" [] Internal)) `shouldNotSatisfy` (contains "keRepr")++    it "an untagged union of refs: each variant names its type in vdRef" $ do+      ir <- irOf "schema-result.json" ["tickets"]+      irRefusals ir `shouldBe` []+      kindOf ir "tickets.SchemaResult" `shouldBe` Just (KindEnum ""+        [ VariantDef "PluginSchema" Nothing [] (Just (named "tickets" "PluginSchema"))+        , VariantDef "MethodSchema" Nothing [] (Just (named "tickets" "MethodSchema")) ] Untagged)+      mdReturns <$> method ir "tickets.schema" `shouldBe` Just (named "tickets" "SchemaResult")++    it "an unreadable union is refused: the type left out, its use RefUnknown" $ do+      ir <- irOf "unreadable-oneof.json" ["tickets"]+      map (\r -> (rfSite r, rfKeyword r, rfVariant r)) (irRefusals ir) `shouldBe` [("tickets.Weird", "oneOf", Just 1)]+      kindOf ir "tickets.Weird" `shouldBe` Nothing+      fieldType ir "tickets.TicketsEvent" "got" "w" `shouldBe` Just RefUnknown++  describe "methods" $ do+    it "a child's return is RefChild, with no refusal" $ do+      ir <- irOf "static-child.json" ["tickets"]+      mdReturns <$> method ir "tickets.inputs" `shouldBe` Just (RefChild "tickets.inputs")+      irRefusals ir `shouldBe` []++    it "an rpc method with no returns is refused" $ do+      ir <- irOf "no-returns.json" ["x"]+      irRefusals ir `shouldBe` [Refusal "x.schema returns" "returns" Nothing "an rpc method with no returns schema"]+      mdReturns <$> method ir "x.schema" `shouldBe` Just RefUnknown++    it "a struct root is a type, and no RefNamed dangles" $ do+      ir <- irOf "hashes.json" ["tickets"]+      irRefusals ir `shouldBe` []+      kindOf ir "tickets.PluginHashes" `shouldSatisfy` \case { Just (KindStruct _) -> True; _ -> False }+      mdReturns <$> method ir "tickets.hashes" `shouldBe` Just (named "tickets" "PluginHashes")++    it "injected params leave mdParams for mdInjected, their source verbatim" $ do+      ir <- irOf "injected.json" ["tickets"]+      let Just md = method ir "tickets.get"+      map pdName (mdParams md) `shouldBe` ["ticket"]+      mdInjected md `shouldBe`+        [ InjectedParam "auth" (obj [("from", "derived")]) Nothing+        , InjectedParam "user" (obj [("from", "auth"), ("resolver", "self.access.verify")]) Nothing ]+      irRefusals ir `shouldBe` []++    it "mdInput: the schema's input as a type; absent, no key" $ do+      ir <- irOf "input.json" ["tickets"]+      mdInput <$> method ir "tickets.chat" `shouldBe` Just (Just (named "tickets" "Token"))+      mdInput <$> method ir "tickets.plain" `shouldBe` Just Nothing+      let Just plain = method ir "tickets.plain"+      encode plain `shouldNotSatisfy` (contains "mdInput")+      encode plain `shouldNotSatisfy` (contains "mdInjected")+      kindOf ir "tickets.Token" `shouldSatisfy` isJust+      -- plexus-protocol reads it, and writes it back only when present+      let Right ms = Aeson.eitherDecode "{\"name\":\"chat\",\"input\":{\"type\":\"string\"}}" :: Either String MethodSchema+      methodInput ms `shouldBe` Just (obj [("type", "string")])+      encode ms `shouldSatisfy` (contains "\"input\"")+      let Right bare = Aeson.eitherDecode "{\"name\":\"plain\"}" :: Either String MethodSchema+      encode bare `shouldNotSatisfy` (contains "\"input\"")++  describe "the JSON type (a serde_json::Value)" $ do+    it "is RefJson, however the schema spells it" $ do+      ir <- irOf "json.json" ["tickets"]+      irRefusals ir `shouldBe` []+      forM_ ["six", "described", "empty", "yes", "byref"] $ \f ->+        structField ir "tickets.Envelope" f `shouldBe` Just RefJson+      structField ir "tickets.Envelope" "list" `shouldBe` Just (RefArray RefJson)+      structField ir "tickets.Envelope" "map" `shouldBe` Just (RefMap RefJson)+      fieldType ir "tickets.TicketsEvent" "got" "value" `shouldBe` Just RefJson+      -- the definition named Json is the JSON type, not a type of the namespace+      kindOf ir "tickets.Json" `shouldBe` Nothing+      encode RefJson `shouldBe` "{\"tag\":\"RefJson\"}"++    it "what is not: a bare object, a bare array, a type list that is neither one type nor JSON" $ do+      ir <- irOf "untyped.json" ["tickets"]+      map (\r -> (rfSite r, rfKeyword r)) (irRefusals ir) `shouldBe`+        [("tickets.Thing.bare", "type"), ("tickets.Thing.list[]", "items"), ("tickets.Thing.mixed", "type")]+      structField ir "tickets.Thing" "bare" `shouldBe` Just RefUnknown+      structField ir "tickets.Thing" "list" `shouldBe` Just (RefArray RefUnknown)++  describe "maps, tuples, bounds" $ do+    it "a map, and an optional map" $ do+      ir <- irOf "theme-map.json" ["themes"]+      irRefusals ir `shouldBe` []+      structField ir "themes.Theme" "light" `shouldBe` Just (RefMap (RefPrimitive "string" Nothing))+      structField ir "themes.Theme" "dark" `shouldBe` Just (RefMap (RefPrimitive "string" Nothing))+      param ir "themes.define" "light" `shouldBe` Just (RefOptional (RefMap (named "themes" "TokenValue")))+      param ir "themes.define" "dark" `shouldBe` Just (RefOptional (RefMap (named "themes" "TokenValue")))++    it "a tuple" $ do+      ir <- irOf "component-preview.json" ["tickets"]+      irRefusals ir `shouldBe` []+      structField ir "tickets.Component" "preview" `shouldBe`+        Just (RefArray (RefTuple [RefPrimitive "string" Nothing, RefPrimitive "string" Nothing]))++    it "implied bounds carry nothing; others are refined" $ do+      ir <- irOf "bounds.json" ["tickets"]+      irRefusals ir `shouldBe` []+      structField ir "tickets.Bounds" "a" `shouldBe` Just (RefPrimitive "integer" (Just "uint64"))+      structField ir "tickets.Bounds" "b" `shouldBe` Just (RefPrimitive "integer" (Just "uint16"))+      structField ir "tickets.Bounds" "c" `shouldBe` Just (RefRefined (RefPrimitive "integer" (Just "uint64")) noRefinements { rnMinimum = Just 1 })+      structField ir "tickets.Bounds" "d" `shouldBe` Just (RefRefined (RefPrimitive "string" Nothing) noRefinements { rnMaxLength = Just 64 })+      structField ir "tickets.Bounds" "e" `shouldBe` Just (RefOptional (RefPrimitive "integer" (Just "uint32")))++    it "an unknown keyword is refused by name" $ do+      ir <- irOf "allof.json" ["tickets"]+      map (\r -> (rfSite r, rfKeyword r)) (irRefusals ir) `shouldBe` [("tickets.Both", "allOf")]+      kindOf ir "tickets.Both" `shouldBe` Nothing+      ir' <- irOf "multipleof.json" ["tickets"]+      map (\r -> (rfSite r, rfKeyword r)) (irRefusals ir') `shouldBe` [("tickets.Even.n", "multipleOf")]++    it "a variant's field keeps its default" $ do+      ir <- irOf "variant-default.json" ["tickets"]+      case kindOf ir "tickets.TicketsEvent" of+        Just (KindEnum "type" (v : _) Internal) ->+          [ (fdDefault f, fdRequired f) | f <- vdFields v, fdName f == "limit" ] `shouldBe` [(Just (Number 1000), False)]+        other -> expectationFailure (show other)++  describe "placement" $ do+    it "a shared type goes where it is referred to most; a tie to the ancestor, then the shortest; never the root" $ do+      ir <- irOf "shared.json" []+      irRefusals ir `shouldBe` []+      let has = (`Map.member` irTypes ir)+      filter has ["notes.TicketRef", "tickets.TicketRef"] `shouldBe` ["tickets.TicketRef"]+      filter has ["chats.Tied", "tickets.Tied"] `shouldBe` ["chats.Tied"]+      filter has ["tickets.Anc", "tickets.inputs.Anc"] `shouldBe` ["tickets.Anc"]+      filter has [".Shared", "tickets.Shared"] `shouldBe` ["tickets.Shared"]+      -- every use follows its type+      fieldType ir "notes.NotesEvent" "e" "r0" `shouldBe` Just (named "tickets" "TicketRef")+      fieldType ir ".PingEvent" "e" "r0" `shouldBe` Just (named "tickets" "Shared")++  describe "every fixture" $+    it "names only types it defines, and is RefUnknown only where a refusal is" $+      forM_ smallFixtures $ \(file, path) -> do+        ir <- irOf file path+        danglingRefs ir `shouldBe` []+        -- a type the reader refused is left out, and its uses say RefUnknown+        let refused = Set.fromList (map rfSite (irRefusals ir))+            typesLeftOut = [ r | r <- Set.toList refused, not (Map.member r (irTypes ir)), not (T.any (`elem` (" (" :: String)) r) ]+        [ s | s <- unknownSites ir, not (Set.member s refused), null typesLeftOut ] `shouldBe` []++  describe "menger, 2026-10-29, whole" $ do+    it "is refused at exactly the walk's 21 sites; the root's carriers are the JSON type" $ do+      ir <- mengerIR+      map (\r -> (rfSite r, rfKeyword r)) (irRefusals ir) `shouldBe` expectedMengerRefusals+      sort (unknownSites ir) `shouldBe` sort (map fst expectedMengerRefusals)+      danglingRefs ir `shouldBe` []+      param ir ".call" "params" `shouldBe` Just RefJson+      fieldType ir ".PlexusStreamItem" "data" "content" `shouldBe` Just RefJson+      fieldType ir ".PlexusStreamItem" "request" "requestData" `shouldBe` Just RefJson++    it "types the 7 enums, the 4 maps, the tuple and .PluginHashes" $ do+      ir <- mengerIR+      forM_ ["HashEvent", "LoginFlow", "AnswerSource", "InputAction", "ThemeLevel", "Reply", "TransitionField"] $ \n ->+        case [ tdKind td | td <- Map.elems (irTypes ir), tdName td == n ] of+          [KindEnum _ vs _] -> vs `shouldNotBe` []+          [KindStringEnum vs] -> vs `shouldNotBe` []+          other -> expectationFailure (T.unpack n <> ": " <> show other)+      structField ir "themes.Theme" "light" `shouldBe` Just (RefMap (RefPrimitive "string" Nothing))+      structField ir "themes.Theme" "dark" `shouldBe` Just (RefMap (RefPrimitive "string" Nothing))+      [ () | Just (RefOptional (RefMap _)) <- [param ir "themes.define" "light", param ir "themes.define" "dark"] ] `shouldBe` [(), ()]+      [ fdType f | td <- Map.elems (irTypes ir), tdName td == "Component", KindStruct fs <- [tdKind td], f <- fs, fdName f == "preview" ]+        `shouldBe` [RefArray (RefTuple [RefPrimitive "string" Nothing, RefPrimitive "string" Nothing])]+      kindOf ir ".PluginHashes" `shouldSatisfy` isJust+      -- no injected param is a param any more: 88 auth, 88 user+      length [ () | md <- Map.elems (irMethods ir), ip <- mdInjected md ] `shouldBe` 176+      [ pdName p | md <- Map.elems (irMethods ir), p <- mdParams md, pdName p `elem` ["auth", "user"] ] `shouldBe` []++    it "equals its golden (menger-2026-10-29.ir-2.1.json)" $ do+      ir <- mengerIR+      let golden = fixtures </> "menger-2026-10-29.ir-2.1.json"+          bytes = encodePretty' defConfig { confCompare = compare } ir { irMetadata = Nothing }+      write <- lookupEnv "IR_GOLDEN_WRITE"+      exists <- doesFileExist golden+      when (write == Just "1" || not exists) $ BL.writeFile golden (bytes <> "\n")+      expected <- BL.readFile golden+      (bytes <> "\n") `shouldBe` expected++    it "serializes every construct IR 2.0 already typed as before" $ do+      ir <- mengerIR+      Right old <- eitherDecode . GZ.decompress <$> BL.readFile (fixtures </> "menger-2026-10-29.ir-2.0.json.gz") :: IO (Either String Value)+      let Object o = old+          Just (Object oldTypes) = KM.lookup "irTypes" o+          Just (Object oldMethods) = KM.lookup "irMethods" o+          newTypes = Map.map toJSON (irTypes ir)+          byLocal = Map.fromListWith (++) [ (tdName td, [toJSON td]) | td <- Map.elems (irTypes ir) ]+      -- types: the same JSON, refs' namespaces aside (placement moves them),+      -- variant fields' fdRequired / fdDefault aside (2.1 reads them); a+      -- type placement moved keeps the moved-to copy's namespace and doc+      let typeMismatches =+            [ "type " <> T.unpack key <> " changed:\n  old " <> show (norm v) <> "\n  new " <> show (map norm candidates)+            | (k, v) <- KM.toList oldTypes, not (changedIn20 v)+            , let key = K.toText k+                  local = T.takeWhileEnd (/= '.') key+                  candidates = case Map.lookup key newTypes of+                    Just n -> [n]+                    Nothing -> Map.findWithDefault [] local byLocal+                  same n = case Map.lookup key newTypes of+                    Just _ -> norm n == norm v+                    Nothing -> moved n == moved v+            , not (any same candidates) ]+          moved = norm . dropKeys ["tdNamespace", "tdDescription"]+      -- methods: the same JSON but for the keys 2.1 adds and the injected params it moves+          methodMismatches =+            [ "method " <> T.unpack key <> ":\n  old " <> show old' <> "\n  new " <> show new'+            | (k, v) <- KM.toList oldMethods+            , let key = K.toText k+                  old' = norm (dropInjected v)+                  new' = maybe Null (norm . dropKeys ["mdInjected", "mdInput"] . toJSON) (Map.lookup key (irMethods ir))+            , not (changedIn20 (dropInjected v)), old' /= new' ]+      mapM_ putStrLn (take 5 (typeMismatches ++ methodMismatches))+      (length typeMismatches, length methodMismatches) `shouldBe` (0, 0)+      -- and the guard is not vacuous: most of 2.0 was typed+      length [ () | (_, v) <- KM.toList oldTypes, not (changedIn20 v) ] `shouldSatisfy` (> 150)+      length [ () | (_, v) <- KM.toList oldMethods, not (changedIn20 (dropInjected v)) ] `shouldSatisfy` (> 100)++  describe "caches another synapse wrote" $+    it "a plan whose IR is 2.0 (3.16.0's) is read as no plan" $+      withSystemTempDirectory "cc8-store" $ \dir -> do+        let st = Store dir+            Right ms = Aeson.eitherDecode "{\"name\":\"get\"}" :: Either String MethodSchema+            plan v = Plan ms ["tickets", "get"] Nothing (Just emptyIR { irVersion = v })+        createDirectoryIfMissing True (dir </> "plans")+        writePlan st ["tickets", "get"] (plan "2.0")+        readPlan st ["tickets", "get"] `shouldReturn` Nothing+        writePlan st ["tickets", "get"] (plan currentIrVersion)+        fmap plPath <$> readPlan st ["tickets", "get"] `shouldReturn` Just ["tickets", "get"]++  describe "synapse -i" $ do+    exe <- runIO builtSynapse+    case exe of+      Nothing -> it "against a service with a bare object" $ pendingWith "the built synapse is not on PATH (cabal test puts it there)"+      Just bin -> it "against a service with a bare object: the IR on stdout, the site on stderr, exit 65" $ do+        rows <- loadSchemasValues (fixtures </> "untyped.json")+        let root = Object (KM.fromList+              [ ("namespace", String "menger"), ("version", String "1.0.0"), ("description", String "root")+              , ("hash", String "r-cc8"), ("methods", Array mempty)+              , ("children", toJSON [ Object (KM.fromList [("namespace", String "tickets"), ("description", String "t"), ("hash", String "t-cc8")]) ]) ])+        writeIORef schemaOverride (Just (("", root) : rows))+        withSystemTempDirectory "cc8-cli" $ \dir -> withMockService todaysService $ \port -> do+          forM_ ["home", "cache", "run"] $ \d -> createDirectoryIfMissing True (dir </> d)+          env0 <- getEnvironment+          let env = [ (k, v) | (k, v) <- env0, k `notElem` ["HOME", "XDG_CACHE_HOME", "XDG_RUNTIME_DIR", "SYNAPSE_AS", "PLEXUS_SESSION"] ]+                 ++ [ ("HOME", dir </> "home"), ("XDG_CACHE_HOME", dir </> "cache"), ("XDG_RUNTIME_DIR", dir </> "run")+                    , ("PLEXUS_KEYCHAIN", "off"), ("SYNAPSE_HOLD_FOR", "3s") ]+          (code, out, err) <- readCreateProcessWithExitCode+            (proc bin ["--url", "ws://127.0.0.1:" <> show port <> "/ws", "-i", "menger"]) { env = Just env } ""+          writeIORef schemaOverride Nothing+          code `shouldBe` ExitFailure 65+          err `shouldSatisfy` ("tickets.Thing.bare" `isInfixOf`)+          err `shouldSatisfy` ("neither properties nor additionalProperties" `isInfixOf`)+          case eitherDecode (BL.pack out) :: Either String IR of+            Left e -> expectationFailure ("stdout is not an IR: " <> e <> "\n" <> take 400 out)+            Right ir -> map rfSite (irRefusals ir) `shouldBe` ["tickets.Thing.bare", "tickets.Thing.list[]", "tickets.Thing.mixed"]++-- ---------------------------------------------------------------------------++fixtures :: FilePath+fixtures = "test/fixtures/ir-coverage"++irOf :: FilePath -> [Text] -> IO IR+irOf file = fixtureIR (fixtures </> file)++mengerIR :: IO IR+mengerIR = fixtureIR menger20261029 []++smallFixtures :: [(FilePath, [Text])]+smallFixtures =+  [ ("transition-field.json", ["tickets"]), ("answer-source.json", ["tickets"]), ("reply.json", ["tickets"])+  , ("hash-event.json", ["tickets"]), ("login-flow.json", ["auth"]), ("schema-result.json", ["tickets"])+  , ("unreadable-oneof.json", ["tickets"]), ("static-child.json", ["tickets"]), ("no-returns.json", ["x"])+  , ("hashes.json", ["tickets"]), ("injected.json", ["tickets"])+  , ("untyped.json", ["tickets"]), ("json.json", ["tickets"]), ("theme-map.json", ["themes"])+  , ("component-preview.json", ["tickets"]), ("bounds.json", ["tickets"]), ("allof.json", ["tickets"])+  , ("multipleof.json", ["tickets"]), ("variant-default.json", ["tickets"]), ("input.json", ["tickets"])+  , ("shared.json", []) ]++-- | The walk's 21 (SYNAPSE-CC-8, the owner's JSON type of 2026-10-29): the+--   21 schema methods' returns. The protocol root's three untyped values+--   are the JSON type now, not refusals.+expectedMengerRefusals :: [(Text, Text)]+expectedMengerRefusals = sort $+  [ (ns <> ".schema returns", "returns")+  | ns <- [ "", "auth", "chats", "chats.inputs", "comments", "deployments", "epics", "media", "members", "notes"+          , "orgs", "session", "themes", "tickets", "tickets.commits", "tickets.components", "tickets.filters"+          , "tickets.inputs", "tickets.nav", "tickets.revisions", "tickets.work" ] ]++named :: Text -> Text -> TypeRef+named ns n = RefNamed (QualifiedName ns n)++obj :: [(Text, Text)] -> Value+obj kvs = Object (KM.fromList [ (K.fromText k, String v) | (k, v) <- kvs ])++kindOf :: IR -> Text -> Maybe TypeKind+kindOf ir n = tdKind <$> Map.lookup n (irTypes ir)++method :: IR -> Text -> Maybe MethodDef+method ir p = Map.lookup p (irMethods ir)++param :: IR -> Text -> Text -> Maybe TypeRef+param ir m p = case method ir m of+  Just md -> case [ pdType x | x <- mdParams md, pdName x == p ] of+    (t : _) -> Just t+    [] -> Nothing+  Nothing -> Nothing++structField :: IR -> Text -> Text -> Maybe TypeRef+structField ir t f = case kindOf ir t of+  Just (KindStruct fs) -> case [ fdType x | x <- fs, fdName x == f ] of+    (ty : _) -> Just ty+    [] -> Nothing+  _ -> Nothing++fieldType :: IR -> Text -> Text -> Text -> Maybe TypeRef+fieldType ir t v f = case kindOf ir t of+  Just (KindEnum _ vs _) -> case [ fdType x | var <- vs, vdName var == v, x <- vdFields var, fdName x == f ] of+    (ty : _) -> Just ty+    [] -> Nothing+  _ -> Nothing++-- | Every ref of the IR, at its site.+refsWithSites :: IR -> [(Text, TypeRef)]+refsWithSites ir = concatMap methodRefs (Map.elems (irMethods ir)) ++ concatMap typeRefs (Map.toList (irTypes ir))+  where+    methodRefs md =+      [ (mdFullPath md <> "(" <> pdName p <> ")", pdType p) | p <- mdParams md ]+      ++ [ (mdFullPath md <> " returns", mdReturns md) ]+      ++ [ (mdFullPath md <> " input", t) | Just t <- [mdInput md] ]+    typeRefs (n, td) = case tdKind td of+      KindStruct fs -> [ (n <> "." <> fdName f, fdType f) | f <- fs ]+      KindEnum _ vs _ -> [ (n <> "." <> vdName v <> "." <> fdName f, fdType f) | v <- vs, f <- vdFields v ]+                      ++ [ (n <> "." <> vdName v, t) | v <- vs, Just t <- [vdRef v] ]+      KindAlias t -> [(n, t)]+      _ -> []++-- | The sites of every RefUnknown, at any depth.+unknownSites :: IR -> [Text]+unknownSites ir = concatMap (uncurry go) (refsWithSites ir)+  where+    go site = \case+      RefUnknown -> [site]+      RefArray t -> go (site <> "[]") t+      RefOptional t -> go (site <> "?") t+      RefMap t -> go (site <> "{}") t+      RefRefined t _ -> go site t+      RefTuple ts -> concat (zipWith (\i t -> go (site <> "." <> T.pack (show i)) t) [0 :: Int ..] ts)+      _ -> []++-- | Every RefNamed that names no type.+danglingRefs :: IR -> [Text]+danglingRefs ir = [ full | (_, t) <- refsWithSites ir, full <- names t, not (Map.member full (irTypes ir)) ]+  where+    names = \case+      RefNamed qn -> [qnNamespace qn <> "." <> qnLocalName qn]+      t -> concatMap names (typeRefChildren t)++-- | A fixture's schemas as JSON, by dotted path (for the mock service).+loadSchemasValues :: FilePath -> IO [(Text, Value)]+loadSchemasValues file = do+  Right rows <- eitherDecode <$> BL.readFile file :: IO (Either String [Value])+  pure [ (T.intercalate "." p, s) | Object r <- rows, Just pv <- [KM.lookup "path" r], Aeson.Success p <- [Aeson.fromJSON pv], Just s <- [KM.lookup "schema" r] ]++-- | The synapse this suite was built with: cabal test puts it on PATH; one+--   from elsewhere (an installed one) is not it.+builtSynapse :: IO (Maybe FilePath)+builtSynapse = do+  found <- findExecutable "synapse"+  pure $ case found of+    Just p | "dist-newstyle" `isInfixOf` p -> Just p+    _ -> Nothing++-- | A construct IR 2.0 did not type (and 2.1 now does, or refuses): an+--   empty enum, a RefAny, a RefUnknown, an untyped object or array.+changedIn20 :: Value -> Bool+changedIn20 = \case+  Object o+    | KM.lookup "tag" o `elem` [Just "RefAny", Just "RefUnknown"] -> True+    | KM.lookup "tag" o == Just "RefPrimitive"+    , Just (Array a) <- KM.lookup "contents" o, (String t : _) <- foldr (:) [] a, t `elem` ["object", "array"] -> True+    | KM.lookup "tag" o == Just "KindEnum", Just (Array vs) <- KM.lookup "keVariants" o, null vs -> True+    | KM.lookup "tag" o == Just "KindStringEnum", Just (Array vs) <- KM.lookup "kseValues" o, null vs -> True+    | KM.lookup "tag" o == Just "KindPrimitive", KM.lookup "kpType" o == Just "any" -> True+    | otherwise -> any changedIn20 (KM.elems o)+  Array a -> any changedIn20 a+  _ -> False++-- | JSON with every ref's namespace blanked, and the fields of variants+--   without fdRequired / fdDefault.+norm :: Value -> Value+norm = \case+  Object o+    | Just (String "RefNamed") <- KM.lookup "tag" o -> Object (adjustKM blankNs "contents" o)+    | Just (Array vs) <- KM.lookup "keVariants" o -> Object (KM.map norm (KM.insert "keVariants" (Array (fmap variant vs)) o))+    | otherwise -> Object (KM.map norm o)+  Array a -> Array (fmap norm a)+  v -> v+  where+    blankNs (Object q) = Object (KM.insert "qnNamespace" (String "") q)+    blankNs v = v+    variant (Object v) = Object (adjustKM (\case { Array fs -> Array (fmap (dropKeys ["fdRequired", "fdDefault"]) fs); x -> x }) "vdFields" v)+    variant v = v++dropKeys :: [Text] -> Value -> Value+dropKeys ks (Object o) = Object (foldr (KM.delete . K.fromText) o ks)+dropKeys _ v = v++-- | A 2.0 method without the params 2.1 moves to mdInjected.+dropInjected :: Value -> Value+dropInjected (Object o) = Object (adjustKM keep "mdParams" o)+  where+    keep (Array ps) = Array (fmap id (foldr (\p acc -> if injected p then acc else p `consV` acc) mempty ps))+    keep v = v+    consV x xs = pure x <> xs+    injected (Object p) = case KM.lookup "pdSource" p of+      Just (Object s) -> KM.lookup "from" s /= Just "rpc"+      _ -> False+    injected _ = False+dropInjected v = v++-- | A JSON encoding holds this text.+contains :: String -> BL.ByteString -> Bool+contains needle hay = needle `isInfixOf` BL.unpack hay++adjustKM :: (Value -> Value) -> K.Key -> KM.KeyMap Value -> KM.KeyMap Value+adjustKM f k o = maybe o (\v -> KM.insert k (f v) o) (KM.lookup k o)
+ test/IRFixture.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}++-- | SYNAPSE-CC-8: menger's activation schemas of 2026-10-29, offline.+--+-- @test/fixtures/ir-coverage/menger-2026-10-29.schemas.jsonl.gz@ holds the+-- root and its 20 activations, one line each: @{"path": [...], "schema":+-- <PluginSchema>}@, as @<ns>.schema@ answered on app.menger.sh. They are+-- handed to the IR builder through the run's schema memo ('seFetched'), so+-- 'buildIR' walks them with no network: the builder alone.+module IRFixture+  ( menger20261029+  , loadSchemas+  , envWithSchemas+  , buildFixtureIR+  , fixtureIR+  ) where++import qualified Codec.Compression.GZip as GZ+import Data.Aeson (FromJSON(..), eitherDecode, withObject, (.:))+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.IORef (writeIORef)+import Data.List (isSuffixOf)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Katip++import Synapse.IR.Builder (buildIR)+import Synapse.IR.Types (IR)+import qualified Synapse.Log as Log+import Synapse.Monad+import Synapse.Schema.Types (Path, PluginSchema)++menger20261029 :: FilePath+menger20261029 = "test/fixtures/ir-coverage/menger-2026-10-29.schemas.jsonl.gz"++data Row = Row Path PluginSchema++instance FromJSON Row where+  parseJSON = withObject "Row" $ \o -> Row <$> o .: "path" <*> o .: "schema"++-- | Every schema of a fixture, by path: a @.jsonl.gz@ one row a line+--   (gunzipped), a @.json@ an array of rows.+loadSchemas :: FilePath -> IO [(Path, PluginSchema)]+loadSchemas file = do+  raw <- BL.readFile file+  if ".json" `isSuffixOf` file+    then case eitherDecode raw of+      Right rows -> pure [ (p, s) | Row p s <- rows ]+      Left e -> fail ("IRFixture: " <> file <> ": " <> e)+    else do+      let body = if ".gz" `isSuffixOf` file then GZ.decompress raw else raw+      mapM row (filter (not . BL.null) (BL.lines body))+  where+    row l = case eitherDecode l of+      Right (Row p s) -> pure (p, s)+      Left e -> fail ("IRFixture: " <> file <> ": " <> e)++-- | An environment whose schemas are these, already fetched.+envWithSchemas :: Text -> [(Path, PluginSchema)] -> IO SynapseEnv+envWithSchemas backend schemas = do+  logger <- Log.makeLogger Katip.ErrorS+  env <- initEnv "127.0.0.1" 1 backend logger Nothing+  writeIORef (seFetched env) (Map.fromList schemas)+  pure env++-- | The IR of the tree under a path, built from the memo alone.+buildFixtureIR :: SynapseEnv -> Path -> IO IR+buildFixtureIR env path = runSynapseM env (buildIR [] path) >>= either (fail . show) pure++-- | The IR of a fixture file, built from the tree under a path.+fixtureIR :: FilePath -> Path -> IO IR+fixtureIR file path = do+  schemas <- loadSchemas file+  env <- envWithSchemas "menger" schemas+  buildFixtureIR env path
test/IRSpec.hs view
@@ -56,9 +56,9 @@   case irResult of     Left err -> do       putStrLn $ "Failed to build IR: " <> show err-      putStrLn "Is the Hub backend running?"+      putStrLn "Is the Service backend running?"       withArgs [] $ hspec $ describe "IR Integration Tests" $-        it "connects to Hub backend" $+        it "connects to Service backend" $           expectationFailure $ "Could not connect: " <> show err      Right ir -> withArgs [] $ hspec $ irSpec ir@@ -232,8 +232,8 @@   RefArray inner -> checkTypeRefResolves ir methodPath paramName inner   RefOptional inner -> checkTypeRefResolves ir methodPath paramName inner   RefPrimitive _ _ -> pure ()-  RefAny -> pure ()   RefUnknown -> pure ()  -- Unknown is valid (just means schema gap)+  _ -> pure ()  -- | Check that no RefNamed references are unresolved checkNoUnresolvedRefs :: IR -> TypeRef -> Bool@@ -242,8 +242,8 @@   RefArray inner -> checkNoUnresolvedRefs ir inner   RefOptional inner -> checkNoUnresolvedRefs ir inner   RefPrimitive _ _ -> True-  RefAny -> True   RefUnknown -> True+  _ -> True  -- | Get list of unresolved RefNamed names getUnresolvedRefs :: IR -> TypeRef -> [Text]@@ -256,5 +256,5 @@   RefArray inner -> getUnresolvedRefs ir inner   RefOptional inner -> getUnresolvedRefs ir inner   RefPrimitive _ _ -> []-  RefAny -> []   RefUnknown -> []+  _ -> []
− test/MockHub.hs 
@@ -1,320 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | AUTH-8: a Plexus hub in miniature, speaking the wire synapse speaks--- (JSON-RPC over a WebSocket; @_info@, @<backend>.call@, subscription--- notifications ending in @done@), answering AUTH-2..5's shapes as the--- tickets write them. It listens on 127.0.0.1, a port the OS picks.------ A 'Scenario' says which hub it is: today's (no view, no auth activation),--- an anonymous caller's, or a signed-in caller's. The person flow's--- browser is played by the hub itself: answering @auth.login {flow:--- {browser: {redirect}}}@ it also, a moment later, sends the GET the--- provider's redirect would — to @redirect?code=…&state=…@.-module MockHub-  ( Scenario(..)-  , ViewMode(..)-  , todaysHub-  , withMockHub-  , serveMockHub-  , mockCode-  , mockState-  , catalogHub-  , schemaCalls-  ) where--import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, tryPutMVar, tryTakeMVar)-import System.Timeout (timeout)-import Control.Exception (SomeException, bracket, try)-import Control.Monad (forever, void)-import Data.Aeson-import qualified Data.Aeson.Key as K-import qualified Data.Aeson.KeyMap as KM-import qualified Data.ByteString.Char8 as BS8-import Data.IORef-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Network.Socket as N-import qualified Network.Socket.ByteString as NB-import qualified Network.WebSockets as WS-import qualified Data.Vector as V-import System.IO (hFlush, stdout)-import System.IO.Unsafe (unsafePerformIO)--data ViewMode = NoView | AnonymousView | CallerView-  deriving (Eq, Show)--data Scenario = Scenario-  { scView          :: ViewMode-  , scAuth          :: Bool   -- ^ has the auth activation (auth.login, auth.whoami, …)-  , scSessionLogin  :: Bool   -- ^ has IDENTITY-42's session.login (today's menger)-  , scBrowserState  :: Text   -- ^ the state the browser comes back with (mockState: the right one)-  , scCatalog       :: Bool   -- ^ SYNAPSE-17: serve menger's tickets and deployments as they were (test/fixtures)-  } deriving (Eq, Show)--todaysHub :: Scenario-todaysHub = Scenario NoView False True mockState False---- | SYNAPSE-17: a hub with a catalog to search — menger's tickets (17 of--- its methods) and deployments (3), as its schema had them on 2026-10-15;--- in a caller's view, tickets.delete (admin only) is not in it.-catalogHub :: ViewMode -> Scenario-catalogHub v = Scenario v False False mockState True---- | How many schema calls the mock hubs have answered (this process).-{-# NOINLINE schemaCalls #-}-schemaCalls :: IORef Int-schemaCalls = unsafePerformIO (newIORef 0)--mockCode, mockState :: Text-mockCode = "c_19ab"-mockState = "s_7f2c"---- | Run an action against a hub on a fresh port; the port is passed in.-withMockHub :: Scenario -> (Int -> IO a) -> IO a-withMockHub sc act = bracket open (N.close . fst) (\(_, port) -> act port)-  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 16-      port <- fromIntegral <$> N.socketPort sock-      void $ forkIO $ acceptLoop sc sock-      pure (sock, port)---- | Serve until killed, printing the port (for transcripts by hand).-serveMockHub :: Scenario -> IO ()-serveMockHub sc = withMockHub sc $ \port -> do-  putStrLn (show port)-  hFlush stdout-  forever (threadDelay 1000000)--acceptLoop :: Scenario -> N.Socket -> IO ()-acceptLoop sc sock = do-  r <- try (N.accept sock)-  case r of-    Left (_ :: SomeException) -> pure ()   -- the hub was closed-    Right (conn, _) -> do-      void $ forkIO $ do-        _ <- try (session conn) :: IO (Either SomeException ())-        N.close conn-      acceptLoop sc sock-  where-    session conn = do-      pending <- WS.makePendingConnection conn WS.defaultConnectionOptions-      -- the credential the upgrade carried, if any-      let bearer = lookup "Authorization" (WS.requestHeaders (WS.pendingRequest pending))-      c <- WS.acceptRequest pending-      next <- newIORef (100 :: Int)-      forever $ do-        msg <- WS.receiveData c-        case decode msg of-          Just (Object o) -> handle sc c next (isBearer bearer) o-          _ -> pure ()-    isBearer = maybe False (BS8.isPrefixOf "Bearer ")--handle :: Scenario -> WS.Connection -> IORef Int -> Bool -> Object -> IO ()-handle sc c next signedIn o = do-  let rid = KM.lookup "id" o-      method = str "method" o-      params = case KM.lookup "params" o of { Just (Object p) -> p; _ -> KM.empty }-  sub <- atomicModifyIORef' next (\n -> (n + 1, n))-  send (object ["jsonrpc" .= ("2.0" :: Text), "id" .= rid, "result" .= sub])-  let emit item = send (object-        [ "jsonrpc" .= ("2.0" :: Text), "method" .= ("subscription" :: Text)-        , "params" .= object ["subscription" .= sub, "result" .= item] ])-      meta = object ["provenance" .= (["menger"] :: [Text]), "plexus_hash" .= ("h0" :: Text), "timestamp" .= (0 :: Int)]-      dat :: Text -> Value -> IO ()-      dat ct v = emit (object ["type" .= ("data" :: Text), "metadata" .= meta, "content_type" .= ct, "content" .= v])-      err :: Text -> [(K.Key, Value)] -> IO ()-      err m extra = emit (Object (KM.fromList (-        [("type", "error"), ("metadata", meta), ("message", String m), ("recoverable", Bool False)] <> extra)))-      done = emit (object ["type" .= ("done" :: Text), "metadata" .= meta])-  case method of-    "_info" -> do-      dat "_info" (infoFor sc)-      done-    "menger.call" -> do-      let inner = str "method" params-          args = case KM.lookup "params" params of { Just (Object a) -> a; _ -> KM.empty }-      if inner == "tickets.ask"-        then askBack emit meta dat err-        else callMethod sc signedIn inner args dat err-      done-    -- SCAFFOLD-21: a bidirectional answer, on a connection of its own-    "menger.respond" -> do-      void (tryPutMVar responses (KM.lookup "response_data" params))-      done-    _ -> err ("Invalid method format: " <> method) [] >> done-  where-    send :: Value -> IO ()-    send = WS.sendTextData c . encode---- | SCAFFOLD-21: the answers to 'askBack's requests (@menger.respond@'s--- @response_data@), as they arrive on any connection.-{-# NOINLINE responses #-}-responses :: MVar (Maybe Value)-responses = unsafePerformIO newEmptyMVar---- | A bidirectional method (@tickets.ask@): it asks the caller to confirm--- (a @request@ item), waits up to 5 s for @menger.respond@, and answers--- with what came back.-askBack :: (Value -> IO ()) -> Value -> (Text -> Value -> IO ()) -> (Text -> [(K.Key, Value)] -> IO ()) -> IO ()-askBack emit meta dat err = do-  _ <- tryTakeMVar responses-  emit (object-    [ "type" .= ("request" :: Text), "metadata" .= meta, "request_id" .= ("req-1" :: Text)-    , "request" .= object ["type" .= ("confirm" :: Text), "message" .= ("go on?" :: Text)] ])-  got <- timeout 5000000 (takeMVar responses)-  case got of-    Just (Just r) -> dat "tickets.ask" (object ["type" .= ("answered" :: Text), "response" .= r])-    _ -> err "no response to req-1" []--infoFor :: Scenario -> Value-infoFor sc = case scView sc of-  NoView -> object ["backend" .= ("menger" :: Text), "auth_capabilities" .= object ["mechanisms" .= [object ["kind" .= ("anonymous" :: Text)]]]]-  AnonymousView -> object-    [ "backend" .= ("menger" :: Text), "view" .= ("anonymous" :: Text)-    , "auth" .= object-        [ "methods" .= (["auth.providers", "auth.login", "auth.signup"] :: [Text])-        , "resource_metadata" .= ("http://127.0.0.1:4456/.well-known/oauth-protected-resource" :: Text) ] ]-  CallerView -> object ["backend" .= ("menger" :: Text), "view" .= ("caller" :: Text), "view_hash" .= ("v-9a77" :: Text)]--callMethod :: Scenario -> Bool -> Text -> Object-           -> (Text -> Value -> IO ()) -> (Text -> [(K.Key, Value)] -> IO ()) -> IO ()-callMethod sc _signedIn inner args dat err = do- if ".schema" `T.isSuffixOf` inner then atomicModifyIORef' schemaCalls (\n -> (n + 1, ())) else pure ()- case inner of-  "menger.schema" -> dat "menger.schema" (rootSchema sc)-  "tickets.schema" | scCatalog sc -> do-      Just (Object o) <- decodeFileStrict "test/fixtures/find-tickets.json"-      dat "tickets.schema" (Object (catalogView sc o))-  "deployments.schema" | scCatalog sc -> do-      Just v <- decodeFileStrict "test/fixtures/find-deployments.json"-      dat "deployments.schema" (v :: Value)-  "auth.schema" | scAuth sc -> dat "auth.schema" authSchema-  "tickets.schema" | scView sc /= AnonymousView -> dat "tickets.schema" (ticketsSchema sc)-  "auth.whoami" | scAuth sc -> dat "auth.whoami" (object-      [ "type" .= ("whoami" :: Text), "principal" .= ("key:ac79e0f3b1c24d5e6f708192a3b4c5d6e7f8091a2b3c4d5e6f708192a3b4c5d6" :: Text)-      , "name" .= ("worker-1" :: Text), "agent" .= ("worker-1" :: Text)-      , "memberships" .= [object ["role" .= ("editor" :: Text), "scope" .= ("MENGER" :: Text)]]-      , "ceiling" .= (["editor@MENGER-12"] :: [Text]) ])-  "tickets.get" -> dat "tickets.get" (object ["type" .= ("ticket" :: Text), "id" .= ("MENGER-12" :: Text)])-  "tickets.set_status"-    | scView sc == CallerView -> err "needs tickets.set_status on IDENTITY"-        [ ("error_kind", "forbidden"), ("grant", "tickets.set_status"), ("scope", "IDENTITY")-        , ("roles", toJSON (["editor", "admin"] :: [Text])), ("held_on", toJSON (["MENGER"] :: [Text])) ]-    | otherwise -> dat "tickets.set_status" (object ["type" .= ("status_changed" :: Text)])-  "auth.login" | scAuth sc -> case KM.lookup "flow" args of-      Just (Object f)-        | Just (Object b) <- KM.lookup "browser" f -> do-            let redirect = str "redirect" b-            dat "auth.login" (object-              [ "type" .= ("login_url" :: Text)-              , "url" .= ("http://127.0.0.1:4456/login?cli=1&state=" <> mockState)-              , "state" .= mockState ])-            -- the provider's redirect, a moment later-            void $ forkIO $ threadDelay 300000 >> browserReturns redirect (scBrowserState sc)-        | Just (Object cd) <- KM.lookup "code" f ->-            if str "code" cd == mockCode && str "state" cd == mockState-              then dat "auth.login" (object-                [ "type" .= ("session" :: Text), "token" .= ("mgs_person" :: Text)-                , "principal" .= ("oidc:workos/user_01M4QXZ7ABCDEF" :: Text), "name" .= ("Ada Lovelace" :: Text)-                , "expires_at" .= (1791663600 :: Int)-                , "memberships" .= [object ["role" .= ("admin" :: Text), "scope" .= ("*" :: Text)]] ])-              else err "the code is not good for this state" []-        | Just (Object s) <- KM.lookup "session" f -> dat "auth.login" (object-            [ "type" .= ("session" :: Text), "token" .= ("mgs_agent_auth" :: Text)-            , "principal" .= ("key:79b5" :: Text), "agent" .= ("worker-1" :: Text)-            , "expires_at" .= (1791663600 :: Int)-            , "ceiling" .= maybe (toJSON ([] :: [Text])) id (KM.lookup "ceiling" s) ])-      _ -> err "auth.login: no flow" []-  "session.login" | scSessionLogin sc -> dat "session.login" (object-      [ "type" .= ("login" :: Text), "token" .= ("mgs_agent_session" :: Text)-      , "principal" .= ("key:79b5" :: Text), "agent" .= ("worker-1" :: Text)-      , "expires_at" .= (1791663600 :: Int)-      , "scope" .= maybe (toJSON ([] :: [Text])) id (KM.lookup "scope" args) ])-  other -> err ("Activation not found: " <> T.takeWhile (/= '.') other) []---- | The browser coming back to synapse's loopback, as the provider's--- redirect sends it.-browserReturns :: Text -> Text -> IO ()-browserReturns redirect state = do-  let rest = maybe redirect id (T.stripPrefix "http://127.0.0.1:" redirect)-      (portT, path) = T.breakOn "/" rest-      port = read (T.unpack portT) :: Int-  sock <- N.socket N.AF_INET N.Stream N.defaultProtocol-  N.connect sock (N.SockAddrInet (fromIntegral port) (N.tupleToHostAddress (127, 0, 0, 1)))-  -- a favicon first, as browsers do: the loopback must not take it for an answer-  NB.sendAll sock "GET /favicon.ico HTTP/1.1\r\nHost: 127.0.0.1\r\n\r\n"-  _ <- NB.recv sock 4096-  N.close sock-  sock' <- N.socket N.AF_INET N.Stream N.defaultProtocol-  N.connect sock' (N.SockAddrInet (fromIntegral port) (N.tupleToHostAddress (127, 0, 0, 1)))-  NB.sendAll sock' $ TE.encodeUtf8 $-    "GET " <> path <> "?code=" <> mockCode <> "&state=" <> state <> " HTTP/1.1\r\nHost: 127.0.0.1\r\n\r\n"-  _ <- NB.recv sock' 4096-  N.close sock'--rootSchema :: Scenario -> Value-rootSchema sc = object $-  [ "namespace" .= ("menger" :: Text), "version" .= ("1.0.0" :: Text)-  , "description" .= ("Central routing and introspection" :: Text)-  , "hash" .= (case scView sc of { AnonymousView -> "v-anon-3c1f"; CallerView | scCatalog sc -> "rc-v9a77"; _ | scCatalog sc -> "rc0"; _ -> "r0" } :: Text)-  , "children" .= children ]-  where-    children = case scView sc of-      _ | scCatalog sc ->-        [ object ["namespace" .= ("tickets" :: Text), "description" .= ("Plans as data" :: Text), "hash" .= ("t0" :: Text)]-        , object ["namespace" .= ("deployments" :: Text), "description" .= ("Deployments" :: Text), "hash" .= ("d0" :: Text)] ]-      AnonymousView -> [object ["namespace" .= ("auth" :: Text), "methods" .= [-        object ["name" .= ("providers" :: Text), "public" .= True],-        object ["name" .= ("login" :: Text), "public" .= True],-        object ["name" .= ("signup" :: Text), "public" .= True]]]]-      _ -> [ object ["namespace" .= ("tickets" :: Text), "description" .= ("Plans as data" :: Text), "hash" .= ("t0" :: Text)] ]-        <> [ object ["namespace" .= ("auth" :: Text), "description" .= ("Sign in, who am I, what does this need" :: Text), "hash" .= ("a0" :: Text)] | scAuth sc ]--authSchema :: Value-authSchema = object-  [ "namespace" .= ("auth" :: Text), "version" .= ("0.1.0" :: Text), "hash" .= ("a0" :: Text)-  , "description" .= ("Sign in, who am I, what does this need" :: Text)-  , "methods" .= [ m "providers" "The ways in this server offers"-                 , m "login" "Sign in \x2014 a person through the browser, an agent with its key"-                 , m "signup" "Create an account, or ask for access" ] ]-  where m n d = object ["name" .= (n :: Text), "description" .= (d :: Text), "hash" .= (n <> "0"), "public" .= True]--ticketsSchema :: Scenario -> Value-ticketsSchema sc = object $-  [ "namespace" .= ("tickets" :: Text), "version" .= ("0.5.0" :: Text), "hash" .= ("t0" :: Text)-  , "description" .= ("Plans as data" :: Text)-  , "methods" .= map method-      [ ("get", "One ticket by id", ["MENGER"], Just "id")-      , ("list", "Tickets, filtered and paged", ["MENGER"], Nothing)-      , ("set_status", "Change a ticket's status", ["MENGER-12"], Just "id") ] ]-  <> [ "view" .= ("caller" :: Text) | caller ]-  where-    caller = scView sc == CallerView-    method (n, d, held, target) = object $-      [ "name" .= (n :: Text), "description" .= (d :: Text), "hash" .= (n <> "0")-      , "params" .= object ["type" .= ("object" :: Text), "required" .= (["id"] :: [Text]),-          "properties" .= object ["id" .= object ["type" .= ("string" :: Text), "description" .= ("Ticket id, e.g. MNG-2" :: Text)]]] ]-      <> (if caller then [ "grant" .= ("tickets." <> n), "held_on" .= (held :: [Text]) ] <> maybe [] (\t -> ["target" .= (t :: Text)]) target else [])---- | The tickets schema as the caller's view shows it: without what only an--- admin holds (tickets.delete).-catalogView :: Scenario -> Object -> Object-catalogView sc o-  | scView sc /= CallerView = o-  | otherwise = KM.insert "view" (String "caller") (maybe o (\ms -> KM.insert "methods" (dropDelete ms) o) (KM.lookup "methods" o))-  where-    dropDelete (Array ms) = Array (V.filter (\case { Object m -> KM.lookup "name" m /= Just (String "delete"); _ -> True }) ms)-    dropDelete v = v--str :: Text -> Object -> Text-str k o = case KM.lookup (K.fromText k) o of-  Just (String s) -> s-  _ -> ""
+ test/MockService.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | AUTH-8: a Plexus service in miniature, speaking the wire synapse speaks+-- (JSON-RPC over a WebSocket; @_info@, @<backend>.call@, subscription+-- notifications ending in @done@), answering AUTH-2..5's shapes as the+-- tickets write them. It listens on 127.0.0.1, a port the OS picks.+--+-- A 'Scenario' says which service it is: today's (no view, no auth activation),+-- an anonymous caller's, or a signed-in caller's. The person flow's+-- browser is played by the service itself: answering @auth.login {flow:+-- {browser: {redirect}}}@ it also, a moment later, sends the GET the+-- provider's redirect would — to @redirect?code=…&state=…@.+module MockService+  ( Scenario(..)+  , ViewMode(..)+  , todaysService+  , withMockService+  , serveMockService+  , mockCode+  , mockState+  , catalogService+  , schemaCalls+    -- * SYNAPSE-28: what a run cost the service+  , connectionsAccepted+  , infoCalls+  , unsubscribes+  , renamedGet+    -- * SYNAPSE-CC-8: a service serving schemas a test gives it+  , schemaOverride+    -- * SYNAPSE-26: what a closed stdout cost the service+  , callsMade+  , floodsEnded+  , dropNext+  ) where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, tryPutMVar, tryTakeMVar)+import System.Timeout (timeout)+import Control.Exception (SomeException, bracket, try)+import Control.Monad (forever, void)+import Data.Aeson+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as KM+import qualified Data.ByteString.Char8 as BS8+import Data.IORef+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Network.Socket as N+import qualified Network.Socket.ByteString as NB+import qualified Network.WebSockets as WS+import qualified Data.Vector as V+import System.IO (hFlush, stdout)+import System.IO.Unsafe (unsafePerformIO)++data ViewMode = NoView | AnonymousView | CallerView+  deriving (Eq, Show)++data Scenario = Scenario+  { scView          :: ViewMode+  , scAuth          :: Bool   -- ^ has the auth activation (auth.login, auth.whoami, …)+  , scSessionLogin  :: Bool   -- ^ has IDENTITY-42's session.login (today's menger)+  , scBrowserState  :: Text   -- ^ the state the browser comes back with (mockState: the right one)+  , scCatalog       :: Bool   -- ^ SYNAPSE-17: serve menger's tickets and deployments as they were (test/fixtures)+  } deriving (Eq, Show)++todaysService :: Scenario+todaysService = Scenario NoView False True mockState False++-- | SYNAPSE-17: a service with a catalog to search — menger's tickets (17 of+-- its methods) and deployments (3), as its schema had them on 2026-10-15;+-- in a caller's view, tickets.delete (admin only) is not in it.+catalogService :: ViewMode -> Scenario+catalogService v = Scenario v False False mockState True++-- | How many schema calls the mock services have answered (this process).+{-# NOINLINE schemaCalls #-}+schemaCalls :: IORef Int+schemaCalls = unsafePerformIO (newIORef 0)++-- | SYNAPSE-28: WebSocket connections the mock services have accepted (this process).+{-# NOINLINE connectionsAccepted #-}+connectionsAccepted :: IORef Int+connectionsAccepted = unsafePerformIO (newIORef 0)++-- | SYNAPSE-28: _info probes answered.+{-# NOINLINE infoCalls #-}+infoCalls :: IORef Int+infoCalls = unsafePerformIO (newIORef 0)++-- | SYNAPSE-28: @menger.call_unsub@ requests, by subscription.+{-# NOINLINE unsubscribes #-}+unsubscribes :: IORef [Value]+unsubscribes = unsafePerformIO (newIORef [])++-- | SYNAPSE-28: the service renamed @tickets.get@ to @tickets.fetch@ (its schema+-- says @fetch@, and @get@ is not found).+{-# NOINLINE renamedGet #-}+renamedGet :: IORef Bool+renamedGet = unsafePerformIO (newIORef False)++-- | SYNAPSE-CC-8: when set, @<ns>.schema@ (@menger.schema@ for the root,+-- keyed @""@) answers these schemas, by dotted path, before anything else.+{-# NOINLINE schemaOverride #-}+schemaOverride :: IORef (Maybe [(Text, Value)])+schemaOverride = unsafePerformIO (newIORef Nothing)++-- | SYNAPSE-26: the method of every @menger.call@ the services took, in order.+{-# NOINLINE callsMade #-}+callsMade :: IORef [Text]+callsMade = unsafePerformIO (newIORef [])++-- | SYNAPSE-26: @tickets.flood@ streams that ended — unsubscribed, or their+-- connection gone.+{-# NOINLINE floodsEnded #-}+floodsEnded :: IORef Int+floodsEnded = unsafePerformIO (newIORef 0)++-- | SYNAPSE-26: methods whose next call is taken and then answered by+-- closing the connection (each name once).+{-# NOINLINE dropNext #-}+dropNext :: IORef [Text]+dropNext = unsafePerformIO (newIORef [])++mockCode, mockState :: Text+mockCode = "c_19ab"+mockState = "s_7f2c"++-- | Run an action against a service on a fresh port; the port is passed in.+withMockService :: Scenario -> (Int -> IO a) -> IO a+withMockService sc act = bracket open (N.close . fst) (\(_, port) -> act port)+  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 16+      port <- fromIntegral <$> N.socketPort sock+      void $ forkIO $ acceptLoop sc sock+      pure (sock, port)++-- | Serve until killed, printing the port (for transcripts by hand).+serveMockService :: Scenario -> IO ()+serveMockService sc = withMockService sc $ \port -> do+  putStrLn (show port)+  hFlush stdout+  forever (threadDelay 1000000)++acceptLoop :: Scenario -> N.Socket -> IO ()+acceptLoop sc sock = do+  r <- try (N.accept sock)+  case r of+    Left (_ :: SomeException) -> pure ()   -- the service was closed+    Right (conn, _) -> do+      void $ forkIO $ do+        _ <- try (session conn) :: IO (Either SomeException ())+        N.close conn+      acceptLoop sc sock+  where+    session conn = do+      pending <- WS.makePendingConnection conn WS.defaultConnectionOptions+      -- the credential the upgrade carried, if any+      let bearer = lookup "Authorization" (WS.requestHeaders (WS.pendingRequest pending))+      c <- WS.acceptRequest pending+      atomicModifyIORef' connectionsAccepted (\n -> (n + 1, ()))+      next <- newIORef (100 :: Int)+      forever $ do+        msg <- WS.receiveData c+        case decode msg of+          Just (Object o) -> handle sc c next (isBearer bearer) o+          _ -> pure ()+    isBearer = maybe False (BS8.isPrefixOf "Bearer ")++handle :: Scenario -> WS.Connection -> IORef Int -> Bool -> Object -> IO ()+handle sc c next signedIn o = do+  let rid = KM.lookup "id" o+      method = str "method" o+      params = case KM.lookup "params" o of { Just (Object p) -> p; _ -> KM.empty }+  -- SYNAPSE-28: an unsubscribe is answered true, and noted+  if method == "menger.call_unsub"+    then do+      atomicModifyIORef' unsubscribes (\us -> (maybe Null id (KM.lookup "params" o) : us, ()))+      send (object ["jsonrpc" .= ("2.0" :: Text), "id" .= rid, "result" .= True])+    else handleCall sc c next signedIn o rid method params+  where+    send :: Value -> IO ()+    send = WS.sendTextData c . encode++handleCall :: Scenario -> WS.Connection -> IORef Int -> Bool -> Object -> Maybe Value -> Text -> Object -> IO ()+handleCall sc c next signedIn _o rid method params = do+  sub <- atomicModifyIORef' next (\n -> (n + 1, n))+  send (object ["jsonrpc" .= ("2.0" :: Text), "id" .= rid, "result" .= sub])+  let emit item = send (object+        [ "jsonrpc" .= ("2.0" :: Text), "method" .= ("subscription" :: Text)+        , "params" .= object ["subscription" .= sub, "result" .= item] ])+      meta = object ["provenance" .= (["menger"] :: [Text]), "plexus_hash" .= ("h0" :: Text), "timestamp" .= (0 :: Int)]+      dat :: Text -> Value -> IO ()+      dat ct v = emit (object ["type" .= ("data" :: Text), "metadata" .= meta, "content_type" .= ct, "content" .= v])+      err :: Text -> [(K.Key, Value)] -> IO ()+      err m extra = emit (Object (KM.fromList (+        [("type", "error"), ("metadata", meta), ("message", String m), ("recoverable", Bool False)] <> extra)))+      done = emit (object ["type" .= ("done" :: Text), "metadata" .= meta])+  case method of+    "_info" -> do+      atomicModifyIORef' infoCalls (\n -> (n + 1, ()))+      dat "_info" (infoFor sc)+      done+    "menger.call" -> do+      let inner = str "method" params+          args = case KM.lookup "params" params of { Just (Object a) -> a; _ -> KM.empty }+      renamed <- readIORef renamedGet+      atomicModifyIORef' callsMade (\cs -> (cs ++ [inner], ()))+      dropIt <- atomicModifyIORef' dropNext (\ds -> if inner `elem` ds then (filter (/= inner) ds, True) else (ds, False))+      if dropIt then ioError (userError "dropped") else pure ()+      case inner of+        -- SYNAPSE-26: a write answered in two parts, a moment apart, so a+        -- reader that closes after the first has closed before the second+        "tickets.amend" -> void $ forkIO $ do+          dat "tickets.amend" (object ["type" .= ("amended" :: Text), "id" .= str "id" args, "part" .= (1 :: Int)])+          threadDelay 300000+          dat "tickets.amend" (object ["type" .= ("amended" :: Text), "id" .= str "id" args, "part" .= (2 :: Int)])+          done+        -- SYNAPSE-26: a stream that ticks every 100 ms until it is+        -- unsubscribed or its connection goes+        "tickets.flood" -> void $ forkIO $ do+          u0 <- length <$> readIORef unsubscribes+          let tick (n :: Int) = do+                u <- length <$> readIORef unsubscribes+                if u > u0 then pure () else do+                  ok <- try (dat "tickets.flood" (object ["type" .= ("tick" :: Text), "n" .= n]))+                  case ok of+                    Left (_ :: SomeException) -> pure ()+                    Right () -> threadDelay 100000 >> tick (n + 1)+          tick 0+          atomicModifyIORef' floodsEnded (\n -> (n + 1, ()))+        -- waits for its answer off the connection's loop, as a real service+        -- runs calls side by side (SYNAPSE-28: the answer may come on this+        -- very connection)+        "tickets.ask" -> void $ forkIO (askBack emit meta dat err >> done)+        -- SYNAPSE-28: a stream that never ends by itself (until unsubscribed)+        "tickets.watch" -> dat "tickets.watch" (object ["type" .= ("watching" :: Text)])+        "tickets.get" | renamed -> err "Method not found: tickets.get" [] >> done+        "tickets.fetch" | renamed -> callMethod sc signedIn "tickets.get" args dat err >> done+        "tickets.schema" | renamed, scView sc /= AnonymousView, not (scCatalog sc) ->+          dat "tickets.schema" (renameGet (ticketsSchema sc)) >> done+        _ -> callMethod sc signedIn inner args dat err >> done+    -- SCAFFOLD-21: a bidirectional answer, on a connection of its own+    "menger.respond" -> do+      void (tryPutMVar responses (KM.lookup "response_data" params))+      done+    _ -> err ("Invalid method format: " <> method) [] >> done+  where+    send :: Value -> IO ()+    send = WS.sendTextData c . encode++-- | SCAFFOLD-21: the answers to 'askBack's requests (@menger.respond@'s+-- @response_data@), as they arrive on any connection.+{-# NOINLINE responses #-}+responses :: MVar (Maybe Value)+responses = unsafePerformIO newEmptyMVar++-- | A bidirectional method (@tickets.ask@): it asks the caller to confirm+-- (a @request@ item), waits up to 5 s for @menger.respond@, and answers+-- with what came back.+askBack :: (Value -> IO ()) -> Value -> (Text -> Value -> IO ()) -> (Text -> [(K.Key, Value)] -> IO ()) -> IO ()+askBack emit meta dat err = do+  _ <- tryTakeMVar responses+  emit (object+    [ "type" .= ("request" :: Text), "metadata" .= meta, "request_id" .= ("req-1" :: Text)+    , "request" .= object ["type" .= ("confirm" :: Text), "message" .= ("go on?" :: Text)] ])+  got <- timeout 5000000 (takeMVar responses)+  case got of+    Just (Just r) -> dat "tickets.ask" (object ["type" .= ("answered" :: Text), "response" .= r])+    _ -> err "no response to req-1" []++infoFor :: Scenario -> Value+infoFor sc = case scView sc of+  NoView -> object ["backend" .= ("menger" :: Text), "auth_capabilities" .= object ["mechanisms" .= [object ["kind" .= ("anonymous" :: Text)]]]]+  AnonymousView -> object+    [ "backend" .= ("menger" :: Text), "view" .= ("anonymous" :: Text)+    , "auth" .= object+        [ "methods" .= (["auth.providers", "auth.login", "auth.signup"] :: [Text])+        , "resource_metadata" .= ("http://127.0.0.1:4456/.well-known/oauth-protected-resource" :: Text) ] ]+  CallerView -> object ["backend" .= ("menger" :: Text), "view" .= ("caller" :: Text), "view_hash" .= ("v-9a77" :: Text)]++callMethod :: Scenario -> Bool -> Text -> Object+           -> (Text -> Value -> IO ()) -> (Text -> [(K.Key, Value)] -> IO ()) -> IO ()+callMethod sc signedIn inner args dat err = do+ if ".schema" `T.isSuffixOf` inner then atomicModifyIORef' schemaCalls (\n -> (n + 1, ())) else pure ()+ override <- readIORef schemaOverride+ let ns = if inner == "menger.schema" then "" else T.dropEnd (T.length ".schema") inner+ case override >>= lookup ns of+  Just v | ".schema" `T.isSuffixOf` inner -> dat inner v+  _ -> callMethod' sc signedIn inner args dat err++callMethod' :: Scenario -> Bool -> Text -> Object+            -> (Text -> Value -> IO ()) -> (Text -> [(K.Key, Value)] -> IO ()) -> IO ()+callMethod' sc _signedIn inner args dat err =+ case inner of+  "menger.schema" -> dat "menger.schema" (rootSchema sc)+  "tickets.schema" | scCatalog sc -> do+      Just (Object o) <- decodeFileStrict "test/fixtures/find-tickets.json"+      dat "tickets.schema" (Object (catalogView sc o))+  "deployments.schema" | scCatalog sc -> do+      Just v <- decodeFileStrict "test/fixtures/find-deployments.json"+      dat "deployments.schema" (v :: Value)+  "auth.schema" | scAuth sc -> dat "auth.schema" authSchema+  "tickets.schema" | scView sc /= AnonymousView -> dat "tickets.schema" (ticketsSchema sc)+  "auth.whoami" | scAuth sc -> dat "auth.whoami" (object+      [ "type" .= ("whoami" :: Text), "principal" .= ("key:ac79e0f3b1c24d5e6f708192a3b4c5d6e7f8091a2b3c4d5e6f708192a3b4c5d6" :: Text)+      , "name" .= ("worker-1" :: Text), "agent" .= ("worker-1" :: Text)+      , "memberships" .= [object ["role" .= ("editor" :: Text), "scope" .= ("MENGER" :: Text)]]+      , "ceiling" .= (["editor@MENGER-12"] :: [Text]) ])+  "tickets.get" -> dat "tickets.get" (object ["type" .= ("ticket" :: Text), "id" .= ("MENGER-12" :: Text)])+  "tickets.set_status"+    | scView sc == CallerView -> err "needs tickets.set_status on IDENTITY"+        [ ("error_kind", "forbidden"), ("grant", "tickets.set_status"), ("scope", "IDENTITY")+        , ("roles", toJSON (["editor", "admin"] :: [Text])), ("held_on", toJSON (["MENGER"] :: [Text])) ]+    | otherwise -> dat "tickets.set_status" (object ["type" .= ("status_changed" :: Text)])+  "auth.login" | scAuth sc -> case KM.lookup "flow" args of+      Just (Object f)+        | Just (Object b) <- KM.lookup "browser" f -> do+            let redirect = str "redirect" b+            dat "auth.login" (object+              [ "type" .= ("login_url" :: Text)+              , "url" .= ("http://127.0.0.1:4456/login?cli=1&state=" <> mockState)+              , "state" .= mockState ])+            -- the provider's redirect, a moment later+            void $ forkIO $ threadDelay 300000 >> browserReturns redirect (scBrowserState sc)+        | Just (Object cd) <- KM.lookup "code" f ->+            if str "code" cd == mockCode && str "state" cd == mockState+              then dat "auth.login" (object+                [ "type" .= ("session" :: Text), "token" .= ("mgs_person" :: Text)+                , "principal" .= ("oidc:workos/user_01M4QXZ7ABCDEF" :: Text), "name" .= ("Ada Lovelace" :: Text)+                , "expires_at" .= (1791663600 :: Int)+                , "memberships" .= [object ["role" .= ("admin" :: Text), "scope" .= ("*" :: Text)]] ])+              else err "the code is not good for this state" []+        | Just (Object s) <- KM.lookup "session" f -> dat "auth.login" (object+            [ "type" .= ("session" :: Text), "token" .= ("mgs_agent_auth" :: Text)+            , "principal" .= ("key:79b5" :: Text), "agent" .= ("worker-1" :: Text)+            , "expires_at" .= (1791663600 :: Int)+            , "ceiling" .= maybe (toJSON ([] :: [Text])) id (KM.lookup "ceiling" s) ])+      _ -> err "auth.login: no flow" []+  "session.login" | scSessionLogin sc -> dat "session.login" (object+      [ "type" .= ("login" :: Text), "token" .= ("mgs_agent_session" :: Text)+      , "principal" .= ("key:79b5" :: Text), "agent" .= ("worker-1" :: Text)+      , "expires_at" .= (1791663600 :: Int)+      , "scope" .= maybe (toJSON ([] :: [Text])) id (KM.lookup "scope" args) ])+  other -> err ("Activation not found: " <> T.takeWhile (/= '.') other) []++-- | The browser coming back to synapse's loopback, as the provider's+-- redirect sends it.+browserReturns :: Text -> Text -> IO ()+browserReturns redirect state = do+  let rest = maybe redirect id (T.stripPrefix "http://127.0.0.1:" redirect)+      (portT, path) = T.breakOn "/" rest+      port = read (T.unpack portT) :: Int+  sock <- N.socket N.AF_INET N.Stream N.defaultProtocol+  N.connect sock (N.SockAddrInet (fromIntegral port) (N.tupleToHostAddress (127, 0, 0, 1)))+  -- a favicon first, as browsers do: the loopback must not take it for an answer+  NB.sendAll sock "GET /favicon.ico HTTP/1.1\r\nHost: 127.0.0.1\r\n\r\n"+  _ <- NB.recv sock 4096+  N.close sock+  sock' <- N.socket N.AF_INET N.Stream N.defaultProtocol+  N.connect sock' (N.SockAddrInet (fromIntegral port) (N.tupleToHostAddress (127, 0, 0, 1)))+  NB.sendAll sock' $ TE.encodeUtf8 $+    "GET " <> path <> "?code=" <> mockCode <> "&state=" <> state <> " HTTP/1.1\r\nHost: 127.0.0.1\r\n\r\n"+  _ <- NB.recv sock' 4096+  N.close sock'++rootSchema :: Scenario -> Value+rootSchema sc = object $+  [ "namespace" .= ("menger" :: Text), "version" .= ("1.0.0" :: Text)+  , "description" .= ("Central routing and introspection" :: Text)+  , "hash" .= (case scView sc of { AnonymousView -> "v-anon-3c1f"; CallerView | scCatalog sc -> "rc-v9a77"; _ | scCatalog sc -> "rc0"; _ -> "r0" } :: Text)+  , "children" .= children ]+  where+    children = case scView sc of+      _ | scCatalog sc ->+        [ object ["namespace" .= ("tickets" :: Text), "description" .= ("Plans as data" :: Text), "hash" .= ("t0" :: Text)]+        , object ["namespace" .= ("deployments" :: Text), "description" .= ("Deployments" :: Text), "hash" .= ("d0" :: Text)] ]+      AnonymousView -> [object ["namespace" .= ("auth" :: Text), "methods" .= [+        object ["name" .= ("providers" :: Text), "public" .= True],+        object ["name" .= ("login" :: Text), "public" .= True],+        object ["name" .= ("signup" :: Text), "public" .= True]]]]+      _ -> [ object ["namespace" .= ("tickets" :: Text), "description" .= ("Plans as data" :: Text), "hash" .= ("t0" :: Text)] ]+        <> [ object ["namespace" .= ("auth" :: Text), "description" .= ("Sign in, who am I, what does this need" :: Text), "hash" .= ("a0" :: Text)] | scAuth sc ]++authSchema :: Value+authSchema = object+  [ "namespace" .= ("auth" :: Text), "version" .= ("0.1.0" :: Text), "hash" .= ("a0" :: Text)+  , "description" .= ("Sign in, who am I, what does this need" :: Text)+  , "methods" .= [ m "providers" "The ways in this server offers"+                 , m "login" "Sign in \x2014 a person through the browser, an agent with its key"+                 , m "signup" "Create an account, or ask for access" ] ]+  where m n d = object ["name" .= (n :: Text), "description" .= (d :: Text), "hash" .= (n <> "0"), "public" .= True]++ticketsSchema :: Scenario -> Value+ticketsSchema sc = object $+  [ "namespace" .= ("tickets" :: Text), "version" .= ("0.5.0" :: Text), "hash" .= ("t0" :: Text)+  , "description" .= ("Plans as data" :: Text)+  , "methods" .= map method+      [ ("get", "One ticket by id", ["MENGER"], Just "id")+      , ("list", "Tickets, filtered and paged", ["MENGER"], Nothing)+      , ("set_status", "Change a ticket's status", ["MENGER-12"], Just "id") ] ]+  <> [ "view" .= ("caller" :: Text) | caller ]+  where+    caller = scView sc == CallerView+    method (n, d, held, target) = object $+      [ "name" .= (n :: Text), "description" .= (d :: Text), "hash" .= (n <> "0")+      , "params" .= object ["type" .= ("object" :: Text), "required" .= (["id"] :: [Text]),+          "properties" .= object ["id" .= object ["type" .= ("string" :: Text), "description" .= ("Ticket id, e.g. MNG-2" :: Text)]]] ]+      <> (if caller then [ "grant" .= ("tickets." <> n), "held_on" .= (held :: [Text]) ] <> maybe [] (\t -> ["target" .= (t :: Text)]) target else [])++-- | SYNAPSE-28: the schema after @get@ was renamed @fetch@ (a new hash).+renameGet :: Value -> Value+renameGet (Object o) = Object (KM.insert "hash" (String "t1") (maybe o (\v -> KM.insert "methods" (ms v) o) (KM.lookup "methods" o)))+  where+    ms (Array a) = Array (V.map m a)+    ms v = v+    m (Object mo) | KM.lookup "name" mo == Just (String "get") =+      Object (KM.insert "name" (String "fetch") (KM.insert "hash" (String "fetch0") mo))+    m v = v+renameGet v = v++-- | The tickets schema as the caller's view shows it: without what only an+-- admin holds (tickets.delete).+catalogView :: Scenario -> Object -> Object+catalogView sc o+  | scView sc /= CallerView = o+  | otherwise = KM.insert "view" (String "caller") (maybe o (\ms -> KM.insert "methods" (dropDelete ms) o) (KM.lookup "methods" o))+  where+    dropDelete (Array ms) = Array (V.filter (\case { Object m -> KM.lookup "name" m /= Just (String "delete"); _ -> True }) ms)+    dropDelete v = v++str :: Text -> Object -> Text+str k o = case KM.lookup (K.fromText k) o of+  Just (String s) -> s+  _ -> ""
+ test/NamingGateSpec.hs view
@@ -0,0 +1,42 @@+-- | NAMING-9: a Plexus backend is a service, never the retired word (owner,+-- 2026-10-29; ~/AGENTS.md "Naming").+-- The suite runs the repository's gate, scripts/naming-gate.sh, so+-- @cabal test@ — and CI — fails the day the retired word is written again.+--+-- A failure says how many lines the gate found and shows the first of them.+-- The gate's output is counted, never compared whole with an expected value:+-- on 2026-10-29 hspec's diff of an 875-line output grew to 7.3 GB and the+-- kernel's OOM killer stopped it (and the session around it). The suite's+-- heap is capped too (-with-rtsopts=-M6G in the cabal file).+module Main (main) where++import Control.Monad (unless)+import GHC.IO.Encoding (setLocaleEncoding)+import System.Exit (ExitCode (..))+import System.IO (hSetEncoding, stderr, stdout, utf8)+import System.Process (readProcessWithExitCode)+import Test.Hspec++-- | How many of the gate's lines a failure shows; @bash scripts/naming-gate.sh@+-- prints every one.+shown :: Int+shown = 20++main :: IO ()+main = do+  -- the gate prints lines of UTF-8 files; read and show them as such+  -- whatever the locale (a C locale would refuse the first em dash)+  setLocaleEncoding utf8+  mapM_ (`hSetEncoding` utf8) [stdout, stderr]+  hspec $+    describe "scripts/naming-gate.sh" $+      it "finds no line that says the retired word (exit 0)" $ do+        (code, out, err) <- readProcessWithExitCode "bash" ["scripts/naming-gate.sh"] ""+        let found = lines out+            n = length found+        unless (code == ExitSuccess && n == 0) . expectationFailure . unlines $+          [ "the gate found " <> show n <> " line(s) (" <> show code <> "); the first "+              <> show (min n shown) <> ":" ]+            <> take shown found+            <> [ "... and " <> show (n - shown) <> " more: bash scripts/naming-gate.sh" | n > shown ]+            <> take 3 (lines err)
+ test/OutputSpec.hs view
@@ -0,0 +1,333 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | SYNAPSE-39: @synapse -o FILE@ writes the call's answer to FILE, whole,+-- and nothing to stdout. The built synapse, end to end against the mock+-- service (a home, a cache and a runtime directory of the test's own):+--+-- * an answer in FILE is byte for byte what stdout would have had (plain+--   and @-j@), and stdout is empty;+-- * a call that fails leaves no FILE (an old one is gone too) and no+--   temporary file beside it, and exits with its own code (a lost write+--   still 75);+-- * a stream's items are in FILE as they come;+-- * FILE is 0600; @-o -@ is stdout;+-- * a FILE that cannot be made (no such directory, a directory) is said at+--   once, and the call is not sent;+-- * the review's (SYNAPSE-39): a failed write to FILE exits 74 (forced with+--   @ulimit -f@), a refusal under @-j@ is said on stderr, a two-way+--   request's line goes to stderr and the answer to FILE, a SIGTERM leaves+--   no temporary file.+module Main (main) where++import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, try)+import Control.Monad (forM_)+import Data.Aeson+import qualified Data.Aeson.Key as Key+import Data.Bits ((.&.))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.IORef+import Data.List (isInfixOf, isPrefixOf, sort)+import Data.Text (Text)+import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, listDirectory)+import System.Environment (getEnvironment)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.IO (hClose, hGetLine, hPutStrLn, hFlush)+import System.IO.Temp (withSystemTempDirectory)+import System.Posix.Files (fileMode, getFileStatus)+import System.Process+import System.Timeout (timeout)+import Test.Hspec++import MockService++main :: IO ()+main = hspec $ do+  synapse <- runIO (findExecutable "synapse")+  case synapse of+    Nothing -> it "(the synapse executable is not on PATH)" $ pendingWith "cabal test puts it there"+    Just exe -> outputSpec exe++outputSpec :: FilePath -> Spec+outputSpec exe = describe "synapse -o FILE (SYNAPSE-39)" $ do+  it "is this build" $ do+    (_, out, _) <- readProcessWithExitCode exe ["--version"] ""+    out `shouldStartWith` "3.17.3"++  forM_ [ ([], "", ["tickets", "get", "--id", "MENGER-12"])+        , (["-j"], " with -j", ["tickets", "get", "--id", "MENGER-12"])+        , ([], ", a write's answer in two parts", ["tickets", "amend", "--id", "MENGER-12", "--body", "the step"])+        , (["-j"], ", a write's answer in two parts with -j", ["tickets", "amend", "--id", "MENGER-12", "--body", "the step"]) ]+    $ \(globals, how, call) ->+   it ("an answer in FILE is what stdout would have had" <> how) $+    withRun $ \dir spawn -> do+      warm spawn+      (code0, onStdout, err0) <- reading (spawn globals) call+      (code0, err0) `shouldBe` (ExitSuccess, "")+      onStdout `shouldNotBe` ""+      let file = dir </> "answer.out"+      (code, out, err) <- reading (spawn (globals ++ ["-o", file])) call+      (code, out, err) `shouldBe` (ExitSuccess, "", "")+      inFile <- readFile file+      inFile `shouldBe` onStdout+      leftovers dir "answer.out" >>= (`shouldBe` [])++  it "--output is -o" $+    withRun $ \dir spawn -> do+      warm spawn+      let file = dir </> "answer.out"+      (code, out, _) <- reading (spawn ["--output", file]) ["tickets", "get", "--id", "MENGER-12"]+      (code, out) `shouldBe` (ExitSuccess, "")+      readFile file >>= (`shouldContain` "MENGER-12")++  it "FILE is 0600" $+    withRun $ \dir spawn -> do+      warm spawn+      let file = dir </> "answer.out"+      (code, _, _) <- reading (spawn ["-o", file]) ["tickets", "get", "--id", "MENGER-12"]+      code `shouldBe` ExitSuccess+      modeOf file >>= (`shouldBe` 0o600)++  it "-o - is stdout" $+    withRun $ \dir spawn -> do+      warm spawn+      (_, onStdout, _) <- reading (spawn []) ["tickets", "get", "--id", "MENGER-12"]+      (code, out, err) <- reading (spawn ["-o", "-"]) ["tickets", "get", "--id", "MENGER-12"]+      (code, out, err) `shouldBe` (ExitSuccess, onStdout, "")+      doesFileExist (dir </> "-") >>= (`shouldBe` False)++  it "a write lost on the socket: exit 75, sent once, no FILE and nothing beside it" $+    withRun $ \dir spawn -> do+      warm spawn+      let file = dir </> "answer.out"+      writeIORef callsMade []+      writeIORef dropNext ["tickets.amend"]+      (code, out, err) <- reading (spawn ["-o", file]) ["tickets", "amend", "--id", "MENGER-12", "--body", "the step"]+      (code, out) `shouldBe` (ExitFailure 75, "")+      err `shouldContain` "the write may have happened"+      amends <- length . filter (== "tickets.amend") <$> readIORef callsMade+      amends `shouldBe` 1+      doesFileExist file >>= (`shouldBe` False)+      leftovers dir "answer.out" >>= (`shouldBe` [])++  it "a call that fails takes an old FILE with it: no stale answer is left to read" $+    withRun $ \dir spawn -> do+      warm spawn+      let file = dir </> "answer.out"+      writeFile file "an answer from before\n"+      writeIORef dropNext ["tickets.amend"]+      (code, _, _) <- reading (spawn ["-o", file]) ["tickets", "amend", "--id", "MENGER-12", "--body", "the step"]+      code `shouldBe` ExitFailure 75+      doesFileExist file >>= (`shouldBe` False)+      leftovers dir "answer.out" >>= (`shouldBe` [])++  it "a call refused before it is sent (an unknown flag) leaves no FILE" $+    withRun $ \dir spawn -> do+      warm spawn+      let file = dir </> "answer.out"+      (code, out, _) <- reading (spawn ["-o", file]) ["tickets", "get", "--id", "MENGER-12", "--nonesuch", "x"]+      code `shouldNotBe` ExitSuccess+      out `shouldBe` ""+      doesFileExist file >>= (`shouldBe` False)+      leftovers dir "answer.out" >>= (`shouldBe` [])++  forM_ [([], ""), (["-j"], " with -j")] $ \(globals, how) ->+   it ("a stream's items are in FILE as they come, each line whole" <> how) $+    withRun $ \dir spawn -> do+      warm spawn+      let file = dir </> "ticks.out"+      (Just inp, Just out, Just err, ph) <- createProcess (spawn (globals ++ ["-o", file]) ["tickets", "flood"])+      hClose inp+      -- three ticks while the stream still runs+      got <- waitUpTo 10 $ do+        e <- doesFileExist file+        if not e then pure False else (>= 3) . length . lines <$> readFile' file+      running <- getProcessExitCode ph+      terminateProcess ph+      _ <- waitForProcess ph+      o <- BS.hGetContents out+      _ <- BS.hGetContents err+      (got, running) `shouldBe` (True, Nothing)+      BS.length o `shouldBe` 0+      body <- readFile' file+      -- what was printed is in FILE whole: it ends with its line's end+      last body `shouldBe` '\n'+      if null globals+        then body `shouldContain` "type: tick"+        else forM_ (lines body) $ \l -> (decodeStrict (BS8.pack l) :: Maybe Value) `shouldSatisfy` (/= Nothing)+      modeOf file >>= (`shouldBe` 0o600)+      leftovers dir "ticks.out" >>= (`shouldBe` [])++  it "a FILE that cannot be made is said at once, and the call is not sent" $+    withRun $ \dir spawn -> do+      warm spawn+      writeIORef callsMade []+      let file = dir </> "no-such-dir" </> "answer.out"+      (code, out, err) <- reading (spawn ["-o", file]) ["tickets", "amend", "--id", "MENGER-12", "--body", "the step"]+      (code, out) `shouldBe` (ExitFailure 73, "")+      err `shouldContain` file+      threadDelay 300000+      amends <- length . filter (== "tickets.amend") <$> readIORef callsMade+      amends `shouldBe` 0++  it "a directory as FILE is said at once, and the call is not sent" $+    withRun $ \dir spawn -> do+      warm spawn+      writeIORef callsMade []+      (code, out, err) <- reading (spawn ["-o", dir]) ["tickets", "amend", "--id", "MENGER-12", "--body", "the step"]+      (code, out) `shouldBe` (ExitFailure 73, "")+      err `shouldContain` "is a directory"+      threadDelay 300000+      amends <- length . filter (== "tickets.amend") <$> readIORef callsMade+      amends `shouldBe` 0+      listDirectory dir >>= (`shouldBe` ["cache", "home", "run"]) . sort++  it "a write to FILE that fails (a file size limit) exits 74, said once, the call unretried" $+    withRun $ \dir spawn -> do+      warm spawn+      writeIORef callsMade []+      let file = dir </> "ticks.out"+          limited args = let p = spawn ["-j", "-o", file] args in case cmdspec p of+            RawCommand exe' as -> p { cmdspec = RawCommand "/bin/sh" (["-c", "trap '' XFSZ; ulimit -f 1; exec \"$0\" \"$@\"", exe'] ++ as) }+            ShellCommand _ -> p+      (code, out, err) <- reading limited ["tickets", "flood"]+      (code, out) `shouldBe` (ExitFailure 74, "")+      err `shouldContain` ("cannot write " <> file)+      err `shouldNotContain` "hFlush"+      err `shouldNotContain` "reconnect"+      floods <- length . filter (== "tickets.flood") <$> readIORef callsMade+      floods `shouldBe` 1+      leftovers dir "ticks.out" >>= (`shouldBe` [])++  it "a refusal under -j -o is said on stderr: exit 77, no FILE" $+    withRunS (Scenario CallerView False True mockState False) $ \dir spawn -> do+      warm spawn+      let file = dir </> "answer.out"+      (code, out, err) <- reading (spawn ["-j", "-o", file]) ["tickets", "set_status", "--id", "IDENTITY-3"]+      (code, out) `shouldBe` (ExitFailure 77, "")+      err `shouldContain` "tickets.set_status"+      doesFileExist file >>= (`shouldBe` False)+      leftovers dir "answer.out" >>= (`shouldBe` [])++  it "a two-way request's line goes to stderr, its answer to FILE" $+    withRun $ \dir spawn -> do+      warm spawn+      let file = dir </> "answer.out"+      (Just inp, Just out, Just err, ph) <- createProcess (spawn ["--bidir-mode", "json", "-o", file] ["tickets", "ask"])+      let untilRequest = do+            l <- hGetLine err+            if "bidir_request" `isInfixOf` l then pure l else untilRequest+      req <- timeout 10000000 untilRequest+      req `shouldSatisfy` (/= Nothing)+      hPutStrLn inp "{\"type\":\"confirmed\",\"value\":true}"+      hFlush inp+      code <- timeout 10000000 (waitForProcess ph)+      code `shouldBe` Just ExitSuccess+      o <- BS.hGetContents out+      BS.length o `shouldBe` 0+      body <- readFile' file+      body `shouldContain` "answered"+      body `shouldNotContain` "bidir_request"++  forM_ [("a SIGTERM", ExitFailure 143)] $ \(how, want) ->+   it (how <> " during an answer leaves no FILE and no temporary file") $+    withRun $ \dir spawn -> do+      warm spawn+      let file = dir </> "answer.out"+      -- tickets.watch, unary here: a call the service never ends+      (Just inp, Just out, Just err, ph) <- createProcess (spawn ["-o", file] ["tickets", "watch"])+      hClose inp+      begun <- waitUpTo 10 (not . null <$> leftovers dir "answer.out")+      threadDelay 500000+      terminateProcess ph+      code <- timeout 5000000 (waitForProcess ph)+      _ <- BS.hGetContents out+      _ <- BS.hGetContents err+      (begun, code) `shouldBe` (True, Just want)+      doesFileExist file >>= (`shouldBe` False)+      leftovers dir "answer.out" >>= (`shouldBe` [])+  where+    -- a run of the built synapse against a fresh mock service serving a+    -- tickets schema with a read (get), a write (amend) and an endless+    -- stream (flood); @spawn globals args@+    withRun = withRunS todaysService+    withRunS sc act = withSystemTempDirectory "synapse39" $ \dir -> withMockService sc $ \port -> do+      forM_ ["home", "cache", "run"] $ \d -> createDirectoryIfMissing True (dir </> d)+      env0 <- getEnvironment+      let env = [ (k, v) | (k, v) <- env0, k `notElem` ["HOME", "XDG_CACHE_HOME", "XDG_RUNTIME_DIR", "SYNAPSE_AS", "PLEXUS_SESSION", "SYNAPSE_RECONNECT_FOR"] ]+              ++ [ ("HOME", dir </> "home"), ("XDG_CACHE_HOME", dir </> "cache"), ("XDG_RUNTIME_DIR", dir </> "run")+                 , ("PLEXUS_KEYCHAIN", "off"), ("SYNAPSE_HOLD_FOR", "3s") ]+          spawn globals args = (proc exe (globals ++ ["--url", "ws://127.0.0.1:" <> show port <> "/ws", "menger"] ++ args))+            { env = Just env, std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }+      writeIORef schemaOverride (Just [("tickets", ticketsWithWrites)])+      writeIORef dropNext []+      r <- try (act dir spawn)+      writeIORef schemaOverride Nothing+      writeIORef dropNext []+      either (\(e :: SomeException) -> ioError (userError (show e))) pure r++    -- the schema in the cache first, so the run under test is the call alone+    warm spawn = do+      (code, _, _) <- reading (spawn []) ["tickets", "get", "--id", "MENGER-12"]+      code `shouldBe` ExitSuccess++-- | What is beside FILE in its directory but FILE itself: a temporary file+-- left behind.+leftovers :: FilePath -> FilePath -> IO [FilePath]+leftovers dir name = filter (\f -> name `isPrefixOf` f && f /= name) <$> listDirectory dir++modeOf :: FilePath -> IO Int+modeOf f = (\s -> fromIntegral (fileMode s .&. 0o777)) <$> getFileStatus f++readFile' :: FilePath -> IO String+readFile' f = BS8.unpack <$> BS.readFile f++-- | Run with stdout read to its end.+reading :: ([String] -> CreateProcess) -> [String] -> IO (ExitCode, String, String)+reading spawn args = do+  (Just inp, Just out, Just err, ph) <- createProcess (spawn args)+  hClose inp+  c <- timeout 30000000 (waitForProcess ph)+  case c of+    Nothing -> do+      terminateProcess ph+      _ <- waitForProcess ph+      e <- BS.hGetContents err+      expectationFailure ("hung; stderr: " <> take 600 (BS8.unpack e))+      error "hung"+    Just code -> do+      o <- BS.hGetContents out+      e <- BS.hGetContents err+      pure (code, BS8.unpack o, BS8.unpack e)++waitUpTo :: Double -> IO Bool -> IO Bool+waitUpTo secs cond = go (round (secs * 20) :: Int)+  where+    go 0 = cond+    go n = cond >>= \ok -> if ok then pure True else threadDelay 50000 >> go (n - 1)++-- | menger's tickets in miniature: a read, a write and an endless stream.+ticketsWithWrites :: Value+ticketsWithWrites = object+  [ "namespace" .= ("tickets" :: Text), "version" .= ("0.5.0" :: Text), "hash" .= ("t0" :: Text)+  , "description" .= ("Plans as data" :: Text)+  , "methods" .=+      [ m "get" "One ticket by id" (Just "read") False [("id", True)]+      , m "amend" "Replace a ticket's body" (Just "write") False [("id", True), ("body", False)]+      , m "flood" "Ticks, every 100 ms, until unsubscribed" (Just "read") True []+      , m "set_status" "Change a ticket's status" (Just "write") False [("id", True)]+      , m "ask" "Ask the caller to confirm" (Just "write") False []+        -- the service's tickets.watch, said here to be unary: one item, and no end+      , m "watch" "One item, and no end" (Just "read") False [] ] ]+  where+    m :: Text -> Text -> Maybe Text -> Bool -> [(Text, Bool)] -> Value+    m n d g s ps = object $+      [ "name" .= n, "description" .= d, "hash" .= (n <> "0"), "streaming" .= s+      , "params" .= object+          [ "type" .= ("object" :: Text)+          , "required" .= [ p | (p, True) <- ps ]+          , "properties" .= object [ Key.fromText p .= object ["type" .= ("string" :: Text)] | (p, _) <- ps ] ] ]+      <> maybe [] (\g' -> ["group" .= g']) g
test/ParseSpec.hs view
@@ -170,7 +170,7 @@           `shouldBe` arr [String "{\"id\":\"a\",\"kind\":\"b\"}"]        it "a list of untyped values is not split" $-        one (listParam "items" (RefArray RefAny)) "a,b" `shouldBe` strs ["a,b"]+        one (listParam "items" (RefArray RefJson)) "a,b" `shouldBe` strs ["a,b"]        it "a list of lists is not split" $         one (listParam "rows" (RefArray (RefArray (RefPrimitive "string" Nothing)))) "a,b"@@ -345,7 +345,7 @@   , mdDescription = Nothing   , mdStreaming = False   , mdParams = params-  , mdReturns = RefAny+  , mdReturns = RefJson   , mdBidirType = Nothing   , mdBidirResponseType = Nothing   , mdBidirResponseSchema = Nothing@@ -353,6 +353,8 @@   , mdGrant = Nothing   , mdTarget = Nothing   , mdLongDescription = Nothing+  , mdInjected = []+  , mdInput = Nothing   }  -- | A reference to a type in 'listIR'@@ -427,9 +429,9 @@ dashIR = emptyIR   { irTypes = Map.fromList       [ ("t.Identifier", TypeDef "Identifier" "t" Nothing (KindEnum "type"-          [ VariantDef "by_name" Nothing [FieldDef "name" (RefPrimitive "string" Nothing) Nothing True Nothing]-          , VariantDef "by_id" Nothing [FieldDef "id" (RefPrimitive "string" Nothing) Nothing True Nothing]-          ]))+          [ VariantDef "by_name" Nothing [FieldDef "name" (RefPrimitive "string" Nothing) Nothing True Nothing] Nothing+          , VariantDef "by_id" Nothing [FieldDef "id" (RefPrimitive "string" Nothing) Nothing True Nothing] Nothing+          ] Internal))       , ("t.Options", TypeDef "Options" "t" Nothing (KindStruct           [ FieldDef "verbose" (RefPrimitive "boolean" Nothing) Nothing False Nothing           , FieldDef "label" (RefPrimitive "string" Nothing) Nothing False Nothing
+ test/PipeSpec.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | SYNAPSE-26: a closed stdout is not an outage. The built synapse, end to+-- end against the mock service (a home, a cache and a runtime directory of+-- the test's own), its stdout a pipe whose reader closes early, as+-- @… | head -1@ does:+--+-- * a write's answer printed to a closed pipe: the service took the write+--   once, synapse exited 141 within 2 s and said nothing of a reconnect;+-- * a stream into a reader that closed after one line: 141 within 2 s, the+--   stream unsubscribed (or its connection closed), subscribed once;+-- * the socket dropping with stdout open: as before — a read sent again+--   and answered, a write that went out never repeated (exit 75).+module Main (main) where++import Control.Exception (SomeException, try)+import Control.Monad (forM_)+import Data.Aeson+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.IORef+import qualified Data.Aeson.Key as Key+import Data.Text (Text)+import GHC.Clock (getMonotonicTime)+import System.Directory (createDirectoryIfMissing, findExecutable)+import System.Environment (getEnvironment)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.IO (Handle, hClose)+import System.IO.Temp (withSystemTempDirectory)+import System.Process+import System.Timeout (timeout)+import Control.Concurrent (threadDelay)+import Test.Hspec++import MockService++main :: IO ()+main = hspec $ do+  synapse <- runIO (findExecutable "synapse")+  case synapse of+    Nothing -> it "(the synapse executable is not on PATH)" $ pendingWith "cabal test puts it there"+    Just exe -> pipeSpec exe++pipeSpec :: FilePath -> Spec+pipeSpec exe = describe "a closed stdout (SYNAPSE-26)" $ do+  it "is this build" $ do+    (_, out, _) <- readProcessWithExitCode exe ["--version"] ""+    out `shouldStartWith` "3.17"++  -- one reader takes a byte and closes, one closes before anything is+  -- printed+  forM_ [ ([], "", firstByte), (["-j"], " with -j", nothing)+        , (["--reconnect-for", "0"], " with --reconnect-for 0", firstByte)+        , (["--no-hold"], " with --no-hold", firstByte) ] $ \(globals, how, reader) ->+   it ("a_closed_stdout_ends_a_write_once" <> how) $+    withRunG globals $ \spawn -> do+      warm spawn+      writeIORef callsMade []+      (code, secs, err) <- closingAfter reader spawn+        ["tickets", "amend", "--id", "MENGER-12", "--body", "the step"]+      threadDelay 500000+      amends <- length . filter (== "tickets.amend") <$> readIORef callsMade+      (code, amends, err) `shouldBe` (ExitFailure 141, 1, "")+      secs `shouldSatisfy` (< 2)++  it "the holder survives a call's closed stdout and answers the next call on its connection" $+    withRun $ \spawn -> do+      warm spawn+      (code, _, _) <- closingAfter firstByte spawn ["tickets", "amend", "--id", "MENGER-12", "--body", "the step"]+      code `shouldBe` ExitFailure 141+      c0 <- readIORef connectionsAccepted+      (code', out, err) <- reading spawn ["tickets", "get", "--id", "MENGER-12"]+      (code', err) `shouldBe` (ExitSuccess, "")+      out `shouldContain` "MENGER-12"+      c1 <- readIORef connectionsAccepted+      (c1 - c0) `shouldBe` 0++  -- (the printer's stdout is line-buffered — katip's scribe sets it — so+  -- what is printed is written at once; a run's own exit code under a+  -- closed stdout is pinned in reconnect-test's exitOnClosedOutput cases)+  it "a write lost on the socket keeps its exit 75 when its stdout is closed too" $+    withRun $ \spawn -> do+      warm spawn+      writeIORef callsMade []+      writeIORef dropNext ["tickets.amend"]+      (code, _, err) <- closingAfter nothing spawn ["tickets", "amend", "--id", "MENGER-12", "--body", "the step"]+      code `shouldBe` ExitFailure 75+      err `shouldContain` "the write may have happened"+      amends <- length . filter (== "tickets.amend") <$> readIORef callsMade+      amends `shouldBe` 1++  forM_ [([], "through the connection holder"), (["--no-hold"], "on a connection of its own (--no-hold)")] $ \(globals, how) ->+   it ("a_closed_stdout_ends_a_stream, " <> how) $+    withRunG globals $ \spawn -> do+      warm spawn+      writeIORef callsMade []+      ended0 <- readIORef floodsEnded+      (code, secs, err) <- closingAfter BS8.hGetLine spawn ["tickets", "flood"]+      (code, err) `shouldBe` (ExitFailure 141, "")+      secs `shouldSatisfy` (< 2)+      -- the service saw the stream end, and it was subscribed once+      waitUpTo 2 ((> ended0) <$> readIORef floodsEnded) >>= (`shouldBe` True)+      floods <- length . filter (== "tickets.flood") <$> readIORef callsMade+      floods `shouldBe` 1++  it "a_lost_socket_with_stdout_open_still_reconnects" $+    withRun $ \spawn -> do+      warm spawn+      writeIORef callsMade []+      writeIORef dropNext ["tickets.get"]+      (code, out, err) <- reading spawn ["tickets", "get", "--id", "MENGER-12"]+      code `shouldBe` ExitSuccess+      out `shouldContain` "MENGER-12"+      err `shouldContain` "lost"+      err `shouldContain` "reconnected"+      gets <- length . filter (== "tickets.get") <$> readIORef callsMade+      gets `shouldBe` 2++  it "a lost socket on a write that went out, stdout open, is still exit 75, sent once" $+    withRun $ \spawn -> do+      warm spawn+      writeIORef callsMade []+      writeIORef dropNext ["tickets.amend"]+      (code, _, err) <- reading spawn ["tickets", "amend", "--id", "MENGER-12", "--body", "the step"]+      code `shouldBe` ExitFailure 75+      err `shouldContain` "the write may have happened"+      amends <- length . filter (== "tickets.amend") <$> readIORef callsMade+      amends `shouldBe` 1+  where+    -- a run of the built synapse against a fresh mock service serving a+    -- tickets schema with a write (amend) and an endless stream (flood)+    withRun = withRunG []+    withRunG globals act = withSystemTempDirectory "synapse26" $ \dir -> withMockService todaysService $ \port -> do+      forM_ ["home", "cache", "run"] $ \d -> createDirectoryIfMissing True (dir </> d)+      env0 <- getEnvironment+      let env = [ (k, v) | (k, v) <- env0, k `notElem` ["HOME", "XDG_CACHE_HOME", "XDG_RUNTIME_DIR", "SYNAPSE_AS", "PLEXUS_SESSION", "SYNAPSE_RECONNECT_FOR"] ]+              ++ [ ("HOME", dir </> "home"), ("XDG_CACHE_HOME", dir </> "cache"), ("XDG_RUNTIME_DIR", dir </> "run")+                 , ("PLEXUS_KEYCHAIN", "off"), ("SYNAPSE_HOLD_FOR", "3s") ]+          spawn args = (proc exe (globals ++ ["--url", "ws://127.0.0.1:" <> show port <> "/ws", "menger"] ++ args))+            { env = Just env, std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }+      writeIORef schemaOverride (Just [("tickets", ticketsWithWrites)])+      writeIORef dropNext []+      r <- try (act spawn)+      writeIORef schemaOverride Nothing+      writeIORef dropNext []+      either (\(e :: SomeException) -> ioError (userError (show e))) pure r++    -- the schema in the cache first, so the run under test is the call alone+    warm spawn = do+      (code, _, _) <- reading spawn ["tickets", "get", "--id", "MENGER-12"]+      code `shouldBe` ExitSuccess++-- | Run, read the stdout until the reader has what it wants, close it, and+-- wait (at most 5 s) for the exit: the code, the seconds from the close to+-- the exit, and stderr.+closingAfter :: (Handle -> IO BS.ByteString) -> ([String] -> CreateProcess) -> [String] -> IO (ExitCode, Double, String)+closingAfter readSome spawn args = do+  (Just inp, Just out, Just err, ph) <- createProcess (spawn args)+  hClose inp+  got <- timeout 10000000 (readSome out)+  got `shouldSatisfy` maybe False (not . BS.null)+  hClose out+  t0 <- getMonotonicTime+  code <- timeout 5000000 (waitForProcess ph)+  t1 <- getMonotonicTime+  case code of+    Nothing -> do+      terminateProcess ph+      _ <- waitForProcess ph+      e <- BS.hGetContents err+      expectationFailure ("still running 5 s after its stdout closed; stderr: " <> take 600 (BS8.unpack e))+      error "unreachable"+    Just c -> do+      e <- BS.hGetContents err+      pure (c, t1 - t0, BS8.unpack e)++-- | A reader that takes the first byte and goes, and one that goes at once.+firstByte, nothing :: Handle -> IO BS.ByteString+firstByte h = BS.hGetSome h 1+nothing _ = pure "-"++-- | Run with stdout read to its end.+reading :: ([String] -> CreateProcess) -> [String] -> IO (ExitCode, String, String)+reading spawn args = do+  (Just inp, Just out, Just err, ph) <- createProcess (spawn args)+  hClose inp+  c <- timeout 30000000 (waitForProcess ph)+  case c of+    Nothing -> do+      terminateProcess ph+      _ <- waitForProcess ph+      e <- BS.hGetContents err+      expectationFailure ("hung; stderr: " <> take 600 (BS8.unpack e))+      error "hung"+    Just code -> do+      o <- BS.hGetContents out+      e <- BS.hGetContents err+      pure (code, BS8.unpack o, BS8.unpack e)++waitUpTo :: Double -> IO Bool -> IO Bool+waitUpTo secs cond = go (round (secs * 20) :: Int)+  where+    go 0 = cond+    go n = cond >>= \ok -> if ok then pure True else threadDelay 50000 >> go (n - 1)++-- | menger's tickets in miniature: a read, a write and an endless stream.+ticketsWithWrites :: Value+ticketsWithWrites = object+  [ "namespace" .= ("tickets" :: Text), "version" .= ("0.5.0" :: Text), "hash" .= ("t0" :: Text)+  , "description" .= ("Plans as data" :: Text)+  , "methods" .=+      [ m "get" "One ticket by id" (Just "read") False [("id", True)]+      , m "amend" "Replace a ticket's body" (Just "write") False [("id", True), ("body", False)]+      , m "flood" "Ticks, every 100 ms, until unsubscribed" (Just "read") True [] ] ]+  where+    m :: Text -> Text -> Maybe Text -> Bool -> [(Text, Bool)] -> Value+    m n d g s ps = object $+      [ "name" .= n, "description" .= d, "hash" .= (n <> "0"), "streaming" .= s+      , "params" .= object+          [ "type" .= ("object" :: Text)+          , "required" .= [ p | (p, True) <- ps ]+          , "properties" .= object [ (fromText' p) .= object ["type" .= ("string" :: Text)] | (p, _) <- ps ] ] ]+      <> maybe [] (\g' -> ["group" .= g']) g+    fromText' = Key.fromText
test/ReconnectSpec.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-}  -- | SYNAPSE-20: a lost connection is noticed, and synapse rides out the--- outage. Against a flaky hub in miniature (each call answered as the test+-- outage. Against a flaky service in miniature (each call answered as the test -- says: answered, dropped mid-stream, dropped before any answer, or taken -- and then silent), on ports of its own: --@@ -11,11 +11,14 @@ --   'PT.ConnectionLost' — instead of waiting forever (APP-41's hang); -- * a read is sent again, a stream resumes (with @since@ when it takes --   one), a write that went out is never repeated, one that never left is;--- * the window, its spelling, and a method's shape from its schema.+-- * the window, its spelling, and a method's shape from its schema;+-- * SYNAPSE-26: an item the printer could not print (stdout closed) ends+--   the call — never a retry — while the socket's own broken pipe is still+--   an outage. module Main (main) where  import Control.Concurrent (forkIO, threadDelay)-import Control.Exception (SomeException, bracket, try)+import Control.Exception (SomeException, bracket, throwIO, try) import Control.Monad (forever, void) import Data.Aeson import qualified Data.Aeson.KeyMap as KM@@ -24,6 +27,9 @@ import qualified Network.Socket as N import qualified Network.WebSockets as WS import System.Environment (setEnv, unsetEnv)+import GHC.Clock (getMonotonicTime)+import GHC.IO.Exception (IOException(..), IOErrorType(..))+import System.IO (stdout) import System.Timeout (timeout) import Test.Hspec @@ -32,25 +38,32 @@ import qualified Plexus.Transport as ST import qualified Plexus.Types as PT import Synapse.Reconnect+import qualified Synapse.Hold as Hold+import System.Directory (doesFileExist, getTemporaryDirectory)+import System.FilePath ((</>))+import System.Posix.Process (ProcessStatus(..), forkProcess, getProcessID, getProcessStatus)+import System.Posix.IO (closeFd, createPipe, dupTo, stdOutput)+import System.Exit (ExitCode(..), exitWith)+import System.IO (BufferMode(..), hSetBuffering)  -- ------------------------------------------------------------------------------ The flaky hub+-- The flaky service --- | How the hub answers one call.+-- | How the service answers one call. data Mode   = Answer   -- ^ confirmed, one item echoing the params, done   | DropMid  -- ^ confirmed, one item, then the connection closed   | DropNow  -- ^ the connection closed before any answer   | Silent   -- ^ confirmed, then nothing — not even a pong -data Hub = Hub-  { hubPort  :: Int-  , hubModes :: IORef [Mode]     -- ^ one per call, the last repeated-  , hubCalls :: IORef [Value]    -- ^ the params of every call, in order+data Service = Service+  { servicePort  :: Int+  , serviceModes :: IORef [Mode]     -- ^ one per call, the last repeated+  , serviceCalls :: IORef [Value]    -- ^ the params of every call, in order   } -withHub :: [Mode] -> (Hub -> IO a) -> IO a-withHub modes act = do+withService :: [Mode] -> (Service -> IO a) -> IO a+withService modes act = do   ms <- newIORef modes   calls <- newIORef []   bracket (open ms calls) (N.close . fst) (\(_, h) -> act h)@@ -62,7 +75,7 @@       N.listen sock 16       port <- fromIntegral <$> N.socketPort sock       void $ forkIO $ acceptLoop sock ms calls-      pure (sock, Hub port ms calls)+      pure (sock, Service port ms calls)  acceptLoop :: N.Socket -> IORef [Mode] -> IORef [Value] -> IO () acceptLoop sock ms calls = do@@ -92,7 +105,7 @@           emit item = send (object             [ "jsonrpc" .= ("2.0" :: Text), "method" .= ("subscription" :: Text)             , "params" .= object ["subscription" .= (7 :: Int), "result" .= item] ])-          meta = object ["provenance" .= (["hub"] :: [Text]), "plexus_hash" .= ("h0" :: Text), "timestamp" .= (0 :: Int)]+          meta = object ["provenance" .= (["service"] :: [Text]), "plexus_hash" .= ("h0" :: Text), "timestamp" .= (0 :: Int)]           dat = emit (object ["type" .= ("data" :: Text), "metadata" .= meta, "content_type" .= ("t.echo" :: Text), "content" .= inner])           done = emit (object ["type" .= ("done" :: Text), "metadata" .= meta])       modifyIORef' calls (++ [inner])@@ -142,7 +155,7 @@   , methodRequestType = Nothing, methodResponseType = Nothing, methodDeprecation = Nothing   , methodParamSchemas = Nothing, methodRole = MethodRoleRpc, methodLongDescription = Nothing   , methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False-  , methodGroup = grp, methodExamples = [] }+  , methodGroup = grp, methodExamples = [], methodInput = Nothing }  -- | Never hang a test: a call that waits forever fails it. within :: Int -> IO a -> IO a@@ -175,31 +188,59 @@   describe "what an outage is" $ do     let upgrade code = PT.ProtocolError ("Connection failed: MalformedResponse (ResponseHead {responseCode = "           <> code <> ", responseMessage = \"x\", responseHeaders = []}) \"Wrong response status or message.\"")-    it "is a proxy in front answering 502 / 503 / 504 while the hub behind it is away (SCAFFOLD-21)" $ do+    it "is a proxy in front answering 502 / 503 / 504 while the service behind it is away (SCAFFOLD-21)" $ do       map (isOutage . upgrade) ["502", "503", "504"] `shouldBe` [True, True, True]       isOutageText "responseCode = 502, responseMessage = \"Bad Gateway\"" `shouldBe` True     it "is not a refused credential, a wrong path, a misdirected request" $       map (isOutage . upgrade) ["401", "403", "404", "421"] `shouldBe` [False, False, False, False]     it "is the server's own 429, as before" $       isOutage (upgrade "429") `shouldBe` True+    it "is a socket's own broken pipe (a peer gone away), as before (SYNAPSE-26)" $+      isOutage (PT.NetworkError "Network.Socket.sendBuf: resource vanished (Broken pipe)") `shouldBe` True +  -- SYNAPSE-26: a run whose stdout's reader went, its last output still in+  -- the buffer (a child process, its stdout a pipe already closed)+  describe "a run with its stdout closed (exitOnClosedOutput)" $ do+    it "exits 141 where it would have succeeded" $+      closedChild (pure ()) `shouldReturn` Just (Exited (ExitFailure 141))+    it "keeps a code of its own — a write of unknown outcome's 75, a refusal's 77" $ do+      closedChild (exitWith (ExitFailure 75)) `shouldReturn` Just (Exited (ExitFailure 75))+      closedChild (exitWith (ExitFailure 77)) `shouldReturn` Just (Exited (ExitFailure 77))++  outageSpec+  -- SYNAPSE-28: the same outages, every call through a connection holder+  -- (in this process, on a socket of the test's own): what the run sees+  -- of an outage is what it saw dialing itself+  describe "through the connection holder" $ beforeAll_ throughHolder $ do+    it "is the holder that answers" $+      withService [Answer] $ \h -> do+        sock <- holderSocket+        acc <- newIORef (0 :: Int)+        Hold.holderCall sock (cfgFor (servicePort h)) (pure ()) "t.call" (object ["method" .= ("t.m" :: Text)])+          (\i -> if isData i then modifyIORef' acc (+ 1) else pure ())+        readIORef acc `shouldReturn` 1+    outageSpec++-- | SYNAPSE-20's outages, as a run meets them.+outageSpec :: Spec+outageSpec = do   describe "the client notices a lost connection" $ do     it "fails a stream whose connection closes, instead of waiting forever" $-      withHub [DropMid] $ \h -> do-        r <- within 10 $ attemptAt (hubPort h) (object []) (pure ()) (\_ -> pure ())+      withService [DropMid] $ \h -> do+        r <- within 10 $ attemptAt (servicePort h) (object []) (pure ()) (\_ -> pure ())         r `shouldSatisfy` \case           Left (PT.ConnectionLost _ True) -> True           _ -> False     it "fails a call dropped before any answer, as sent" $-      withHub [DropNow] $ \h -> do-        r <- within 10 $ attemptAt (hubPort h) (object []) (pure ()) (\_ -> pure ())+      withService [DropNow] $ \h -> do+        r <- within 10 $ attemptAt (servicePort h) (object []) (pure ()) (\_ -> pure ())         r `shouldSatisfy` \case           Left (PT.ConnectionLost _ True) -> True           _ -> False     it "notices a silent peer by its keepalive" $-      withHub [Silent] $ \h -> do+      withService [Silent] $ \h -> do         setEnv "PLEXUS_KEEPALIVE" "1,1"-        r <- within 10 $ attemptAt (hubPort h) (object []) (pure ()) (\_ -> pure ())+        r <- within 10 $ attemptAt (servicePort h) (object []) (pure ()) (\_ -> pure ())         unsetEnv "PLEXUS_KEEPALIVE"         case r of           Left (PT.ConnectionLost why True) -> why `shouldBe` "no answer to a keepalive ping in 1 s"@@ -207,41 +248,41 @@    describe "synapse rides out an outage" $ do     it "sends a read again, and says the call resumed when part had arrived" $-      withHub [DropMid, Answer] $ \h -> do+      withService [DropMid, Answer] $ \h -> do         setReconnectWindow 10         items <- newIORef (0 :: Int)         resumed <- newIORef []-        e <- within 20 $ resilientCall "hub" readShape (attemptAt (hubPort h)) noReauth (object ["id" .= ("A-1" :: Text)])+        e <- within 20 $ resilientCall "service" readShape (attemptAt (servicePort h)) noReauth (object ["id" .= ("A-1" :: Text)])                (\r -> modifyIORef' resumed (r :)) (\i -> if isData i then modifyIORef' items (+ 1) else pure ())         e `shouldBe` Finished         readIORef items `shouldReturn` 2         length <$> readIORef resumed `shouldReturn` 1-        length <$> readIORef (hubCalls h) `shouldReturn` 2+        length <$> readIORef (serviceCalls h) `shouldReturn` 2     it "resumes a stream with since set to when it began" $-      withHub [DropMid, Answer] $ \h -> do+      withService [DropMid, Answer] $ \h -> do         setReconnectWindow 10         resumed <- newIORef []-        e <- within 20 $ resilientCall "hub" sinceShape (attemptAt (hubPort h)) noReauth (object ["id" .= ("A-1" :: Text), "since" .= Null])+        e <- within 20 $ resilientCall "service" sinceShape (attemptAt (servicePort h)) noReauth (object ["id" .= ("A-1" :: Text), "since" .= Null])                (\r -> modifyIORef' resumed (r :)) (\_ -> pure ())         e `shouldBe` Finished-        [first, second] <- readIORef (hubCalls h)+        [first, second] <- readIORef (serviceCalls h)         first `shouldBe` object ["id" .= ("A-1" :: Text), "since" .= Null]         case second of           Object o -> KM.lookup "since" o `shouldSatisfy` \case { Just (Number _) -> True; _ -> False }           _ -> expectationFailure "params"         map rsSince <$> readIORef resumed >>= \ss -> ss `shouldSatisfy` all (/= Nothing)     it "keeps a since the caller gave" $-      withHub [DropMid, Answer] $ \h -> do+      withService [DropMid, Answer] $ \h -> do         setReconnectWindow 10-        _ <- within 20 $ resilientCall "hub" sinceShape (attemptAt (hubPort h)) noReauth (object ["since" .= (42 :: Int)])+        _ <- within 20 $ resilientCall "service" sinceShape (attemptAt (servicePort h)) noReauth (object ["since" .= (42 :: Int)])                (\_ -> pure ()) (\_ -> pure ())-        readIORef (hubCalls h) `shouldReturn` [object ["since" .= (42 :: Int)], object ["since" .= (42 :: Int)]]+        readIORef (serviceCalls h) `shouldReturn` [object ["since" .= (42 :: Int)], object ["since" .= (42 :: Int)]]     it "never sends a write again once it went out" $-      withHub [DropNow, Answer] $ \h -> do+      withService [DropNow, Answer] $ \h -> do         setReconnectWindow 10-        e <- within 20 $ resilientCall "hub" writeShape (attemptAt (hubPort h)) noReauth (object []) (\_ -> pure ()) (\_ -> pure ())+        e <- within 20 $ resilientCall "service" writeShape (attemptAt (servicePort h)) noReauth (object []) (\_ -> pure ()) (\_ -> pure ())         e `shouldSatisfy` \case { WriteUnknown _ -> True; _ -> False }-        length <$> readIORef (hubCalls h) `shouldReturn` 1+        length <$> readIORef (serviceCalls h) `shouldReturn` 1     it "sends a write that never left once the backend is back" $ do       port <- deadPort       setReconnectWindow 20@@ -249,31 +290,96 @@       r <- newEmptyIORef       void $ forkIO $ do         threadDelay 2000000-        withHubAt port [Answer] $ \h -> do+        withServiceAt port [Answer] $ \h -> do           threadDelay 8000000-          readIORef (hubCalls h) >>= writeIORef r . Just . length-      e <- within 20 $ resilientCall "hub" writeShape (attemptAt port) noReauth (object []) (\_ -> pure ()) (\_ -> pure ())+          readIORef (serviceCalls h) >>= writeIORef r . Just . length+      e <- within 20 $ resilientCall "service" writeShape (attemptAt port) noReauth (object []) (\_ -> pure ()) (\_ -> pure ())       e `shouldBe` Finished     it "gives up when the window runs out" $ do       port <- deadPort       setReconnectWindow 2-      e <- within 20 $ resilientCall "hub" readShape (attemptAt port) noReauth (object []) (\_ -> pure ()) (\_ -> pure ())+      e <- within 20 $ resilientCall "service" readShape (attemptAt port) noReauth (object []) (\_ -> pure ()) (\_ -> pure ())       e `shouldSatisfy` \case { GaveUp 2 _ -> True; _ -> False }     it "with no window, reports the loss as before" $-      withHub [DropMid] $ \h -> do+      withService [DropMid] $ \h -> do         setReconnectWindow 0-        e <- within 20 $ resilientCall "hub" readShape (attemptAt (hubPort h)) noReauth (object []) (\_ -> pure ()) (\_ -> pure ())+        e <- within 20 $ resilientCall "service" readShape (attemptAt (servicePort h)) noReauth (object []) (\_ -> pure ()) (\_ -> pure ())         e `shouldSatisfy` \case { Failed (PT.ConnectionLost _ True) -> True; _ -> False }++  describe "a closed stdout is not an outage (SYNAPSE-26)" $ do+    it "ends a write whose answer cannot be printed, sent once, with no pause" $+      withService [Answer] $ \h -> do+        setReconnectWindow 10+        t0 <- getMonotonicTime+        e <- within 20 $ resilientCall "service" writeShape (attemptAt (servicePort h)) noReauth (object []) (\_ -> pure ()) (\_ -> throwIO stdoutClosed)+        t1 <- getMonotonicTime+        length <$> readIORef (serviceCalls h) `shouldReturn` 1+        e `shouldNotBe` Finished+        e `shouldSatisfy` \case { GaveUp{} -> False; WriteUnknown{} -> False; _ -> True }+        (t1 - t0) `shouldSatisfy` (< 1)+    it "ends a read whose item cannot be printed, sent once, even with no window" $+      withService [Answer] $ \h -> do+        setReconnectWindow 0+        e <- within 20 $ resilientCall "service" readShape (attemptAt (servicePort h)) noReauth (object []) (\_ -> pure ()) (\_ -> throwIO stdoutClosed)+        length <$> readIORef (serviceCalls h) `shouldReturn` 1+        show e `shouldNotContain` "Transport"+        e `shouldSatisfy` \case { Failed{} -> False; _ -> True }+    it "with stdout open, a read cut mid-answer is sent again and printed whole" $+      withService [DropMid, Answer] $ \h -> do+        setReconnectWindow 10+        printed <- newIORef (0 :: Int)+        e <- within 20 $ resilientCall "service" readShape (attemptAt (servicePort h)) noReauth (object [])+               (\_ -> pure ()) (\i -> if isData i then modifyIORef' printed (+ 1) else pure ())+        e `shouldBe` Finished+        readIORef printed `shouldReturn` 2+        length <$> readIORef (serviceCalls h) `shouldReturn` 2   where+    -- what a write to stdout raises once its reader has gone (GHC ignores+    -- SIGPIPE, so EPIPE comes back as this)+    stdoutClosed = IOError (Just stdout) ResourceVanished "hPutChar" "Broken pipe" (Just 32) Nothing     newEmptyIORef :: IO (IORef (Maybe Int))     newEmptyIORef = newIORef Nothing --- | A hub on a port already chosen.-withHubAt :: Int -> [Mode] -> (Hub -> IO a) -> IO a-withHubAt port modes act = do+-- | SYNAPSE-26: run @body@ under 'exitOnClosedOutput' in a child whose+-- stdout is a pipe nobody reads, with output left in its buffer.+closedChild :: IO () -> IO (Maybe ProcessStatus)+closedChild body = do+  (r, w) <- createPipe+  closeFd r+  pid <- forkProcess $ do+    _ <- dupTo w stdOutput+    closeFd w+    hSetBuffering stdout (BlockBuffering Nothing)+    exitOnClosedOutput (putStr "the answer, still in the buffer" >> body)+  closeFd w+  getProcessStatus True False pid++-- | SYNAPSE-28: the holder's socket for these tests.+holderSocket :: IO FilePath+holderSocket = do+  tmp <- getTemporaryDirectory+  pid <- getProcessID+  pure (tmp </> ("synapse-reconnect-test-" <> show pid <> ".sock"))++-- | Start a holder in this process and route every call through it.+throughHolder :: IO ()+throughHolder = do+  sock <- holderSocket+  _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 600) `catch'` ()+  let wait (0 :: Int) = pure ()+      wait n = doesFileExist sock >>= \ok -> if ok then pure () else threadDelay 20000 >> wait (n - 1)+  wait 250+  _ <- Hold.installRouter Hold.RouterOpts { Hold.roHold = Just (const (pure (Just sock))), Hold.roHoldFor = 600 }+  pure ()+  where+    catch' act v = void (try act :: IO (Either SomeException ())) >> pure v++-- | A service on a port already chosen.+withServiceAt :: Int -> [Mode] -> (Service -> IO a) -> IO a+withServiceAt port modes act = do   ms <- newIORef modes   calls <- newIORef []-  bracket (open ms calls) N.close (\_ -> act (Hub port ms calls))+  bracket (open ms calls) N.close (\_ -> act (Service port ms calls))   where     open ms calls = do       sock <- N.socket N.AF_INET N.Stream N.defaultProtocol
test/RenderSpec.hs view
@@ -10,7 +10,7 @@ -- a usage line naming the required flags, aligned options with their types -- and allowed values, examples as command lines (the schema's, else one -- synthesised), and, in a caller's view, what it requires. A schema from a--- hub that says none of the new fields still renders sensibly.+-- service that says none of the new fields still renders sensibly. module Main (main) where  import Data.Aeson (Value)@@ -35,7 +35,7 @@   , methodRequestType = Nothing, methodResponseType = Nothing, methodDeprecation = Nothing   , methodParamSchemas = Nothing, methodRole = MethodRoleRpc   , methodLongDescription = Nothing, methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False-  , methodGroup = Nothing, methodExamples = [] }+  , methodGroup = Nothing, methodExamples = [], methodInput = Nothing }  grouped :: Text -> MethodSchema -> MethodSchema grouped g m = m { methodGroup = Just g }@@ -44,9 +44,9 @@ -- Fixtures -- --------------------------------------------------------------------------- --- | A hub with children and ungrouped methods (an older hub's shape).-hub :: PluginSchema-hub = PluginSchema+-- | A parent with children and ungrouped methods (an older service's shape).+parentSchema :: PluginSchema+parentSchema = PluginSchema   { psNamespace = "menger", psVersion = "1.0.0"   , psDescription = "Central routing and introspection"   , psLongDescription = Nothing, psHash = "h0"@@ -113,7 +113,7 @@   "required": ["ticket", "value"] }|] --- | set_status as a hub with SYNAPSE-13's fields serves it.+-- | set_status as a service with SYNAPSE-13's fields serves it. setStatus :: MethodSchema setStatus = (method "set_status" "Set a ticket's status (not a doc's: a doc has no lifecycle)" (Just setStatusParams))   { methodLongDescription = Just "Yields exactly one event: `StatusChanged`, `NotFound`, or `Error`.\n\nA doc has no lifecycle."@@ -134,7 +134,7 @@         , mpSchema = Just ms, mpCaller = caller }   in (md, renderMethodPage page ir md) --- | An older hub's set_status: no long description, examples, values,+-- | An older service's set_status: no long description, examples, values, -- grant or group — and only the IR (no schema) at hand. oldPage :: Text oldPage =@@ -168,10 +168,10 @@ main :: IO () main = do   let listing = renderListing defaultStyle (Listing "synapse -P 4455 menger tickets" Nothing) tickets-      hubListing = renderListing defaultStyle (Listing "synapse -P 4455 menger" Nothing) hub+      parentListing = renderListing defaultStyle (Listing "synapse -P 4455 menger" Nothing) parentSchema       (_, page) = pageOf False setStatus       (_, callerPage) = pageOf True setStatus-  mapM_ TIO.putStrLn [listing, hubListing, page, callerPage, oldPage]+  mapM_ TIO.putStrLn [listing, parentListing, page, callerPage, oldPage]   hspec $ do     describe "a listing (gh's shape)" $ do       let ls = linesOf listing@@ -207,8 +207,8 @@         filter ((> 80) . T.length) ls `shouldBe` []         ("\n\n\n" `T.isInfixOf` listing) `shouldBe` False -    describe "a listing of a hub with no groups (an older hub)" $ do-      let ls = linesOf hubListing+    describe "a listing of a parent with no groups (an older service)" $ do+      let ls = linesOf parentListing       it "lists activations, then methods, alphabetically" $ do         filter (`elem` ["ACTIVATIONS", "METHODS"]) ls `shouldBe` ["ACTIVATIONS", "METHODS"]         (indexOf ls "  comments " < indexOf ls "  tickets ", indexOf ls "  call " < indexOf ls "  hash ") `shouldBe` (True, True)@@ -285,7 +285,7 @@       it "fits in 80 columns, its command lines (usage, examples) aside" $         filter (\l -> T.length l > 80 && not ("  synapse " `T.isPrefixOf` l) && not ("Usage: " `T.isPrefixOf` l)) ls `shouldBe` [] -    describe "a method's page from an older hub (none of the new fields)" $ do+    describe "a method's page from an older service (none of the new fields)" $ do       let ls = linesOf oldPage       it "still has its usage line and options" $ do         lineWith ls "Usage:" `shouldBe` "Usage: synapse menger tickets set_status --id <ID> --status <STATUS>"
test/Req8RenderSpec.hs view
@@ -55,7 +55,7 @@       , methodDeprecation   = Nothing       , methodParamSchemas  = Nothing       , methodRole          = defaultRole-      , methodLongDescription = Nothing, methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False, methodGroup = Nothing, methodExamples = []+      , methodLongDescription = Nothing, methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False, methodGroup = Nothing, methodExamples = [], methodInput = Nothing       }  -- | Stub role — renderSchema doesn't branch on role for this test.
test/TlsSpec.hs view
@@ -5,7 +5,7 @@  -- | SCAFFOLD-21: synapse speaks wss. A TLS terminator of the test's own — -- a CA and a certificate for @localhost@ made with openssl for this run,--- in front of the mock hub, as the edge sits in front of a hosted app —+-- in front of the mock service, as the edge sits in front of a hosted app — -- and against it: the probe, a call and a key login over wss at a path, -- with the request's path and Host as the edge would see them; a server -- the trust store does not vouch for, and a certificate for another name,@@ -34,14 +34,14 @@ import Test.Hspec  import qualified Katip-import MockHub (todaysHub, withMockHub)+import MockService (todaysService, withMockService) import Synapse.Backend.Discovery (probeBackendAtEp) import Synapse.Endpoint (Endpoint(..)) import qualified Synapse.Identity.Proof as Proof import qualified Synapse.Identity.Session as Session import qualified Synapse.Log as Log import Synapse.Monad (initEnvAt, runSynapseM)-import Synapse.Schema.Types (pattern HubData)+import Synapse.Schema.Types (pattern ServiceData) import Synapse.Transport (invoke, invokeStreamingWithBidir) import Synapse.Reconnect (CallShape(..)) import Plexus.Types (Response(..))@@ -82,7 +82,7 @@ type Heads = IORef [BS.ByteString]  -- | A TLS terminator on 127.0.0.1 (a port the OS picks) forwarding each--- connection to the plain hub at @backend@, as the edge does.+-- connection to the plain service at @backend@, as the edge does. withTerminator :: Pki -> Int -> (Int -> Heads -> IO a) -> IO a withTerminator pki backend act = do   cred <- TLS.credentialLoadX509 (pkiCert pki) (pkiKey pki) >>= either fail pure@@ -110,7 +110,7 @@         seen <- newIORef False         let down = forever $ do               b <- NB.recv up 65536-              if BS.null b then fail "hub closed" else TLS.sendData ctx (LBS.fromStrict b)+              if BS.null b then fail "service closed" else TLS.sendData ctx (LBS.fromStrict b)         t <- forkIO (void (try @SomeException down) >> TLS.bye ctx)         flip finally (killThread t) $ forever $ do           b <- TLS.recvData ctx@@ -126,7 +126,7 @@ specs = do   describe "wss through a TLS terminator, the CA given with --cacert" $ do     it "answers the _info probe, dialing the path with the Host the certificate names" $ \pki ->-      withMockHub todaysHub $ \hub -> withTerminator pki hub $ \port heads -> do+      withMockService todaysService $ \service -> withTerminator pki service $ \port heads -> do         let ep = Endpoint "localhost" port True "/ws" [pkiCa pki]         probeBackendAtEp [] ep `shouldReturn` Right "menger"         hs <- readIORef heads@@ -137,17 +137,17 @@         BS8.lines h `shouldSatisfy` any (== BS8.pack ("Host: localhost:" <> show port <> "\r"))      it "carries a call and its answer" $ \pki ->-      withMockHub todaysHub $ \hub -> withTerminator pki hub $ \port _ -> do+      withMockService todaysService $ \service -> withTerminator pki service $ \port _ -> do         lg <- logger         env <- initEnvAt (Endpoint "localhost" port True "/ws" [pkiCa pki]) "menger" lg Nothing         r <- runSynapseM env (invoke ["tickets"] "get" (object [("id", String "MENGER-12")]))         case r of-          Right items -> [v | HubData _ _ _ (Object v) <- items, KM.lookup "id" v == Just (String "MENGER-12")]+          Right items -> [v | ServiceData _ _ _ (Object v) <- items, KM.lookup "id" v == Just (String "MENGER-12")]                            `shouldSatisfy` (not . null)           Left e -> expectationFailure (show e)      it "logs in from a key, the proof's audience the server's wss origin" $ \pki ->-      withMockHub todaysHub $ \hub -> withTerminator pki hub $ \port heads -> do+      withMockService todaysService $ \service -> withTerminator pki service $ \port heads -> do         lg <- logger         let ep = Endpoint "localhost" port True "/ws" [pkiCa pki]             seed = either (error . T.unpack) id (Proof.seedFromBytes (BS.pack [1 .. 32]))@@ -161,7 +161,7 @@         mapM_ (\p -> KM.lookup "aud" p `shouldBe` Just (String ("wss://localhost:" <> T.pack (show port)))) proofs      it "carries a bidirectional request and its answer (respond goes over wss too)" $ \pki ->-      withMockHub todaysHub $ \hub -> withTerminator pki hub $ \port heads -> do+      withMockService todaysService $ \service -> withTerminator pki service $ \port heads -> do         lg <- logger         env <- initEnvAt (Endpoint "localhost" port True "/ws" [pkiCa pki]) "menger" lg Nothing         seen <- newIORef []@@ -174,7 +174,7 @@         r `shouldSatisfy` either (const False) (const True)         readIORef asked `shouldReturn` ["req-1"]         items <- readIORef seen-        [v | HubData _ _ _ (Object v) <- items, KM.lookup "type" v == Just (String "answered")]+        [v | ServiceData _ _ _ (Object v) <- items, KM.lookup "type" v == Just (String "answered")]           `shouldBe` [KM.fromList [("type", String "answered"), ("response", object [("type", String "confirmed"), ("value", Bool True)])]]         -- the call and the respond: two upgrades, both through TLS at the path         hs <- readIORef heads@@ -182,19 +182,19 @@    describe "refusing what it cannot verify" $ do     it "refuses a certificate the trust store does not vouch for — nothing is sent" $ \pki ->-      withMockHub todaysHub $ \hub -> withTerminator pki hub $ \port heads -> do+      withMockService todaysService $ \service -> withTerminator pki service $ \port heads -> do         r <- probeBackendAtEp [] (Endpoint "localhost" port True "/ws" [pkiOtherCa pki])         r `shouldSatisfy` either (const True) (const False)         readIORef heads `shouldReturn` []      it "refuses a certificate for another name (127.0.0.1 is not localhost)" $ \pki ->-      withMockHub todaysHub $ \hub -> withTerminator pki hub $ \port heads -> do+      withMockService todaysService $ \service -> withTerminator pki service $ \port heads -> do         r <- probeBackendAtEp [] (Endpoint "127.0.0.1" port True "/ws" [pkiCa pki])         r `shouldSatisfy` either (const True) (const False)         readIORef heads `shouldReturn` []      it "refuses a CA file that holds no certificate" $ \pki ->-      withMockHub todaysHub $ \hub -> withTerminator pki hub $ \port _ -> do+      withMockService todaysService $ \service -> withTerminator pki service $ \port _ -> do         r <- probeBackendAtEp [] (Endpoint "localhost" port True "/ws" [pkiKey pki])         either T.unpack (const "") r `shouldContain` "holds no PEM certificate"
test/TypeRefJson.hs view
@@ -3,10 +3,12 @@ -- | Quick test to see TypeRef JSON serialization module Main where -import Data.Aeson (encode)+import Control.Monad (forM_, unless)+import Data.Aeson (decode, encode) import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Text (Text)+import System.Exit (exitFailure)  import Synapse.IR.Types @@ -64,3 +66,30 @@         }   putStrLn "   JSON (pretty):"   BSL.putStrLn (encodePretty fd)+  putStrLn ""++  -- SYNAPSE-CC-8 (IR 2.1): each new constructor encodes as the contract says+  -- and decodes back; IR 2.0's RefAny (a serde_json::Value) reads as RefJson+  putStrLn "6. IR 2.1 constructors (SYNAPSE-CC-8):"+  let str = RefPrimitive "string" Nothing+      cases :: [(TypeRef, BSL.ByteString)]+      cases =+        [ (RefJson, "{\"tag\":\"RefJson\"}")+        , (RefMap str, "{\"contents\":{\"contents\":[\"string\",null],\"tag\":\"RefPrimitive\"},\"tag\":\"RefMap\"}")+        , (RefTuple [str, str], "{\"contents\":[{\"contents\":[\"string\",null],\"tag\":\"RefPrimitive\"},{\"contents\":[\"string\",null],\"tag\":\"RefPrimitive\"}],\"tag\":\"RefTuple\"}")+        , (RefRefined (RefPrimitive "integer" (Just "uint64")) noRefinements { rnMinimum = Just 1 }, "{\"contents\":[{\"contents\":[\"integer\",\"uint64\"],\"tag\":\"RefPrimitive\"},{\"minimum\":1}],\"tag\":\"RefRefined\"}")+        , (RefChild "tickets.inputs", "{\"contents\":\"tickets.inputs\",\"tag\":\"RefChild\"}")+        , (RefUnknown, "{\"tag\":\"RefUnknown\"}")+        ]+  failures <- fmap concat $ mapM (\(t, j) -> do+      let ok = encode t == j && decode j == Just t+      putStrLn ("   " <> (if ok then "ok   " else "FAIL ") <> BSL.unpack j)+      pure [ () | not ok ]) cases+  let legacy = decode "{\"tag\":\"RefAny\"}" :: Maybe TypeRef+  putStrLn ("   2.0's RefAny reads as " <> show legacy)+  let refusal = Refusal "tickets.Reply" "oneOf" (Just 2) "why"+      refusalOk = decode (encode refusal) == Just refusal+      reprOk = encode External == "\"external\"" && decode "\"untagged\"" == Just Untagged+  forM_ [("Refusal", refusalOk), ("EnumRepr", reprOk), ("legacy RefAny", legacy == Just RefJson)] $ \(n, ok) ->+    putStrLn ("   " <> (if ok then "ok   " else "FAIL ") <> n)+  unless (null failures && refusalOk && reprOk && legacy == Just RefJson) exitFailure