diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2025-2026 hypermemetic + +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. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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] [--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 diff --git a/bench/IRBench.hs b/bench/IRBench.hs new file mode 100644 --- /dev/null +++ b/bench/IRBench.hs @@ -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 diff --git a/plexus-synapse.cabal b/plexus-synapse.cabal --- a/plexus-synapse.cabal +++ b/plexus-synapse.cabal @@ -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" diff --git a/src/Synapse/Algebra/Recursion.hs b/src/Synapse/Algebra/Recursion.hs --- a/src/Synapse/Algebra/Recursion.hs +++ b/src/Synapse/Algebra/Recursion.hs @@ -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) diff --git a/src/Synapse/Auth.hs b/src/Synapse/Auth.hs --- a/src/Synapse/Auth.hs +++ b/src/Synapse/Auth.hs @@ -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) diff --git a/src/Synapse/Auth/Loopback.hs b/src/Synapse/Auth/Loopback.hs --- a/src/Synapse/Auth/Loopback.hs +++ b/src/Synapse/Auth/Loopback.hs @@ -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:@, asks the hub for a +-- synapse listens on @127.0.0.1:@, 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:/cb@. +-- | Where the service sends the browser back: @http://127.0.0.1:/cb@. loopbackRedirect :: Loopback -> Text loopbackRedirect lb = "http://127.0.0.1:" <> T.pack (show (lbPort lb)) <> "/cb" diff --git a/src/Synapse/Backend/Discovery.hs b/src/Synapse/Backend/Discovery.hs --- a/src/Synapse/Backend/Discovery.hs +++ b/src/Synapse/Backend/Discovery.hs @@ -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 diff --git a/src/Synapse/Bidir.hs b/src/Synapse/Bidir.hs --- a/src/Synapse/Bidir.hs +++ b/src/Synapse/Bidir.hs @@ -17,6 +17,10 @@ -- - @--bidir-respond@: Prints request to stdout as JSON, returns Nothing so the -- agent can respond via a separate @synapse \ 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 diff --git a/src/Synapse/CLI/Help.hs b/src/Synapse/CLI/Help.hs --- a/src/Synapse/CLI/Help.hs +++ b/src/Synapse/CLI/Help.hs @@ -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 diff --git a/src/Synapse/CLI/Parse.hs b/src/Synapse/CLI/Parse.hs --- a/src/Synapse/CLI/Parse.hs +++ b/src/Synapse/CLI/Parse.hs @@ -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"] diff --git a/src/Synapse/CLI/Support.hs b/src/Synapse/CLI/Support.hs --- a/src/Synapse/CLI/Support.hs +++ b/src/Synapse/CLI/Support.hs @@ -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 diff --git a/src/Synapse/CLI/Template.hs b/src/Synapse/CLI/Template.hs --- a/src/Synapse/CLI/Template.hs +++ b/src/Synapse/CLI/Template.hs @@ -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 <> "}}" diff --git a/src/Synapse/Endpoint.hs b/src/Synapse/Endpoint.hs --- a/src/Synapse/Endpoint.hs +++ b/src/Synapse/Endpoint.hs @@ -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://.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 diff --git a/src/Synapse/Find.hs b/src/Synapse/Find.hs --- a/src/Synapse/Find.hs +++ b/src/Synapse/Find.hs @@ -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 diff --git a/src/Synapse/Hold.hs b/src/Synapse/Hold.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Hold.hs @@ -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 +-- (@.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 () diff --git a/src/Synapse/IR/Builder.hs b/src/Synapse/IR/Builder.hs --- a/src/Synapse/IR/Builder.hs +++ b/src/Synapse/IR/Builder.hs @@ -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 diff --git a/src/Synapse/IR/Cache.hs b/src/Synapse/IR/Cache.hs --- a/src/Synapse/IR/Cache.hs +++ b/src/Synapse/IR/Cache.hs @@ -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 diff --git a/src/Synapse/IR/Read.hs b/src/Synapse/IR/Read.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/IR/Read.hs @@ -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 diff --git a/src/Synapse/IR/Types.hs b/src/Synapse/IR/Types.hs --- a/src/Synapse/IR/Types.hs +++ b/src/Synapse/IR/Types.hs @@ -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: +-- @[.].@ · @()@ · +-- @ 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 -- ^ @{"": "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, StandardResponse>. -- -- 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 diff --git a/src/Synapse/Identity/Command.hs b/src/Synapse/Identity/Command.hs --- a/src/Synapse/Identity/Command.hs +++ b/src/Synapse/Identity/Command.hs @@ -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]@. diff --git a/src/Synapse/Identity/Session.hs b/src/Synapse/Identity/Session.hs --- a/src/Synapse/Identity/Session.hs +++ b/src/Synapse/Identity/Session.hs @@ -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 @\.\@ 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 diff --git a/src/Synapse/Identity/Store.hs b/src/Synapse/Identity/Store.hs --- a/src/Synapse/Identity/Store.hs +++ b/src/Synapse/Identity/Store.hs @@ -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 @.call@) + , srBackend :: Text -- ^ the service's name (its @.call@) } deriving (Eq, Show) instance ToJSON SessionRec where diff --git a/src/Synapse/Monad.hs b/src/Synapse/Monad.hs --- a/src/Synapse/Monad.hs +++ b/src/Synapse/Monad.hs @@ -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 diff --git a/src/Synapse/Output.hs b/src/Synapse/Output.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Output.hs @@ -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 () diff --git a/src/Synapse/Reconnect.hs b/src/Synapse/Reconnect.hs --- a/src/Synapse/Reconnect.hs +++ b/src/Synapse/Reconnect.hs @@ -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, @.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" diff --git a/src/Synapse/Renderer.hs b/src/Synapse/Renderer.hs --- a/src/Synapse/Renderer.hs +++ b/src/Synapse/Renderer.hs @@ -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) diff --git a/src/Synapse/Schema/Types.hs b/src/Synapse/Schema/Types.hs --- a/src/Synapse/Schema/Types.hs +++ b/src/Synapse/Schema/Types.hs @@ -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 diff --git a/src/Synapse/SchemaStore.hs b/src/Synapse/SchemaStore.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/SchemaStore.hs @@ -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 () diff --git a/src/Synapse/Self/Debugger.hs b/src/Synapse/Self/Debugger.hs --- a/src/Synapse/Self/Debugger.hs +++ b/src/Synapse/Self/Debugger.hs @@ -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) diff --git a/src/Synapse/Self/Examples.hs b/src/Synapse/Self/Examples.hs --- a/src/Synapse/Self/Examples.hs +++ b/src/Synapse/Self/Examples.hs @@ -39,8 +39,12 @@ "'[" <> generateExampleValue ir inner <> "]'" RefOptional inner -> generateExampleValue ir inner - RefAny -> "{}" + RefJson -> "{}" RefUnknown -> "" + RefMap _ -> "{}" + RefTuple ts -> "'[" <> T.intercalate "," (map (generateExampleValue ir) ts) <> "]'" + RefRefined inner _ -> generateExampleValue ir inner + RefChild _ -> "" -- | 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 [] -> "{}" diff --git a/src/Synapse/Transport.hs b/src/Synapse/Transport.hs --- a/src/Synapse/Transport.hs +++ b/src/Synapse/Transport.hs @@ -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 diff --git a/test/AuthSpec.hs b/test/AuthSpec.hs --- a/test/AuthSpec.hs +++ b/test/AuthSpec.hs @@ -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 diff --git a/test/BidirIntegrationSpec.hs b/test/BidirIntegrationSpec.hs --- a/test/BidirIntegrationSpec.hs +++ b/test/BidirIntegrationSpec.hs @@ -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 diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -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"] diff --git a/test/DeprecationSpec.hs b/test/DeprecationSpec.hs --- a/test/DeprecationSpec.hs +++ b/test/DeprecationSpec.hs @@ -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 diff --git a/test/EndpointSpec.hs b/test/EndpointSpec.hs --- a/test/EndpointSpec.hs +++ b/test/EndpointSpec.hs @@ -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" diff --git a/test/FindSpec.hs b/test/FindSpec.hs --- a/test/FindSpec.hs +++ b/test/FindSpec.hs @@ -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 diff --git a/test/HoldSpec.hs b/test/HoldSpec.hs new file mode 100644 --- /dev/null +++ b/test/HoldSpec.hs @@ -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) diff --git a/test/IR12MethodRoleSpec.hs b/test/IR12MethodRoleSpec.hs --- a/test/IR12MethodRoleSpec.hs +++ b/test/IR12MethodRoleSpec.hs @@ -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) diff --git a/test/IRCoverageSpec.hs b/test/IRCoverageSpec.hs new file mode 100644 --- /dev/null +++ b/test/IRCoverageSpec.hs @@ -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) diff --git a/test/IRFixture.hs b/test/IRFixture.hs new file mode 100644 --- /dev/null +++ b/test/IRFixture.hs @@ -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": +-- }@, as @.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 diff --git a/test/IRSpec.hs b/test/IRSpec.hs --- a/test/IRSpec.hs +++ b/test/IRSpec.hs @@ -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 -> [] + _ -> [] diff --git a/test/MockHub.hs b/test/MockHub.hs deleted file mode 100644 --- a/test/MockHub.hs +++ /dev/null @@ -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@, @.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 - _ -> "" diff --git a/test/MockService.hs b/test/MockService.hs new file mode 100644 --- /dev/null +++ b/test/MockService.hs @@ -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@, @.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, @.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 + _ -> "" diff --git a/test/NamingGateSpec.hs b/test/NamingGateSpec.hs new file mode 100644 --- /dev/null +++ b/test/NamingGateSpec.hs @@ -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) diff --git a/test/OutputSpec.hs b/test/OutputSpec.hs new file mode 100644 --- /dev/null +++ b/test/OutputSpec.hs @@ -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 diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs --- a/test/ParseSpec.hs +++ b/test/ParseSpec.hs @@ -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 diff --git a/test/PipeSpec.hs b/test/PipeSpec.hs new file mode 100644 --- /dev/null +++ b/test/PipeSpec.hs @@ -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 diff --git a/test/ReconnectSpec.hs b/test/ReconnectSpec.hs --- a/test/ReconnectSpec.hs +++ b/test/ReconnectSpec.hs @@ -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 diff --git a/test/RenderSpec.hs b/test/RenderSpec.hs --- a/test/RenderSpec.hs +++ b/test/RenderSpec.hs @@ -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 --status " diff --git a/test/Req8RenderSpec.hs b/test/Req8RenderSpec.hs --- a/test/Req8RenderSpec.hs +++ b/test/Req8RenderSpec.hs @@ -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. diff --git a/test/TlsSpec.hs b/test/TlsSpec.hs --- a/test/TlsSpec.hs +++ b/test/TlsSpec.hs @@ -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" diff --git a/test/TypeRefJson.hs b/test/TypeRefJson.hs --- a/test/TypeRefJson.hs +++ b/test/TypeRefJson.hs @@ -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