diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -15,983 +15,1773 @@ -- is passed through for method invocation. module Main where -import Control.Monad (when) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (asks) -import Data.Aeson -import qualified Data.Aeson.Key as K -import qualified Data.Aeson.KeyMap as KM -import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.Maybe (isJust) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import qualified Data.Text.Encoding as TE -import Options.Applicative -import Data.Version (showVersion) -import qualified Paths_plexus_synapse as Meta -import System.Directory (doesFileExist, getHomeDirectory) -import System.Exit (exitFailure, exitSuccess) -import System.FilePath (()) -import System.IO (hPutStrLn, stderr, hFlush, stdout) - - -import Synapse.Schema.Types -import Synapse.Monad (SynapseM, SynapseEnv(..), SynapseError(..), BackendErrorType(..), TransportContext(..), TransportErrorCategory(..), initEnv, runSynapseM, throwNav, throwTransport, throwParse, throwBackend) -import qualified Synapse.Log as Log -import qualified Katip -import Synapse.Algebra.Navigate -import Synapse.Algebra.Render (renderSchema) -import Synapse.CLI.Help (renderMethodHelp) -import Synapse.CLI.Parse (parseParams) -import qualified Synapse.CLI.Parse as Parse -import Synapse.IR.Types (IR, irMethods, MethodDef) -import qualified Data.Map.Strict as Map -import qualified Synapse.CLI.Template as TemplateIR -import Synapse.Deprecation (emitActivationWarning, emitMethodWarning) -import Synapse.Transport -import Synapse.Bidir (BidirMode(..), parseBidirMode, detectBidirMode, handleBidirRequest) -import Plexus.Types (Response(..)) -import Synapse.CLI.Transform (mkTransformEnv, transformParams, defaultTransformers, injectBooleanDefaults, injectSmartDefaults) -import Synapse.IR.Builder (buildIR) -import Synapse.Renderer (RendererConfig, defaultRendererConfig, renderItem, prettyValue, withMethodPath) -import System.Directory (createDirectoryIfMissing, getHomeDirectory) -import System.FilePath (()) -import qualified Synapse.Self.Commands as Self -import Synapse.Backend.Discovery (Backend(..), BackendDiscovery(..), registryDiscovery, pingBackends, getBackendAt, registerWithRegistry) - --- ============================================================================ --- Types --- ============================================================================ - --- | Synapse-level options (must appear before backend) --- Controls connection settings and output format -data SynapseOpts = SynapseOpts - { soHost :: Text -- ^ Registry host for discovery - , soPort :: Int -- ^ Registry port for discovery - , soJson :: Bool -- ^ Output raw JSON stream items - , soRaw :: Bool -- ^ Output raw content (no templates) - , soDryRun :: Bool -- ^ Show request without sending - , soSchema :: Bool -- ^ Fetch raw schema JSON - , soGenerate :: Bool -- ^ Generate templates from IR - , soEmitIR :: Bool -- ^ Emit IR for code generation - , soParams :: Maybe Text -- ^ JSON params via -p - , soRpc :: Maybe Text -- ^ Raw JSON-RPC passthrough - , soGeneratorInfo :: [Text] -- ^ Generator tool info (tool:version pairs) - , soBidirMode :: Maybe Text -- ^ Bidirectional mode override - , soBidirCmd :: Maybe Text -- ^ Bidirectional subprocess command (--bidir-cmd) - , soNoCache :: Bool -- ^ Disable IR caching - , soLogLevel :: Maybe Text -- ^ Log level: info, debug, trace - , soLogSubsystems :: [Text] -- ^ Filter logs by subsystems (empty = all) - , soToken :: Maybe Text -- ^ JWT sent as Cookie: access_token= - , soTokenFile :: Maybe Text -- ^ Path to token file (overridden by --token) - , soNoDeprecationWarnings :: Bool -- ^ Suppress invocation-time deprecation warnings (IR-15) - } - deriving Show - --- | Full CLI arguments after two-phase parsing -data Args = Args - { argOpts :: SynapseOpts -- ^ Synapse-level options - , argBackend :: Maybe Text -- ^ Backend name (first positional) - , argPath :: [Text] -- ^ Path segments and --key value params (raw) - } - deriving Show - - --- ============================================================================ --- Constants --- ============================================================================ - -defaultHost :: Text -defaultHost = "127.0.0.1" - -defaultPort :: Int -defaultPort = 4444 - --- ============================================================================ --- Logging Helper --- ============================================================================ - --- | Create a logger from command-line options --- Default: ErrorS (only show errors) -makeLoggerFromOpts :: SynapseOpts -> IO Log.Logger -makeLoggerFromOpts opts = do - let level = case soLogLevel opts of - Nothing -> Katip.ErrorS -- Default: only errors - Just levelStr -> parseLogLevel levelStr - Log.makeLogger level - where - parseLogLevel "error" = Katip.ErrorS - parseLogLevel "warn" = Katip.WarningS - parseLogLevel "info" = Katip.InfoS - parseLogLevel "debug" = Katip.DebugS - parseLogLevel _ = Katip.ErrorS -- Default to error - --- ============================================================================ --- Token Resolution --- ============================================================================ - --- | Resolve the auth token to use for this invocation. --- --- Priority: --- 1. --token (explicit, highest priority) --- 2. --token-file (explicit file) --- 3. ~/.plexus/tokens/ (per-backend default) --- --- Token files contain just the raw JWT, optionally with a trailing newline. -resolveToken :: SynapseOpts -> Text -> IO (Maybe Text) -resolveToken opts backend = - case soToken opts of - Just tok -> pure (Just tok) - Nothing -> do - mPath <- case soTokenFile opts of - Just path -> pure (Just (T.unpack path)) - Nothing -> do - home <- getHomeDirectory - let defaultPath = home ".plexus" "tokens" T.unpack backend - exists <- doesFileExist defaultPath - pure $ if exists then Just defaultPath else Nothing - case mPath of - Nothing -> pure Nothing - Just path -> do - contents <- TIO.readFile path - let tok = T.strip contents - pure $ if T.null tok then Nothing else Just tok - --- ============================================================================ --- Argument Splitting --- ============================================================================ --- Main --- ============================================================================ - -main :: IO () -main = do - args <- execParser argsInfo - let opts = argOpts args - - -- Initialize logger (default: ErrorS, only show errors) - logger <- makeLoggerFromOpts opts - - Log.logDebug logger Log.SubsystemCLI "synapse starting..." - - -- Use specified host/port for registry discovery - let discovery = registryDiscovery (soHost opts) (soPort opts) - - -- Get the backend at the connection point (host:port) - -- If it has a registry plugin, that's used for discovering other backends - Log.logDebug logger Log.SubsystemDiscovery $ - "Checking backend at " <> soHost opts <> ":" <> T.pack (show (soPort opts)) - - maybeBackend <- getBackendAt (soHost opts) (soPort opts) - - Log.logDebug logger Log.SubsystemDiscovery $ - "Backend check complete: " <> T.pack (show maybeBackend) - let hostBackend = maybe "plexus" id maybeBackend - - -- Auto-register: if we're connecting to a non-default port, push the - -- discovered backend to the registry at the default port (if reachable) - let targetPort = soPort opts - targetHost = soHost opts - when (targetPort /= defaultPort) $ do - case maybeBackend of - Just name -> do - -- Check if the registry is at the default port - maybeRegistry <- getBackendAt targetHost defaultPort - case maybeRegistry of - Just registryName -> - registerWithRegistry targetHost defaultPort registryName - name targetHost targetPort - Nothing -> pure () - Nothing -> pure () - - case argBackend args of - Nothing - -- Suppress banner for data output modes - | soEmitIR opts || soSchema opts || soJson opts || soRaw opts -> - runWithDiscovery discovery hostBackend args - | otherwise -> do - -- No backend specified, show available backends - TIO.putStr cliHeader - backends <- discoverBackends discovery - -- Ping backends to check if they're reachable - backendsWithStatus <- pingBackends backends - TIO.putStrLn "\nAvailable backends:" - mapM_ printBackend backendsWithStatus - TIO.putStrLn "\nUsage: synapse [command...]" - Just backend - -- Handle --help/-h if it somehow ends up as the backend - | backend `elem` ["--help", "-h"] -> TIO.putStr cliHeader - -- Handle _self meta-commands (use discovered primary backend) - | backend == "_self" -> runWithDiscovery discovery hostBackend args - | otherwise -> runWithDiscovery discovery backend args - --- | Print a backend in the list -printBackend :: Backend -> IO () -printBackend b = do - let nameField = T.justifyLeft 15 ' ' (backendName b) - let hostPort = backendHost b <> ":" <> T.pack (show (backendPort b)) - let status = case backendReachable b of - Just True -> " [OK]" - Just False -> " [UNREACHABLE]" - Nothing -> "" - let desc = if T.null (backendDescription b) - then "" - else " - " <> backendDescription b - TIO.putStrLn $ " " <> nameField <> hostPort <> status <> desc - --- | Run a Hub command with backend discovery -runWithDiscovery :: BackendDiscovery -> Text -> Args -> IO () -runWithDiscovery discovery backendName args = do - let opts = argOpts args - -- Try to discover backend info - maybeBackend <- getBackendInfo discovery backendName - - case maybeBackend of - Just backend -> do - -- Verify the resolved backend actually identifies as the requested name. - -- This catches cases where -P points to a different backend than expected, - -- or the registry has stale entries. - actualName <- getBackendAt (backendHost backend) (backendPort backend) - case actualName of - Just name | name /= backendName -> do - hPutStrLn stderr $ "Backend mismatch: requested '" <> T.unpack backendName - <> "' but " <> T.unpack (backendHost backend) <> ":" <> show (backendPort backend) - <> " identifies as '" <> T.unpack name <> "'" - exitFailure - Nothing -> do - -- Protocol handshake failed when verifying backend - logger <- makeLoggerFromOpts opts - token <- resolveToken opts backendName - env <- initEnv (soHost opts) (soPort opts) backendName logger token - result <- runSynapseM env (throwBackend (ProtocolHandshakeFailed (backendHost backend) (backendPort backend)) []) - case result of - Left err -> do - hPutStrLn stderr $ renderError err - exitFailure - Right () -> exitSuccess - Just _ -> - -- Match confirmed - run backendName (backendHost backend) (backendPort backend) args - Nothing -> do - -- Backend not found in registry - check if this was a direct connection attempt - -- where the protocol handshake failed - maybeDirectBackend <- getBackendAt (soHost opts) (soPort opts) - logger <- makeLoggerFromOpts opts - token <- resolveToken opts backendName - env <- initEnv (soHost opts) (soPort opts) backendName logger token - case maybeDirectBackend of - Nothing -> do - -- Protocol handshake failed at the specified host:port - result <- runSynapseM env (throwBackend (ProtocolHandshakeFailed (soHost opts) (soPort opts)) []) - case result of - Left err -> do - hPutStrLn stderr $ renderError err - exitFailure - Right () -> exitSuccess - Just discoveredName | discoveredName /= backendName -> do - -- Backend exists but has a different name - backends <- discoverBackends discovery - backendsWithStatus <- pingBackends backends - result <- runSynapseM env (throwBackend (BackendNotFound backendName) backendsWithStatus) - case result of - Left err -> do - hPutStrLn stderr $ renderError err - exitFailure - Right () -> exitSuccess - Just _ -> do - -- Backend discovered successfully - should not reach here, but proceed - run backendName (soHost opts) (soPort opts) args - --- | Run a Hub command with specified backend and connection details -run :: Text -> Text -> Int -> Args -> IO () -run backend host port args = do - let opts = argOpts args - logger <- makeLoggerFromOpts opts - Log.logInfo logger Log.SubsystemCLI $ "Synapse starting: backend=" <> backend <> ", host=" <> host <> ", port=" <> T.pack (show port) - token <- resolveToken opts backend - env <- initEnv host port backend logger token - rendererCfg <- defaultRendererConfig - Log.logDebug logger Log.SubsystemCLI "Running dispatch..." - result <- runSynapseM env (dispatch args rendererCfg) - case result of - Left err -> do - hPutStrLn stderr $ renderError err - exitFailure - Right () -> exitSuccess - --- | Dispatch based on navigation result -dispatch :: Args -> RendererConfig -> SynapseM () -dispatch Args{argOpts = SynapseOpts{..}, argBackend, argPath} rendererCfg = do - -- Check for _self commands first (before anything else) - case argBackend of - Just "_self" -> do - -- _self meta-command: parse subcommand and rest from argPath - let (pathSegs, rawParams, _) = parsePathAndParams argPath - case pathSegs of - (subcommand : rest) -> do - Self.dispatch subcommand rest rawParams - return () - [] -> do - -- No subcommand provided, show help - Self.showHelp - return () - - -- Normal dispatch - _ -> do - -- Mode 1: Raw JSON-RPC passthrough - case soRpc of - Just rpcJson -> do - case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 rpcJson) of - Left err -> throwParse $ T.pack err - Right rpcReq -> do - items <- invokeRawRpc rpcReq - liftIO $ mapM_ (printResult soJson soRaw rendererCfg) items - return () - - Nothing -> do - -- Parse path and inline params (--key value pairs) - let (pathSegs, rawParams, helpRequested) = parsePathAndParams argPath - - -- Normal Plexus RPC routing - -- Apply parameter transformations (path expansion, env vars) - transformEnv <- liftIO mkTransformEnv - inlineParams <- liftIO $ transformParams transformEnv defaultTransformers rawParams - - -- Mode 1.5: Respond subcommand (agent sends a response to a pending bidir request) - if not (null pathSegs) && head pathSegs == "respond" - then handleRespondCommand rawParams - - -- Mode 2: Schema request - else if soSchema - then do - -- Try to navigate and determine if last segment is a method - schemaResult <- fetchSchemaForPath pathSegs - case schemaResult of - Left err -> throwNav $ FetchError err pathSegs - Right val -> liftIO $ LBS.putStrLn $ encode val - - -- Mode 3: Generate templates (IR-driven approach) - else if soGenerate - then do - homeDir <- liftIO getHomeDirectory - let baseDir = homeDir ".config" "synapse" "templates" - writeAndLog gt = do - writeGeneratedTemplateIR baseDir gt - TIO.putStrLn $ " " <> T.pack (TemplateIR.gtPath gt) - liftIO $ TIO.putStrLn $ "Generating templates in " <> T.pack baseDir <> "..." - count <- TemplateIR.generateAllTemplatesWithCallback writeAndLog pathSegs - liftIO $ TIO.putStrLn $ "Generated " <> T.pack (show count) <> " templates" - - -- Mode 4: Emit IR for code generation - else if soEmitIR - then do - ir <- buildIR soGeneratorInfo pathSegs - liftIO $ LBS.putStrLn $ encode ir - - else do - -- Mode 5: Normal navigation - if null pathSegs - then do - rootSchema <- navigate [] - case rootSchema of - ViewPlugin schema _ -> liftIO $ do - TIO.putStr cliHeader - TIO.putStr "\n\n" - TIO.putStr $ renderSchema schema - _ -> pure () - else do - -- Navigate to target - view <- navigate pathSegs - case view of - -- Landed on a plugin: show help - ViewPlugin schema _ -> - liftIO $ TIO.putStr $ renderSchema schema - - -- Landed on a method: invoke or show help - ViewMethod method path -> do - let fullPath = T.intercalate "." path - - -- IR-15: emit stderr deprecation warnings right before any - -- real invocation. Dedupe is per-process-lifetime, so this - -- action is idempotent on repeat calls. We bind it as a - -- local SynapseM action and invoke it at both invocation - -- sites below (fast path and slow path). --help, --dry-run, - -- --schema, and --emit-ir do not invoke, and intentionally - -- do not fire these warnings. - let fireDeprecationWarnings :: SynapseM () - fireDeprecationWarnings = do - liftIO $ emitMethodWarning - soNoDeprecationWarnings - fullPath - (methodDeprecation method) - let namespacePath = init path - when (not (null namespacePath)) $ do - let activationNs = T.intercalate "." namespacePath - parentPlugin <- fetchSchemaAt namespacePath - liftIO $ emitActivationWarning - soNoDeprecationWarnings - activationNs - (psDeprecation parentPlugin) - - -- Optimization: Skip IR construction for parameter-less methods - -- IR is only needed for: - -- 1. Help rendering (--help flag) - -- 2. Parameter parsing (methods with params) - let needsIR = helpRequested - || isJust (methodParams method) - || isJust soParams - || not (null inlineParams) - - -- Fast path: parameter-less method with no help requested - if not needsIR - then fireDeprecationWarnings >> invokeMethod path (object []) - else do - -- Build IR for this method's namespace - ir <- buildIR soGeneratorInfo (init path) - - -- If --help was explicitly requested, show help and exit - if helpRequested - then do - case Map.lookup fullPath (irMethods ir) of - Just methodDef -> - liftIO $ TIO.putStr $ renderMethodHelp ir methodDef - Nothing -> - liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method - else do - -- Build params: use IR-driven parsing for inline params - let schemaDefaults = extractSchemaDefaults method - userParams <- case soParams of - -- -p JSON: parse as raw JSON (bypass IR parsing) - Just jsonStr -> - case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 jsonStr) of - Left err -> throwParse $ T.pack err - Right p -> pure p - Nothing - | not (null inlineParams) -> - -- Use IR-driven parsing for inline params - case Map.lookup fullPath (irMethods ir) of - Just methodDef -> do - -- Inject boolean defaults for flags without values - let paramsWithBools = injectBooleanDefaults ir methodDef inlineParams - -- Inject smart defaults for missing required params (e.g., --path defaults to cwd) - paramsWithDefaults <- liftIO $ injectSmartDefaults transformEnv ir methodDef paramsWithBools - case parseParams ir methodDef paramsWithDefaults of - Right p -> pure p - Left errs -> do - liftIO $ mapM_ (hPutStrLn stderr . renderParseError) errs - throwParse "Parameter parsing failed" - Nothing -> - -- Fallback to flat object if method not in IR - pure $ buildParamsObject inlineParams - | otherwise -> pure $ object [] - -- Merge: user params override schema defaults - let params = mergeParams schemaDefaults userParams - - if soDryRun - then do - backend <- asks seBackend - liftIO $ LBS.putStrLn $ encodeDryRun backend (init path) (last path) params - -- Show help when: method has required params AND user provided no params - else if hasRequiredParams method && userParams == object [] && null inlineParams - then do - -- Render help from IR - case Map.lookup fullPath (irMethods ir) of - Just methodDef -> - liftIO $ TIO.putStr $ renderMethodHelp ir methodDef - Nothing -> - -- Fallback: method not in IR, use basic info - liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method - -- IR-15: fire stderr deprecation warnings before real invocation. - else fireDeprecationWarnings >> invokeMethod path params - where - handleRespondCommand :: [(Text, Text)] -> SynapseM () - handleRespondCommand params = do - let mRequestId = lookup "request_id" params - mResponseStr = lookup "response" params - case (mRequestId, mResponseStr) of - (Nothing, _) -> throwParse "Missing --request-id for respond subcommand" - (_, Nothing) -> throwParse "Missing --response for respond subcommand" - (Just requestId, Just responseStr) -> - case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 responseStr) of - Left err -> throwParse $ "Invalid --response JSON: " <> T.pack err - Right (resp :: Response Value) -> sendResponse requestId resp - - invokeMethod path params = do - let namespacePath = init path -- path without method name - let methodName' = last path - -- Set method path hint for template resolution - let rendererCfg' = withMethodPath rendererCfg path - -- Determine bidirectional mode (--bidir-cmd takes precedence) - bidirMode <- liftIO $ case soBidirCmd of - Just cmd -> pure $ BidirCmd cmd - Nothing -> case soBidirMode of - Just modeStr -> case parseBidirMode modeStr of - Just mode -> pure mode - Nothing -> do - TIO.hPutStrLn stderr $ "[synapse] Unknown --bidir-mode: " <> modeStr <> ", using auto-detect" - detectBidirMode - Nothing -> detectBidirMode - -- Use bidirectional streaming handler - invokeStreamingWithBidir - namespacePath - methodName' - params - (printResult soJson soRaw rendererCfg') - (handleBidirRequest bidirMode Nothing) - - -- Extract default values from JSON Schema properties - -- Schema format: {"properties": {"key": {"default": value, ...}, ...}, ...} - extractSchemaDefaults :: MethodSchema -> Value - extractSchemaDefaults m = case methodParams m of - Nothing -> object [] - Just (Object o) -> case KM.lookup "properties" o of - Just (Object props) -> object - [ (k, defaultVal) - | (k, propSchema) <- KM.toList props - , Object propObj <- [propSchema] - , Just defaultVal <- [KM.lookup "default" propObj] - ] - _ -> object [] - Just _ -> object [] - - -- Merge two JSON objects: right takes precedence over left - mergeParams :: Value -> Value -> Value - mergeParams (Object defaults) (Object user) = - Object (KM.union user defaults) -- union prefers first arg on conflict - mergeParams _ user = user -- if defaults aren't an object, just use user params - - -- Check if method has required parameters - hasRequiredParams :: MethodSchema -> Bool - hasRequiredParams m = case methodParams m of - Nothing -> False - Just (Object o) -> case KM.lookup "required" o of - Just (Array arr) -> not (null arr) - _ -> False - Just _ -> False - - -- Fetch schema for a path, detecting if last segment is a method - -- Uses navigate to determine what type of schema to fetch - fetchSchemaForPath :: [Text] -> SynapseM (Either Text Value) - fetchSchemaForPath segs = do - view <- navigate segs - case view of - ViewPlugin schema _ -> pure $ Right $ toJSON schema - ViewMethod method path -> do - -- Use method-specific schema query for detailed method info - let parentPath = init path - methodName' = last path - detailedMethod <- fetchMethodSchema parentPath methodName' - pure $ Right $ toJSON detailedMethod - - -- Invoke raw JSON-RPC request - invokeRawRpc :: Value -> SynapseM [HubStreamItem] - invokeRawRpc rpcReq = do - case rpcReq of - Object o -> case (KM.lookup "method" o, KM.lookup "params" o) of - (Just (String method), Just params) -> invokeRaw method params - (Just (String method), Nothing) -> invokeRaw method (object []) - _ -> throwParse "JSON-RPC must have 'method' field" - _ -> throwParse "JSON-RPC must be an object" - --- | Parse path segments and --key value params --- Returns (path segments, [(key, value)] params, help requested) --- Example: ["echo", "once", "--message", "hello", "--count", "3"] --- -> (["echo", "once"], [("message", "hello"), ("count", "3")], False) --- Example: ["echo", "once", "--help"] --- -> (["echo", "once"], [], True) -parsePathAndParams :: [Text] -> ([Text], [(Text, Text)], Bool) -parsePathAndParams = go [] [] False - where - go path params helpReq [] = (reverse path, reverse params, helpReq) - go path params helpReq (x:xs) - -- --help flag: mark help requested, don't add as param - | x == "--help" || x == "-h" = - go path params True xs - -- --key value pair (value must not start with --) - | Just key <- T.stripPrefix "--" x - , not (T.null key) - , (val:rest) <- xs - , not (T.isPrefixOf "--" val) = - let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case - in go path ((normalizedKey, val) : params) helpReq rest - -- --key with no value or next arg is another flag (boolean flag) - | Just key <- T.stripPrefix "--" x - , not (T.null key) = - let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case - in go path ((normalizedKey, "") : params) helpReq xs - -- Regular path segment - split on dots to support Plexus RPC path syntax (e.g., cone.chat) - | otherwise = - let segments = map (T.replace "-" "_") $ filter (not . T.null) $ T.splitOn "." x - in go (reverse segments ++ path) params helpReq xs - --- | Build JSON object from key-value pairs -buildParamsObject :: [(Text, Text)] -> Value -buildParamsObject pairs = object - [ (K.fromText k, inferValue v) | (k, v) <- pairs ] - where - -- Try to infer the JSON type from the string value - inferValue :: Text -> Value - inferValue t - | t == "true" = Bool True - | t == "false" = Bool False - | Just n <- readMaybe (T.unpack t) :: Maybe Integer = Number (fromInteger n) - | Just n <- readMaybe (T.unpack t) :: Maybe Double = Number (realToFrac n) - | otherwise = String t - -readMaybe :: Read a => String -> Maybe a -readMaybe s = case reads s of - [(x, "")] -> Just x - _ -> Nothing - --- | ASCII splash logo -splash :: Text -splash = T.unlines - [ "" - , "███████╗██╗ ██╗███╗ ██╗ █████╗ ██████╗ ███████╗███████╗" - , "██╔════╝╚██╗ ██╔╝████╗ ██║██╔══██╗██╔══██╗██╔════╝██╔════╝" - , "███████╗ ╚████╔╝ ██╔██╗ ██║███████║██████╔╝███████╗█████╗ " - , "╚════██║ ╚██╔╝ ██║╚██╗██║██╔══██║██╔═══╝ ╚════██║██╔══╝ " - , "███████║ ██║ ██║ ╚████║██║ ██║██║ ███████║███████╗" - , "╚══════╝ ╚═╝ ╚═╝ ╚═══╝╚═╝ ╚═╝╚═╝ ╚══════╝╚══════╝" - , "" - ] - --- | Get CLI help text from optparse-applicative -cliHeader :: Text -cliHeader = splash <> T.pack (fst $ renderFailure failure "synapse") <> selfHelp - where - failure = parserFailure defaultPrefs argsInfo (ShowHelpText Nothing) mempty - selfHelp = T.unlines - [ "" - , "Meta-commands (local, no RPC):" - , "" - , " synapse _self template" - , " Manage Mustache templates (CRUD operations)" - , "" - , " Subcommands:" - , " list [pattern] - List existing templates" - , " show - Display template content" - , " generate [pattern] - Generate new templates from IR" - , " delete - Delete templates" - , " reload - Clear template cache" - , "" - , " Examples:" - , " synapse _self template list" - , " synapse _self template show cone.chat" - , " synapse _self template generate 'plexus.cone.*'" - , "" - ] - --- | Render an error for display -renderError :: SynapseError -> String -renderError = \case - NavError (NotFound seg path maybeSchema) -> - let baseMsg = "Command not found: '" <> T.unpack seg <> "' at " <> showPath path - in case maybeSchema of - Nothing -> baseMsg - Just schema -> - let methods = psMethods schema - children = pluginChildren schema - suggestions = if null methods && null children - then "" - else "\n\nAvailable commands:" - <> renderMethods methods - <> renderChildren children - in baseMsg <> suggestions - NavError (MethodNotTerminal seg path) -> - "Method '" <> T.unpack seg <> "' cannot have subcommands at " <> showPath path - NavError (Cycle hash path) -> - "Cycle detected: hash " <> T.unpack hash <> " at " <> showPath path - NavError (FetchError msg path) -> - "Fetch error at " <> showPath path <> ": " <> T.unpack msg - TransportError msg -> - "Transport error: " <> T.unpack msg - TransportErrorContext ctx -> - renderTransportError ctx - ParseError msg -> - "Parse error: " <> T.unpack msg - ValidationError msg -> - "Validation error: " <> T.unpack msg - BackendError errorType backends -> - case errorType of - BackendNotFound name -> - "Backend not found: '" <> T.unpack name <> "'" - <> renderBackendList backends - BackendUnreachable name -> - "Backend unreachable: '" <> T.unpack name <> "'" - <> renderBackendList backends - NoBackendsAvailable -> - "No backends available" - <> renderBackendList backends - ProtocolHandshakeFailed host port -> - "Protocol handshake failed at " <> T.unpack host <> ":" <> show port <> "\n" - <> "The _info request did not complete successfully within 2 seconds.\n" - <> "This typically means:\n" - <> " - The server is not responding to Plexus RPC protocol messages\n" - <> " - The server is not sending required StreamDone messages\n" - <> " - The connection is timing out" - where - showPath [] = "root" - showPath p = T.unpack $ T.intercalate "." p - - renderMethods [] = "" - renderMethods methods = - let header = "\n\n Methods:" - methodLines = map renderMethod methods - in header <> concat methodLines - - renderMethod method = - let name = T.unpack $ methodName method - desc = T.unpack $ methodDescription method - padding = 20 - namePadded = name <> replicate (max 1 (padding - length name)) ' ' - in "\n " <> namePadded <> desc - - renderChildren [] = "" - renderChildren children = - let header = "\n\n Child plugins:" - childLines = map renderChild children - in header <> concat childLines - - renderChild child = - let name = T.unpack $ csNamespace child - desc = T.unpack $ csDescription child - padding = 20 - namePadded = name <> replicate (max 1 (padding - length name)) ' ' - in "\n " <> namePadded <> desc - - renderBackendList [] = "\n\nNo backends available." - renderBackendList backends = - let header = "\n\nAvailable backends:" - backendLines = map renderBackendLine backends - usageHint = "\n\nUsage: synapse [command...]" - in header <> concat backendLines <> usageHint - - renderBackendLine backend = - let name = T.unpack $ backendName backend - nameField = name <> replicate (max 1 (15 - length name)) ' ' - hostPort = T.unpack $ backendHost backend <> ":" <> T.pack (show (backendPort backend)) - status = case backendReachable backend of - Just True -> " [OK]" - Just False -> " [UNREACHABLE]" - Nothing -> "" - desc = if T.null (backendDescription backend) - then "" - else " - " <> T.unpack (backendDescription backend) - in "\n " <> nameField <> hostPort <> status <> desc - --- | Render transport error with context -renderTransportError :: TransportContext -> String -renderTransportError TransportContext{..} = case tcCategory of - ConnectionRefused -> - "Connection refused\n\n" <> - "Backend: " <> T.unpack tcBackend <> "\n" <> - "Address: " <> T.unpack tcHost <> ":" <> show tcPort <> "\n" <> - "Path: " <> showPath tcPath <> "\n\n" <> - "Troubleshooting:\n" <> - " - Check if the backend is running\n" <> - " - Verify host (-H) and port (-P) settings\n" <> - " - Run 'synapse' (no args) to list backends" - - ConnectionTimeout -> - "Connection timeout\n\n" <> - "Backend: " <> T.unpack tcBackend <> " @ " <> - T.unpack tcHost <> ":" <> show tcPort <> "\n\n" <> - "The server may be overloaded or network latency is high\n" <> - "Error: " <> T.unpack tcMessage - - ProtocolError -> - "Protocol error\n\n" <> - "Backend: " <> T.unpack tcBackend <> "\n" <> - "This may indicate a version mismatch\n\n" <> - "Error: " <> T.unpack tcMessage - - UnknownTransportError -> - "Transport error: " <> T.unpack tcMessage <> "\n\n" <> - "Backend: " <> T.unpack tcBackend <> " @ " <> - T.unpack tcHost <> ":" <> show tcPort - where - showPath [] = "root" - showPath p = T.unpack $ T.intercalate "." p - --- | Render a parse error for display -renderParseError :: Parse.ParseError -> String -renderParseError = \case - Parse.UnknownParam name suggestions -> - "Unknown parameter: --" <> T.unpack name <> - case suggestions of - [] -> "" - [s] -> "\n\nDid you mean: --" <> T.unpack s <> "?" - ss -> "\n\nDid you mean one of:\n" <> - unlines [" --" <> T.unpack s | s <- ss] - Parse.MissingRequired name -> - "Missing required parameter: --" <> T.unpack name - Parse.InvalidValue name reason -> - "Invalid value for --" <> T.unpack name <> ": " <> T.unpack reason - Parse.AmbiguousVariant name variants -> - "Ambiguous variant for --" <> T.unpack name <> ": could be one of " <> show (map T.unpack variants) - Parse.MissingDiscriminator param field -> - "Missing discriminator for --" <> T.unpack param <> ": need --" <> T.unpack param <> "." <> T.unpack field - Parse.UnknownVariant param value valid suggestions -> - "Unknown variant '" <> T.unpack value <> "' for --" <> T.unpack param <> - "\n\nValid variants: " <> T.unpack (T.intercalate ", " valid) <> - case suggestions of - [] -> "" - [s] -> "\n\nDid you mean: " <> T.unpack s <> "?" - ss -> "\n\nDid you mean one of: " <> T.unpack (T.intercalate ", " ss) <> "?" - Parse.TypeNotFound name -> - "Type not found in IR: " <> T.unpack name - - --- | Write a generated template to disk (no logging) -writeGeneratedTemplateIR :: FilePath -> TemplateIR.GeneratedTemplate -> IO () -writeGeneratedTemplateIR baseDir gt = do - let fullPath = baseDir TemplateIR.gtPath gt - createDirectoryIfMissing True (baseDir T.unpack (TemplateIR.gtNamespace gt)) - TIO.writeFile fullPath (TemplateIR.gtTemplate gt) - --- | Encode a dry-run request -encodeDryRun :: Text -> [Text] -> Text -> Value -> LBS.ByteString -encodeDryRun backend namespacePath method params = - let fullPath = if null namespacePath then [backend] else namespacePath - dotPath = T.intercalate "." (fullPath ++ [method]) - in encode $ object - [ "jsonrpc" .= ("2.0" :: Text) - , "id" .= (1 :: Int) - , "method" .= (backend <> ".call") - , "params" .= object - [ "method" .= dotPath - , "params" .= params - ] - ] - --- | Print a stream result --- soJson: output raw JSON stream items --- soRaw: skip template rendering, just output content JSON --- otherwise: try template rendering, fall back to content JSON -printResult :: Bool -> Bool -> RendererConfig -> HubStreamItem -> IO () -printResult True _ _ item = LBS.putStrLn $ encode item -printResult _ True _ item = case item of - -- Raw mode: just output the content - HubData _ _ _ dat -> do - LBS.putStrLn $ encode dat - hFlush stdout - HubProgress _ _ msg _ -> do - TIO.putStr msg - TIO.putStr "\r" - hFlush stdout - HubError _ _ err _ -> - hPutStrLn stderr $ "Error: " <> T.unpack err - _ -> pure () -printResult _ _ cfg item = do - -- Template mode: try to render with template - mRendered <- renderItem cfg item - case mRendered of - Just text - | T.null (T.strip text) -> pure () - | otherwise -> do - TIO.putStr text - hFlush stdout - Nothing -> case item of - -- Fallback to pretty-printed content - HubData _ _ _ dat -> do - TIO.putStrLn $ prettyValue dat - hFlush stdout - HubProgress _ _ msg _ -> do - TIO.putStr msg - TIO.putStr "\r" - hFlush stdout - HubError _ _ err _ -> - hPutStrLn stderr $ "Error: " <> T.unpack err - _ -> pure () - --- ============================================================================ --- Argument Parsing (Synapse Options Only) --- ============================================================================ - --- | Parser for synapse-level options only --- Backend and path are handled separately after arg splitting -argsInfo :: ParserInfo Args -argsInfo = info (argsParser <**> versionOption <**> helper) - ( fullDesc - <> header "synapse - Algebraic CLI for Hub" - <> progDesc "synapse [OPTIONS] [--param value ...]" - <> noIntersperse -- Stop option parsing at first positional arg - ) - where - versionOption = infoOption (showVersion Meta.version) - ( long "version" <> short 'V' <> help "Show version" ) - -argsParser :: Parser Args -argsParser = Args <$> optsParser <*> backendParser <*> restParser - where - backendParser = optional $ T.pack <$> argument str - ( metavar "BACKEND" - <> help "Backend name (e.g., plexus, registry-hub)" ) - - restParser = many $ T.pack <$> argument str - ( metavar "PATH... [--param value ...]" - <> help "Path and method parameters (passed through)" ) - -optsParser :: Parser SynapseOpts -optsParser = do - soHost <- T.pack <$> strOption - ( long "host" <> short 'H' <> metavar "HOST" - <> value (T.unpack defaultHost) - <> help "Registry/discovery host (default: 127.0.0.1)" ) - soPort <- option auto - ( long "port" <> short 'P' <> metavar "PORT" - <> value defaultPort - <> help "Registry/discovery port (default: 4444)" ) - soJson <- switch - ( long "json" <> short 'j' - <> help "Output raw JSON stream items" ) - soRaw <- switch - ( long "raw" - <> help "Output raw content JSON (skip templates)" ) - soDryRun <- switch - ( long "dry-run" <> short 'n' - <> help "Show JSON-RPC request without sending" ) - soSchema <- switch - ( long "schema" <> short 's' - <> help "Fetch raw schema JSON for path" ) - soGenerate <- switch - ( long "generate-templates" <> short 'g' - <> help "Generate mustache templates from IR" ) - soEmitIR <- switch - ( long "emit-ir" <> short 'i' - <> help "Emit IR for code generation (JSON)" ) - soParams <- optional $ T.pack <$> strOption - ( long "params" <> short 'p' <> metavar "JSON" - <> help "Method parameters as JSON object" ) - soRpc <- optional $ T.pack <$> strOption - ( long "rpc" <> short 'r' <> metavar "JSON" - <> help "Raw JSON-RPC request (bypass navigation)" ) - soGeneratorInfo <- many $ T.pack <$> strOption - ( long "generator-info" <> metavar "TOOL:VERSION" - <> help "Generator tool version info (can be specified multiple times)" ) - soBidirMode <- optional $ T.pack <$> strOption - ( long "bidir-mode" <> short 'b' <> metavar "MODE" - <> help "Bidirectional mode: interactive (TTY), json (pipe protocol), auto-cancel, defaults, respond" ) - soBidirCmd <- optional $ T.pack <$> strOption - ( long "bidir-cmd" <> metavar "CMD" - <> help "Shell command to handle bidir requests (stdin=JSON request, stdout=JSON response)" ) - soNoCache <- switch - ( long "no-cache" - <> help "Disable IR caching (force rebuild from schema)" ) - soLogLevel <- optional $ T.pack <$> strOption - ( long "log-level" <> metavar "LEVEL" - <> help "Log level: info, debug, trace (default: disabled)" ) - soLogSubsystems <- many $ T.pack <$> strOption - ( long "log-subsystem" <> metavar "SUBSYSTEM" - <> help "Filter logs by subsystem: discovery, transport, rpc, schema, cache, navigation (can specify multiple, default: all)" ) - soToken <- optional $ T.pack <$> strOption - ( long "token" <> short 't' <> metavar "JWT" - <> help "JWT sent as Cookie: access_token= on WebSocket upgrade" ) - soTokenFile <- optional $ T.pack <$> strOption - ( long "token-file" <> metavar "PATH" - <> help "Path to token file (default lookup: ~/.plexus/tokens/)" ) - soNoDeprecationWarnings <- switch - ( long "no-deprecation-warnings" - <> help "Suppress invocation-time deprecation warnings on stderr (IR-15)" ) - pure SynapseOpts{..} +import Control.Monad (filterM, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (asks) +import Data.Aeson +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.List (stripPrefix) +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Data.Text.Encoding as TE +import Options.Applicative +import qualified Options.Applicative.Help.Pretty as Pretty +import System.Environment (getEnvironment) +import Data.Version (showVersion) +import qualified Paths_plexus_synapse as Meta +import System.Directory (getHomeDirectory) +import System.Exit (exitFailure, exitSuccess) +import System.FilePath (()) +import System.IO (hPutStrLn, stderr, hFlush, stdout, hIsTerminalDevice) + + +import Synapse.Schema.Types +import Synapse.Monad (SynapseM, SynapseEnv(..), SynapseError(..), BackendErrorType(..), TransportContext(..), TransportErrorCategory(..), initEnvAt, runSynapseM, throwNav, throwTransport, throwParse, throwBackend, withRequestContext, withViewKey) +import qualified Synapse.Self as Self + ( CredentialRef(..) + , ResolveError(..) + , ResolvedDefaults(..) + , defaultRegistry + , loadDefaults + , merge + , resolveAll + ) +import qualified Control.Exception as E +import qualified Synapse.Log as Log +import qualified Katip +import Synapse.Algebra.Navigate +import Synapse.Algebra.Render (Listing(..), renderListing, defaultStyle) +import Synapse.Auth (AnonPage(..), anonymousMethods, renderAnonymousPage, renderCallerHeader, renderRefusal, SessionGrant(..)) +import Plexus.Auth (BackendInfo(..), View(..), viewText) +import Plexus.Types (itemRefusal) +import Control.Monad.Except (catchError, throwError) +import Synapse.CLI.Help (MethodPage(..), renderMethodPage) +import Synapse.CLI.Parse (parseParams, parsePathAndParams, pairFlags) +import qualified Synapse.CLI.Parse as Parse +import Synapse.IR.Types (IR, irMethods, MethodDef) +import qualified Data.Map.Strict as Map +import qualified Synapse.CLI.Template as TemplateIR +import Synapse.Deprecation (emitActivationWarning, emitMethodWarning) +import Synapse.Transport +import Synapse.Bidir (BidirMode(..), parseBidirMode, detectBidirMode, handleBidirRequest) +import Plexus.Types (Response(..)) +import Synapse.CLI.Transform (TransformEnv(..), mkTransformEnv, transformParams, defaultTransformers, injectBooleanDefaults, injectSmartDefaults) +import Synapse.CLI.Source (SourceEnv, mkSourceEnv, expandSources, expandValue, stdinWasRead, renderSourceError) +import Synapse.IR.Builder (buildIR) +import Synapse.Renderer (RendererConfig, defaultRendererConfig, renderItem, prettyValue, withMethodPath) +import System.Directory (createDirectoryIfMissing, doesFileExist, getHomeDirectory) +import System.FilePath (()) +import qualified Synapse.Self.Commands as Self +import qualified Synapse.Self.Command as SelfCmd +import Synapse.Backend.Discovery (Backend(..), BackendDiscovery(..), registryDiscoveryAt, endpointFor, pingBackendsVia, getBackendAt, getBackendAtEp, probeBackendAtEp, registerWithRegistry, probedInfoAt, probeFailureAt) +import Synapse.Endpoint (Endpoint(..), plainAt, isPlain, parseUrl, normalisePath, cliOptions) +import qualified Synapse.Endpoint as E +import Control.Applicative ((<|>)) +import System.Environment (lookupEnv) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Format (formatTime, defaultTimeLocale) +import qualified Synapse.Identity.Command as IdCmd +import qualified Synapse.Identity.Proof as Proof +import qualified Synapse.Identity.Session as Session +import qualified Synapse.Reconnect as Reconnect +import qualified Synapse.Identity.Store as Store +import System.Exit (ExitCode(..), exitWith) +import qualified Synapse.Find as Find +import Synapse.IR.Cache (newIRCache, defaultCacheConfig) + +-- ============================================================================ +-- Types +-- ============================================================================ + +-- | Synapse-level options (must appear before backend) +-- Controls connection settings and output format +data SynapseOpts = SynapseOpts + { soHost :: Text -- ^ Registry host for discovery + , soPort :: Int -- ^ Registry port for discovery + , soHostFlag :: Maybe Text -- ^ SCAFFOLD-21: -H as given + , soPortFlag :: Maybe Int -- ^ SCAFFOLD-21: -P as given + , soUrl :: Maybe Text -- ^ SCAFFOLD-21: --url ws[s]://HOST[:PORT][/PATH] + , soTls :: Bool -- ^ SCAFFOLD-21: --tls — wss to -H / -P + , soPath :: Maybe Text -- ^ SCAFFOLD-21: --path — the socket's path + , soCaCerts :: [Text] -- ^ SCAFFOLD-21: --cacert FILE — trusted beside the system's + , soEndpoint :: Endpoint -- ^ SCAFFOLD-21: the connection point, resolved from the above + , soJson :: Bool -- ^ Output raw JSON stream items + , soRaw :: Bool -- ^ Output raw content (no templates) + , soDryRun :: Bool -- ^ Show request without sending + , soSchema :: Bool -- ^ Fetch raw schema JSON + , soGenerate :: Bool -- ^ Generate templates from IR + , soEmitIR :: Bool -- ^ Emit IR for code generation + , soParams :: Maybe Text -- ^ JSON params via -p + , soRpc :: Maybe Text -- ^ Raw JSON-RPC passthrough + , soGeneratorInfo :: [Text] -- ^ Generator tool info (tool:version pairs) + , soBidirMode :: Maybe Text -- ^ Bidirectional mode override + , soBidirCmd :: Maybe Text -- ^ Bidirectional subprocess command (--bidir-cmd) + , soNoCache :: Bool -- ^ Disable IR caching + , soLogLevel :: Maybe Text -- ^ Log level: info, debug, trace + , soLogSubsystems :: [Text] -- ^ Filter logs by subsystems (empty = all) + , soToken :: Maybe Text -- ^ JWT sent as Cookie: access_token= + , soTokenFile :: Maybe Text -- ^ Path to token file (overridden by --token) + , soCookies :: [(Text, Text)] -- ^ SAFE-S04/REQ-5: extra --cookie KEY=VALUE entries + , soHeaders :: [(Text, Text)] -- ^ SAFE-S04/REQ-5: extra --header KEY=VALUE entries + , soNoDeprecationWarnings :: Bool -- ^ Suppress invocation-time deprecation warnings (IR-15) + , soAs :: Maybe Text -- ^ IDENTITY-43: which stored agent session to carry + , soReconnectFor :: Maybe Text -- ^ SYNAPSE-20: how long to ride out an outage (10m; 0 = never) + } + deriving Show + +-- | Full CLI arguments after two-phase parsing +data Args = Args + { argOpts :: SynapseOpts -- ^ Synapse-level options + , argBackend :: Maybe Text -- ^ Backend name (first positional) + , argPath :: [Text] -- ^ Path segments and --key value params (raw) + , argFind :: Maybe Find.FindOpts -- ^ SYNAPSE-17: a search (_find), not a call + } + deriving Show + + +-- ============================================================================ +-- Constants +-- ============================================================================ + +defaultHost :: Text +defaultHost = "127.0.0.1" + +defaultPort :: Int +defaultPort = 4444 + +-- ============================================================================ +-- Logging Helper +-- ============================================================================ + +-- | Create a logger from command-line options +-- Default: ErrorS (only show errors) +makeLoggerFromOpts :: SynapseOpts -> IO Log.Logger +makeLoggerFromOpts opts = do + let level = case soLogLevel opts of + Nothing -> Katip.ErrorS -- Default: only errors + Just levelStr -> parseLogLevel levelStr + Log.makeLogger level + where + parseLogLevel "error" = Katip.ErrorS + parseLogLevel "warn" = Katip.WarningS + parseLogLevel "info" = Katip.InfoS + parseLogLevel "debug" = Katip.DebugS + parseLogLevel _ = Katip.ErrorS -- Default to error + +-- ============================================================================ +-- Token Resolution +-- ============================================================================ + +-- | Build the request-context (extra cookies/headers) for the WS upgrade, +-- combining --cookie/--header flags with SYNAPSE_COOKIE_*/SYNAPSE_HEADER_* +-- env vars. Env keys are lowercased. +collectRequestContext :: SynapseOpts -> IO ([(Text, Text)], [(Text, Text)]) +collectRequestContext opts = do + envVars <- getEnvironment + let envCookies = [ (T.toLower (T.pack k), T.pack v) + | (k0, v) <- envVars + , Just k <- [stripPrefix "SYNAPSE_COOKIE_" k0] + ] + envHeaders = [ (T.toLower (T.pack k), T.pack v) + | (k0, v) <- envVars + , Just k <- [stripPrefix "SYNAPSE_HEADER_" k0] + ] + pure (soCookies opts ++ envCookies, soHeaders opts ++ envHeaders) + +-- | Resolve the auth token to use for this invocation from CLI-only +-- sources. +-- +-- Priority: +-- 1. --token (explicit, highest priority) +-- 2. --token-file (explicit file) +-- +-- Any persistent per-backend default (including the former +-- @~\/.plexus\/tokens\/\@, now auto-migrated by +-- 'Synapse.Self.loadDefaults' on first read) lives in +-- @~\/.plexus\/\\/defaults.json@ as a +-- @cookies.access_token@ ref and is loaded through the SELF-2 pipeline +-- in 'buildEnv'. This function therefore only consults +-- invocation-scoped flags; returning 'Nothing' means "no CLI override", +-- not "no token available". +-- +-- Token files contain just the raw JWT, optionally with a trailing +-- newline. +resolveToken :: SynapseOpts -> Text -> IO (Maybe Text) +resolveToken opts _backend = + case soToken opts of + Just tok -> pure (Just tok) + Nothing -> case soTokenFile opts of + Nothing -> pure Nothing + Just path -> do + contents <- TIO.readFile (T.unpack path) + let tok = T.strip contents + pure $ if T.null tok then Nothing else Just tok + +-- | IDENTITY-16: the upgrade headers a discovery probe carries — the token +-- (as the access_token cookie), --cookie and --header, as the command line +-- and its env forms give them. Stored per-backend defaults are not read +-- here: the probe runs before the backend is named. +-- +-- (No signature: the result is the websockets package's header list, which +-- this executable does not depend on by name.) +probeHeaders opts ep = do + mToken <- resolveToken opts "" + (cookies, headers) <- collectRequestContext opts + sess <- sessionHeaders opts ep (isJust mToken || hasCredential cookies headers) + pure (mergeUpgradeHeaders mToken cookies (headers ++ sess)) + +-- | Does this cookie/header set already carry a credential (an +-- access_token cookie or an Authorization header)? Then no stored session +-- is added to it. +hasCredential :: [(Text, Text)] -> [(Text, Text)] -> Bool +hasCredential cookies headers = + any ((== "access_token") . T.toLower . fst) cookies + || any ((== "authorization") . T.toLower . fst) headers + +-- | IDENTITY-43: the agent asked for — @--as@, else @SYNAPSE_AS@. +askedAgent :: SynapseOpts -> IO (Maybe Text) +askedAgent opts = do + env <- lookupEnv "SYNAPSE_AS" + pure (soAs opts <|> (T.pack <$> mfilter' (not . null) env)) + where mfilter' f m = m >>= \x -> if f x then Just x else Nothing + +-- | IDENTITY-43: the stored session's @Authorization: Bearer@ for a call to +-- the address — none when the call already carries a credential (-t, +-- --token-file, an access_token cookie, an Authorization header). +sessionHeaders :: SynapseOpts -> Endpoint -> Bool -> IO [(Text, Text)] +sessionHeaders opts ep explicit + | explicit = pure [] + | otherwise = do + st <- Store.systemStoreEnv + asked <- askedAgent opts + logger <- makeLoggerFromOpts opts + maybe [] (\s -> [Session.bearer (Session.asToken s)]) <$> Session.sessionFor logger st asked ep + +-- | IDENTITY-43: the _info probe, logging in again from the key once when +-- the upgrade is refused (401) while a stored session is carried. +probeWithSession :: SynapseOpts -> Endpoint -> IO (Maybe Text) +probeWithSession = probeWithSession' False + +-- | SYNAPSE-20: with @waits@, a probe that fails as an outage does is +-- tried again for the reconnect window. +probeWithSession' :: Bool -> SynapseOpts -> Endpoint -> IO (Maybe Text) +probeWithSession' waits opts ep = do + probe <- probeHeaders opts ep + let once = probeBackendAtEp probe ep + whereTo = Store.addressKey ep + r <- if waits + then Reconnect.awaitBackend + (\why -> Reconnect.isOutageText why && not (Session.isUpgradeRefused why)) + whereTo once + else once + case r of + Right name -> pure (Just name) + Left why + | Session.isUpgradeRefused why -> do + can <- Session.canReattest ep + if not can then pure Nothing else do + st <- Store.systemStoreEnv + logger <- makeLoggerFromOpts opts + new <- Session.reattest logger st ep + case new of + Nothing -> pure Nothing + Just _ -> do + probe' <- probeHeaders opts ep + getBackendAtEp probe' ep + | otherwise -> pure Nothing + +-- ============================================================================ +-- Env Construction (SELF-2 read path) +-- ============================================================================ + +-- | Render a 'Self.ResolveError' as a human-readable message naming the +-- failing URI and the underlying reason. +renderResolveError :: Self.ResolveError -> String +renderResolveError = \case + Self.ResolveUnknownScheme scheme -> + "unknown credential scheme: " <> T.unpack scheme + <> " (no resolver registered; known schemes: literal, env, file)" + Self.ResolveNotFound (Self.CredentialRef uri) -> + "credential not found: " <> T.unpack uri + Self.ResolveBackendError (Self.CredentialRef uri) msg -> + "credential backend error for " <> T.unpack uri <> ": " <> T.unpack msg + Self.ResolveParseError msg -> + "malformed credential reference: " <> T.unpack msg + +-- | Build a fully-wired 'SynapseEnv' for a backend invocation. +-- +-- SELF-2 read path: +-- +-- 1. CLI token resolution (--token / --token-file; persistent defaults +-- live in ~/.plexus//defaults.json and are loaded in step 3) +-- 2. Collect CLI --cookie / --header flags and SYNAPSE_COOKIE_*/HEADER_* env +-- 3. Load stored defaults from @~\/.plexus\/\\/defaults.json@ +-- 4. Resolve every 'CredentialRef' through the default registry +-- (literal / env / file) +-- 5. Wrap the legacy token (if any) as a CLI @access_token@ cookie so it +-- flows through the same 'Self.merge' and wins over any stored default +-- — preserving the pre-SELF-2 precedence of the --token flag. +-- 6. Merge CLI overrides onto resolved stored defaults (CLI wins per key). +-- +-- On resolve failure: print a clear message and 'exitFailure'. We never +-- build a half-authenticated 'SynapseEnv'. +buildEnv :: Endpoint -> Text -> Log.Logger -> SynapseOpts -> IO SynapseEnv +buildEnv ep backend logger opts = do + -- Legacy token path (unchanged semantically; SELF-3 consolidates). + mToken <- resolveToken opts backend + (cliCookieList, cliHeaderList) <- collectRequestContext opts + + -- SELF-2: load + resolve + merge. + stored <- E.catch (Self.loadDefaults backend) $ \e -> do + hPutStrLn stderr $ "Error: " <> show (e :: E.IOException) + exitFailure + resolved <- Self.resolveAll Self.defaultRegistry stored [] + resolvedDefaults <- case resolved of + Left err -> do + hPutStrLn stderr $ "Error resolving defaults for backend '" + <> T.unpack backend <> "': " <> renderResolveError err + exitFailure + Right rd -> pure rd + + -- Fold CLI flags (and the legacy --token / SYNAPSE_TOKEN / token file) + -- into the CLI-side maps so the unified 'Self.merge' produces the final + -- cookie + header set. + let cliCookiesBase = Map.fromList cliCookieList + cliCookies = case mToken of + Just tok -> Map.insert "access_token" tok cliCookiesBase + Nothing -> cliCookiesBase + cliHeaders = Map.fromList cliHeaderList + (mergedCookies, mergedHeaders) = + Self.merge resolvedDefaults cliCookies cliHeaders + + -- IDENTITY-43: no credential given or stored for this backend — carry + -- the agent's stored session, if there is one. + sess <- sessionHeaders opts ep + (hasCredential (Map.toList mergedCookies) (Map.toList mergedHeaders)) + + -- 'seToken = Nothing' here: any access_token cookie already sits in the + -- merged cookie map. Transport's mergeUpgradeHeaders joins them into a + -- single Cookie header exactly as before. + env0 <- initEnvAt ep backend logger Nothing + pure $ withRequestContext (Map.toList mergedCookies) + (Map.toList mergedHeaders ++ sess) + env0 + +-- ============================================================================ +-- Argument Splitting +-- ============================================================================ +-- Main +-- ============================================================================ + +main :: IO () +main = do + args0 <- execParser argsInfo + -- SCAFFOLD-21: where the connection point is — --url, or -H / -P with + -- --tls / --path — resolved once, before anything dials + opts <- either (\e -> hPutStrLn stderr ("synapse: " <> T.unpack e) >> exitWith (ExitFailure 2)) pure + =<< resolveConnection (argOpts args0) + let args = args0 { argOpts = opts } + ep = soEndpoint opts + + -- SYNAPSE-20: the reconnect window, before anything dials + envWindow <- lookupEnv "SYNAPSE_RECONNECT_FOR" + case soReconnectFor opts <|> fmap T.pack envWindow of + Nothing -> pure () + Just w -> case Reconnect.parseDuration w of + Just secs -> Reconnect.setReconnectWindow secs + Nothing -> do + hPutStrLn stderr $ "synapse: --reconnect-for takes a duration (10m, 90s, 1h, 0), not '" <> T.unpack w <> "'" + exitWith (ExitFailure 2) + + -- IDENTITY-43: keys are local; _login / _logout dial the backend + -- themselves (a proof opens exactly one connection — no probe first). + when (argBackend args == Just "_key") $ runKey (argPath args) + when (argBackend args == Just "_login") $ runLogin opts (argPath args) + when (argBackend args == Just "_logout") $ runLogout opts (argPath args) + + -- Initialize logger (default: ErrorS, only show errors) + logger <- makeLoggerFromOpts opts + + Log.logDebug logger Log.SubsystemCLI "synapse starting..." + + -- Use specified host/port for registry discovery + let discovery = registryDiscoveryAt ep + + -- Get the backend at the connection point (host:port) + -- If it has a registry plugin, that's used for discovering other backends + Log.logDebug logger Log.SubsystemDiscovery $ + "Checking backend at " <> Store.addressKey ep + + -- IDENTITY-16: the probe carries what the command line supplied (-t, + -- --token-file, --cookie, --header and their env forms), so a backend that + -- refuses anonymous upgrades still answers it. + -- IDENTITY-43: and the agent's stored session, made again from its key + -- if the upgrade refuses it. + -- SYNAPSE-20: a call to a named backend waits out an outage at start + -- too (a promote's restart); the registry listing and _self never wait. + let waits = case argBackend args of + Just b -> b == "_find" || not ("_" `T.isPrefixOf` b || "-" `T.isPrefixOf` b) + Nothing -> False + maybeBackend <- probeWithSession' waits opts ep + + Log.logDebug logger Log.SubsystemDiscovery $ + "Backend check complete: " <> T.pack (show maybeBackend) + let hostBackend = maybe "plexus" id maybeBackend + + -- Auto-register: if we're connecting to a non-default port, push the + -- discovered backend to the registry at the default port (if reachable) + let targetPort = soPort opts + targetHost = soHost opts + -- SCAFFOLD-21: a registry records ws://HOST:PORT; an address behind TLS + -- or on a path is not registered + when (targetPort /= defaultPort && isPlain ep) $ do + case maybeBackend of + Just name -> do + -- Check if the registry is at the default port + maybeRegistry <- getBackendAt targetHost defaultPort + case maybeRegistry of + Just registryName -> + registerWithRegistry targetHost defaultPort registryName + name targetHost targetPort + Nothing -> pure () + Nothing -> pure () + + case argBackend args of + Nothing + -- Suppress banner for data output modes + | soEmitIR opts || soSchema opts || soJson opts || soRaw opts -> + runWithDiscovery discovery hostBackend args + | otherwise -> do + -- No backend specified, show available backends + TIO.putStr cliHeader + backends <- discoverBackends discovery + -- Ping backends to check if they're reachable + backendsWithStatus <- pingBackendsVia ep backends + TIO.putStrLn "\nAvailable backends:" + mapM_ (printBackend ep) backendsWithStatus + TIO.putStrLn "\nUsage: synapse [command...]" + Just backend + -- Handle --help/-h if it somehow ends up as the backend + | backend `elem` ["--help", "-h"] -> TIO.putStr cliHeader + -- SYNAPSE-17: _find BACKEND [activation…] WORDS… — a search over the + -- backend's schema, reached as a call to that backend is + | backend == "_find" -> do + fo <- parseBuiltin "_find" Find.findInfo (argPath args) + runWithDiscovery discovery (Find.foBackend fo) + args { argBackend = Just (Find.foBackend fo), argPath = [], argFind = Just fo } + -- Handle _self meta-commands + | backend == "_self" -> + -- SELF-4 verbs (synapse _self ) dispatch through + -- a dedicated parser on the raw argPath. Legacy _self + -- subcommands (template / scan / debug / validate / test) keep + -- the original path through runWithDiscovery. + if isSelfV4Invocation (argPath args) + then runSelfV4 (argPath args) + else runWithDiscovery discovery hostBackend args + | otherwise -> runWithDiscovery discovery backend args + +-- | Legacy @_self@ subcommands that predate SELF-4. These keep their +-- original dispatch path through 'Synapse.Self.Commands.dispatch'. +-- +-- Anything else under @_self@ is treated as SELF-4 (@_self \ +-- ...@) and routes through 'Synapse.Self.Command.runSelfCommand'. +legacySelfSubcommands :: [Text] +legacySelfSubcommands = + [ "template", "scan", "debug", "validate", "test" + , "--help", "-h" -- Legacy help path is also handled by the old dispatcher + ] + +-- | True when @_self@ was invoked in the SELF-4 shape — anything other +-- than a legacy subcommand as the first positional. The SELF-4 parser +-- handles its own help / error messaging from there, so even +-- @_self \@ (no verb) routes here: optparse emits a +-- "Missing: COMMAND" message listing the SELF-4 verbs. +isSelfV4Invocation :: [Text] -> Bool +isSelfV4Invocation [] = False -- No args at all: legacy help. +isSelfV4Invocation (first : _) = first `notElem` legacySelfSubcommands + +-- | Re-parse the post-@_self@ token stream through the SELF-4 +-- optparse-applicative parser, then run the resulting command. +runSelfV4 :: [Text] -> IO () +runSelfV4 rest = do + let argv = map T.unpack rest + parserInfo = SelfCmd.selfCommandInfo + pr = execParserPure defaultPrefs parserInfo argv + cmd <- handleParseResult pr + code <- SelfCmd.runSelfCommand cmd + case code of + ExitSuccess -> pure () + ExitFailure _ -> exitWith code + +-- | A builtin's options, its usage said as @synapse NAME …@. +parseBuiltin :: String -> ParserInfo a -> [Text] -> IO a +parseBuiltin name pinfo rest = + case execParserPure defaultPrefs pinfo (map T.unpack rest) of + Failure f -> do + let (msg, code) = renderFailure f ("synapse " <> name) + case code of + ExitSuccess -> putStrLn msg >> exitSuccess + _ -> hPutStrLn stderr msg >> exitWith code + r -> handleParseResult r + +-- | IDENTITY-43: @synapse _key new|show|list@ — local. +runKey :: [Text] -> IO () +runKey rest = do + cmd <- handleParseResult (execParserPure defaultPrefs IdCmd.keyCommandInfo (map T.unpack rest)) + st <- Store.systemStoreEnv + IdCmd.runKeyCommand st cmd >>= exitWith + +-- | IDENTITY-43: where @_login@ / @_logout@ dial — the connection point +-- named with @-P@, else what the registry says of the backend, else the +-- connection point. +loginAddress :: SynapseOpts -> Text -> IO Endpoint +loginAddress opts backendName + | soPort opts /= defaultPort || not (isPlain ep) = pure ep + | otherwise = do + registered <- getBackendInfo (registryDiscoveryAt ep) backendName + pure $ maybe ep (endpointFor ep) registered + where ep = soEndpoint opts + +dieWith :: Text -> IO a +dieWith msg = TIO.hPutStrLn stderr ("synapse: " <> msg) >> exitFailure + +-- | IDENTITY-43: @synapse -P PORT _login BACKEND --key NAME --as AGENT +-- [--scope role\@SCOPE …] [--ttl SECS]@. +runLogin :: SynapseOpts -> [Text] -> IO () +runLogin opts rest = do + lo <- handleParseResult (execParserPure defaultPrefs IdCmd.loginInfo (map T.unpack rest)) + asked <- askedAgent opts + -- AUTH-8: no key and no agent named — a person, through the browser + when (IdCmd.loKey lo == Nothing && IdCmd.loAs lo == Nothing && asked == Nothing) $ + runLoginPerson opts lo + agent <- maybe (dieWith "name the agent to log in as: --as AGENT (or SYNAPSE_AS)") pure (IdCmd.loAs lo <|> asked) + let keyName = maybe "default" id (IdCmd.loKey lo) + st <- Store.systemStoreEnv + seed <- Store.lookupKey st keyName >>= \case + Left e -> dieWith e + Right Nothing -> dieWith ("no key " <> keyName <> " (synapse _key new " <> keyName <> ")") + Right (Just (s, _)) -> pure s + ep <- loginAddress opts (IdCmd.loBackend lo) + logger <- makeLoggerFromOpts opts + r <- Session.loginWithKey logger ep (IdCmd.loBackend lo) seed agent (IdCmd.loScope lo) (IdCmd.loTtl lo) + lr <- either (\e -> dieWith ("login to " <> IdCmd.loBackend lo <> " at " <> Store.addressKey ep <> " failed: " <> e)) pure r + let rec = Store.SessionRec + { Store.srToken = Session.lrToken lr + , Store.srPrincipal = if T.null (Session.lrPrincipal lr) then Proof.principalOf seed else Session.lrPrincipal lr + , Store.srAgent = Session.lrAgent lr + , Store.srExpiresAt = Session.lrExpiresAt lr + , Store.srKey = keyName + , Store.srScope = IdCmd.loScope lo + , Store.srTtl = IdCmd.loTtl lo + , Store.srBackend = IdCmd.loBackend lo + } + src <- Store.writeSession st ep rec + Store.writeDefaultAgent st ep (Store.srAgent rec) + let until' = case Store.srExpiresAt rec of + Just t -> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" (posixSecondsToUTCTime (fromIntegral t))) + Nothing -> "(the server named no end)" + scope = if null (Session.lrScope lr) then "the key's own grants" else T.intercalate ", " (Session.lrScope lr) + kept = case src of + Store.SessionFromKeychain -> "keychain" + Store.SessionFromFile p -> T.pack p + Store.SessionFromEnv -> "PLEXUS_SESSION" + TIO.putStrLn $ "signed in to " <> IdCmd.loBackend lo <> " at " <> Store.addressKey ep <> " as " <> Store.srAgent rec + mapM_ (\(k, v) -> TIO.putStrLn (" " <> T.justifyLeft 10 ' ' k <> v)) + [ ("principal", Store.srPrincipal rec) + , ("scope", scope) + , ("until", until') + , ("kept in", kept) + ] + exitSuccess + +-- | AUTH-8: the session slot a person's sign-in is kept under. +personAgent :: Text +personAgent = "me" + +-- | AUTH-8: @synapse -P PORT _login BACKEND@ — a person signs in through +-- the browser (the loopback flow), and the session is kept as an agent's +-- is (keychain, else file), under the name @me@, with no key to make it +-- again from: when it ends, synapse says to sign in again. +runLoginPerson :: SynapseOpts -> IdCmd.LoginOpts -> IO () +runLoginPerson opts lo = do + let backend = IdCmd.loBackend lo + ep <- loginAddress opts backend + logger <- makeLoggerFromOpts opts + r <- Session.loginPerson logger ep backend 300 (TIO.hPutStrLn stderr) + g <- either (\e -> dieWith ("sign-in to " <> backend <> " at " <> Store.addressKey ep <> " failed: " <> e)) pure r + who <- case sgWhoami g of + Just w -> pure (Just w) + Nothing -> Session.whoamiWith logger ep backend (sgToken g) + let rec = Store.SessionRec + { Store.srToken = sgToken g + , Store.srPrincipal = sgPrincipal g + , Store.srAgent = personAgent + , Store.srExpiresAt = sgExpiresAt g + , Store.srKey = "" -- a person's: nothing to sign in again from + , Store.srScope = sgCeiling g + , Store.srTtl = Nothing + , Store.srBackend = backend + } + st <- Store.systemStoreEnv + src <- Store.writeSession st ep rec + Store.writeDefaultAgent st ep personAgent + let named = case who of + Just w -> maybe "" id (T.stripPrefix "you are " (renderCallerHeader w)) + Nothing -> case sgName g of + Just n -> n <> " (" <> sgPrincipal g <> ")" + Nothing -> sgPrincipal g + until' = case sgExpiresAt g of + Just t -> T.pack (formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" (posixSecondsToUTCTime (fromIntegral t))) + Nothing -> "(the server named no end)" + kept = case src of + Store.SessionFromKeychain -> "keychain" + Store.SessionFromFile p -> T.pack p + Store.SessionFromEnv -> "PLEXUS_SESSION" + TIO.putStrLn $ "signed in to " <> backend <> " as " <> named + mapM_ (\(k, v) -> TIO.putStrLn (" " <> T.justifyLeft 10 ' ' k <> v)) + [ ("until", until') + , ("kept in", kept <> " (as " <> personAgent <> ")") + ] + exitSuccess + +-- | IDENTITY-43: @synapse -P PORT _logout BACKEND [--as AGENT]@. +runLogout :: SynapseOpts -> [Text] -> IO () +runLogout opts rest = do + lo <- handleParseResult (execParserPure defaultPrefs IdCmd.logoutInfo (map T.unpack rest)) + st <- Store.systemStoreEnv + ep <- loginAddress opts (IdCmd.lgBackend lo) + asked <- askedAgent opts + dflt <- Store.readDefaultAgent st ep + agent <- maybe (dieWith ("no agent is signed in to " <> Store.addressKey ep <> " (name one: --as AGENT)")) pure + (IdCmd.lgAs lo <|> asked <|> dflt) + found <- Store.lookupSession st ep agent + rec <- case found of + Just (Right r, src) | src /= Store.SessionFromEnv -> pure r + _ -> dieWith ("no stored session for " <> agent <> " at " <> Store.addressKey ep) + logger <- makeLoggerFromOpts opts + r <- Session.logoutWithToken logger ep (IdCmd.lgBackend lo) (Store.srToken rec) + Store.removeSession st ep agent + Store.clearDefaultAgent st ep agent + case r of + Right () -> TIO.putStrLn ("signed out " <> agent <> " at " <> Store.addressKey ep) + Left e -> TIO.putStrLn ("forgot " <> agent <> "'s session at " <> Store.addressKey ep + <> " (the server said: " <> e <> ")") + exitSuccess + +-- | Print a backend in the list +-- (SCAFFOLD-21: the connection point by the URL it was named with, when +-- it is not plain ws://HOST:PORT/) +printBackend :: Endpoint -> Backend -> IO () +printBackend ep b = do + let nameField = T.justifyLeft 15 ' ' (backendName b) + let hostPort = Store.addressKey (endpointFor ep b) + let status = case backendReachable b of + Just True -> " [OK]" + Just False -> " [UNREACHABLE]" + Nothing -> "" + let desc = if T.null (backendDescription b) + then "" + else " - " <> backendDescription b + TIO.putStrLn $ " " <> nameField <> hostPort <> status <> desc + +-- | Run a Hub command with backend discovery +runWithDiscovery :: BackendDiscovery -> Text -> Args -> IO () +runWithDiscovery discovery backendName args = do + let opts = argOpts args + ep = soEndpoint opts + -- Try to discover backend info + maybeBackend <- getBackendInfo discovery backendName + + case maybeBackend of + Just backend -> do + -- Verify the resolved backend actually identifies as the requested name. + -- This catches cases where -P points to a different backend than expected, + -- or the registry has stale entries. + -- SYNAPSE-20: a named backend's probe waits out an outage (or the + -- server's 429 under many parallel calls) as the first one did + -- SCAFFOLD-21: at the connection point, reached as it was named + let at = endpointFor ep backend + actualName <- probeWithSession' True opts at + case actualName of + Just name | name /= backendName -> do + hPutStrLn stderr $ "Backend mismatch: requested '" <> T.unpack backendName + <> "' but " <> T.unpack (Store.addressKey at) + <> " identifies as '" <> T.unpack name <> "'" + exitFailure + Nothing -> do + -- Protocol handshake failed when verifying backend + when (epTls at) $ tlsUnreachable at + logger <- makeLoggerFromOpts opts + env <- buildEnv ep backendName logger opts + result <- runSynapseM env (throwBackend (ProtocolHandshakeFailed (backendHost backend) (backendPort backend)) []) + case result of + Left err -> do + hPutStrLn stderr $ renderError err + exitFailure + Right () -> exitSuccess + Just _ -> + -- Match confirmed + run backendName at args + Nothing -> do + -- Backend not found in registry - check if this was a direct connection attempt + -- where the protocol handshake failed + maybeDirectBackend <- probeWithSession' True opts ep + logger <- makeLoggerFromOpts opts + env <- buildEnv ep backendName logger opts + case maybeDirectBackend of + Nothing -> do + -- Protocol handshake failed at the specified host:port + when (epTls ep) $ tlsUnreachable ep + result <- runSynapseM env (throwBackend (ProtocolHandshakeFailed (soHost opts) (soPort opts)) []) + case result of + Left err -> do + hPutStrLn stderr $ renderError err + exitFailure + Right () -> exitSuccess + Just discoveredName | discoveredName /= backendName -> do + -- Backend exists but has a different name + backends <- discoverBackends discovery + backendsWithStatus <- pingBackendsVia ep backends + result <- runSynapseM env (throwBackend (BackendNotFound backendName) backendsWithStatus) + case result of + Left err -> do + hPutStrLn stderr $ renderError err + exitFailure + Right () -> exitSuccess + Just _ -> do + -- Backend discovered successfully - should not reach here, but proceed + run backendName ep args + +-- | SCAFFOLD-21: a wss address whose probe failed — why, from the probe +-- (a certificate the trust store refused, a name it does not cover, a +-- proxy that does not upgrade), and what to do about a local CA. Exits 1. +tlsUnreachable :: Endpoint -> IO () +tlsUnreachable at = do + why <- maybe "no answer" id <$> probeFailureAt at + let shown = T.replace "\\\"" "\"" (fst (T.breakOn "\\nCallStack" why)) + detail = case T.breakOn "Error_Protocol \"" shown of + (_, r) | not (T.null r) -> T.takeWhile (/= '"') (T.drop (T.length "Error_Protocol \"") r) + _ -> shown + has = any (`T.isInfixOf` shown) + if has ["HandshakeFailed"] + then do + TIO.hPutStrLn stderr $ "synapse: the TLS handshake with " <> E.shortUrl at <> " failed: " <> detail + TIO.hPutStrLn stderr $ + if has ["UnknownCa", "unknown CA", "ertificate", "NameMismatch", "Expired", "SelfSigned"] + then " its certificate is checked against the system's trust store and each --cacert, and its name\n" + <> " against " <> epHost at <> "; for a local CA, add --cacert ROOT.pem" + else " the server refused it — does it serve a certificate for " <> epHost at <> "?" + else case T.breakOn "responseCode = " shown of + (_, r) | not (T.null r) -> do + let code = T.takeWhile (`elem` ['0' .. '9']) (T.drop (T.length "responseCode = ") r) + TIO.hPutStrLn stderr $ "synapse: " <> E.shortUrl at <> " answered the upgrade with HTTP " <> code + <> ", not a WebSocket" + TIO.hPutStrLn stderr $ if code `elem` ["401", "403"] + then " it refused the credential: sign in with synapse " <> cliOptions at <> " _login BACKEND" + else " is " <> epPath at <> " the socket's path? (a hosted app's is /ws)" + _ -> TIO.hPutStrLn stderr $ "synapse: " <> E.shortUrl at <> " did not answer the _info probe: " <> detail + exitFailure + +-- | Run a Hub command with specified backend and connection details +run :: Text -> Endpoint -> Args -> IO () +run backend ep args = do + let opts = argOpts args + logger <- makeLoggerFromOpts opts + Log.logInfo logger Log.SubsystemCLI $ "Synapse starting: backend=" <> backend <> ", at " <> Store.addressKey ep + env <- withView ep =<< buildEnv ep backend logger opts + rendererCfg <- defaultRendererConfig + Log.logDebug logger Log.SubsystemCLI "Running dispatch..." + result <- runSynapseM env (dispatch args rendererCfg) + -- IDENTITY-43: the server refused the stored session (the upgrade's 401, + -- or the in-band "you have signed out" held back before anything was + -- shown): log in again from the key, and run the call once more. + ended <- Session.takeSessionEnded + let refused = case result of + Left (TransportErrorContext ctx) -> Session.isUpgradeRefused (tcMessage ctx) + Left (NavError (FetchError m _)) -> Session.isUpgradeRefused m + _ -> False + result' <- if not (isJust ended || refused) then pure result else do + st <- Store.systemStoreEnv + new <- Session.reattest logger st ep + case new of + Just _ -> do + env' <- withView ep =<< buildEnv ep backend logger opts + runSynapseM env' (dispatch args rendererCfg) + Nothing -> do + mapM_ (\m -> hPutStrLn stderr ("Error: " <> T.unpack m)) ended + pure result + case result' of + Left err -> do + hPutStrLn stderr $ renderError err + exitFailure + Right () -> do + -- AUTH-8: a refusal was shown — the call did not happen + refused' <- Session.wasRefused + if refused' then exitWith (ExitFailure refusedExit) else exitSuccess + +-- | AUTH-8: the exit status of a call the hub refused (sysexits' EX_NOPERM). +refusedExit :: Int +refusedExit = 77 + +-- | AUTH-8: the env's cache keys qualified by the caller's view, as the +-- _info probe at this address answered it (the view's hash, else its kind). +withView :: Endpoint -> SynapseEnv -> IO SynapseEnv +withView ep env = do + info <- probedInfoAt ep + let key = info >>= \i -> infoViewHash i <|> (viewText <$> infoView i) + pure (withViewKey key env) + +-- | Dispatch based on navigation result +dispatch :: Args -> RendererConfig -> SynapseM () +dispatch Args{argOpts = soOpts@SynapseOpts{..}, argBackend, argPath, argFind} rendererCfg = do + -- Check for _self commands first (before anything else) + case argBackend of + _ | Just fo <- argFind -> runFind fo + Just "_self" -> do + -- _self meta-command: parse subcommand and rest from argPath + let (pathSegs, rawParams, _, _) = parsePathAndParams argPath + case pathSegs of + (subcommand : rest) -> do + Self.dispatch subcommand rest rawParams + return () + [] -> do + -- No subcommand provided, show help + Self.showHelp + return () + + -- Normal dispatch + _ -> do + -- Mode 1: Raw JSON-RPC passthrough + case soRpc of + Just rpcJson -> do + case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 rpcJson) of + Left err -> throwParse $ T.pack err + Right rpcReq -> do + items <- invokeRawRpc rpcReq + liftIO $ mapM_ (printResult soJson soRaw rendererCfg) items + return () + + Nothing -> do + -- Parse path and inline params (--key value pairs) + let (pathSegs, rawParams, flagArgs, helpRequested) = parsePathAndParams argPath + + -- Normal Plexus RPC routing + -- Apply parameter transformations (path expansion, env vars) + transformEnv <- liftIO mkTransformEnv + -- SYNAPSE-10: a value that names its source (@file, -) is read + -- first, so no other step ever sees the literal "@file"; stdin is + -- read once and kept for the second pass below + sourceEnv <- liftIO $ mkSourceEnv (teCwd transformEnv) (teHome transformEnv) + let fromSources pairs = liftIO (expandSources sourceEnv pairs) >>= either (throwParse . renderSourceError) pure + sourcedParams <- if helpRequested then pure rawParams else fromSources rawParams + inlineParams <- liftIO $ transformParams transformEnv defaultTransformers sourcedParams + + -- Mode 1.5: Respond subcommand (agent sends a response to a pending bidir request) + if not (null pathSegs) && head pathSegs == "respond" + then handleRespondCommand sourcedParams + + -- Mode 2: Schema request + else if soSchema + then do + -- Try to navigate and determine if last segment is a method + schemaResult <- fetchSchemaForPath pathSegs + case schemaResult of + Left err -> throwNav $ FetchError err pathSegs + Right val -> liftIO $ LBS.putStrLn $ encode val + + -- Mode 3: Generate templates (IR-driven approach) + else if soGenerate + then do + homeDir <- liftIO getHomeDirectory + let baseDir = homeDir ".config" "synapse" "templates" + writeAndLog gt = do + writeGeneratedTemplateIR baseDir gt + TIO.putStrLn $ " " <> T.pack (TemplateIR.gtPath gt) + liftIO $ TIO.putStrLn $ "Generating templates in " <> T.pack baseDir <> "..." + count <- TemplateIR.generateAllTemplatesWithCallback writeAndLog pathSegs + liftIO $ TIO.putStrLn $ "Generated " <> T.pack (show count) <> " templates" + + -- Mode 4: Emit IR for code generation + else if soEmitIR + then do + ir <- buildIR soGeneratorInfo pathSegs + liftIO $ LBS.putStrLn $ encode ir + + else do + -- Mode 5: Normal navigation + info <- currentInfo + let anonymous = (info >>= infoView) == Just Anonymous + if null pathSegs + then do + -- SYNAPSE-12: a backend named, its help is the + -- backend's alone — no banner, options or meta-commands. + -- AUTH-8: to an anonymous caller, only the door. + rootSchema <- if anonymous + then (Just <$> navigate []) `catchError` \_ -> pure Nothing + else Just <$> navigate [] + case rootSchema of + _ | anonymous -> showAnonymous info (rootSchema >>= viewSchema) + Just (ViewPlugin schema _) -> showPluginHelp info [] schema + _ -> pure () + else do + -- Navigate to target + -- AUTH-8: an anonymous caller asking for anything the + -- door does not show is shown the door + view <- navigate pathSegs `catchError` \e -> case e of + NavError (NotFound {}) | anonymous -> do + root <- (Just <$> navigate []) `catchError` \_ -> pure Nothing + showAnonymous info (root >>= viewSchema) + liftIO $ do + TIO.hPutStrLn stderr $ "synapse: sign in to reach " <> T.intercalate " " pathSegs + exitWith (ExitFailure refusedExit) + _ -> throwError e + case view of + -- Landed on a plugin: show help + ViewPlugin schema _ -> showPluginHelp info pathSegs schema + + -- Landed on a method: invoke or show help + ViewMethod method path -> do + let fullPath = T.intercalate "." path + + -- IR-15: emit stderr deprecation warnings right before any + -- real invocation. Dedupe is per-process-lifetime, so this + -- action is idempotent on repeat calls. We bind it as a + -- local SynapseM action and invoke it at both invocation + -- sites below (fast path and slow path). --help, --dry-run, + -- --schema, and --emit-ir do not invoke, and intentionally + -- do not fire these warnings. + let fireDeprecationWarnings :: SynapseM () + fireDeprecationWarnings = do + liftIO $ emitMethodWarning + soNoDeprecationWarnings + fullPath + (methodDeprecation method) + let namespacePath = init path + when (not (null namespacePath)) $ do + let activationNs = T.intercalate "." namespacePath + parentPlugin <- fetchSchemaAt namespacePath + liftIO $ emitActivationWarning + soNoDeprecationWarnings + activationNs + (psDeprecation parentPlugin) + + -- Optimization: Skip IR construction for parameter-less methods + -- IR is only needed for: + -- 1. Help rendering (--help flag) + -- 2. Parameter parsing (methods with params) + let needsIR = helpRequested + || isJust (methodParams method) + || isJust soParams + || not (null inlineParams) + + -- Fast path: parameter-less method with no help requested + if not needsIR + then fireDeprecationWarnings >> invokeMethod sourceEnv method path (object []) + else do + -- Build IR for this method's namespace + ir <- buildIR soGeneratorInfo (init path) + + -- If --help was explicitly requested, show help and exit + if helpRequested + then do + case Map.lookup fullPath (irMethods ir) of + Just methodDef -> do + page <- pageFor info pathSegs method + liftIO $ do + TIO.putStr $ renderMethodPage page ir methodDef + backendHelpFooter + Nothing -> + liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method + else do + -- Build params: use IR-driven parsing for inline params + let schemaDefaults = extractSchemaDefaults method + userParams <- case soParams of + -- -p JSON: parse as raw JSON (bypass IR parsing); + -- SYNAPSE-10: -p @params.json and -p - name a source + Just given -> do + jsonStr <- liftIO (expandValue sourceEnv "" given) >>= either (throwParse . renderSourceError) pure + case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 jsonStr) of + Left err -> throwParse $ T.pack err + Right p -> pure p + Nothing + | not (null inlineParams) -> + -- Use IR-driven parsing for inline params + case Map.lookup fullPath (irMethods ir) of + Just methodDef -> do + -- Pair the flags again by parameter type, now that the + -- method is known (a value may begin with dashes) + methodParams <- case pairFlags ir methodDef flagArgs of + Right pairs -> fromSources pairs >>= liftIO . transformParams transformEnv defaultTransformers + Left errs -> do + liftIO $ mapM_ (hPutStrLn stderr . renderParseError) errs + throwParse "Parameter parsing failed" + -- Inject boolean defaults for flags without values + let paramsWithBools = injectBooleanDefaults ir methodDef methodParams + -- Inject smart defaults for missing required params (e.g., --path defaults to cwd) + paramsWithDefaults <- liftIO $ injectSmartDefaults transformEnv ir methodDef paramsWithBools + case parseParams ir methodDef paramsWithDefaults of + Right p -> pure p + Left errs -> do + liftIO $ mapM_ (hPutStrLn stderr . renderParseError) errs + throwParse "Parameter parsing failed" + Nothing -> + -- Fallback to flat object if method not in IR + pure $ buildParamsObject inlineParams + | otherwise -> pure $ object [] + -- Merge: user params override schema defaults + let params = mergeParams schemaDefaults userParams + + if soDryRun + then do + backend <- asks seBackend + liftIO $ LBS.putStrLn $ encodeDryRun backend (init path) (last path) params + -- Show help when: method has required params AND user provided no params + else if hasRequiredParams method && userParams == object [] && null inlineParams + then do + -- Render help from IR + case Map.lookup fullPath (irMethods ir) of + Just methodDef -> do + page <- pageFor info pathSegs method + liftIO $ do + TIO.putStr $ renderMethodPage page ir methodDef + backendHelpFooter + Nothing -> + -- Fallback: method not in IR, use basic info + liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method + -- IR-15: fire stderr deprecation warnings before real invocation. + else fireDeprecationWarnings >> invokeMethod sourceEnv method path params + where + -- AUTH-8: what the _info probe at this address answered (view, auth) + currentInfo :: SynapseM (Maybe BackendInfo) + currentInfo = do + ep <- asks seEndpoint + liftIO (probedInfoAt ep) + + viewSchema = \case + ViewPlugin schema _ -> Just schema + _ -> Nothing + + -- A plugin's help: as SYNAPSE-12 laid it out; in a caller's view (AUTH-4) + -- with who the caller is under the description, and each method's + -- grant and where it is held when the schema says them. + -- + -- SYNAPSE-13: in gh's shape — a usage line, one line per method in its + -- group, and how to see a method's options. + showPluginHelp :: Maybe BackendInfo -> [Text] -> PluginSchema -> SynapseM () + showPluginHelp info segs schema = do + backend <- asks seBackend + let invoke = T.unwords ([invokeProgram, backend] ++ segs) + who <- case info >>= infoView of + Just Caller -> Session.whoamiM + _ -> pure Nothing + let caller = case info >>= infoView of + Just Caller -> Just (maybe "you are signed in" renderCallerHeader who) + _ -> Nothing + liftIO $ do + TIO.putStr $ renderListing defaultStyle (Listing invoke caller) schema + synapseHelpLine + + -- SYNAPSE-13: synapse and the global options that reach this backend, + -- as a command line shown in help (@synapse -P 4455@). + invokeProgram :: Text + invokeProgram = T.unwords (filter (not . T.null) ["synapse", cliOptions soEndpoint]) + + -- SYNAPSE-13: what a method's page needs beside the IR — how it is + -- reached, its schema (examples, values, grant) and the caller's view. + pageFor :: Maybe BackendInfo -> [Text] -> MethodSchema -> SynapseM MethodPage + pageFor info segs method = do + backend <- asks seBackend + pure MethodPage + { mpProgram = invokeProgram + , mpTarget = T.unwords (backend : segs) + , mpSchema = Just method + , mpCaller = (info >>= infoView) == Just Caller + } + + -- SYNAPSE-17: search the backend's methods and parameters (the + -- caller's view of its schema, from the IR cache when its hash is + -- current) and answer in help's shape; -j: one JSON object per hit. + runFind :: Find.FindOpts -> SynapseM () + runFind fo = do + backend <- asks seBackend + cache <- liftIO $ if soNoCache then pure Nothing else + (Just <$> (newIRCache . defaultCacheConfig =<< getHomeDirectory)) + `E.catch` \(_ :: E.SomeException) -> pure Nothing + ir <- Find.loadCatalog cache + tty <- liftIO $ hIsTerminalDevice stdout + noColor <- liftIO $ lookupEnv "NO_COLOR" + let ans = Find.answer invokeProgram backend (tty && maybe True null noColor) fo ir + liftIO $ if not (Find.anMatched ans) + then do + if soJson + then TIO.hPutStrLn stderr ("No match for '" <> T.unwords (Find.foTerms fo) <> "' in " <> Find.anScope ans <> ".") + else TIO.putStr (Find.anText ans) + exitWith (ExitFailure 1) + else if soJson + then mapM_ (LBS.putStrLn . encode) (Find.anJson ans) + else TIO.putStr (Find.anText ans) + + -- AUTH-8: the page an anonymous caller sees: the door, and how to sign in. + showAnonymous :: Maybe BackendInfo -> Maybe PluginSchema -> SynapseM () + showAnonymous info root = do + backend <- asks seBackend + authSchema <- (Just <$> fetchSchemaAt ["auth"]) `catchError` \_ -> pure Nothing + let invokePrefix = invokeProgram + page = AnonPage + { apBackend = backend + , apVersion = psVersion <$> root + , apMethods = anonymousMethods (info >>= infoAuth) authSchema + , apInvoke = invokePrefix + } + liftIO $ TIO.putStr (renderAnonymousPage page) + + handleRespondCommand :: [(Text, Text)] -> SynapseM () + handleRespondCommand params = do + let mRequestId = lookup "request_id" params + mResponseStr = lookup "response" params + case (mRequestId, mResponseStr) of + (Nothing, _) -> throwParse "Missing --request-id for respond subcommand" + (_, Nothing) -> throwParse "Missing --response for respond subcommand" + (Just requestId, Just responseStr) -> + case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 responseStr) of + Left err -> throwParse $ "Invalid --response JSON: " <> T.pack err + Right (resp :: Response Value) -> sendResponse requestId resp + + invokeMethod srcEnv method path params = do + let namespacePath = init path -- path without method name + let methodName' = last path + -- Set method path hint for template resolution + let rendererCfg' = withMethodPath rendererCfg path + -- Determine bidirectional mode (--bidir-cmd takes precedence) + bidirMode <- liftIO $ case soBidirCmd of + Just cmd -> pure $ BidirCmd cmd + Nothing -> case soBidirMode of + Just modeStr -> case parseBidirMode modeStr of + Just mode -> pure mode + Nothing -> do + TIO.hPutStrLn stderr $ "[synapse] Unknown --bidir-mode: " <> modeStr <> ", using auto-detect" + detectBidirMode + Nothing -> detectBidirMode + -- SYNAPSE-10: a value read from stdin (-) has taken it; the JSON + -- bidirectional mode reads stdin too, and the two cannot share + stdinTaken <- liftIO $ stdinWasRead srcEnv + case bidirMode of + BidirJson | stdinTaken -> throwParse "a value was read from stdin (-), so --bidir-mode json cannot read it too; answer the backend's requests with --bidir-cmd, or use a file (@FILE) for the value" + _ -> pure () + -- IDENTITY-43: while the stored session could still be made again, + -- a "you have signed out" answered before anything else is held back + -- for 'run' to log in again and retry. + ep <- asks seEndpoint + armed <- liftIO $ Session.canReattest ep + let printer item = do + shown <- Session.printedAny + if armed && not shown && Session.isSessionEndedItem item + then Session.markSessionEnded (endedMessage item) + else do + case item of + HubData{} -> Session.notePrinted + _ -> pure () + printResult soJson soRaw rendererCfg' item + -- SYNAPSE-20: a stream that resumed after a gap says so — on -j as a + -- line of its own (stdout, in the stream), else on stderr + let resumed r + | soJson = do + LBS.putStrLn $ encode $ object $ + [ "type" .= ("reconnected" :: Text) + , "outage_secs" .= (fromIntegral (round (Reconnect.rsOutageSecs r) :: Int) :: Int) + , "attempts" .= Reconnect.rsAttempts r + ] ++ maybe [] (\s -> ["since" .= s]) (Reconnect.rsSince r) + hFlush stdout + | otherwise = TIO.hPutStrLn stderr $ + "synapse: the stream resumed" + <> maybe "; anything sent during the gap may be missing" (\s -> " from " <> T.pack (show s) <> " (since)") (Reconnect.rsSince r) + -- SYNAPSE-20: a stream outliving a restart finds its session gone + -- (menger keeps them in memory): sign in again from the key, and + -- reconnect with the new one + backendName' <- asks seBackend + logger' <- asks seLogger + let refreshAuth = do + st <- Store.systemStoreEnv + new <- Session.reattestAgain logger' st ep + case new of + Nothing -> pure Nothing + Just _ -> do + env' <- buildEnv ep backendName' logger' soOpts + pure (Just (mergeUpgradeHeaders (seToken env') (seCookies env') (seHeaders env'))) + -- Use bidirectional streaming handler + invokeStreamingWithBidir + (Reconnect.callShape method) + refreshAuth + resumed + namespacePath + methodName' + params + printer + (handleBidirRequest bidirMode Nothing) + + endedMessage item = case item of + HubData _ _ _ (Object o) | Just (String m) <- KM.lookup "message" o -> m + HubError _ _ e _ -> e + _ -> "your session has ended" + + -- Extract default values from JSON Schema properties + -- Schema format: {"properties": {"key": {"default": value, ...}, ...}, ...} + extractSchemaDefaults :: MethodSchema -> Value + extractSchemaDefaults m = case methodParams m of + Nothing -> object [] + Just (Object o) -> case KM.lookup "properties" o of + Just (Object props) -> object + [ (k, defaultVal) + | (k, propSchema) <- KM.toList props + , Object propObj <- [propSchema] + , Just defaultVal <- [KM.lookup "default" propObj] + ] + _ -> object [] + Just _ -> object [] + + -- Merge two JSON objects: right takes precedence over left + mergeParams :: Value -> Value -> Value + mergeParams (Object defaults) (Object user) = + Object (KM.union user defaults) -- union prefers first arg on conflict + mergeParams _ user = user -- if defaults aren't an object, just use user params + + -- Check if method has required parameters + hasRequiredParams :: MethodSchema -> Bool + hasRequiredParams m = case methodParams m of + Nothing -> False + Just (Object o) -> case KM.lookup "required" o of + Just (Array arr) -> not (null arr) + _ -> False + Just _ -> False + + -- Fetch schema for a path, detecting if last segment is a method + -- Uses navigate to determine what type of schema to fetch + fetchSchemaForPath :: [Text] -> SynapseM (Either Text Value) + fetchSchemaForPath segs = do + view <- navigate segs + case view of + ViewPlugin schema _ -> pure $ Right $ toJSON schema + ViewMethod method path -> do + -- Use method-specific schema query for detailed method info + let parentPath = init path + methodName' = last path + detailedMethod <- fetchMethodSchema parentPath methodName' + pure $ Right $ toJSON detailedMethod + + -- Invoke raw JSON-RPC request + invokeRawRpc :: Value -> SynapseM [HubStreamItem] + invokeRawRpc rpcReq = do + case rpcReq of + Object o -> case (KM.lookup "method" o, KM.lookup "params" o) of + (Just (String method), Just params) -> invokeRaw method params + (Just (String method), Nothing) -> invokeRaw method (object []) + _ -> throwParse "JSON-RPC must have 'method' field" + _ -> throwParse "JSON-RPC must be an object" + +-- | Build JSON object from key-value pairs +buildParamsObject :: [(Text, Text)] -> Value +buildParamsObject pairs = object + [ (K.fromText k, inferValue v) | (k, v) <- pairs ] + where + -- Try to infer the JSON type from the string value + inferValue :: Text -> Value + inferValue t + | t == "true" = Bool True + | t == "false" = Bool False + | Just n <- readMaybe (T.unpack t) :: Maybe Integer = Number (fromInteger n) + | Just n <- readMaybe (T.unpack t) :: Maybe Double = Number (realToFrac n) + | otherwise = String t + +readMaybe :: Read a => String -> Maybe a +readMaybe s = case reads s of + [(x, "")] -> Just x + _ -> Nothing + +-- | SYNAPSE-12: the one line under a backend's help that points at +-- synapse's own (dim on a terminal). +backendHelpFooter :: IO () +backendHelpFooter = TIO.putStrLn "" >> synapseHelpLine + +-- | SYNAPSE-13: the pointer to synapse's own help, dimmed on a terminal — +-- under a listing's own "Run '…'" lines, with no blank between. +synapseHelpLine :: IO () +synapseHelpLine = do + tty <- hIsTerminalDevice stdout + let line = "Run 'synapse --help' for synapse's own options." + TIO.putStrLn (if tty then "\ESC[2m" <> line <> "\ESC[0m" else line) + +-- | ASCII splash logo +splash :: Text +splash = T.unlines + [ "" + , "███████╗██╗ ██╗███╗ ██╗ █████╗ ██████╗ ███████╗███████╗" + , "██╔════╝╚██╗ ██╔╝████╗ ██║██╔══██╗██╔══██╗██╔════╝██╔════╝" + , "███████╗ ╚████╔╝ ██╔██╗ ██║███████║██████╔╝███████╗█████╗ " + , "╚════██║ ╚██╔╝ ██║╚██╗██║██╔══██║██╔═══╝ ╚════██║██╔══╝ " + , "███████║ ██║ ██║ ╚████║██║ ██║██║ ███████║███████╗" + , "╚══════╝ ╚═╝ ╚═╝ ╚═══╝╚═╝ ╚═╝╚═╝ ╚══════╝╚══════╝" + , "" + ] + +-- | Get CLI help text from optparse-applicative +cliHeader :: Text +cliHeader = splash <> T.pack (fst $ renderFailure failure "synapse") <> "\n" + where + failure = parserFailure defaultPrefs argsInfo (ShowHelpText Nothing) mempty + +-- | The meta-commands, under synapse's own options: in @synapse --help@ and +-- on the page bare @synapse@ shows. +metaCommands :: [Text] +metaCommands = + [ "" + , "Values (after the backend and the method):" + , " --flag @FILE the value is that file's contents; --flag - reads stdin" + , " (once, however many values ask); @@text sends a literal" + , " @text. -p @params.json and -p - take the whole object the" + , " same way. No argument then carries the value, so a body" + , " can be as large as the backend accepts" + , "" + , "Where the hub is (before the backend):" + , " -P PORT / -H HOST plain ws://HOST:PORT/ (default 127.0.0.1:4444, the registry)" + , " --url wss://HOST/ws a hub behind TLS (every hosted app), or ws://HOST:PORT/PATH;" + , " the same as -H HOST --tls --path /ws (443 unless -P). The" + , " certificate is checked against the system's trust store;" + , " --cacert FILE trusts a local CA too. Sessions are kept per" + , " URL, so _login and every call take the same options" + , "" + , "Meta-commands:" + , "" + , " synapse _key new|show|list [NAME]" + , " Ed25519 keys an agent proves who it is with (keychain, else" + , " ~/.plexus/keys/NAME.key; PLEXUS_KEY and $CREDENTIALS_DIRECTORY read first)" + , "" + , " synapse -P PORT _login BACKEND" + , " synapse -P PORT _login BACKEND --key NAME --as AGENT [--scope ROLE@SCOPE] [--ttl SECS]" + , " synapse -P PORT _logout BACKEND [--as AGENT]" + , " A person signs in through the browser (a loopback on 127.0.0.1; kept as" + , " 'me'); an agent logs in from a key. Later calls to that backend carry the" + , " session by themselves (--as AGENT / SYNAPSE_AS picks one; else the last" + , " logged in), and an agent's logs in again from the key when it ends" + , "" + , " synapse -P PORT _find BACKEND [ACTIVATION...] WORDS... [--limit N] [--methods|--params]" + , " Search the backend's methods and parameters: names and descriptions," + , " typos and abbreviations too (setpar finds set_parent), best first, in" + , " help's shape (METHODS, PARAMETERS, MENTIONED IN); -j one JSON object per hit" + , "" + , " synapse _self template" + , " Manage Mustache templates (CRUD operations)" + , "" + , " Subcommands:" + , " list [pattern] - List existing templates" + , " show - Display template content" + , " generate [pattern] - Generate new templates from IR" + , " delete - Delete templates" + , " reload - Clear template cache" + , "" + , " Examples:" + , " synapse _self template list" + , " synapse _self template show cone.chat" + , " synapse _self template generate 'plexus.cone.*'" + , "" + ] + +-- | Render an error for display +renderError :: SynapseError -> String +renderError = \case + NavError (NotFound seg path maybeSchema) -> + let baseMsg = "Command not found: '" <> T.unpack seg <> "' at " <> showPath path + in case maybeSchema of + Nothing -> baseMsg + Just schema -> + let methods = psMethods schema + children = pluginChildren schema + suggestions = if null methods && null children + then "" + else "\n\nAvailable commands:" + <> renderMethods methods + <> renderChildren children + in baseMsg <> suggestions + NavError (MethodNotTerminal seg path) -> + "Method '" <> T.unpack seg <> "' cannot have subcommands at " <> showPath path + NavError (Cycle hash path) -> + "Cycle detected: hash " <> T.unpack hash <> " at " <> showPath path + NavError (FetchError msg path) -> + "Fetch error at " <> showPath path <> ": " <> T.unpack msg + TransportError msg -> + "Transport error: " <> T.unpack msg + TransportErrorContext ctx -> + renderTransportError ctx + ParseError msg -> + "Parse error: " <> T.unpack msg + ValidationError msg -> + "Validation error: " <> T.unpack msg + BackendError errorType backends -> + case errorType of + BackendNotFound name -> + "Backend not found: '" <> T.unpack name <> "'" + <> renderBackendList backends + BackendUnreachable name -> + "Backend unreachable: '" <> T.unpack name <> "'" + <> renderBackendList backends + NoBackendsAvailable -> + "No backends available" + <> renderBackendList backends + ProtocolHandshakeFailed host port -> + "Protocol handshake failed at " <> T.unpack host <> ":" <> show port <> "\n" + <> "The _info request did not complete successfully within 2 seconds.\n" + <> "This typically means:\n" + <> " - The server is not responding to Plexus RPC protocol messages\n" + <> " - The server is not sending required StreamDone messages\n" + <> " - The connection is timing out" + where + showPath [] = "root" + showPath p = T.unpack $ T.intercalate "." p + + renderMethods [] = "" + renderMethods methods = + let header = "\n\n Methods:" + methodLines = map renderMethod methods + in header <> concat methodLines + + renderMethod method = + let name = T.unpack $ methodName method + desc = T.unpack $ methodDescription method + padding = 20 + namePadded = name <> replicate (max 1 (padding - length name)) ' ' + in "\n " <> namePadded <> desc + + renderChildren [] = "" + renderChildren children = + let header = "\n\n Child plugins:" + childLines = map renderChild children + in header <> concat childLines + + renderChild child = + let name = T.unpack $ csNamespace child + desc = T.unpack $ csDescription child + padding = 20 + namePadded = name <> replicate (max 1 (padding - length name)) ' ' + in "\n " <> namePadded <> desc + + renderBackendList [] = "\n\nNo backends available." + renderBackendList backends = + let header = "\n\nAvailable backends:" + backendLines = map renderBackendLine backends + usageHint = "\n\nUsage: synapse [command...]" + in header <> concat backendLines <> usageHint + + renderBackendLine backend = + let name = T.unpack $ backendName backend + nameField = name <> replicate (max 1 (15 - length name)) ' ' + hostPort = T.unpack $ backendHost backend <> ":" <> T.pack (show (backendPort backend)) + status = case backendReachable backend of + Just True -> " [OK]" + Just False -> " [UNREACHABLE]" + Nothing -> "" + desc = if T.null (backendDescription backend) + then "" + else " - " <> T.unpack (backendDescription backend) + in "\n " <> nameField <> hostPort <> status <> desc + +-- | Render transport error with context +renderTransportError :: TransportContext -> String +renderTransportError TransportContext{..} = case tcCategory of + ConnectionRefused -> + "Connection refused\n\n" <> + "Backend: " <> T.unpack tcBackend <> "\n" <> + "Address: " <> T.unpack tcHost <> ":" <> show tcPort <> "\n" <> + "Path: " <> showPath tcPath <> "\n\n" <> + "Troubleshooting:\n" <> + " - Check if the backend is running\n" <> + " - Verify host (-H) and port (-P) settings\n" <> + " - Run 'synapse' (no args) to list backends" + + ConnectionTimeout -> + "Connection timeout\n\n" <> + "Backend: " <> T.unpack tcBackend <> " @ " <> + T.unpack tcHost <> ":" <> show tcPort <> "\n\n" <> + "The server may be overloaded or network latency is high\n" <> + "Error: " <> T.unpack tcMessage + + ProtocolError -> + "Protocol error\n\n" <> + "Backend: " <> T.unpack tcBackend <> "\n" <> + "This may indicate a version mismatch\n\n" <> + "Error: " <> T.unpack tcMessage + + UnknownTransportError -> + "Transport error: " <> T.unpack tcMessage <> "\n\n" <> + "Backend: " <> T.unpack tcBackend <> " @ " <> + T.unpack tcHost <> ":" <> show tcPort + where + showPath [] = "root" + showPath p = T.unpack $ T.intercalate "." p + +-- | Render a parse error for display +renderParseError :: Parse.ParseError -> String +renderParseError = \case + Parse.UnknownParam name suggestions -> + "Unknown parameter: --" <> T.unpack name <> + case suggestions of + [] -> "" + [s] -> "\n\nDid you mean: --" <> T.unpack s <> "?" + ss -> "\n\nDid you mean one of:\n" <> + unlines [" --" <> T.unpack s | s <- ss] + Parse.MissingRequired name -> + "Missing required parameter: --" <> T.unpack name + Parse.InvalidValue name reason -> + "Invalid value for --" <> T.unpack name <> ": " <> T.unpack reason + Parse.AmbiguousVariant name variants -> + "Ambiguous variant for --" <> T.unpack name <> ": could be one of " <> show (map T.unpack variants) + Parse.MissingDiscriminator param field -> + "Missing discriminator for --" <> T.unpack param <> ": need --" <> T.unpack param <> "." <> T.unpack field + Parse.UnknownVariant param value valid suggestions -> + "Unknown variant '" <> T.unpack value <> "' for --" <> T.unpack param <> + "\n\nValid variants: " <> T.unpack (T.intercalate ", " valid) <> + case suggestions of + [] -> "" + [s] -> "\n\nDid you mean: " <> T.unpack s <> "?" + ss -> "\n\nDid you mean one of: " <> T.unpack (T.intercalate ", " ss) <> "?" + Parse.TypeNotFound name -> + "Type not found in IR: " <> T.unpack name + Parse.MalformedListValue name value reason -> + "Malformed list value for --" <> T.unpack name <> ": " <> T.unpack value <> + " (" <> T.unpack reason <> ")" + Parse.UnexpectedArgument arg -> + "Unexpected argument: " <> T.unpack arg <> + "\n\nA value follows its flag (--key VALUE or --key=VALUE); a boolean flag takes none unless it is true or false." + + +-- | Write a generated template to disk (no logging) +writeGeneratedTemplateIR :: FilePath -> TemplateIR.GeneratedTemplate -> IO () +writeGeneratedTemplateIR baseDir gt = do + let fullPath = baseDir TemplateIR.gtPath gt + createDirectoryIfMissing True (baseDir T.unpack (TemplateIR.gtNamespace gt)) + TIO.writeFile fullPath (TemplateIR.gtTemplate gt) + +-- | Encode a dry-run request +encodeDryRun :: Text -> [Text] -> Text -> Value -> LBS.ByteString +encodeDryRun backend namespacePath method params = + let fullPath = if null namespacePath then [backend] else namespacePath + dotPath = T.intercalate "." (fullPath ++ [method]) + in encode $ object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (1 :: Int) + , "method" .= (backend <> ".call") + , "params" .= object + [ "method" .= dotPath + , "params" .= params + ] + ] + +-- | Print a stream result +-- soJson: output raw JSON stream items +-- soRaw: skip template rendering, just output content JSON +-- otherwise: try template rendering, fall back to content JSON +printResult :: Bool -> Bool -> RendererConfig -> HubStreamItem -> IO () +printResult json raw cfg item = case itemRefusal item of + -- AUTH-8: a refusal says what it needed (and the call exits non-zero) + Just r -> do + Session.noteRefused + if json then LBS.putStrLn (encode item) else do + ceiling' <- Session.currentCeiling + TIO.hPutStr stderr (renderRefusal ceiling' r) + Nothing -> printResult' json raw cfg item + +printResult' :: Bool -> Bool -> RendererConfig -> HubStreamItem -> IO () +printResult' True _ _ item = LBS.putStrLn $ encode item +printResult' _ True _ item = case item of + -- Raw mode: just output the content + HubData _ _ _ dat -> do + LBS.putStrLn $ encode dat + hFlush stdout + HubProgress _ _ msg _ -> do + TIO.putStr msg + TIO.putStr "\r" + hFlush stdout + HubError _ _ err _ -> + hPutStrLn stderr $ "Error: " <> T.unpack err + _ -> pure () +printResult' _ _ cfg item = do + -- Template mode: try to render with template + mRendered <- renderItem cfg item + case mRendered of + Just text + | T.null (T.strip text) -> pure () + | otherwise -> do + TIO.putStr text + hFlush stdout + Nothing -> case item of + -- Fallback to pretty-printed content + HubData _ _ _ dat -> do + TIO.putStrLn $ prettyValue dat + hFlush stdout + HubProgress _ _ msg _ -> do + TIO.putStr msg + TIO.putStr "\r" + hFlush stdout + HubError _ _ err _ -> + hPutStrLn stderr $ "Error: " <> T.unpack err + _ -> pure () + +-- ============================================================================ +-- Argument Parsing (Synapse Options Only) +-- ============================================================================ + +-- | Parser for synapse-level options only +-- Backend and path are handled separately after arg splitting +argsInfo :: ParserInfo Args +argsInfo = info (argsParser <**> versionOption <**> helper) + ( fullDesc + <> header "synapse - Algebraic CLI for Hub" + <> progDesc "synapse [OPTIONS] [--param value ...]" + <> noIntersperse -- Stop option parsing at first positional arg + <> footerDoc (Just (Pretty.vsep (map (Pretty.pretty . T.unpack) (drop 1 metaCommands)))) + ) + where + versionOption = infoOption (showVersion Meta.version) + ( long "version" <> short 'V' <> help "Show version" ) + +argsParser :: Parser Args +argsParser = Args <$> optsParser <*> backendParser <*> restParser <*> pure Nothing + where + backendParser = optional $ T.pack <$> argument str + ( metavar "BACKEND" + <> help "Backend name (e.g., plexus, registry-hub)" ) + + restParser = many $ T.pack <$> argument str + ( metavar "PATH... [--param value ...]" + <> help "Path and method parameters (passed through)" ) + +optsParser :: Parser SynapseOpts +optsParser = do + soHostFlag <- optional $ T.pack <$> strOption + ( long "host" <> short 'H' <> metavar "HOST" + <> help "Registry/discovery host (default: 127.0.0.1)" ) + soPortFlag <- optional $ option auto + ( long "port" <> short 'P' <> metavar "PORT" + <> help "Registry/discovery port (default: 4444; 443 with --tls)" ) + soUrl <- optional $ T.pack <$> strOption + ( long "url" <> metavar "URL" + <> help "The hub's socket as a URL: ws://HOST[:PORT][/PATH] or wss://HOST[:PORT][/PATH] (e.g. wss://app.menger.sh/ws); in place of -H/-P/--tls/--path" ) + soTls <- switch + ( long "tls" + <> help "Dial wss:// (TLS; the certificate checked against the system's trust store) at -H/-P" ) + soPath <- optional $ T.pack <$> strOption + ( long "path" <> metavar "PATH" + <> help "The socket's path at -H/-P (default: /), e.g. /ws" ) + soCaCerts <- many $ T.pack <$> strOption + ( long "cacert" <> metavar "FILE" + <> help "With wss: also trust the CA certificate(s) in this PEM file (repeatable; a local CA for a test)" ) + soJson <- switch + ( long "json" <> short 'j' + <> help "Output raw JSON stream items" ) + soRaw <- switch + ( long "raw" + <> help "Output raw content JSON (skip templates)" ) + soDryRun <- switch + ( long "dry-run" <> short 'n' + <> help "Show JSON-RPC request without sending" ) + soSchema <- switch + ( long "schema" <> short 's' + <> help "Fetch raw schema JSON for path" ) + soGenerate <- switch + ( long "generate-templates" <> short 'g' + <> help "Generate mustache templates from IR" ) + soEmitIR <- switch + ( long "emit-ir" <> short 'i' + <> help "Emit IR for code generation (JSON)" ) + soParams <- optional $ T.pack <$> strOption + ( long "params" <> short 'p' <> metavar "JSON" + <> help "Method parameters as a JSON object, sent as written; @FILE reads it from a file, - from stdin" ) + soRpc <- optional $ T.pack <$> strOption + ( long "rpc" <> short 'r' <> metavar "JSON" + <> help "Raw JSON-RPC request (bypass navigation)" ) + soGeneratorInfo <- many $ T.pack <$> strOption + ( long "generator-info" <> metavar "TOOL:VERSION" + <> help "Generator tool version info (can be specified multiple times)" ) + soBidirMode <- optional $ T.pack <$> strOption + ( long "bidir-mode" <> short 'b' <> metavar "MODE" + <> help "Bidirectional mode: interactive (TTY), json (pipe protocol), auto-cancel, defaults, respond" ) + soBidirCmd <- optional $ T.pack <$> strOption + ( long "bidir-cmd" <> metavar "CMD" + <> help "Shell command to handle bidir requests (stdin=JSON request, stdout=JSON response)" ) + soNoCache <- switch + ( long "no-cache" + <> help "Disable IR caching (force rebuild from schema)" ) + soLogLevel <- optional $ T.pack <$> strOption + ( long "log-level" <> metavar "LEVEL" + <> help "Log level: info, debug, trace (default: disabled)" ) + soLogSubsystems <- many $ T.pack <$> strOption + ( long "log-subsystem" <> metavar "SUBSYSTEM" + <> help "Filter logs by subsystem: discovery, transport, rpc, schema, cache, navigation (can specify multiple, default: all)" ) + soToken <- optional $ T.pack <$> strOption + ( long "token" <> short 't' <> metavar "JWT" + <> help "JWT sent as Cookie: access_token= on WebSocket upgrade (overrides any access_token in ~/.plexus//defaults.json)" ) + soTokenFile <- optional $ T.pack <$> strOption + ( long "token-file" <> metavar "PATH" + <> help "Path to file containing a raw JWT (overrides any access_token in ~/.plexus//defaults.json)" ) + soCookies <- many (parseKv <$> strOption + ( long "cookie" <> metavar "KEY=VALUE" + <> help "Extra cookie attached to WS upgrade (repeatable; SAFE-S04/REQ-5)" )) + soHeaders <- many (parseKv <$> strOption + ( long "header" <> metavar "KEY=VALUE" + <> help "Extra HTTP header attached to WS upgrade (repeatable; SAFE-S04/REQ-5)" )) + soNoDeprecationWarnings <- switch + ( long "no-deprecation-warnings" + <> help "Suppress invocation-time deprecation warnings on stderr (IR-15)" ) + soAs <- optional $ T.pack <$> strOption + ( long "as" <> metavar "AGENT" + <> help "Carry this agent's stored session (see _login; else SYNAPSE_AS, else the backend's default agent)" ) + soReconnectFor <- optional $ T.pack <$> strOption + ( long "reconnect-for" <> metavar "DURATION" + <> help "Ride out an outage this long: a lost connection is retried, a read sent again, a stream resumed (10m, 90s, 1h; 0 = never; else SYNAPSE_RECONNECT_FOR, else 10m)" ) + pure SynapseOpts + { soHost = maybe defaultHost id soHostFlag + , soPort = maybe defaultPort id soPortFlag + , soEndpoint = plainAt (maybe defaultHost id soHostFlag) (maybe defaultPort id soPortFlag) + , .. + } + +-- | SCAFFOLD-21: the connection point from the options — @--url@, or @-H@ +-- / @-P@ with @--tls@ (port 443 unless @-P@) and @--path@; plain +-- @ws://127.0.0.1:4444/@ when none is given. @soHost@ / @soPort@ follow it. +-- A @--cacert@ that cannot be read is refused here, not at the handshake. +resolveConnection :: SynapseOpts -> IO (Either Text SynapseOpts) +resolveConnection o = case pick of + Left e -> pure (Left e) + Right ep0 -> do + let ep = ep0 { epCaFiles = map T.unpack (soCaCerts o) } + missing <- filterM (fmap not . doesFileExist . T.unpack) (soCaCerts o) + pure $ case () of + _ | not (null (soCaCerts o)) && not (epTls ep) -> + Left "--cacert is for a wss:// address (--url wss://… or --tls)" + | (f : _) <- missing -> Left ("--cacert " <> f <> ": no such file") + | otherwise -> Right o { soHost = epHost ep, soPort = epPort ep, soEndpoint = ep } + where + pick = case soUrl o of + Just u + | isJust (soHostFlag o) || isJust (soPortFlag o) || soTls o || isJust (soPath o) -> + Left "--url names the whole address: give it alone, or -H / -P with --tls / --path" + | otherwise -> parseUrl u + Nothing -> Right Endpoint + { epHost = maybe defaultHost id (soHostFlag o) + , epPort = maybe (if soTls o then 443 else defaultPort) id (soPortFlag o) + , epTls = soTls o + , epPath = maybe "/" normalisePath (soPath o) + , epCaFiles = [] + } + +-- | Parse a KEY=VALUE pair (used by --cookie/--header). Treats the first '=' +-- as the separator; everything before is the key, everything after is the value. +parseKv :: String -> (Text, Text) +parseKv s = + let (k, rest) = break (== '=') s + v = case rest of + '=':vv -> vv + _ -> "" + in (T.pack k, T.pack v) diff --git a/plexus-synapse.cabal b/plexus-synapse.cabal --- a/plexus-synapse.cabal +++ b/plexus-synapse.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: plexus-synapse -version: 3.13.0 +version: 3.15.0 synopsis: Schema-driven CLI for Plexus RPC servers license: MIT author: @@ -12,10 +12,19 @@ default: False manual: True +flag build-keychain-tests + description: Build and run SELF-8 keychain tests. These shell out to + `security` on macOS and touch the real keychain; they're + opt-in so default `cabal test` runs stay quiet. + Enable with: cabal test -f build-keychain-tests + default: False + manual: True + library exposed-modules: Synapse.Schema.Types Synapse.Schema.Functor + Synapse.Endpoint Synapse.Monad Synapse.Log Synapse.Algebra.Navigate @@ -23,6 +32,7 @@ Synapse.Algebra.Walk Synapse.Algebra.Recursion Synapse.Transport + Synapse.Reconnect Synapse.Cache Synapse.Deprecation Synapse.Renderer @@ -34,9 +44,21 @@ Synapse.CLI.Parse Synapse.CLI.Support Synapse.CLI.Template + Synapse.CLI.Source Synapse.CLI.Transform Synapse.CLI.Similarity + Synapse.Find Synapse.Backend.Discovery + Synapse.Self + Synapse.Self.Types + Synapse.Self.Resolve + Synapse.Self.IO + Synapse.Self.Resolve.Literal + Synapse.Self.Resolve.Env + Synapse.Self.Resolve.File + Synapse.Self.Resolve.Keychain + Synapse.Self.Resolve.Default + Synapse.Self.Command Synapse.Self.Commands Synapse.Self.Template Synapse.Self.Pattern @@ -46,13 +68,21 @@ Synapse.Self.Protocol.StreamTracker Synapse.Self.Protocol.Reporter Synapse.Self.Protocol.TestRunner + Synapse.Identity.Proof + Synapse.Identity.Store + Synapse.Identity.Session + Synapse.Identity.Command + Synapse.Auth + Synapse.Auth.Loopback build-depends: base >= 4.17 && < 5, - plexus-protocol, + -- SCAFFOLD-21: substrateTls (wss) + plexus-protocol >= 0.5.2, aeson >= 2.0 && < 2.3, aeson-pretty >= 0.8 && < 0.9, text >= 2.0 && < 2.2, bytestring >= 0.11 && < 0.13, + case-insensitive >= 1.2 && < 1.3, websockets >= 0.13 && < 0.14, network >= 3.1 && < 3.3, async >= 2.2 && < 2.3, @@ -75,7 +105,13 @@ array >= 0.5 && < 0.6, process >= 1.6 && < 1.7, fast-logger >= 3.0 && < 3.3, - katip >= 0.8 && < 0.9 + katip >= 0.8 && < 0.9, + base64-bytestring >= 1.2 && < 1.3, + optparse-applicative >= 0.18 && < 0.19, + unix >= 2.7 && < 2.9, + -- IDENTITY-43: Ed25519 keys and their randomness + crypton >= 1.0 && < 1.2, + ram >= 0.20 && < 0.23 hs-source-dirs: src default-language: GHC2021 default-extensions: @@ -203,6 +239,62 @@ RecordWildCards ghc-options: -threaded +test-suite schema-decode-test + type: exitcode-stdio-1.0 + main-is: SchemaDecodeSpec.hs + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + aeson >= 2.2 && < 2.3, + aeson-qq >= 0.8 && < 0.9, + bytestring >= 0.11 && < 0.13, + vector >= 0.13 && < 0.14 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + +test-suite req8-render-test + type: exitcode-stdio-1.0 + main-is: Req8RenderSpec.hs + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + plexus-synapse, + aeson >= 2.2 && < 2.3, + aeson-qq >= 0.8 && < 0.9, + containers >= 0.6 && < 0.8, + text >= 2.0 && < 2.2 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + +test-suite render-test + -- SYNAPSE-12: a backend's help laid out (blank lines, columns, wrapping, + -- required before optional, types as the schema says them). + -- SYNAPSE-13: in the gh / cargo shape — listings of one-line summaries in + -- their groups; a method's page with its usage line, aligned options, + -- values and examples; an older hub's schema still rendered. + type: exitcode-stdio-1.0 + main-is: RenderSpec.hs + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + plexus-synapse, + aeson >= 2.2 && < 2.3, + aeson-qq >= 0.8 && < 0.9, + containers >= 0.6 && < 0.8, + text >= 2.0 && < 2.2, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + test-suite typeref-json type: exitcode-stdio-1.0 main-is: TypeRefJson.hs @@ -236,11 +328,30 @@ OverloadedStrings ghc-options: -threaded +-- SYNAPSE-10: a parameter's value from a file or stdin +test-suite source-test + type: exitcode-stdio-1.0 + main-is: SourceSpec.hs + build-depends: + base >= 4.17 && < 5, + plexus-synapse, + text >= 2.0 && < 2.2, + bytestring >= 0.11 && < 0.13, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + test-suite path-normalization-test type: exitcode-stdio-1.0 main-is: PathNormalizationSpec.hs build-depends: base >= 4.17 && < 5, + plexus-synapse, text >= 2.0 && < 2.2, hspec >= 2.10 && < 2.12 hs-source-dirs: test @@ -333,15 +444,217 @@ OverloadedStrings ghc-options: -threaded +test-suite self-test + type: exitcode-stdio-1.0 + main-is: SelfSpec.hs + other-modules: + SelfCommandSpec + SelfMigrationSpec + SelfSafeWriteSpec + build-depends: + base >= 4.17 && < 5, + plexus-synapse, + text >= 2.0 && < 2.2, + bytestring >= 0.11 && < 0.13, + containers >= 0.6 && < 0.8, + aeson >= 2.2 && < 2.3, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6, + hspec >= 2.10 && < 2.12, + time >= 1.12 && < 1.15, + temporary >= 1.3 && < 1.4, + base64-bytestring >= 1.2 && < 1.3, + unix >= 2.7 && < 2.9 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + +test-suite identity-test + -- IDENTITY-43: the canonical message, the fixed proof vector the Rust + -- side cross-checks, and the key and session stores' order (env, a + -- mocked keychain, files in a directory of the test's own). + type: exitcode-stdio-1.0 + main-is: IdentitySpec.hs + build-depends: + base >= 4.17 && < 5, + async >= 2.2 && < 2.3, + plexus-synapse, + text >= 2.0 && < 2.2, + bytestring >= 0.11 && < 0.13, + base64-bytestring >= 1.2 && < 1.3, + aeson >= 2.2 && < 2.3, + containers >= 0.6 && < 0.8, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6, + hspec >= 2.10 && < 2.12, + temporary >= 1.3 && < 1.4, + unix >= 2.7 && < 2.9 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + test-suite ir12-method-role-test type: exitcode-stdio-1.0 main-is: IR12MethodRoleSpec.hs build-depends: base >= 4.17 && < 5, + containers >= 0.6 && < 0.8, plexus-protocol, plexus-synapse, aeson >= 2.2 && < 2.3, bytestring >= 0.11 && < 0.13, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + +test-suite keychain-test + -- SELF-8 keychain tests. Opt-in via `-f build-keychain-tests` because + -- they shell out to macOS `security` and touch the real keychain. + type: exitcode-stdio-1.0 + main-is: KeychainSpec.hs + build-depends: + base >= 4.17 && < 5, + plexus-synapse, + text >= 2.0 && < 2.2, + hspec >= 2.10 && < 2.12, + uuid >= 1.3 && < 1.4 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + if !flag(build-keychain-tests) + buildable: False + +test-suite auth-test + -- AUTH-8: the auth shapes plexus-protocol parses (and their absence), + -- the anonymous page, the caller's header and grant columns, the refusal + -- block, the loopback's state check, and the flows end to end against a + -- hub in miniature (test/MockHub.hs) on ports of their own. + type: exitcode-stdio-1.0 + main-is: AuthSpec.hs + other-modules: MockHub + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + plexus-synapse, + aeson >= 2.2 && < 2.3, + aeson-qq >= 0.8 && < 0.9, + bytestring >= 0.11 && < 0.13, + containers >= 0.6 && < 0.8, + text >= 2.0 && < 2.2, + katip >= 0.8 && < 0.9, + network >= 3.1 && < 3.3, + websockets >= 0.13 && < 0.14, + vector >= 0.12 && < 0.14, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + +test-suite find-test + -- SYNAPSE-17: _find's matcher (exact, prefix, typo at both thresholds, + -- snake_case subsequence, every word, ranking) and its renders against + -- the mock hub's catalog (menger's schema as it was, test/fixtures), on a + -- terminal and piped; a caller's view; the IR cache's hash check. + type: exitcode-stdio-1.0 + main-is: FindSpec.hs + other-modules: MockHub + build-depends: + base >= 4.17 && < 5, + plexus-synapse, + aeson >= 2.2 && < 2.3, + bytestring >= 0.11 && < 0.13, + containers >= 0.6 && < 0.8, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6, + text >= 2.0 && < 2.2, + katip >= 0.8 && < 0.9, + network >= 3.1 && < 3.3, + websockets >= 0.13 && < 0.14, + vector >= 0.12 && < 0.14, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + +test-suite reconnect-test + -- SYNAPSE-20: a lost connection is noticed (a close, a drop before any + -- answer, a silent peer by its keepalive) and synapse rides out the + -- outage — a read sent again, a stream resumed with since, a write that + -- went out never repeated, one that never left sent when the backend is + -- back, the window run out — against a flaky hub on ports of its own. + type: exitcode-stdio-1.0 + main-is: ReconnectSpec.hs + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + plexus-synapse, + aeson >= 2.2 && < 2.3, + text >= 2.0 && < 2.2, + network >= 3.1 && < 3.3, + websockets >= 0.13 && < 0.14, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + +test-suite endpoint-test + -- SCAFFOLD-21: --url and -H/-P with --tls/--path read into one address, + -- and every key derived from it — the session store's (a plain address + -- keyed exactly as before), the proof's audience, the options messages + -- tell the reader to type, the plexus-protocol config. + type: exitcode-stdio-1.0 + main-is: EndpointSpec.hs + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + plexus-synapse, + text >= 2.0 && < 2.2, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + +test-suite tls-test + -- SCAFFOLD-21: synapse speaks wss — the probe, a call and a key login + -- through a TLS terminator of the test's own (a CA openssl makes for the + -- run, in front of the mock hub), at a path; an unknown CA and a wrong + -- name refused at the handshake. Pending without openssl. + type: exitcode-stdio-1.0 + main-is: TlsSpec.hs + other-modules: MockHub + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + plexus-synapse, + aeson >= 2.2 && < 2.3, + base64-bytestring >= 1.2 && < 1.3, + bytestring >= 0.11 && < 0.13, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6, + katip >= 0.8 && < 0.9, + network >= 3.1 && < 3.3, + process >= 1.6 && < 1.7, + temporary >= 1.3 && < 1.4, + text >= 2.0 && < 2.2, + tls >= 2.1 && < 2.5, + vector >= 0.12 && < 0.14, + websockets >= 0.13 && < 0.14, hspec >= 2.10 && < 2.12 hs-source-dirs: test default-language: GHC2021 diff --git a/src/Synapse/Algebra/Render.hs b/src/Synapse/Algebra/Render.hs --- a/src/Synapse/Algebra/Render.hs +++ b/src/Synapse/Algebra/Render.hs @@ -3,6 +3,12 @@ ( -- * Rendering Functions renderSchema , renderSchemaWith + , renderSchemaFor + , renderListing + , Listing(..) + , summarize + , fitText + , quoteMask , renderMethod , renderMethodFull , renderChild @@ -21,11 +27,14 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Aeson (Value(..)) +import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM -import Data.List (intersperse, sortOn) -import Prettyprinter -import Prettyprinter.Render.Text (renderStrict) +import qualified Data.Vector as V +import Control.Applicative ((<|>)) +import Data.Char (isAlphaNum, toLower) +import Data.List (sortOn) +import Data.Maybe (fromMaybe, isJust, isNothing) import Synapse.Schema.Types import Plexus.Schema.Recursive (DeprecationInfo(..), ParamSchema(..)) @@ -36,6 +45,7 @@ , rsShowHash :: !Bool -- ^ Show plugin/method hashes , rsShowTypes :: !Bool -- ^ Show parameter types , rsCompact :: !Bool -- ^ Compact single-line format + , rsWidth :: !Int -- ^ Columns to wrap descriptions at (SYNAPSE-12) } deriving stock (Show, Eq) @@ -46,6 +56,7 @@ , rsShowHash = False , rsShowTypes = True , rsCompact = False + , rsWidth = 80 } -- | Compact style: single-line descriptions @@ -58,102 +69,247 @@ -- | Render with custom style renderSchemaWith :: RenderStyle -> PluginSchema -> Text -renderSchemaWith _style PluginSchema{..} - | null psMethods && maybe True null psChildren = deprecationBanner <> headerText - | otherwise = renderStrict $ layoutPretty layoutOpts doc +renderSchemaWith style = renderSchemaFor style Nothing + +-- | AUTH-8: render for a caller — the header line saying who it is +-- (@you are … · editor on MENGER@) under the description, when given. +-- SYNAPSE-13: the listing as 'renderListing' lays it out, reached by +-- @synapse @. +renderSchemaFor :: RenderStyle -> Maybe Text -> PluginSchema -> Text +renderSchemaFor style callerLine ps = + renderListing style (Listing ("synapse " <> psNamespace ps) callerLine) ps + +-- | SYNAPSE-13: what a listing needs beside the schema. +data Listing = Listing + { lsInvoke :: Text -- ^ the command line that reaches this plugin (@synapse -P 4455 menger tickets@) + , lsCaller :: Maybe Text -- ^ AUTH-8: who the caller is, in a caller's view + } + deriving stock (Show, Eq) + +-- | SYNAPSE-13: a plugin's listing in gh's shape — the name, version and +-- description; a usage line; then one line per activation and per method +-- (its name and summary, the first sentence of its description), the +-- methods in their groups (the schema's @group@, in the order they first +-- appear; alphabetical within each; one METHODS section when there are +-- none), and how to see a method's options. In a caller's view (AUTH-8) +-- who the caller is sits under the description, and each method's line +-- ends with its grant and where it is held, in two aligned columns. +renderListing :: RenderStyle -> Listing -> PluginSchema -> Text +renderListing style Listing{..} PluginSchema{..} = T.unlines (dropTrailingBlanks body) where - layoutOpts = LayoutOptions (AvailablePerLine 80 1.0) + width = rsWidth style + authCols = isJust lsCaller || any (isJust . methodHeldOn) psMethods - -- Activation-level deprecation banner (plain-text, rendered ahead - -- of the compact header variant used for trivial schemas). - deprecationBanner = case psDeprecation of - Just di -> deprecationMarker <> " " <> formatDeprecationLine di <> "\n" - Nothing -> "" + body = concat + [ [heading] + , deprecationNotice + , map (" " <>) (wrap (width - 2) psDescription) + , maybe [] (\l -> [" " <> l]) lsCaller + , section "USAGE" (map (" " <>) usage) + , section "ACTIVATIONS" (map childRow children) + , concat [ section title (concatMap methodRows ms) | (title, ms) <- methodSections ] + , if null footer then [] else "" : footer + ] - headerText = psNamespace <> " v" <> psVersion <> "\n" <> psDescription <> "\n" + heading = case psDeprecation of + Just _ -> deprecationMarker <> " " <> psNamespace <> " v" <> psVersion + Nothing -> psNamespace <> " v" <> psVersion - -- Name line; decorated with the warning marker when the activation - -- carries Just DeprecationInfo. - namespaceHeading = case psDeprecation of - Just _ -> pretty (deprecationMarker <> " " <> psNamespace) - <+> pretty ("v" <> psVersion) - Nothing -> pretty psNamespace <+> pretty ("v" <> psVersion) + deprecationNotice = case psDeprecation of + Just di -> [" " <> formatDeprecationLine di] + Nothing -> [] - -- Full deprecation notice rendered immediately below the heading - -- when relevant, before the description block. - deprecationNoticeDoc = case psDeprecation of - Just di -> vsep - [ emptyDoc - , indent 2 $ pretty (formatDeprecationLine di) - ] - Nothing -> emptyDoc + section _ [] = [] + section title rows = "" : title : rows - doc :: Doc ann - doc = vsep - [ namespaceHeading - , deprecationNoticeDoc - , emptyDoc - , indent 2 $ align $ fillSep $ map pretty $ T.words psDescription - , emptyDoc - , childrenDoc - , methodsDoc + children = maybe [] (sortOn csNamespace) psChildren + + usage = concat + [ [lsInvoke <> " [flags]" | not (null children)] + , [lsInvoke <> " [flags]" | not (null psMethods)] ] - childrenDoc = case psChildren of - Nothing -> emptyDoc - Just [] -> emptyDoc - Just children -> vsep - [ pretty ("activations" :: Text) - , emptyDoc - , indent 2 $ vsep $ map renderChildDoc (sortOn csNamespace children) - , emptyDoc - ] + footer = concat + [ ["Run '" <> lsInvoke <> " ' for its methods." | not (null children)] + , ["Run '" <> lsInvoke <> " --help' for its options." | not (null psMethods)] + ] - methodsDoc - | null psMethods = emptyDoc - | otherwise = vsep - [ pretty ("methods" :: Text) - , emptyDoc - , indent 2 $ vsep $ intersperse emptyDoc $ map renderMethodDoc (sortOn methodName psMethods) - ] + -- The groups in the order they first appear, each alphabetical; the + -- ungrouped last (as OTHER), or all of them as METHODS when no method + -- says a group. + methodSections = + let groups = dedupe [g | Just g <- map methodGroup psMethods] + inGroup g = sortOn methodName [m | m <- psMethods, methodGroup m == Just g] + ungrouped = sortOn methodName [m | m <- psMethods, isNothing (methodGroup m)] + in if null groups + then [("METHODS", ungrouped) | not (null ungrouped)] + else [(T.toUpper g, inGroup g) | g <- groups] + ++ [("OTHER", ungrouped) | not (null ungrouped)] + dedupe = foldl (\acc x -> if x `elem` acc then acc else acc ++ [x]) [] - renderChildDoc child = fillBreak 12 (pretty $ csNamespace child) - <+> align (fillSep $ map pretty $ T.words $ csDescription child) + decoratedName m = case methodDeprecation m of + Just _ -> deprecationMarker <> " " <> methodName m + Nothing -> methodName m - renderMethodDoc method = - let nameText = case methodDeprecation method of - Just _ -> deprecationMarker <> " " <> methodName method - Nothing -> methodName method - nameLine = fillBreak 12 (pretty nameText) - <+> align (fillSep $ map pretty $ T.words $ methodDescription method) - depLines = case methodDeprecation method of - Just di -> [indent 12 $ pretty (formatDeprecationLine di)] - Nothing -> [] - in vsep $ [nameLine] ++ depLines ++ paramsDocs (methodParams method) + -- The name column: wide enough for the longest name (capped), shared by + -- every section so the summaries start in one column. + nameW = min 24 $ maximum $ 8 : map T.length (map csNamespace children ++ map decoratedName psMethods) + descCol = 2 + nameW + 2 - paramsDocs Nothing = [] - paramsDocs (Just (Object o)) = case KM.lookup "properties" o of - Just (Object props) -> - let reqList = case KM.lookup "required" o of - Just (Array arr) -> [t | String t <- foldr (:) [] arr] - _ -> [] - propList = KM.toList props - sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList - in [indent 12 $ vsep $ map (renderParamDoc reqList) sorted] - _ -> [] - paramsDocs _ = [] + -- AUTH-8: the grant and where it is held, after the summary. + grantOf m = fromMaybe "" (methodGrant m) + heldOf m = maybe "" (T.intercalate ", ") (methodHeldOn m) + grantW = maximum (0 : map (T.length . grantOf) psMethods) + heldW = maximum (0 : map (T.length . heldOf) psMethods) + summaryW + | authCols = max 20 (width - descCol - 2 - grantW - 2 - heldW) + | otherwise = width - descCol - renderParamDoc :: [Text] -> (K.Key, Value) -> Doc ann - renderParamDoc required (name, propSchema) = - let nameText = K.toText name - isReq = nameText `elem` required - (typ, desc) = extractTypeDesc propSchema - flag = "--" <> T.replace "_" "-" nameText - typStr = " <" <> typ <> ">" <> if isReq then "" else "?" - descWords = if T.null desc then [] else map pretty (T.words desc) - in fillBreak 20 (pretty flag <> pretty typStr) - <+> align (fillSep descWords) + row name summary = + T.stripEnd (" " <> T.justifyLeft nameW ' ' name <> " " <> summary) + childRow c = row (csNamespace c) (fitText (width - descCol) (summarize (csDescription c))) + + methodRows m = + let s = fitText summaryW (summarize (methodDescription m)) + line + | authCols = row (decoratedName m) + (T.justifyLeft summaryW ' ' s <> " " <> T.justifyLeft grantW ' ' (grantOf m) <> " " <> heldOf m) + | otherwise = row (decoratedName m) s + in line : maybe [] (\di -> [T.replicate descCol " " <> formatDeprecationLine di]) (methodDeprecation m) + +-- | SYNAPSE-13: a description's summary — its first sentence: up to the +-- first @. @, @; @ or @: @ outside brackets and quotes (an @e.g.@ or +-- @i.e.@ is not an end), without the stop. +summarize :: Text -> Text +summarize desc = T.strip (go (0 :: Int) "" (zip str (quoteMask str))) + where + str = T.unpack (T.strip desc) + go _ acc [] = T.pack (reverse acc) + go d acc ((c, q) : rest) + | q = go d (c : acc) rest + | c `elem` ("([{" :: String) = go (d + 1) (c : acc) rest + | c `elem` (")]}" :: String) = go (max 0 (d - 1)) (c : acc) rest + | d == 0, c `elem` (".;:" :: String), startsSpace rest, not (abbrev c acc) = T.pack (reverse acc) + | otherwise = go d (c : acc) rest + startsSpace ((' ', _) : _) = True + startsSpace _ = False + abbrev '.' acc = map toLower (reverse (takeWhile (/= ' ') acc)) `elem` ["e.g", "i.e", "etc", "vs", "cf"] + abbrev _ _ = False + +-- | Which characters are inside a quoted span — @'…'@ or @`…`@, the quotes +-- included. A @'@ opens a quote after a non-letter and before a non-space +-- (so @ticket's@ is an apostrophe), and closes before a non-letter; a quote +-- never closed is no quote. +quoteMask :: String -> [Bool] +quoteMask str = case openAt of + Just j -> take j marks ++ map (const False) (drop j marks) + Nothing -> marks + where + (marks, openAt) = go Nothing Nothing (0 :: Int) str + alnum = maybe False isAlphaNum + go open _ _ [] = ([], fmap snd open) + go open prev i (c : rest) = + let next = case rest of { (x : _) -> Just x; [] -> Nothing } + (m, open') = case open of + Nothing + | c == '`' -> (True, Just ('`', i)) + | c == '\'', not (alnum prev), maybe False (/= ' ') next -> (True, Just ('\'', i)) + | otherwise -> (False, Nothing) + Just (q, _) + | c == q, q == '`' || not (alnum next) -> (True, Nothing) + | otherwise -> (True, open) + (ms, o) = go open' (Just c) (i + 1) rest + in (m : ms, o) + +-- | SYNAPSE-13: a line's text in at most @w@ columns: whole when it fits; +-- else without its parentheticals; else up to the last @ — @ that fits; +-- else cut after a comma that keeps most of it, or at a word, ending in @…@. +-- SYNAPSE-17: a quoted span (@'…'@, @`…`@) is never cut or changed inside: +-- its brackets stay, and a cut ends before it (or keeps it whole when it +-- leads the line). +fitText :: Int -> Text -> Text +fitText w t + | T.length t <= w = t + | T.length bare <= w = bare + | Just c <- lastFitting 0 " \x2014 " = c + | Just c <- lastFitting 1 ", ", T.length c * 10 >= w * 6 = c <> "\x2026" + | otherwise = wordCut atoms + where + chars = T.unpack t + (bareCs, bareMask) = unzip (tidy (dropParens (zip chars (quoteMask chars)))) + bare = T.pack bareCs + -- the longest prefix ending before @sep@ (outside a quote) that fits + -- (with @room@ for an …) + lastFitting room sep = + case [ p | (p, _) <- T.breakOnAll sep bare, T.length p + room <= w + , not (T.null (T.strip p)), not (quotedAt (T.length p)) ] of + [] -> Nothing + ps -> Just (T.stripEnd (last ps)) + quotedAt i = i < length bareMask && bareMask !! i + -- words, a quoted span with its spaces one of them + atoms = map (T.pack . map fst) (splitAtoms (zip bareCs bareMask)) + splitAtoms cs = case dropWhile (\(c, q) -> c == ' ' && not q) cs of + [] -> [] + cs' -> let (a, rest) = break (\(c, q) -> c == ' ' && not q) cs' in a : splitAtoms rest + quotedAtom x = T.any (`elem` ("'`" :: String)) x + wordCut ws = go "" ws + where + go acc [] = acc + go acc (x : xs) + | T.length (join acc x) + 1 <= w = go (join acc x) xs + | T.null acc = if quotedAtom x then x else T.take (max 1 (w - 1)) x <> "\x2026" + | otherwise = T.dropWhileEnd (`elem` (",;:" :: String)) acc <> "\x2026" + join acc x = if T.null acc then x else acc <> " " <> x + -- whitespace runs outside quotes made one space, none left before a + -- comma or a stop, none at the ends + tidy = trimEnds . noSpaceBefore . collapse + where + collapse [] = [] + collapse ((c, False) : rest) + | isSpaceC c = (' ', False) : collapse (dropWhile (\(x, q) -> isSpaceC x && not q) rest) + collapse (x : rest) = x : collapse rest + noSpaceBefore ((' ', False) : x@(c, False) : rest) + | c `elem` (",.;:" :: String) = noSpaceBefore (x : rest) + noSpaceBefore (x : rest) = x : noSpaceBefore rest + noSpaceBefore [] = [] + trimEnds = reverse . dropWhile blank . reverse . dropWhile blank + blank (c, q) = isSpaceC c && not q + isSpaceC x = x == ' ' || x == '\n' || x == '\t' + -- parentheticals outside quotes dropped (a quote inside one goes with it) + dropParens = strip (0 :: Int) + where + strip _ [] = [] + strip d (x@(c, q) : rest) + | not q, c == '(' = strip (d + 1) rest + | not q, c == ')', d > 0 = strip (d - 1) rest + | d > 0 = strip d rest + | otherwise = x : strip d rest + +-- | Words wrapped greedily to a width (at least 20); a word longer than the +-- width stands on its own line. +wrap :: Int -> Text -> [Text] +wrap w0 txt = go (T.words txt) + where + w = max 20 w0 + go [] = [] + go (x : xs) = line x xs + line acc [] = [acc] + line acc (y : ys) + | T.length acc + 1 + T.length y <= w = line (acc <> " " <> y) ys + | otherwise = acc : line y ys + +-- | A lead and lines that start in column @col@: the first beside the lead +-- when it fits (two spaces between), else all of them under it. +hang :: Int -> Text -> [Text] -> [Text] +hang col lead ds = case ds of + (d : rest) | T.length lead <= col - 2 -> (T.justifyLeft col ' ' lead <> d) : map (pad <>) rest + _ -> lead : map (pad <>) ds + where pad = T.replicate col " " + +dropTrailingBlanks :: [Text] -> [Text] +dropTrailingBlanks = reverse . dropWhile (T.null . T.strip) . reverse + -- | Render a method (short form) renderMethod :: MethodSchema -> Text renderMethod = renderMethodWith defaultStyle @@ -258,13 +414,39 @@ in " " <> decoratedName <> " <" <> typ <> ">" <> reqText <> "\n " <> desc <> depLine --- | Extract type and description from property schema +-- | Extract type and description from property schema. +-- +-- SYNAPSE-12: the type a flag takes, as the schema says it — a nullable +-- type is its non-null part (@["string", "null"]@ → @string@), an array +-- its element's (@string[]@), a @$ref@ the type it names, a union its +-- alternatives (@a|b@); @any@ only when the schema says nothing. extractTypeDesc :: Value -> (Text, Text) -extractTypeDesc (Object po) = - ( case KM.lookup "type" po of { Just (String t) -> t; _ -> "any" } +extractTypeDesc v@(Object po) = + ( schemaTypeName v , case KM.lookup "description" po of { Just (String d) -> d; _ -> "" } ) extractTypeDesc _ = ("any", "") + +schemaTypeName :: Value -> Text +schemaTypeName (Object po) + | Just (String ref) <- KM.lookup "$ref" po = last (T.splitOn "/" ref) + | Just (String "array") <- KM.lookup "type" po = itemsName <> "[]" + | Just (String t) <- KM.lookup "type" po = t + | Just (Array ts) <- KM.lookup "type" po = + case [t | String t <- V.toList ts, t /= "null"] of + ["array"] -> itemsName <> "[]" + [] -> "any" + ts' -> T.intercalate "|" ts' + | Just (Array alts) <- KM.lookup "anyOf" po <|> KM.lookup "oneOf" po = + case filter (/= "null") (map schemaTypeName (V.toList alts)) of + [] -> "any" + ns -> T.intercalate "|" (dedupe ns) + | Just (Array _) <- KM.lookup "enum" po = "string" + | otherwise = "any" + where + itemsName = maybe "any" schemaTypeName (KM.lookup "items" po) + dedupe = foldr (\x acc -> if x `elem` acc then acc else x : acc) [] +schemaTypeName _ = "any" -- | Pad text to a minimum width padRight :: Int -> Text -> Text diff --git a/src/Synapse/Auth.hs b/src/Synapse/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Auth.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | AUTH-8: what synapse shows of a hub's auth — pure, so every render is +-- tested from fixtures. +-- +-- * The anonymous page: a hub whose @_info@ says @view: anonymous@ shows +-- only its door (login, signup, providers) and how to sign in from here. +-- * The caller's header: @you are NAME (PRINCIPAL) · ROLE on SCOPES, within +-- CEILING@, from @auth.whoami@ (or, on a hub without it, @session.whoami@). +-- * A refusal: @refused: needs GRANT on SCOPE@ and what would allow it. +-- +-- Every wire field read here is optional (AUTH-1, "Login off stays open"): +-- a hub without a gate answers none of it, and nothing here is shown. +module Synapse.Auth + ( -- * Who the caller is + Whoami(..) + , parseWhoami + , renderCallerHeader + , abbreviatePrincipal + , scopeOf + + -- * The anonymous page + , AnonPage(..) + , anonymousMethods + , renderAnonymousPage + + -- * Refusals + , renderRefusal + + -- * The session auth.login answers + , SessionGrant(..) + , parseSessionGrant + , isMissingAuth + ) where + +import Control.Applicative ((<|>)) +import Data.Aeson (Value(..)) +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import Data.List (nub, sortOn) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Scientific (toBoundedInteger) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V + +import Plexus.Auth (AuthInfo(..), Refusal(..)) +import Plexus.Schema.Recursive (MethodSchema(..), PluginSchema(..)) + +-- ============================================================================ +-- Who the caller is +-- ============================================================================ + +-- | What @auth.whoami@ (or @session.whoami@'s @identity@) says. +data Whoami = Whoami + { whoPrincipal :: Text + , whoName :: Maybe Text + , whoAgent :: Maybe Text + , whoMemberships :: [(Text, Text)] -- ^ (role, scope); scope "" when the hub names none + , whoCeiling :: [Text] -- ^ as the hub says it: @editor\@MENGER-12@ or a scope + } deriving (Eq, Show) + +-- | A whoami from a data item's content. Shapes read (all fields but the +-- principal optional): +-- +-- @ +-- {"type":"whoami","principal":"key:ac79…","name":"worker-1","agent":"worker-1", +-- "memberships":[{"role":"editor","scope":"MENGER"}],"ceiling":["editor\@MENGER-12"]} +-- {"type":"identity","principal":"idp:…","name":"ada","roles":["admin"]} -- session.whoami +-- @ +-- +-- @memberships@ (or @roles@) may also be strings, @role\@SCOPE@ or a bare +-- role; @ceiling@ strings or @{role|grant, scope}@ objects. An anonymous +-- answer (@type: anonymous@, or no principal) is Nothing. +parseWhoami :: Value -> Maybe Whoami +parseWhoami = \case + Object o + | Just (String "anonymous") <- KM.lookup "type" o -> Nothing + | Just (String p) <- KM.lookup "principal" o, not (T.null p) -> Just Whoami + { whoPrincipal = p + , whoName = nonEmpty (str "name" o) + , whoAgent = nonEmpty (str "agent" o) + , whoMemberships = memberships o + , whoCeiling = ceilingOf o + } + -- a whoami nested one level (e.g. {"type":"whoami","identity":{…}}) + | Just inner@(Object _) <- KM.lookup "identity" o -> parseWhoami inner + _ -> Nothing + where + memberships o = case KM.lookup "memberships" o of + Just v -> roleScopes v + Nothing -> maybe [] roleScopes (KM.lookup "roles" o) + roleScopes = \case + Array xs -> mapMaybe one (V.toList xs) + _ -> [] + one = \case + String s -> Just (splitRoleScope s) + Object e -> case (str "role" e, str "scope" e) of + ("", _) -> Nothing + (r, s) -> Just (r, s) + _ -> Nothing + +ceilingOf :: KM.KeyMap Value -> [Text] +ceilingOf o = case KM.lookup "ceiling" o <|> KM.lookup "scope" o of + Just (Array xs) -> mapMaybe one (V.toList xs) + Just (String s) | not (T.null s) -> [s] + _ -> [] + where + one = \case + String s -> Just s + Object e -> + let what = case (str "role" e, str "grant" e) of + (r, _) | not (T.null r) -> r + (_, g) -> g + sc = str "scope" e + in if T.null what && T.null sc then Nothing + else Just (if T.null what then sc else if T.null sc then what else what <> "@" <> sc) + _ -> Nothing + +-- | @editor\@MENGER@ → (editor, MENGER); @admin@ → (admin, ""). +splitRoleScope :: Text -> (Text, Text) +splitRoleScope s = case T.breakOn "@" s of + (r, rest) | not (T.null rest) -> (r, T.drop 1 rest) + _ -> (s, "") + +-- | The scope of a ceiling entry: @editor\@MENGER-12@ → @MENGER-12@; an +-- entry with no @\@@ is its own scope. +scopeOf :: Text -> Text +scopeOf s = case T.breakOn "@" s of + (_, rest) | not (T.null rest) -> T.drop 1 rest + _ -> s + +-- | @you are worker-1 (key:ac79…) · editor on MENGER, within MENGER-12@. +-- +-- Several roles: each @ROLE on SCOPES@, joined with @; @. A membership the +-- hub named no scope for is the role alone. No memberships: the name and +-- principal alone. +renderCallerHeader :: Whoami -> Text +renderCallerHeader w = "you are " <> who <> held <> within + where + shown = abbreviatePrincipal (whoPrincipal w) + who = case whoName w <|> whoAgent w of + Just n | n /= whoPrincipal w -> n <> " (" <> shown <> ")" + _ -> shown + roles = nub (map fst (whoMemberships w)) + onScopes r = case filter (not . T.null) [s | (r', s) <- whoMemberships w, r' == r] of + [] -> r + ss -> r <> " on " <> T.intercalate ", " (nub ss) + held = if null roles then "" else " \x00B7 " <> T.intercalate "; " (map onScopes roles) + within = case nub (map scopeOf (whoCeiling w)) of + [] -> "" + cs -> ", within " <> T.intercalate ", " cs + +-- | A principal shortened for a one-line header: the part after its last +-- @:@ or @/@ kept to its leading word-and-underscore and four more +-- characters — @key:ac79e0…@ → @key:ac79…@, @oidc:workos/user_01M4QX…@ → +-- @oidc:workos/user_01M4…@. A short one is shown whole. +abbreviatePrincipal :: Text -> Text +abbreviatePrincipal p + | T.length ident <= 12 = p + | otherwise = prefix <> T.take keep ident <> "\x2026" + where + (prefix, ident) = splitIdent p + lead = case T.breakOn "_" ident of + (w, rest) | not (T.null rest), T.length w <= 8 -> T.length w + 1 + _ -> 0 + keep = lead + 4 + splitIdent t = + let i = maximum (0 : [n + 1 | (n, c) <- zip [0 ..] (T.unpack t), c == ':' || c == '/']) + in T.splitAt i t + +-- ============================================================================ +-- The anonymous page +-- ============================================================================ + +data AnonPage = AnonPage + { apBackend :: Text -- ^ the hub's name + , apVersion :: Maybe Text -- ^ the root schema's version, when the view shows it + , apMethods :: [(Text, Text)] -- ^ (method, description) under @auth@ + , apInvoke :: Text -- ^ how this synapse was pointed: @synapse -P 4455@ + } deriving (Eq, Show) + +-- | The door's methods, each with its description: the ones @_info@'s @auth@ +-- block names (@auth.login@ → @login@), else the auth schema's public +-- ones, else login, signup and providers; described by the auth schema +-- when it says, else in synapse's words. login, signup, providers first, +-- in that order; any others after, by name. +anonymousMethods :: Maybe AuthInfo -> Maybe PluginSchema -> [(Text, Text)] +anonymousMethods info authSchema = sortOn (rank . fst) [ (m, describe m) | m <- names ] + where + fromInfo = maybe [] (map (\m -> fromMaybe m (T.stripPrefix "auth." m)) . authMethods) info + fromSchema = maybe [] (map methodName . filter methodPublic . psMethods) authSchema + names = nub $ case (fromInfo, fromSchema) of + ([], []) -> ["login", "signup", "providers"] + ([], s) -> s + (i, _) -> i + described = maybe [] (\s -> [(methodName m, methodDescription m) | m <- psMethods s]) authSchema + describe m = case lookup m described of + Just d | not (T.null d) -> d + _ -> fromMaybe "" (lookup m ownWords) + ownWords = + [ ("login", "Sign in \x2014 a person through the browser, an agent with its key") + , ("signup", "Create an account, or ask for access") + , ("providers", "The ways in this server offers") + ] + rank m = (fromMaybe 3 (lookup m (zip ["login", "signup", "providers"] [0 :: Int ..])), m) + +-- | The page an anonymous caller sees for a hub (AUTH-8): +-- +-- @ +-- menger v1.0.0 +-- Sign in to see what you can do here. +-- +-- auth +-- login Sign in — a person through the browser, an agent with its key +-- signup Create an account, or ask for access +-- providers The ways in this server offers +-- +-- synapse -P 4455 _login menger # a person +-- synapse -P 4455 _login menger --key agent-7 --as w-1 # an agent +-- @ +renderAnonymousPage :: AnonPage -> Text +renderAnonymousPage AnonPage{..} = T.unlines $ + [ apBackend <> maybe "" (\v -> if T.null v then "" else " v" <> v) apVersion + , " Sign in to see what you can do here." + , "" + , "auth" + ] + <> [ " " <> T.justifyLeft nameW ' ' m <> (if T.null d then "" else " " <> d) | (m, d) <- apMethods ] + <> [ "" ] + <> [ " " <> T.justifyLeft exW ' ' ex <> " # " <> who | (ex, who) <- examples ] + where + nameW = maximum (0 : map (T.length . fst) apMethods) + examples = + [ (apInvoke <> " _login " <> apBackend, "a person") + , (apInvoke <> " _login " <> apBackend <> " --key agent-7 --as w-1", "an agent") + ] + exW = maximum (map (T.length . fst) examples) + +-- ============================================================================ +-- Refusals +-- ============================================================================ + +-- | A refusal, as a block for stderr: +-- +-- @ +-- refused: needs tickets.set_status on IDENTITY +-- roles with it editor, admin +-- you hold it on MENGER (within MENGER-12) +-- @ +-- +-- The ceiling is the refusal's own when the hub names one, else the one +-- passed in (the stored session's, as asked at login). A line with +-- nothing to say is left out; a refusal naming no grant is its message. +renderRefusal :: [Text] -> Refusal -> Text +renderRefusal fallbackCeiling r = T.unlines (headline : details) + where + headline = case (refusalGrant r, refusalScope r) of + (Just g, Just s) -> "refused: needs " <> g <> " on " <> s + (Just g, Nothing) -> "refused: needs " <> g + _ -> "refused: " <> refusalMessage r + ceilingScopes = nub $ map scopeOf $ + if null (refusalCeiling r) then fallbackCeiling else refusalCeiling r + within = if null ceilingScopes then "" else " (within " <> T.intercalate ", " ceilingScopes <> ")" + details = + [ " roles with it " <> T.intercalate ", " (refusalRoles r) | not (null (refusalRoles r)) ] + <> [ " you hold it on " <> heldText ] + heldText = case refusalHeldOn r of + [] -> "nowhere" <> within + hs -> T.intercalate ", " hs <> within + +-- ============================================================================ +-- The session auth.login answers +-- ============================================================================ + +-- | @{type: session, token, principal, name?, agent?, expires_at?, ceiling?}@ +-- (AUTH-5), or IDENTITY-42's @{type: login, …, scope}@ from session.login. +data SessionGrant = SessionGrant + { sgToken :: Text + , sgPrincipal :: Text + , sgName :: Maybe Text + , sgAgent :: Maybe Text + , sgExpiresAt :: Maybe Integer + , sgCeiling :: [Text] + , sgWhoami :: Maybe Whoami -- ^ when the answer carries memberships + } deriving (Eq, Show) + +-- | The session in a data item's content, when it is one. +parseSessionGrant :: Value -> Maybe SessionGrant +parseSessionGrant = \case + Object o + | Just (String t) <- KM.lookup "type" o, t `elem` ["session", "login"] + , Just (String tok) <- KM.lookup "token" o, not (T.null tok) -> Just SessionGrant + { sgToken = tok + , sgPrincipal = str "principal" o + , sgName = nonEmpty (str "name" o) + , sgAgent = nonEmpty (str "agent" o) + , sgExpiresAt = KM.lookup "expires_at" o >>= int + , sgCeiling = ceilingOf o + , sgWhoami = case parseWhoami (Object o) of + Just w | not (null (whoMemberships w)) -> Just w + _ -> Nothing + } + _ -> Nothing + +-- | Is this error the hub saying it has no @auth@ activation (or no such +-- method on it)? Then synapse falls back to IDENTITY-42's @session.*@. +isMissingAuth :: Text -> Bool +isMissingAuth m = any (`T.isInfixOf` T.toLower m) + [ "activation not found", "method not found", "unknown method", "no such method" + , "unknown activation", "not found: auth", "-32601", "activationnotfound", "methodnotfound" ] + +-- ============================================================================ +-- Helpers +-- ============================================================================ + +str :: Text -> KM.KeyMap Value -> Text +str k o = case KM.lookup (K.fromText k) o of + Just (String s) -> s + _ -> "" + +nonEmpty :: Text -> Maybe Text +nonEmpty t = if T.null t then Nothing else Just t + +int :: Value -> Maybe Integer +int = \case + Number n -> fromIntegral <$> (toBoundedInteger n :: Maybe Int) + String s | [(i, "")] <- reads (T.unpack s) -> Just i + _ -> Nothing diff --git a/src/Synapse/Auth/Loopback.hs b/src/Synapse/Auth/Loopback.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Auth/Loopback.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | AUTH-8: a person signing in from synapse — the loopback flow (AUTH-1, +-- "Settled to start", Q3). +-- +-- synapse listens on @127.0.0.1:@, asks the hub for a +-- sign-in URL that returns there (@auth.login {flow: {browser: {redirect}}}@), +-- opens it, and waits — at most five minutes — for the browser to come +-- back with @GET /cb?code=…&state=…@. The state must be the one the hub +-- handed out with the URL; anything else is refused and ends the wait. +-- The code then goes back to the hub (@auth.login {flow: {code: …}}@). +-- +-- The parsing and the state check are pure ('parseRequestLine', +-- 'checkCallback') and tested; the socket is only 127.0.0.1, accepts one +-- answer and closes. +module Synapse.Auth.Loopback + ( -- * The listener + Loopback + , loopbackPort + , loopbackRedirect + , withLoopback + , awaitCallback + + -- * Pure parts + , parseRequestLine + , checkCallback + , CallbackResult(..) + , percentDecode + , callbackPage + , durationText + + -- * The browser + , openBrowser + ) where + +import Control.Exception (SomeException, bracket, try) +import Control.Monad (void) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (chr, digitToInt, isHexDigit) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TEE +import qualified Network.Socket as N +import qualified Network.Socket.ByteString as NB +import System.Environment (lookupEnv) +import System.Info (os) +import System.Process (createProcess, proc, std_err, std_out, std_in, StdStream(..)) +import System.Timeout (timeout) + +-- | A listening socket on 127.0.0.1 and the port the OS gave it. +data Loopback = Loopback + { lbSocket :: N.Socket + , lbPort :: Int + } + +loopbackPort :: Loopback -> Int +loopbackPort = lbPort + +-- | Where the hub sends the browser back: @http://127.0.0.1:/cb@. +loopbackRedirect :: Loopback -> Text +loopbackRedirect lb = "http://127.0.0.1:" <> T.pack (show (lbPort lb)) <> "/cb" + +-- | Listen on 127.0.0.1 (never another interface), port 0, for the +-- duration of the action. +withLoopback :: (Loopback -> IO a) -> IO a +withLoopback act = bracket open (N.close . lbSocket) act + where + open = do + sock <- N.socket N.AF_INET N.Stream N.defaultProtocol + N.setSocketOption sock N.ReuseAddr 1 + N.bind sock (N.SockAddrInet 0 (N.tupleToHostAddress (127, 0, 0, 1))) + N.listen sock 4 + port <- N.socketPort sock + pure (Loopback sock (fromIntegral port)) + +-- | What one request to the loopback came to. +data CallbackResult + = CallbackCode Text -- ^ @/cb@ with the state expected: the code + | CallbackRefused Text -- ^ @/cb@ that cannot be accepted: why (ends the wait) + | CallbackIgnored -- ^ anything else (@/favicon.ico@): answered 404, keep waiting + deriving (Eq, Show) + +-- | The method, path and query of an HTTP request line: +-- @GET /cb?code=c_1&state=s_2 HTTP/1.1@ → @("GET", "/cb", [("code","c_1"),("state","s_2")])@. +parseRequestLine :: BS.ByteString -> Maybe (Text, Text, [(Text, Text)]) +parseRequestLine raw = case BS8.words (BS8.takeWhile (\c -> c /= '\r' && c /= '\n') raw) of + (method : target : _) -> + let (path, query) = BS8.break (== '?') target + params = [ (dec k, dec (BS.drop 1 v)) + | kv <- BS8.split '&' (BS.drop 1 query), not (BS.null kv) + , let (k, v) = BS8.break (== '=') kv ] + in Just (utf8 method, utf8 path, params) + _ -> Nothing + where + dec = percentDecode . utf8 + utf8 = TE.decodeUtf8With TEE.lenientDecode + +-- | Decide a request: @GET /cb@ carrying the expected state and a code is +-- the code; @/cb@ with a provider's @error@, a missing code, or another +-- state is refused (a mismatched state is never a code); any other path +-- is ignored. +checkCallback :: Text -> (Text, Text, [(Text, Text)]) -> CallbackResult +checkCallback expected (_method, path, params) + | path /= "/cb" = CallbackIgnored + | Just e <- lookup "error" params = + CallbackRefused ("the sign-in was not completed: " <> e + <> maybe "" (" \x2014 " <>) (lookup "error_description" params)) + | lookup "state" params /= Just expected = + CallbackRefused "the browser came back with a state this sign-in did not ask for; refused" + | otherwise = case lookup "code" params of + Just c | not (T.null c) -> CallbackCode c + _ -> CallbackRefused "the browser came back without a code" + +-- | @%2F@ → @/@, @+@ → space. +percentDecode :: Text -> Text +percentDecode = T.pack . go . T.unpack + where + go ('%' : a : b : rest) | isHexDigit a && isHexDigit b = chr (digitToInt a * 16 + digitToInt b) : go rest + go ('+' : rest) = ' ' : go rest + go (c : rest) = c : go rest + go [] = [] + +-- | @300@ → @5 minutes@; @90@ → @90 seconds@. +durationText :: Int -> Text +durationText secs + | secs >= 60 && secs `mod` 60 == 0 = T.pack (show (secs `div` 60)) <> " minutes" + | secs == 1 = "1 second" + | otherwise = T.pack (show secs) <> " seconds" + +-- | The small page the browser shows once synapse has the answer. +callbackPage :: Bool -> Text -> BS.ByteString +callbackPage ok msg = response + where + status = if ok then "200 OK" else "400 Bad Request" + title = if ok then "Signed in" else "Not signed in" + body = TE.encodeUtf8 $ T.concat + [ "", title, "" + , "

", title, "

" + , escape msg, "

" ] + response = BS.concat + [ "HTTP/1.1 ", status, "\r\nContent-Type: text/html; charset=utf-8\r\n" + , "Content-Length: ", BS8.pack (show (BS.length body)), "\r\nConnection: close\r\n" + , "Cache-Control: no-store\r\n\r\n", body ] + escape = T.concatMap (\case '<' -> "<"; '>' -> ">"; '&' -> "&"; '"' -> """; c -> T.singleton c) + +-- | Wait (up to @secs@) for the browser to come back with the state +-- expected. The code, or why there is none. +awaitCallback :: Loopback -> Text -> Int -> IO (Either Text Text) +awaitCallback lb expected secs = do + r <- timeout (secs * 1000000) loop + pure $ case r of + Nothing -> Left ("no answer from the browser within " <> durationText secs) + Just x -> x + where + loop = do + (conn, _) <- N.accept (lbSocket lb) + req <- readHead conn + let decided = maybe CallbackIgnored (checkCallback expected) (parseRequestLine req) + case decided of + CallbackIgnored -> do + send conn "HTTP/1.1 404 Not Found\r\nContent-Length: 0\r\nConnection: close\r\n\r\n" + N.close conn + loop + CallbackRefused why -> do + send conn (callbackPage False why) + N.close conn + pure (Left why) + CallbackCode code -> do + send conn (callbackPage True "You are signed in to synapse. You can close this tab.") + N.close conn + pure (Right code) + send conn bytes = void (try (NB.sendAll conn bytes) :: IO (Either SomeException ())) + -- the request line is all that is read; enough of the head to hold it + readHead conn = go BS.empty + where + go acc + | "\r\n" `BS.isInfixOf` acc || BS.length acc > 16384 = pure acc + | otherwise = do + chunk <- try (NB.recv conn 4096) :: IO (Either SomeException BS.ByteString) + case chunk of + Right c | not (BS.null c) -> go (acc <> c) + _ -> pure acc + +-- | Open the URL in the person's browser (@xdg-open@; @open@ on macOS), +-- detached and silent. @SYNAPSE_NO_BROWSER=1@ opens nothing (the URL is +-- printed either way). True when a browser was asked. +openBrowser :: Text -> IO Bool +openBrowser url = do + off <- lookupEnv "SYNAPSE_NO_BROWSER" + if maybe False (`elem` ["1", "true", "yes"]) off then pure False else do + let opener = if os == "darwin" then "open" else "xdg-open" + r <- try (void (createProcess (proc opener [T.unpack url]) + { std_in = NoStream, std_out = NoStream, std_err = NoStream })) + :: IO (Either SomeException ()) + pure (either (const False) (const True) r) 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 @@ -44,16 +44,34 @@ -- * Implementations , stubDiscovery , registryDiscovery + , registryDiscoveryAt + -- * SCAFFOLD-21: an address that is not plain ws://HOST:PORT/ + , endpointFor + -- * Backend Discovery , getBackendAt + , getBackendAtWith + , getBackendAtEp + , probeBackendAtWith + , probeBackendAtEp + , probedInfo + , probedInfoAt + , probeFailureAt -- * Health Checks , pingBackend , pingBackends + , pingBackendsVia -- * Registry Registration , registerWithRegistry + + -- * Registry Endpoint + , registryUrlEnvVar + , defaultRegistryHost + , defaultRegistryPort + , registryEndpointFromEnv ) where import Data.Aeson (ToJSON, FromJSON, (.:), (.:?), withObject) @@ -66,13 +84,19 @@ import Data.Either (isRight) import Control.Concurrent.Async (mapConcurrently, race, async, wait) import Control.Concurrent (threadDelay) -import Data.IORef (newIORef, writeIORef, readIORef) +import Data.IORef (IORef, newIORef, writeIORef, readIORef, modifyIORef') +import qualified Data.Map.Strict as Map +import System.IO.Unsafe (unsafePerformIO) +import Plexus.Auth (BackendInfo, parseBackendInfo) import Control.Monad (void) -import Plexus.Client (SubstrateConfig(..)) +import Synapse.Endpoint (Endpoint(..), plainAt, substrateConfig, addressKey) +import qualified Network.WebSockets as WS import qualified Plexus.Transport as ST import Plexus.Types (PlexusStreamItem(..), TransportError(..)) import qualified Synapse.Log as Log import qualified System.IO as IO +import qualified Data.Text.Read as TR +import System.Environment (lookupEnv) -- ============================================================================ -- Backend Type @@ -178,10 +202,17 @@ -- Connects to the registry service and queries for registered backends. -- Falls back to stubDiscovery if registry is unavailable. registryDiscovery :: Text -> Int -> BackendDiscovery -registryDiscovery registryHost registryPort = BackendDiscovery +registryDiscovery registryHost registryPort = registryDiscoveryAt (plainAt registryHost registryPort) + +-- | SCAFFOLD-21: 'registryDiscovery' through a connection point at any +-- address (a hub behind TLS, on a path). The backends a registry lists +-- are plain @ws://HOST:PORT/@, as it records them; the connection point +-- itself is reached as it was named ('endpointFor'). +registryDiscoveryAt :: Endpoint -> BackendDiscovery +registryDiscoveryAt ep = BackendDiscovery { discoverBackends = do -- First, discover the backend name using _info - maybeBackendName <- discoverBackendName registryHost registryPort + maybeBackendName <- either (const Nothing) Just <$> probeBackendAtEp [] ep case maybeBackendName of Just discoveredName -> do -- Create a Backend entry for the discovered backend @@ -195,7 +226,7 @@ } -- Try to get additional backends from registry (if it exists) - registryBackends <- queryRegistry registryHost registryPort discoveredName + registryBackends <- queryRegistry ep discoveredName -- Only include discovered backend if not already in registry -- (prefer registry entry since it has more details) @@ -211,67 +242,119 @@ Nothing -> -- Connection failed completely discoverBackends stubDiscovery - , getBackendInfo = queryBackend registryHost registryPort + , getBackendInfo = queryBackend ep } + where + registryHost = epHost ep + registryPort = epPort ep +-- | SCAFFOLD-21: how to reach a backend a discovery answered — the +-- connection point as it was named (its scheme, path, CAs) when the +-- backend is at its host and port, else plain @ws://HOST:PORT/@. +endpointFor :: Endpoint -> Backend -> Endpoint +endpointFor ep b + | backendHost b == epHost ep && backendPort b == epPort ep = ep + | otherwise = plainAt (backendHost b) (backendPort b) + -- | Get the backend name at a given host/port via _info -- Returns whatever backend is running there (e.g., "registry-hub", "plexus") -- If that backend has a registry plugin, it can be used to discover other backends getBackendAt :: Text -> Int -> IO (Maybe Text) -getBackendAt = discoverBackendName +getBackendAt host port = getBackendAtEp [] (plainAt host port) --- | Discover the backend name by calling _info (with 2000ms timeout) -discoverBackendName :: Text -> Int -> IO (Maybe Text) -discoverBackendName host port = do - let cfg = SubstrateConfig - { substrateHost = T.unpack host - , substratePort = port - , substratePath = "/" - , substrateBackend = "" -- Not used for _info - , substrateHeaders = [] - } +-- | IDENTITY-16: 'getBackendAt', its _info probe carrying the caller's +-- upgrade headers (the token's cookie, --cookie, --header; see +-- 'Synapse.Transport.mergeUpgradeHeaders'). A backend that refuses +-- anonymous upgrades answers the probe only with them. +getBackendAtWith :: WS.Headers -> Text -> Int -> IO (Maybe Text) +getBackendAtWith headers host port = getBackendAtEp headers (plainAt host port) + +-- | SCAFFOLD-21: 'getBackendAtWith' at any address. +getBackendAtEp :: WS.Headers -> Endpoint -> IO (Maybe Text) +getBackendAtEp headers ep = either (const Nothing) Just <$> probeBackendAtEp headers ep + +-- | IDENTITY-43: the _info probe, saying why when it fails — so a caller +-- can tell the upgrade's 401 (its session ended) from a backend that is +-- down. +probeBackendAtWith :: WS.Headers -> Text -> Int -> IO (Either Text Text) +probeBackendAtWith headers host port = probeBackendAtEp headers (plainAt host port) + +-- | SCAFFOLD-21: 'probeBackendAtWith' at any address. Behind TLS the +-- probe waits longer (a handshake across the internet, not loopback). +probeBackendAtEp :: WS.Headers -> Endpoint -> IO (Either Text Text) +probeBackendAtEp headers ep = do + let cfg = substrateConfig ep "" headers -- the backend is not used for _info + secs = probeSecs ep timeout = do - threadDelay 2000000 -- 2 second timeout - pure (Left $ ConnectionTimeout host port) + threadDelay (secs * 1000000) + pure (Left $ ConnectionTimeout (epHost ep) (epPort ep)) rpcCall = do ST.rpcCallWith cfg "_info" Aeson.Null - `catch` \(_e :: SomeException) -> - pure (Left $ NetworkError "Connection failed") + `catch` \(e :: SomeException) -> + pure (Left $ NetworkError ("Connection failed: " <> T.pack (show e))) - -- Race the RPC call against a 2 second timeout + -- Race the RPC call against the timeout raceResult <- race timeout rpcCall + let failed why = do + -- SCAFFOLD-21: kept, so a caller can say why (a certificate refused) + modifyIORef' failMemo (Map.insert (addressKey ep) why) + pure (Left why) case raceResult of Left _err -> - pure Nothing - Right (Left _err) -> - pure Nothing + failed "the _info probe timed out" + Right (Left err) -> + failed (T.pack (show err)) Right (Right items) -> do -- Extract the backend name from subscription response case [Aeson.fromJSON content | StreamData _ _ _ content <- items] of - (Aeson.Success (Aeson.Object obj):_) | Just (Aeson.String name) <- KM.lookup "backend" obj -> - pure (Just name) + (Aeson.Success v@(Aeson.Object obj):_) | Just (Aeson.String name) <- KM.lookup "backend" obj -> do + -- AUTH-8: kept for the rest of the process — the view and the + -- auth block this connection's credential was answered with + mapM_ (\i -> modifyIORef' infoMemo (Map.insert (addressKey ep) i)) (parseBackendInfo v) + pure (Right name) _ -> - pure Nothing + failed "the _info probe answered no backend name" +-- | How long the _info probe waits: 2 s on a plain socket (loopback, as +-- ever), 10 s behind TLS. +probeSecs :: Endpoint -> Int +probeSecs ep = if epTls ep then 10 else 2 + +-- | AUTH-8: what the last successful _info probe at HOST:PORT answered in +-- this process (its view and auth block), when it was probed. +probedInfo :: Text -> Int -> IO (Maybe BackendInfo) +probedInfo host port = probedInfoAt (plainAt host port) + +-- | SCAFFOLD-21: 'probedInfo' at any address. +probedInfoAt :: Endpoint -> IO (Maybe BackendInfo) +probedInfoAt ep = Map.lookup (addressKey ep) <$> readIORef infoMemo + +-- | SCAFFOLD-21: why the last _info probe at this address failed, in this +-- process (a TLS handshake's refusal, say), if it did. +probeFailureAt :: Endpoint -> IO (Maybe Text) +probeFailureAt ep = Map.lookup (addressKey ep) <$> readIORef failMemo + +{-# NOINLINE failMemo #-} +failMemo :: IORef (Map.Map Text Text) +failMemo = unsafePerformIO (newIORef Map.empty) + +{-# NOINLINE infoMemo #-} +infoMemo :: IORef (Map.Map Text BackendInfo) +infoMemo = unsafePerformIO (newIORef Map.empty) + -- | Query the registry for all backends -queryRegistry :: Text -> Int -> Text -> IO [Backend] -queryRegistry host port backendName = do +queryRegistry :: Endpoint -> Text -> IO [Backend] +queryRegistry ep backendName = do -- Try registry query first - queryRegistryImpl host port backendName `catch` \(_e :: SomeException) -> + queryRegistryImpl ep backendName `catch` \(_e :: SomeException) -> -- Return empty list on error - caller will handle fallback pure [] -- | Implementation of registry query -queryRegistryImpl :: Text -> Int -> Text -> IO [Backend] -queryRegistryImpl host port backendName = do - let cfg = SubstrateConfig - { substrateHost = T.unpack host - , substratePort = port - , substratePath = "/" - , substrateBackend = backendName - , substrateHeaders = [] - } +queryRegistryImpl :: Endpoint -> Text -> IO [Backend] +queryRegistryImpl ep backendName = do + let cfg = substrateConfig ep backendName [] -- Call registry.list through the backend result <- ST.invokeMethod cfg ["registry"] "list" (Aeson.object []) case result of @@ -284,10 +367,10 @@ pure $ map convertBackend backendInfos -- | Query for a specific backend by name -queryBackend :: Text -> Int -> Text -> IO (Maybe Backend) -queryBackend host port name = do +queryBackend :: Endpoint -> Text -> IO (Maybe Backend) +queryBackend ep name = do -- First discover the backend name - maybeBackendName <- discoverBackendName host port + maybeBackendName <- getBackendAtEp [] ep case maybeBackendName of Just discoveredName -> do -- Check if the requested name matches the discovered backend @@ -295,29 +378,23 @@ then pure $ Just Backend { backendName = discoveredName , backendDescription = "Backend discovered via _info" - , backendHost = host - , backendPort = port + , backendHost = epHost ep + , backendPort = epPort ep , backendVersion = Nothing , backendReachable = Nothing } else do -- Try to find it in the registry result <- catch - (queryBackendImpl host port discoveredName name) + (queryBackendImpl ep discoveredName name) (\(_e :: SomeException) -> pure Nothing) pure result Nothing -> getBackendInfo stubDiscovery name -- | Implementation of backend get query -queryBackendImpl :: Text -> Int -> Text -> Text -> IO (Maybe Backend) -queryBackendImpl host port backendName name = do - let cfg = SubstrateConfig - { substrateHost = T.unpack host - , substratePort = port - , substratePath = "/" - , substrateBackend = backendName - , substrateHeaders = [] - } +queryBackendImpl :: Endpoint -> Text -> Text -> IO (Maybe Backend) +queryBackendImpl ep backendName name = do + let cfg = substrateConfig ep backendName [] params = Aeson.object ["name" Aeson..= name] result <- ST.invokeMethod cfg ["registry"] "get" params case result of @@ -345,19 +422,21 @@ -- 300ms allows for WebSocket connection establishment overhead (~150-200ms) -- plus actual RPC round-trip time pingBackend :: Backend -> IO Backend -pingBackend backend = do - let cfg = SubstrateConfig - { substrateHost = T.unpack (backendHost backend) - , substratePort = backendPort backend - , substratePath = "/" - , substrateBackend = "" -- _info has no namespace prefix - , substrateHeaders = [] - } - timeout = threadDelay 300000 >> pure (Left $ ConnectionTimeout (backendHost backend) (backendPort backend)) +pingBackend = pingBackendAt Nothing + +-- | SCAFFOLD-21: ping at the backend's own address — the connection point +-- as it was named when the backend is there ('endpointFor'), which behind +-- TLS is given 5 s rather than 300 ms. +pingBackendAt :: Maybe Endpoint -> Backend -> IO Backend +pingBackendAt via backend = do + let ep = maybe (plainAt (backendHost backend) (backendPort backend)) (`endpointFor` backend) via + cfg = substrateConfig ep "" [] -- _info has no namespace prefix + micros = if epTls ep then 5000000 else 300000 + timeout = threadDelay micros >> pure (Left $ ConnectionTimeout (backendHost backend) (backendPort backend)) rpcCall = ST.rpcCallWith cfg "_info" Aeson.Null `catch` \(_e :: SomeException) -> pure (Left $ NetworkError "Connection failed") - -- Race the RPC call against a 300ms timeout + -- Race the RPC call against the timeout result <- race timeout rpcCall let reachable = case result of Left _ -> False -- Timeout @@ -370,6 +449,10 @@ pingBackends :: [Backend] -> IO [Backend] pingBackends backends = mapConcurrently pingBackend backends +-- | SCAFFOLD-21: 'pingBackends', the connection point reached as named. +pingBackendsVia :: Endpoint -> [Backend] -> IO [Backend] +pingBackendsVia ep = mapConcurrently (pingBackendAt (Just ep)) + -- ============================================================================ -- Registry Registration -- ============================================================================ @@ -387,13 +470,7 @@ -> Int -- ^ Backend port -> IO () registerWithRegistry registryHost registryPort registryBackend name host port = do - let cfg = SubstrateConfig - { substrateHost = T.unpack registryHost - , substratePort = registryPort - , substratePath = "/" - , substrateBackend = registryBackend - , substrateHeaders = [] - } + let cfg = substrateConfig (plainAt registryHost registryPort) registryBackend [] params = Aeson.object [ "name" Aeson..= name , "host" Aeson..= host @@ -405,3 +482,53 @@ _ <- ST.invokeMethod cfg ["registry"] "register" params `catch` \(_e :: SomeException) -> pure (Left $ NetworkError "Registry unavailable") pure () + +-- ============================================================================ +-- Registry Endpoint +-- ============================================================================ +-- +-- SYNAPSE-7: the endpoint helpers synapse-cc 0.3.4 imports +-- (src/SynapseCC/RegistryResolve.hs). They were written with Z2H-6 on +-- the feature/Z2H-6-registry branch (e176373), which was never merged to +-- main, so synapse-cc's main did not build against synapse's. These are +-- that commit's definitions, unchanged and additive: nothing in synapse +-- calls them yet, so no behavior here moves. + +-- | Environment variable naming the registry endpoint, shared with +-- plexus-transport's boot-time self-registration. +registryUrlEnvVar :: String +registryUrlEnvVar = "PLEXUS_REGISTRY_URL" + +defaultRegistryHost :: Text +defaultRegistryHost = "127.0.0.1" + +defaultRegistryPort :: Int +defaultRegistryPort = 4444 + +-- | Resolve the registry endpoint from @PLEXUS_REGISTRY_URL@ +-- (e.g. @ws:\/\/127.0.0.1:4444@ or @host:port@), falling back to +-- @127.0.0.1:4444@. Malformed values fall back to the default rather +-- than failing the invocation. +registryEndpointFromEnv :: IO (Text, Int) +registryEndpointFromEnv = do + mUrl <- lookupEnv registryUrlEnvVar + pure $ case mUrl of + Nothing -> (defaultRegistryHost, defaultRegistryPort) + Just raw -> parseRegistryUrl (T.strip (T.pack raw)) + +-- | Parse @[ws://]host[:port]@. +parseRegistryUrl :: Text -> (Text, Int) +parseRegistryUrl raw + | T.null raw = (defaultRegistryHost, defaultRegistryPort) + | otherwise = + let noScheme = case T.breakOn "://" raw of + (_, rest) | not (T.null rest) -> T.drop 3 rest + _ -> raw + noPath = T.takeWhile (/= '/') noScheme + (host, portTxt) = case T.breakOnEnd ":" noPath of + (h, p) | not (T.null h) -> (T.dropEnd 1 h, p) + _ -> (noPath, "") + in case TR.decimal portTxt of + Right (p, "") | not (T.null host) -> (host, p) + _ | T.null noPath -> (defaultRegistryHost, defaultRegistryPort) + | otherwise -> (noPath, defaultRegistryPort) 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 @@ -43,6 +43,19 @@ renderMethodHelp , renderMethodHelpWith + -- * The method page (SYNAPSE-13) + , MethodPage(..) + , methodPage + , renderMethodPage + , renderExample + , synthesiseExample + , shellQuote + , flagLabel + , flagType + , paramValuesOf + , serverSourced + , wrapWords + -- * Parameter Help , renderParamHelp , renderParamHelpWith @@ -56,15 +69,26 @@ , defaultHelpStyle ) where -import Data.List (intersperse) -import Data.Map.Strict (Map) +import Control.Applicative ((<|>)) +import Data.Aeson (Value(..)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy as LBS +import Data.Char (isAlphaNum) +import Data.List (sortOn) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, maybeToList) +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Scientific (floatingOrInteger) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import Plexus.Schema.Recursive (MethodExample(..), MethodSchema(..), paramValues) import Synapse.IR.Types -import Synapse.Algebra.Render (deprecationMarker, formatDeprecationLine) +import Synapse.Algebra.Render (deprecationMarker, formatDeprecationLine, fitText) +import Synapse.CLI.Parse (isScalarElement) -- ============================================================================ -- Configuration @@ -92,33 +116,316 @@ -- Method Help -- ============================================================================ --- | Render complete help for a method +-- | Render complete help for a method: its page ('renderMethodPage'), +-- reached by @synapse @, from the IR alone. renderMethodHelp :: IR -> MethodDef -> Text -renderMethodHelp = renderMethodHelpWith defaultHelpStyle +renderMethodHelp ir md = renderMethodPage (methodPage md) ir md --- | Render method help with custom style +-- | Render method help with custom style (the style no longer changes the +-- page; kept for callers of the earlier layout). renderMethodHelpWith :: HelpStyle -> IR -> MethodDef -> Text -renderMethodHelpWith style ir method = T.unlines $ - [ header - , "" - ] ++ descSection ++ paramSection +renderMethodHelpWith _ = renderMethodHelp + +-- ============================================================================ +-- The method page (SYNAPSE-13) +-- ============================================================================ + +-- | What a method's page needs beside the IR. +data MethodPage = MethodPage + { mpProgram :: Text -- ^ synapse and its global options (@synapse -P 4455@) + , mpTarget :: Text -- ^ the backend and path to the method (@menger tickets set_status@) + , mpSchema :: Maybe MethodSchema -- ^ the method's schema: long description, examples, values, grant + , mpCaller :: Bool -- ^ AUTH-8: in a caller's view (say what it requires) + } + deriving stock (Show, Eq) + +-- | A page for a method known only from the IR: reached as +-- @synapse @. +methodPage :: MethodDef -> MethodPage +methodPage md = MethodPage + { mpProgram = "synapse" + , mpTarget = T.replace "." " " (mdFullPath md) + , mpSchema = Nothing + , mpCaller = False + } + +-- | SYNAPSE-13: a method's page in cargo's shape — the description; a +-- blank line and the long description; @Usage:@ with the required flags +-- spelled out; @Options:@ aligned, required first then optional in +-- [brackets], each with its type, description and allowed values; +-- @Example:@ — the schema's examples as command lines, each under its +-- note, else one synthesised from the required options; and, in a caller's +-- view, what it requires and where the caller holds it. +renderMethodPage :: MethodPage -> IR -> MethodDef -> Text +renderMethodPage MethodPage{..} ir md = T.unlines (dropTrailing body) where - header = mdFullPath method <> streamingIndicator + width = 80 + invoke = mpProgram <> " " <> mpTarget - streamingIndicator - | mdStreaming method = " [streaming]" - | otherwise = "" + body = concat + [ descLines + , longLines + , [""] + , usageLines + , optionsBlock + , exampleBlock + , requiresBlock + ] - descSection = case mdDescription method of - Just desc -> [desc, ""] + descLines = case mdDescription md of + Just d | not (T.null (T.strip d)) -> wrapWords width d + _ -> [mdName md] + + longText = (mpSchema >>= methodLongDescription) <|> mdLongDescription md + longLines = case longText of + Just l | not (T.null (T.strip l)) -> + "" : concatMap (\p -> if T.null p then [""] else wrapWords width p) (paragraphs l) + _ -> [] + + -- What a caller passes (a server-supplied param, REQ-8, is not a flag). + (callerParams, serverParams) = + ( [p | p <- params, not (serverSourced p)] + , [p | p <- params, serverSourced p] ) + params = sortOn (not . pdRequired) (mdParams md) + required = [p | p <- callerParams, pdRequired p] + optional = [p | p <- callerParams, not (pdRequired p)] + + usageLines = + [ "Usage: " <> T.unwords ([invoke] ++ map usageFlag required ++ ["[OPTIONS]" | not (null optional)]) ] + usageFlag p = flagOf p <> " <" <> T.toUpper (pdName p) <> ">" + + optionsBlock + | null callerParams && null serverParams = [] + | otherwise = ["", "Options:"] ++ concatMap optionRows callerParams ++ concatMap serverRows serverParams + + flagCol = 2 + min 28 (maximum (0 : map (T.length . flagText) callerParams ++ map (T.length . pdName) serverParams)) + 2 + + flagText = flagLabel ir + + optionRows p = hangAt flagCol (" " <> flagText p) (descOf p ++ extras p) + serverRows p = hangAt flagCol (" " <> pdName p) ["\x2190 " <> sourceLabel p] + + descW = max 20 (width - flagCol) + descOf p = maybe [] (wrapWords descW) (pdDescription p) + extras p = concat + [ maybe [] (\di -> [formatDeprecationLine di]) (pdDeprecation p) + , listLines p + , maybe [] (\vs -> wrapWords descW ("[values: " <> T.intercalate ", " vs <> "]")) (valuesOf p) + , if hsExpandEnums defaultHelpStyle then expandType ir (pdName p) (pdType p) else [] + ] + + listLines p = case listElement (pdType p) of + Just inner + | isScalarElement ir inner -> ["Repeat the flag or use commas: " <> flagOf p <> " a,b"] + | otherwise -> ["Repeat the flag for each element"] Nothing -> [] + listElement = \case + RefArray inner -> Just inner + RefOptional inner -> listElement inner + _ -> Nothing - paramSection - | null (mdParams method) = ["(no parameters)"] - | otherwise = - ["Parameters:"] ++ - concatMap (renderParamBlock style ir) (mdParams method) + -- The schema's hint (x-plexus-values), else the type's own literals. + valuesOf p = pdValues p <|> schemaValues (pdName p) <|> stringEnumValues ir (pdType p) + schemaValues name = do + ms <- mpSchema + Object o <- methodParams ms + Object props <- KM.lookup "properties" o + prop <- KM.lookup (K.fromText name) props + paramValues prop + -- Examples: the schema's, else one from the required options. + examples = case maybe [] methodExamples mpSchema of + [] -> [MethodExample (synthesiseExample ir md (fmap methodParams mpSchema >>= id)) Nothing] + es -> es + exampleBlock = + -- SYNAPSE-10: where a value may come from, on every method page + [ "" + , "A value may be read from a file (--flag @FILE) or stdin (--flag -);" + , "@@text sends a literal @text." + , "", if length examples == 1 then "Example:" else "Examples:"] + ++ concat (zipWith exampleLines [0 :: Int ..] examples) + exampleLines i ex = + [ "" | i > 0 ] + ++ maybe [] (\n -> [" # " <> n]) (exampleNote ex) + ++ [" " <> renderExample mpProgram mpTarget md (exampleParams ex)] + + -- AUTH-8: in a caller's view, the grant and where it is held. + requiresBlock = case mpSchema of + Just ms | mpCaller -> maybe [] (\l -> ["", l]) (requiresLine ms) + _ -> [] + requiresLine ms + | methodPublic ms = Just "Requires: nothing (public)" + | otherwise = do + grant <- methodGrant ms + let held = case methodHeldOn ms of + Just hs@(_ : _) -> "you hold it on " <> T.intercalate ", " hs + _ -> "you hold it nowhere" + pure $ case methodTarget ms of + Just t -> "Requires: " <> grant <> " on the scope of --" <> kebab t <> " (" <> held <> ")" + Nothing -> "Requires: " <> grant <> ", answered from where it is held (" <> held <> ")" + + paragraphs = map (T.unwords . T.words) . splitBlank . T.lines + splitBlank ls = case break (T.null . T.strip) ls of + (p, []) -> [T.unlines p] + (p, _ : rest) -> T.unlines p : "" : splitBlank rest + + dropTrailing = reverse . dropWhile (T.null . T.strip) . reverse + +-- | A lead and lines that start in column @col@: the first beside the lead +-- when it fits (two spaces between), else all of them under it. +hangAt :: Int -> Text -> [Text] -> [Text] +hangAt col lead ds = case ds of + [] -> [lead] + (d : rest) | T.length lead <= col - 2 -> (T.justifyLeft col ' ' lead <> d) : map (pad <>) rest + _ -> lead : map (pad <>) ds + where pad = T.replicate col " " + +flagOf :: ParamDef -> Text +flagOf p = "--" <> kebab (pdName p) + +-- | SYNAPSE-13: a parameter as an option line shows it — its flag and the +-- type it takes, in [brackets] when optional, ⚠ before a deprecated one +-- (@--id @, @[--snoozed ]@). SYNAPSE-17's search shows a +-- parameter the same way. +flagLabel :: IR -> ParamDef -> Text +flagLabel ir p = + let decorated = case pdDeprecation p of + Just _ -> deprecationMarker <> " " <> flagOf p + Nothing -> flagOf p + f = decorated <> " <" <> flagType ir (pdType p) <> ">" + in if pdRequired p then f else "[" <> f <> "]" + +-- | A type as a flag takes it: an optional one as its inner type (the +-- brackets say it is optional), a named one by its own name. +flagType :: IR -> TypeRef -> Text +flagType ir = \case + RefOptional inner -> flagType ir inner + RefArray inner -> flagType ir inner <> "[]" + t@(RefNamed qn) -> + let full = renderTypeRef ir t + in if full == qualifiedNameFull qn then qnLocalName qn else full + t -> renderTypeRef ir t + +-- | The values a parameter takes: its schema's hint (@x-plexus-values@), +-- else its type's literals when it is a string enum. +paramValuesOf :: IR -> ParamDef -> Maybe [Text] +paramValuesOf ir p = pdValues p <|> stringEnumValues ir (pdType p) + +kebab :: Text -> Text +kebab = T.replace "_" "-" + +-- | REQ-8: a param the server supplies (@x-plexus-source@ other than rpc). +serverSourced :: ParamDef -> Bool +serverSourced p = isJust (pdSource p) && sourceLabel p /= "rpc" + +sourceLabel :: ParamDef -> Text +sourceLabel p = case pdSource p of + Just (Object src) -> + let str k = case KM.lookup k src of { Just (String t) -> Just t; _ -> Nothing } + in case str "from" of + Just "auth" -> maybe "auth" ("auth: " <>) (str "resolver") + Just "cookie" -> "cookie" <> maybe "" (" " <>) (str "key") + Just "header" -> "header" <> maybe "" (" " <>) (str "key") + Just "query" -> "query" <> maybe "" (" " <>) (str "key") + Just "derived" -> "server-derived" + Just other -> other + Nothing -> "server" + _ -> "rpc" + +-- | The literals a string-enum type takes, when it is one. +stringEnumValues :: IR -> TypeRef -> Maybe [Text] +stringEnumValues ir = \case + RefOptional inner -> stringEnumValues ir inner + RefNamed qn -> case Map.lookup (qualifiedNameFull qn) (irTypes ir) of + Just TypeDef{tdKind = KindStringEnum vs} | not (null vs) -> Just vs + _ -> Nothing + _ -> Nothing + +-- | SYNAPSE-13: one example from a method's required options: each the +-- value its description gives after @e.g.@, else the first of its values, +-- else a stand-in by type (@@ for a string). +synthesiseExample :: IR -> MethodDef -> Maybe Value -> Value +synthesiseExample ir md schemaParams = Object $ KM.fromList + [ (K.fromText (pdName p), sample p) | p <- mdParams md, pdRequired p, not (serverSourced p) ] + where + sample p = fromMaybe (byType p (pdType p)) (fromDesc p <|> fromValues p) + fromDesc p = do + d <- pdDescription p + let (_, after) = T.breakOn "e.g. " d + guard' (not (T.null after)) + let tok = T.takeWhile (\c -> c `notElem` (" ,;)" :: String)) (T.drop 5 after) + bare = T.dropAround (`elem` ("'\"`[]" :: String)) tok + guard' (not (T.null bare)) + pure (String bare) + fromValues p = do + Object o <- schemaParams + Object props <- KM.lookup "properties" o + prop <- KM.lookup (K.fromText (pdName p)) props + v : _ <- paramValues prop + pure (String v) + byType p = \case + RefPrimitive "integer" _ -> Number 1 + RefPrimitive "number" _ -> Number 1 + RefPrimitive "boolean" _ -> Bool True + RefArray inner -> Array (V.singleton (byType p inner)) + RefOptional inner -> byType p inner + RefNamed qn -> case Map.lookup (qualifiedNameFull qn) (irTypes ir) of + Just TypeDef{tdKind = KindStringEnum (v : _)} -> String v + Just TypeDef{tdKind = KindAlias t} -> byType p t + Just TypeDef{tdKind = KindPrimitive t _} -> byType p (RefPrimitive t Nothing) + _ -> String ("<" <> T.toUpper (pdName p) <> ">") + _ -> String ("<" <> T.toUpper (pdName p) <> ">") + guard' b = if b then Just () else Nothing + +-- | SYNAPSE-13: an example's params as a synapse command line: each param +-- its flag (required first, in the method's order), a list its values joined +-- by commas (an element holding one double-quoted, SYNAPSE-2), an object its dotted fields +-- (@--value.type choice@); params a flag cannot carry (a list inside an +-- object, SYNAPSE-9) go whole as @-p '{…}'@, before the backend. +renderExample :: Text -> Text -> MethodDef -> Value -> Text +renderExample program target md params = case params of + Object o -> case mapM flagsOf (ordered o) of + Just groups -> T.unwords ([program, target] ++ concat groups) + Nothing -> whole + _ -> whole + where + whole = T.unwords [program, "-p", shellQuote (TE.decodeUtf8 (LBS.toStrict (Aeson.encode params))), target] + -- required first, then optional, each in the method's order + order = zip (map pdName (sortOn (not . pdRequired) (mdParams md))) [0 :: Int ..] + ordered o = sortOn (\(k, _) -> (fromMaybe maxBound (lookup (K.toText k) order), K.toText k)) (KM.toList o) + flagsOf (k, v) = flags True ("--" <> kebab (K.toText k)) v + flags _ _ Null = Just [] + -- an object's fields, its discriminator (@type@) first + flags _ f (Object o) = + concat <$> mapM (\(k, v) -> flags False (f <> "." <> kebab (K.toText k)) v) + (sortOn (\(k, _) -> (K.toText k /= "type", K.toText k)) (KM.toList o)) + flags top f (Array xs) + | not top = Nothing -- a list inside an object: not as flags (SYNAPSE-9) + | V.null xs = Just [] + | otherwise = do + scalars <- mapM scalar (V.toList xs) + -- an element holding a comma is double-quoted inside the value + let element x = if T.isInfixOf "," x || T.isPrefixOf "\"" x || T.null x || T.strip x /= x + then "\"" <> T.replace "\"" "\"\"" x <> "\"" + else x + pure [f, shellQuote (T.intercalate "," (map element scalars))] + flags _ f v = (\x -> [f, shellQuote x]) <$> scalar v + scalar = \case + String t -> Just t + Number n -> Just (either (T.pack . show) (T.pack . show) (floatingOrInteger n :: Either Double Integer)) + Bool b -> Just (if b then "true" else "false") + _ -> Nothing + +-- | A word as the shell reads it: bare when it is plain, else in single +-- quotes. +shellQuote :: Text -> Text +shellQuote t + | not (T.null t), T.all plain t = t + | Just inner <- T.stripPrefix "<" t >>= T.stripSuffix ">", not (T.null inner), T.all plain inner = t + | T.any (== '\'') t, not (T.any (`elem` ("\"$`\\!" :: String)) t) = "\"" <> t <> "\"" + | otherwise = "'" <> T.replace "'" "'\\''" t <> "'" + where plain c = isAlphaNum c || c `elem` ("_@%+=:,./-" :: String) + -- | Render a parameter as a block (may be multi-line for complex types). -- -- IR-14: when @pdDeprecation param@ is @Just DeprecationInfo@ the @@ -142,9 +449,9 @@ reqText = if pdRequired param then "(required)" else "(optional)" headerLine = indent' <> flagName <> " <" <> typeStr <> "> " <> reqText - -- Description line + -- Description, wrapped in its column descLines = case pdDescription param of - Just desc -> [indent2 <> desc] + Just desc -> map (indent2 <>) (wrapWords (80 - T.length indent2) desc) Nothing -> [] -- Deprecation detail line (IR-14). Indented one level beyond the @@ -153,12 +460,36 @@ Just di -> [indent2 <> formatDeprecationLine di] Nothing -> [] + -- How to pass several elements of a list (SYNAPSE-2) + listLines = case listElement (pdType param) of + Just inner + | isScalarElement ir inner -> + [indent2 <> "Repeat the flag or use commas: " <> rawFlag <> " a,b"] + | otherwise -> [indent2 <> "Repeat the flag for each element"] + Nothing -> [] + listElement = \case + RefArray inner -> Just inner + RefOptional inner -> listElement inner + _ -> Nothing + -- Type expansion (for enums/unions) expansionLines = if hsExpandEnums style then map (indent2 <>) (expandType ir (pdName param) (pdType param)) else [] - in [""] ++ [headerLine] ++ descLines ++ deprecationLines ++ expansionLines + in [""] ++ [headerLine] ++ descLines ++ deprecationLines ++ listLines ++ expansionLines + +-- | Words wrapped greedily to a width (at least 20). +wrapWords :: Int -> Text -> [Text] +wrapWords w0 = go . T.words + where + w = max 20 w0 + go [] = [] + go (x : xs) = line x xs + line acc [] = [acc] + line acc (y : ys) + | T.length acc + 1 + T.length y <= w = line (acc <> " " <> y) ys + | otherwise = acc : line y ys -- ============================================================================ -- Parameter Help 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 @@ -42,19 +42,50 @@ -- -> [("tags", [("", "backend"), ("", "critical"), ("", "urgent")])] -- -> {"tags": ["backend", "critical", "urgent"]} -- @ +-- +-- For a list of scalars, each flag value is also a comma-separated record +-- (see 'splitListValue'): +-- +-- @ +-- --tags backend,critical --tags '"a,b"' +-- -> {"tags": ["backend", "critical", "a,b"]} +-- @ +-- +-- = Command line +-- +-- The pairs come from the command line in two passes. 'parsePathAndParams' +-- runs before the method is known and finds the path; 'pairFlags' runs once +-- it is, and uses each parameter's type to decide whether a flag takes the +-- argument after it, so a value may begin with dashes: +-- +-- @ +-- --summary --body "--- id: X" --limit=3 (summary a boolean) +-- -> [("summary", "true"), ("body", "--- id: X"), ("limit", "3")] +-- @ module Synapse.CLI.Parse - ( -- * Parsing - parseParams + ( -- * Command line + parsePathAndParams + , pairFlags + + -- * Parsing + , parseParams , ParseError(..) + -- * List values + , isScalarElement + , splitListValue + -- * Helpers (exposed for testing) , groupByPrefix , buildParamValue ) where +import Control.Monad (foldM) import Data.Aeson (Value(..), object) import qualified Data.Aeson.Key as K +import Data.Either (partitionEithers) import Data.List (find) +import Data.Maybe (fromMaybe) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) @@ -86,9 +117,144 @@ -- ^ Unknown variant name (param name, provided value, valid variants, suggestions) | TypeNotFound Text -- ^ Referenced type not found in IR + | MalformedListValue Text Text Text + -- ^ List flag value with broken quoting (param name, flag value, reason) + | UnexpectedArgument Text + -- ^ Argument that no flag takes as its value deriving (Show, Eq) -- ============================================================================ +-- Command Line +-- ============================================================================ + +-- | Whether a flag written without @=@ takes the argument after it +data FlagArity + = TakesNext -- ^ Always, whatever it begins with: the parameter takes a value + | TakesBoolean -- ^ Only when it reads as a boolean: the parameter is a boolean + | TakesUnlessFlag -- ^ Unless it begins with @--@ (and is not @--@): no parameter is known + +-- | Split the arguments after the backend into path segments, (key, value) +-- pairs, the flag arguments the pairs came from, and whether help was asked +-- for. +-- +-- This runs before the method is known, so a flag takes the next argument +-- unless that begins with @--@ and is not exactly @--@. That is enough to find +-- the path. Once the method is known, 'pairFlags' pairs the flag arguments +-- again by type; the pairs returned here serve only where there is no method +-- schema (@_self@, @respond@, a method missing from the IR). +-- +-- Example: ["echo", "once", "--message", "hello", "--count", "3"] +-- -> (["echo", "once"], [("message", "hello"), ("count", "3")], +-- ["--message", "hello", "--count", "3"], False) +-- Example: ["echo", "once", "--help"] +-- -> (["echo", "once"], [], [], True) +parsePathAndParams :: [Text] -> ([Text], [(Text, Text)], [Text], Bool) +parsePathAndParams = go [] [] [] False + where + go path params flags helpReq [] = (reverse path, reverse params, reverse flags, helpReq) + go path params flags helpReq (x:xs) + -- --help flag: mark help requested, don't add as param + | x == "--help" || x == "-h" = + go path params flags True xs + -- --key value, --key=value, or a bare --key + | Just flag <- T.stripPrefix "--" x + , not (T.null flag) = + let (key, val, n) = takeFlag (const TakesUnlessFlag) flag xs + (taken, rest) = splitAt n xs + in go path ((normalizeKey key, fromMaybe "" val) : params) + (reverse (x : taken) ++ flags) helpReq rest + -- Regular path segment - split on dots to support Plexus RPC path syntax (e.g., cone.chat) + | otherwise = + let segments = map (T.replace "-" "_") $ filter (not . T.null) $ T.splitOn "." x + in go (reverse segments ++ path) params flags helpReq xs + +-- | Pair a method's flag arguments (from 'parsePathAndParams') by the types +-- of its parameters: +-- +-- * @--key=value@: everything after the first @=@, empty or not +-- * a boolean: @true@ when bare; it takes the next argument only when that +-- reads as a boolean (@true@, @false@, @1@, @0@), so @--summary --limit 3@ +-- is two flags +-- * any other parameter: the next argument, whatever it begins with +-- (@---@, @--force@, @-5@, @--@) +-- * a flag that names no parameter: as in 'parsePathAndParams'; its key +-- stays as typed, so 'UnknownParam' names it so +-- +-- Keys are normalized (kebab-case to snake_case); values never are. An +-- argument that no flag takes is an 'UnexpectedArgument'. +pairFlags :: IR -> MethodDef -> [Text] -> Either [ParseError] [(Text, Text)] +pairFlags ir method args = case partitionEithers (go args) of + ([], pairs) -> Right pairs + (errs, _) -> Left errs + where + go [] = [] + go (x:xs) = case T.stripPrefix "--" x of + Just flag | not (T.null flag) -> + let (typed, val, n) = takeFlag arity flag xs + key = normalizeKey typed + pair = case arity key of + TakesNext -> (key, fromMaybe "" val) + TakesBoolean -> (key, fromMaybe "true" val) + TakesUnlessFlag -> (typed, fromMaybe "" val) + in Right pair : go (drop n xs) + _ -> Left (UnexpectedArgument x) : go xs + + arity = flagArity ir method + +-- | Read one flag (the text after @--@) against the arguments after it: +-- its key as typed, its value ('Nothing' when bare), and how many of those +-- arguments it took (0 or 1). +takeFlag :: (Text -> FlagArity) -> Text -> [Text] -> (Text, Maybe Text, Int) +takeFlag arity flag next + | (key, eqValue) <- T.breakOn "=" flag, not (T.null eqValue) = + (key, Just (T.drop 1 eqValue), 0) + | otherwise = case (arity (normalizeKey flag), next) of + (TakesNext, val : _) -> (flag, Just val, 1) + (TakesBoolean, val : _) | isBooleanWord val -> (flag, Just val, 1) + (TakesUnlessFlag, val : _) | val == "--" || not ("--" `T.isPrefixOf` val) -> (flag, Just val, 1) + _ -> (flag, Nothing, 0) + where + -- The spellings 'inferTypedValue' reads as a boolean + isBooleanWord val = T.toLower val `elem` ["true", "false", "1", "0"] + +-- | How the flag with this (normalized) key takes its value: by the type of +-- the parameter it names, or of the field a dotted key names +flagArity :: IR -> MethodDef -> Text -> FlagArity +flagArity ir method key = case T.splitOn "." key of + name : fields + | Just param <- find ((== name) . pdName) (mdParams method) -> + case foldM (fieldType ir) (pdType param) fields of + Just ty | isBooleanRef ir ty -> TakesBoolean + _ -> TakesNext + _ -> TakesUnlessFlag + +-- | The type of a field of a struct, or of any variant of an enum +fieldType :: IR -> TypeRef -> Text -> Maybe TypeRef +fieldType ir ref name = case ref of + RefOptional inner -> fieldType ir inner name + RefNamed qn -> case tdKind <$> Map.lookup (qualifiedNameFull qn) (irTypes ir) of + Just (KindStruct fields) -> fdType <$> find ((== name) . fdName) fields + Just (KindEnum _ variants) -> fdType <$> find ((== name) . fdName) (concatMap vdFields variants) + Just (KindAlias target) -> fieldType ir target name + _ -> Nothing + _ -> Nothing + +-- | Is this a boolean (optional, or a named type that is one)? +isBooleanRef :: IR -> TypeRef -> Bool +isBooleanRef ir = \case + RefPrimitive typ _ -> typ == "boolean" + RefOptional inner -> isBooleanRef ir inner + RefNamed qn -> case tdKind <$> Map.lookup (qualifiedNameFull qn) (irTypes ir) of + Just (KindPrimitive typ _) -> typ == "boolean" + Just (KindAlias target) -> isBooleanRef ir target + _ -> False + _ -> False + +-- | Normalize a flag key from kebab-case to snake_case +normalizeKey :: Text -> Text +normalizeKey = T.replace "-" "_" + +-- ============================================================================ -- Main Parsing Function -- ============================================================================ @@ -203,11 +369,18 @@ else buildParamValue ir param{pdType = inner} kvs RefArray innerType -> - -- Collect all repeated --key value entries (no comma splitting - use shell separation) - let values = [val | ("", val) <- kvs] - in if null values + -- Collect all repeated --key value entries; for a list of scalars each + -- entry is itself a comma-separated record (objects/lists/any stay whole) + let rawValues = [val | ("", val) <- kvs] + elements val + | isScalarElement ir innerType = + either (Left . MalformedListValue (pdName param) val) Right (splitListValue val) + | otherwise = Right [val] + in if null rawValues then Left $ InvalidValue (pdName param) "array requires at least one value" - else Right $ Array $ V.fromList $ map (buildTypedValue ir innerType) values + else do + values <- concat <$> traverse elements rawValues + Right $ Array $ V.fromList $ map (buildTypedValue ir innerType) values RefAny -> -- Dynamic type, try to parse as JSON or use as string @@ -242,7 +415,7 @@ KindAlias target -> -- Follow the alias - buildParamValue ir ParamDef{pdName = paramName, pdType = target, pdDescription = Nothing, pdRequired = True, pdDefault = Nothing, pdDeprecation = Nothing} kvs + buildParamValue ir ParamDef{pdName = paramName, pdType = target, pdDescription = Nothing, pdRequired = True, pdDefault = Nothing, pdDeprecation = Nothing, pdSource = Nothing, pdValues = Nothing} kvs KindStringEnum allowedValues -> -- Expect single string value from allowed set @@ -305,6 +478,67 @@ RefArray _ -> inferValue val -- Best effort for arrays RefAny -> inferValue val RefUnknown -> String val + +-- ============================================================================ +-- List Values +-- ============================================================================ + +-- | Is this list element type a scalar (string, integer, number, boolean, or +-- a named type that is one of those)? Only lists of scalars split their flag +-- values on commas; objects, lists and untyped values are passed whole. +isScalarElement :: IR -> TypeRef -> Bool +isScalarElement ir = \case + RefPrimitive typ _ -> typ `elem` scalarTypes + RefNamed qn -> case Map.lookup (qualifiedNameFull qn) (irTypes ir) of + Just TypeDef{tdKind = KindPrimitive typ _} -> typ `elem` scalarTypes + Just TypeDef{tdKind = KindStringEnum _} -> True + Just TypeDef{tdKind = KindAlias target} -> isScalarElement ir target + _ -> False + RefOptional inner -> isScalarElement ir inner + RefArray _ -> False + RefAny -> False + RefUnknown -> False + where + scalarTypes = ["string", "integer", "number", "boolean"] + +-- | Split one flag value of a scalar list into its elements. +-- +-- The value is one comma-separated record. Unquoted fields are trimmed and +-- dropped when empty. A field starting with @"@ runs to its closing quote, +-- keeps its commas and spaces, and reads @""@ inside as one quote. +-- +-- @ +-- a,b,c -> ["a", "b", "c"] +-- a, b ,c -> ["a", "b", "c"] +-- a,,b, -> ["a", "b"] +-- "a,b","c" -> ["a,b", "c"] +-- "say ""hi""",b -> ["say \"hi\"", "b"] +-- "",a -> ["", "a"] +-- "a,b or "a"x,b -> Left reason +-- @ +splitListValue :: Text -> Either Text [Text] +splitListValue = field + where + field t = case T.uncons (T.stripStart t) of + Just ('"', rest) -> quoted "" rest + _ -> + let (raw, rest) = T.breakOn "," t + val = T.strip raw + in ([val | not (T.null val)] ++) <$> afterComma rest + + -- Inside quotes: a doubled quote is one quote, a single one closes the field + quoted acc t = case T.breakOn "\"" t of + (_, "") -> Left "a quoted element has no closing quote" + (chunk, close) -> case T.uncons (T.drop 1 close) of + Just ('"', more) -> quoted (acc <> chunk <> "\"") more + _ -> case T.uncons (T.stripStart (T.drop 1 close)) of + Nothing -> Right [acc <> chunk] + Just (',', more) -> ((acc <> chunk) :) <$> field more + Just _ -> Left "a closing quote must be followed by a comma or the end" + + afterComma rest = case T.uncons rest of + Nothing -> Right [] + Just (_, more) -> field more -- drop the comma -- ============================================================================ -- Value Inference diff --git a/src/Synapse/CLI/Source.hs b/src/Synapse/CLI/Source.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/CLI/Source.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE RecordWildCards #-} +-- | SYNAPSE-10: a parameter's value from a file or stdin. +-- +-- A flag's value is one shell argument, and Linux caps an argument at 128 KB +-- (@MAX_ARG_STRLEN@), so @--body "$(cat body.md)"@ fails before synapse +-- starts once the body is large. Here a value names its source instead and +-- synapse reads it after it has started, so the only limit left is the +-- backend's own: +-- +-- @ +-- --body @body.md the file's contents (UTF-8), as they are +-- --body - standard input, read once however many values ask +-- --body @@literal a value that really begins with @ (one @ is dropped) +-- -p @params.json the whole params object from a file; -p - from stdin +-- @ +-- +-- The rule applies to every flag value of every backend, after the flags are +-- paired and before any other transformation, so @--body=\@body.md@ works +-- too and a path parameter read from a file is still expanded afterwards. +-- A file that cannot be read is a refusal naming the flag, the path and the +-- escape — never a value sent as the literal text @\@body.md@. +module Synapse.CLI.Source + ( SourceEnv(..) + , SourceError(..) + , mkSourceEnv + , expandSources + , expandValue + , stdinWasRead + , renderSourceError + ) where + +import Control.Exception (IOException, try) +import System.IO.Error (ioeGetErrorString) +import qualified Data.ByteString as BS +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TE +import System.FilePath (isRelative, ()) +import System.IO (Handle, stdin) + +-- | What a source needs: where relative paths resolve, what @~/@ means, how +-- stdin is read (a test hands in its own), and stdin's contents once read. +data SourceEnv = SourceEnv + { seCwd :: FilePath + , seHome :: Maybe FilePath + , seStdin :: IO BS.ByteString + , seCache :: IORef (Maybe Text) + } + +-- | A source that could not be read: the flag it was for (empty for @-p@), +-- the path as written, and the system's reason. +data SourceError = SourceUnreadable + { seKey :: Text + , seSource :: Text + , seWhy :: Text + } + deriving (Show, Eq) + +mkSourceEnv :: FilePath -> Maybe FilePath -> IO SourceEnv +mkSourceEnv cwd home = do + cache <- newIORef Nothing + pure SourceEnv { seCwd = cwd, seHome = home, seStdin = readToEnd stdin, seCache = cache } + +-- | All of a handle, without closing it: 'BS.getContents' semi-closes +-- stdin, and the bidirectional mode's terminal check later throws on a +-- closed handle. +readToEnd :: Handle -> IO BS.ByteString +readToEnd h = go [] + where + go acc = do + chunk <- BS.hGetSome h 65536 + if BS.null chunk then pure (BS.concat (reverse acc)) else go (chunk : acc) + +-- | Whether some value has taken stdin: the bidirectional JSON mode reads it +-- too, and the two cannot share. +stdinWasRead :: SourceEnv -> IO Bool +stdinWasRead env = maybe False (const True) <$> readIORef (seCache env) + +-- | Every flag value through 'expandValue'; the first failure wins. +expandSources :: SourceEnv -> [(Text, Text)] -> IO (Either SourceError [(Text, Text)]) +expandSources env = go [] + where + go acc [] = pure (Right (reverse acc)) + go acc ((k, v) : rest) = do + r <- expandValue env k v + case r of + Left e -> pure (Left e) + Right v' -> go ((k, v') : acc) rest + +-- | One value: @-@ is stdin, @\@\@x@ is the literal @\@x@, @\@path@ is that +-- file, anything else is itself. +expandValue :: SourceEnv -> Text -> Text -> IO (Either SourceError Text) +expandValue env@SourceEnv{..} key val + | val == "-" = Right <$> readStdinOnce env + | "@@" `T.isPrefixOf` val = pure (Right (T.drop 1 val)) + | Just path <- T.stripPrefix "@" val, not (T.null path) = do + r <- try (BS.readFile (resolve path)) :: IO (Either IOException BS.ByteString) + pure $ case r of + Left e -> Left SourceUnreadable { seKey = key, seSource = val, seWhy = T.pack (ioeGetErrorString e) } + Right bytes -> Right (decode bytes) + | otherwise = pure (Right val) + where + resolve p = case (T.unpack p, seHome) of + ('~' : '/' : rest, Just home) -> home rest + (fp, _) | isRelative fp -> seCwd fp + | otherwise -> fp + +readStdinOnce :: SourceEnv -> IO Text +readStdinOnce SourceEnv{..} = do + cached <- readIORef seCache + case cached of + Just t -> pure t + Nothing -> do + t <- decode <$> seStdin + writeIORef seCache (Just t) + pure t + +decode :: BS.ByteString -> Text +decode = TE.decodeUtf8With TE.lenientDecode + +-- | The refusal, with the escape for a value that really begins with @. +renderSourceError :: SourceError -> Text +renderSourceError SourceUnreadable{..} = + flag <> seSource <> ": cannot read " <> T.drop 1 seSource <> " (" <> seWhy <> "). " + <> "A value that begins with @ is read from that file; write @@" <> T.drop 1 seSource + <> " to send the text " <> seSource <> " itself." + where + flag = if T.null seKey then "-p " else "--" <> T.replace "_" "-" seKey <> " " diff --git a/src/Synapse/CLI/Transform.hs b/src/Synapse/CLI/Transform.hs --- a/src/Synapse/CLI/Transform.hs +++ b/src/Synapse/CLI/Transform.hs @@ -11,8 +11,10 @@ -- @ -- Command line args -- ↓ --- parsePathAndParams (extract --key value pairs) +-- parsePathAndParams (find the path and the flag arguments) -- ↓ +-- pairFlags (pair --key value / --key=value by parameter type) +-- ↓ -- [(Text, Text)] raw params -- ↓ -- transformParams (THIS MODULE - middleware chain) @@ -190,17 +192,24 @@ -- Environment Variable Expansion -- ============================================================================ --- | Expand environment variables in parameter values +-- | Expand environment variables in path parameter values -- -- Handles: --- - @--value $VAR@ → @--value \@ --- - @--message \"Hello $USER\"@ → @--message \"Hello alice\"@ +-- - @--path $PROJECT/src@ → @--path \/home\/user\/proj\/src@ -- +-- Path parameters only (SYNAPSE-6), as the README has always said. Any +-- other value is sent exactly as it arrived: a shell has already expanded +-- every @$VAR@ the caller left unquoted or double-quoted, so the only +-- @$@ that reaches synapse is one the caller protected on purpose — +-- single quotes, a value read from a file (@--body "$(cat body.md)"@). +-- Expanding it again rewrote text the caller meant literally: a ticket +-- body mentioning @$HOME@ was sent as @\/home\/alice@. +-- -- Simple implementation: only expands $VARNAME format (not ${VAR}). -- Fail-safe: Returns original value if variable not found. envExpansion :: Transformer envExpansion TransformEnv{..} (key, val) - | T.any (== '$') val = do + | isPathParam key && T.any (== '$') val = do let expanded = expandEnvVars teEnv val pure (key, expanded) | otherwise = pure (key, val) @@ -282,8 +291,8 @@ -- | Inject "true" for boolean flags that were present but had no value -- --- When a user writes @--force@ without a value, parsePathAndParams marks it --- as @("force", "")@. This function looks at the method definition to determine +-- A bare @--force@ is already @("force", "true")@ from @pairFlags@; @--force=@ +-- arrives as @("force", "")@. This function looks at the method definition to determine -- which empty-value params are actually booleans, and fills them with "true". -- -- Non-boolean params with empty values are left as-is and will fail validation diff --git a/src/Synapse/Endpoint.hs b/src/Synapse/Endpoint.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Endpoint.hs @@ -0,0 +1,204 @@ +-- | SCAFFOLD-21: where a hub is reached — a host and port, and, for a hub +-- behind TLS (every hosted app: @wss://.menger.sh/ws@), the scheme +-- and the path its socket answers at. +-- +-- One value, from the command line (@--url@, or @-H@ / @-P@ with @--tls@ +-- and @--path@), carried to every dial: the probe, the call, the stream and +-- its reconnects, the schema, a bidirectional response, @_login@ and the +-- session a call carries. The store keys a session by 'addressKey': a +-- plain @ws://HOST:PORT/@ keeps the @HOST:PORT@ it always had (no stored +-- session moves), anything else is keyed by its whole URL, so a @ws@ and a +-- @wss@ backend on one host, or two paths, never share a session. +module Synapse.Endpoint + ( Endpoint(..) + , plainAt + , isPlain + , parseUrl + , normalisePath + , renderUrl + , shortUrl + , addressKey + , dirName + , audience + , cliFlags + , cliOptions + , defaultHost + , defaultPort + , substrateConfig + ) where + +import qualified Data.ByteString as BS +import Data.Char (isAlphaNum, isDigit, ord, toLower) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Network.WebSockets as WS +import Numeric (showHex) + +import Plexus.Client (SubstrateConfig(..), TlsOptions(..)) + +-- | A hub's address. +data Endpoint = Endpoint + { epHost :: !Text + , epPort :: !Int + , epTls :: !Bool -- ^ @wss://@: TLS, the certificate verified + , epPath :: !Text -- ^ the socket's path, @/@ when none is given + , epCaFiles :: ![FilePath] -- ^ PEM files trusted beside the system's (@--cacert@) + } + deriving stock (Eq, Ord, Show) + +-- | @ws://HOST:PORT/@ — what @-H@ / @-P@ have always named. +plainAt :: Text -> Int -> Endpoint +plainAt h p = Endpoint { epHost = h, epPort = p, epTls = False, epPath = "/", epCaFiles = [] } + +-- | Is this the plain @ws://HOST:PORT/@ every address was before +-- SCAFFOLD-21? (Then everything keyed by it is keyed as it was.) +isPlain :: Endpoint -> Bool +isPlain ep = not (epTls ep) && epPath ep == "/" + +-- | Parse @ws://HOST[:PORT][/PATH]@ or @wss://HOST[:PORT][/PATH]@. The +-- port defaults to the scheme's (80, 443); the path to @/@. An IPv6 +-- literal is bracketed (@wss://[::1]:8443/ws@). A query or fragment is +-- refused: a Plexus socket is named by its path alone. +parseUrl :: Text -> Either Text Endpoint +parseUrl raw0 = do + let raw = T.strip raw0 + (tls, rest) <- case T.breakOn "://" raw of + (scheme, r) | not (T.null r) -> case T.toLower scheme of + "ws" -> Right (False, T.drop 3 r) + "wss" -> Right (True, T.drop 3 r) + "http" -> Left ("--url takes ws:// or wss://, not http:// (the socket of an http page is ws://" <> T.drop 3 r <> ")") + "https" -> Left ("--url takes ws:// or wss://, not https:// (the socket of an https page is wss://" <> T.drop 3 r <> ")") + other -> Left ("--url takes ws:// or wss://, not " <> other <> "://") + _ -> Left ("--url needs a scheme: ws://" <> raw <> " or wss://" <> raw) + let (authority, pathPart) = T.breakOn "/" rest + if T.any (`elem` ['?', '#']) pathPart || T.any (`elem` ['?', '#']) authority + then Left "--url takes no query or fragment: a socket is named by its path" + else Right () + if T.any (== '@') authority + then Left "--url takes no user:password@ — a credential goes in --token-file or the stored session" + else Right () + (host, port) <- splitAuthority (if tls then 443 else 80) authority + pure Endpoint + { epHost = host + , epPort = port + , epTls = tls + , epPath = normalisePath pathPart + , epCaFiles = [] + } + +-- | @HOST[:PORT]@ or @[V6][:PORT]@. +splitAuthority :: Int -> Text -> Either Text (Text, Int) +splitAuthority dflt a + | T.null a = Left "--url names no host" + | Just inner <- T.stripPrefix "[" a = + case T.breakOn "]" inner of + (h, r) | not (T.null r), not (T.null h) -> case T.drop 1 r of + "" -> Right (h, dflt) + p | Just digits <- T.stripPrefix ":" p -> (,) h <$> port digits + _ -> Left ("--url: cannot read the host " <> a) + _ -> Left ("--url: cannot read the host " <> a) + | otherwise = case T.breakOnEnd ":" a of + ("", _) -> Right (T.toLower a, dflt) + (h, p) -> (,) (T.toLower (T.dropEnd 1 h)) <$> port p + where + port digits + | not (T.null digits), T.all isDigit digits, T.length digits <= 5 + , n <- read (T.unpack digits), n >= 1, n <= 65535 = Right n + | otherwise = Left ("--url: the port '" <> digits <> "' is not a port") + +-- | A path as a socket is named by it: a leading @/@, no trailing one +-- (@ws/@ → @/ws@; empty → @/@). +normalisePath :: Text -> Text +normalisePath p = + let trimmed = T.dropWhileEnd (== '/') (T.dropWhile (== '/') (T.strip p)) + in "/" <> trimmed + +-- | The URL, with the port always written (@wss://host:443/ws@) — the form +-- the store keys by. +renderUrl :: Endpoint -> Text +renderUrl ep = scheme ep <> "://" <> hostPart (epHost ep) <> ":" <> T.pack (show (epPort ep)) <> epPath ep + +scheme :: Endpoint -> Text +scheme ep = if epTls ep then "wss" else "ws" + +hostPart :: Text -> Text +hostPart h = if T.any (== ':') h then "[" <> h <> "]" else h + +-- | What a session is kept under: @HOST:PORT@ for a plain address (as +-- every session before SCAFFOLD-21 was), the whole URL otherwise. +addressKey :: Endpoint -> Text +addressKey ep + | isPlain ep = epHost ep <> ":" <> T.pack (show (epPort ep)) + | otherwise = renderUrl ep + +-- | The directory name under @~/.plexus/sessions/@: @HOST_PORT@ for a +-- plain address (unchanged), else @wss_HOST_PORT@ (or @ws_…@) and the path +-- with each @/@ as @_@ — any other byte outside @[A-Za-z0-9.-]@ written +-- @%XX@, so two addresses never share one. +dirName :: Endpoint -> FilePath +dirName ep + | isPlain ep = T.unpack (epHost ep) <> "_" <> show (epPort ep) + | otherwise = + T.unpack (scheme ep) <> "_" <> escape (T.unpack (epHost ep)) <> "_" <> show (epPort ep) + <> concatMap pathChar (T.unpack (T.dropWhileEnd (== '/') (epPath ep))) + where + escape = concatMap safe + safe c | isAlphaNum c && ord c < 128 || c `elem` ['.', '-'] = [c] + | otherwise = pct c + pathChar '/' = "_" + pathChar c = safe c + pct c = concatMap (\b -> '%' : hex2 b) (BS.unpack (TE.encodeUtf8 (T.singleton c))) + hex2 b = let h = map toLower (showHex b "") in if length h < 2 then '0' : h else h + +-- | A key proof's audience (IDENTITY-40's @aud@): the server's socket +-- origin, as the server lists the URLs it is dialed at — @ws://HOST:PORT@ +-- for a plain address (unchanged), @wss://HOST@ (@:PORT@ when not 443) +-- behind TLS, which is what a hub run with @--public-url https://HOST@ +-- accepts (plexus-login's @socket_urls@). The path is not part of it. +audience :: Endpoint -> Text +audience ep + | epTls ep = "wss://" <> hostPart (epHost ep) <> (if epPort ep == 443 then "" else ":" <> T.pack (show (epPort ep))) + | otherwise = "ws://" <> epHost ep <> ":" <> T.pack (show (epPort ep)) + +-- | The global options that reach this address, as synapse's own help and +-- messages write them: @-P 4455@, @-H host -P 4455@, @--url wss://host/ws@ +-- (and @--cacert FILE@ for each local CA). Empty for the default address. +cliFlags :: Text -> Int -> Endpoint -> Text +cliFlags defaultHost defaultPort ep + | isPlain ep = T.unwords $ + (if epHost ep /= defaultHost then ["-H", epHost ep] else []) + <> (if epPort ep /= defaultPort then ["-P", T.pack (show (epPort ep))] else []) + | otherwise = T.unwords $ ["--url", shortUrl ep] <> concatMap (\f -> ["--cacert", T.pack f]) (epCaFiles ep) + +-- | The URL as a person writes it: the scheme's default port and a bare +-- @/@ left out (@wss://hostdemo.menger.sh/ws@). +shortUrl :: Endpoint -> Text +shortUrl ep = scheme ep <> "://" <> hostPart (epHost ep) + <> (if epPort ep == dflt then "" else ":" <> T.pack (show (epPort ep))) + <> (if epPath ep == "/" then "" else epPath ep) + where dflt = if epTls ep then 443 else 80 + +-- | The connection point when none is named: the registry's, @ws://127.0.0.1:4444/@. +defaultHost :: Text +defaultHost = "127.0.0.1" + +defaultPort :: Int +defaultPort = 4444 + +-- | 'cliFlags' against the default address — what a message tells the +-- reader to type (@synapse -P 4455 _login …@, @synapse --url wss://h/ws _login …@). +cliOptions :: Endpoint -> Text +cliOptions = cliFlags defaultHost defaultPort + +-- | The plexus-protocol config that dials this address for @backend@, +-- carrying @headers@ on the upgrade. +substrateConfig :: Endpoint -> Text -> WS.Headers -> SubstrateConfig +substrateConfig ep backend headers = SubstrateConfig + { substrateHost = T.unpack (epHost ep) + , substratePort = epPort ep + , substratePath = T.unpack (epPath ep) + , substrateBackend = backend + , substrateHeaders = headers + , substrateTls = if epTls ep then Just (TlsOptions (epCaFiles ep)) else Nothing + } diff --git a/src/Synapse/Find.hs b/src/Synapse/Find.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Find.hs @@ -0,0 +1,657 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} + +-- | SYNAPSE-17: @synapse _find [activation…] @ — a fuzzy +-- search over a backend's methods and parameters, answered in the shape of +-- synapse's help (SYNAPSE-13): grouped, aligned, every line a command. +-- +-- * The catalog is the backend's IR (the caller's view of its schema), +-- kept in synapse's IR cache under the root schema's hash: a search +-- costs one schema call — the hash check — when nothing has changed. +-- * A word matches a name exactly, as a prefix (of the name or of one of +-- its @snake_case@ segments), as a subsequence of segment prefixes +-- (@setpar@ → @set_parent@), or with a typo (edit distance ≤ 1 for 4–7 +-- letters, ≤ 2 beyond); else as a word (or a word's prefix) of a +-- description. Every word must match. +-- * A hit whose words all match names is a METHOD or a PARAMETER; one that +-- needs a description is MENTIONED IN — unless its method is a named hit +-- already. +module Synapse.Find + ( -- * The command + FindOpts(..) + , findInfo + , defaultLimit + + -- * The catalog + , loadCatalog + , Entry(..) + , EntryKind(..) + , catalogEntries + , narrowPath + , entryLocation + + -- * Matching + , MatchKind(..) + , WordMatch(..) + , matchName + , matchDescription + , typoLimit + , kindScore + + -- * Search + , Hit(..) + , Where(..) + , Group(..) + , Only(..) + , search + , hitGroup + , takenAs + + -- * The answer + , Answer(..) + , answer + + -- * Rendering + , FindRender(..) + , renderFind + , renderNoMatch + , nearest + , hitJson + ) where + +import Control.Exception (SomeException, try) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (asks) +import Data.Aeson (Value, object, (.=)) +import Data.Char (isAlphaNum) +import Data.List (sortOn, foldl') +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Options.Applicative + +import Synapse.Algebra.Render (fitText, summarize) +import Synapse.CLI.Help (flagLabel, flagType, paramValuesOf, serverSourced, wrapWords) +import Synapse.CLI.Similarity (levenshteinDistance) +import Synapse.IR.Builder (buildIR) +import Synapse.IR.Cache (IRCache, insertIR, irCacheKey, lookupIR) +import Synapse.IR.Types +import Synapse.Monad (SynapseM, SynapseEnv(..)) +import Synapse.Schema.Types (psHash) +import Synapse.Transport (fetchSchemaAt) + +-- ============================================================================ +-- The command +-- ============================================================================ + +-- | What @_find@ was asked. +data FindOpts = FindOpts + { foBackend :: Text -- ^ the backend, e.g. menger + , foTerms :: [Text] -- ^ an activation path (optional), then the words + , foLimit :: Int -- ^ at most this many hits + , foMethods :: Bool -- ^ only METHODS + , foParams :: Bool -- ^ only PARAMETERS + } + deriving stock (Show, Eq) + +defaultLimit :: Int +defaultLimit = 20 + +findInfo :: ParserInfo FindOpts +findInfo = info (p <**> helper) + ( fullDesc + <> header "synapse _find - search a backend's methods and parameters" + <> progDesc "Every method and parameter whose name or description matches all the words, best first, in help's shape: METHODS, PARAMETERS, MENTIONED IN (a match only in a description). A word may be misspelled (one edit for 4-7 letters, two beyond), a prefix, or an abbreviation of a snake_case name (setpar finds set_parent). Activation names before the words narrow the search (_find menger tickets setpar). Global options (-H, -P, -j) go before _find; -j prints one JSON object per hit." + ) + where + p = FindOpts + <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The hub's name, e.g. menger")) + <*> some (T.pack <$> strArgument (metavar "WORDS..." <> help "[activation…] then the words to look for")) + <*> option auto (long "limit" <> metavar "N" <> value defaultLimit <> showDefault <> help "At most N hits") + <*> switch (long "methods" <> help "Only methods") + <*> switch (long "params" <> help "Only parameters") + +-- ============================================================================ +-- The catalog +-- ============================================================================ + +-- | The backend's IR, as the caller's view of its schema has it: the root +-- schema is fetched (the hash check), and the IR kept under that hash — +-- qualified by the caller's view (AUTH-8) — is used when there is one; +-- else the tree is walked once and the IR kept for next time. A cache that +-- cannot be read or written is no cache. +loadCatalog :: Maybe IRCache -> SynapseM IR +loadCatalog mcache = do + root <- fetchSchemaAt [] + view <- asks seViewKey + let key = "find-" <> irCacheKey view (psHash root) + cached <- case mcache of + Nothing -> pure Nothing + Just c -> liftIO (either (const Nothing) id <$> (try (lookupIR c key) :: IO (Either SomeException (Maybe IR)))) + case cached of + Just ir -> pure ir + Nothing -> do + ir <- buildIR [] [] + case mcache of + Nothing -> pure () + Just c -> liftIO (() <$ (try (insertIR c key ir) :: IO (Either SomeException ()))) + pure ir + +data EntryKind = MethodEntry | ParamEntry + deriving stock (Show, Eq, Ord) + +-- | One thing a search can find: a method, or one of its parameters. +data Entry = Entry + { enKind :: EntryKind + , enMethod :: MethodDef + , enParam :: Maybe ParamDef + } + deriving stock (Show, Eq) + +-- | Every method of the IR, and every parameter a caller passes (one the +-- server supplies, REQ-8, is not a flag), under the activation path. +catalogEntries :: [Text] -> IR -> [Entry] +catalogEntries path ir = + concat + [ Entry MethodEntry m Nothing + : [Entry ParamEntry m (Just p) | p <- mdParams m, not (serverSourced p)] + | m <- Map.elems (irMethods ir) + , under (mdNamespace m) + ] + where + prefix = T.intercalate "." path + under ns = null path || ns == prefix || (prefix <> ".") `T.isPrefixOf` ns + +-- | The leading terms that name an activation (as help's path does), and +-- the words after them; at least one word is always left. +narrowPath :: IR -> [Text] -> ([Text], [Text]) +narrowPath ir = go [] + where + namespaces = Set.fromList (map mdNamespace (Map.elems (irMethods ir))) + isPath segs = + let p = T.intercalate "." segs + in any (\ns -> ns == p || (p <> ".") `T.isPrefixOf` ns) (Set.toList namespaces) + go acc (t : rest@(_ : _)) + | isPath (acc ++ [t]) = go (acc ++ [t]) rest + go acc rest = (acc, rest) + +-- | Where an entry is: its activation path and method, as typed +-- (@tickets snooze@). +entryLocation :: Entry -> Text +entryLocation = methodLocation . enMethod + +methodLocation :: MethodDef -> Text +methodLocation m = T.unwords (filter (not . T.null) [T.replace "." " " (mdNamespace m), mdName m]) + +-- ============================================================================ +-- Matching +-- ============================================================================ + +-- | How a word matched, best first. +data MatchKind + = Exact -- ^ the whole name + | Prefix -- ^ the start of the name + | SegmentExact -- ^ one @snake_case@ segment of it + | SegmentPrefix -- ^ the start of a segment + | Subsequence -- ^ prefixes of segments, in order (@setpar@) + | Typo Int -- ^ within this many edits of the name or a segment's start + | InDescription -- ^ a word of a description, or its start + deriving stock (Show, Eq) + +kindScore :: MatchKind -> Double +kindScore = \case + Exact -> 1.0 + Prefix -> 0.9 + SegmentExact -> 0.85 + SegmentPrefix -> 0.8 + Subsequence -> 0.6 + Typo d -> 0.55 - 0.1 * fromIntegral (d - 1) + InDescription -> 0.3 + +-- | A word's match: how, what it was taken as, and which characters of the +-- text it matched (offset, length). +data WordMatch = WordMatch + { wmKind :: MatchKind + , wmTaken :: Text + , wmSpans :: [(Int, Int)] + } + deriving stock (Show, Eq) + +-- | The edits a word of this length may be off by: none under 4 letters, +-- one for 4–7, two beyond. +typoLimit :: Int -> Int +typoLimit n + | n < 4 = 0 + | n <= 7 = 1 + | otherwise = 2 + +-- | A name's segments and where each starts (@set_parent@ → set@0, parent@4). +segments :: Text -> [(Int, Text)] +segments name = go 0 (T.unpack name) + where + go _ [] = [] + go off s = + let (seg, rest) = break isSep s + off' = off + length seg + in case rest of + [] -> [(off, T.pack seg) | not (null seg)] + (_ : rest') -> [(off, T.pack seg) | not (null seg)] ++ go (off' + 1) rest' + isSep c = c `elem` ("_-." :: String) + +-- | Match a word (lower case) against a name. +matchName :: Text -> Text -> Maybe WordMatch +matchName w0 name0 + | T.null w = Nothing + | w == name = Just (WordMatch Exact name0 [(0, T.length w)]) + | w `T.isPrefixOf` name = Just (WordMatch Prefix w [(0, T.length w)]) + | Just (off, _) <- find' (\(_, s) -> s == w) segs = Just (WordMatch SegmentExact w [(off, T.length w)]) + | Just (off, _) <- find' (\(_, s) -> w `T.isPrefixOf` s) segs = Just (WordMatch SegmentPrefix w [(off, T.length w)]) + | Just spans <- subsequence (T.unpack w) segs = Just (WordMatch Subsequence name0 spans) + | otherwise = typo + where + w = normalise w0 + name = T.toLower name0 + segs = segments name + find' f = listToMaybe . filter f + + -- prefixes of segments, in order, at least two of them + subsequence ws ss = case pieces ws ss of + Just sp@(_ : _ : _) -> Just sp + _ -> Nothing + pieces [] _ = Just [] + pieces _ [] = Nothing + pieces ws ((off, s) : rest) = + let common = length (takeWhile id (zipWith (==) ws (T.unpack s))) + tryLen k = ((off, k) :) <$> pieces (drop k ws) rest + viaThis = foldr (\k acc -> maybe acc Just (tryLen k)) Nothing [common, common - 1 .. 1] + in case viaThis of + Just sp -> Just sp + Nothing -> pieces ws rest + + -- within the limit of the whole name or of a segment's start + typo + | k == 0 = Nothing + | otherwise = + case sortOn rank candidates of + ((d, _, off, taken) : _) | d <= k -> Just (WordMatch (Typo d) (orig off (T.length taken)) [(off, T.length taken)]) + _ -> Nothing + where + n = T.length w + k = typoLimit n + candidates = + [ (levenshteinDistance w p, T.length c - j, off, p) + | (off, c) <- (0, name) : segs + , j <- [max 1 (n - k) .. min (T.length c) (n + k)] + , let p = T.take j c + ] + -- fewest edits; then the whole segment; then the longest + rank (d, short, _, p) = (d, short, negate (T.length p)) + orig off len = T.take len (T.drop off name0) + +-- | A word (lower case) as a word of a description, or a word's start: +-- the matched characters of the text. Words under 3 letters are not +-- looked for in descriptions. +matchDescription :: Text -> Text -> Maybe WordMatch +matchDescription w0 text + | T.length w < 3 = Nothing + | null spans = Nothing + | otherwise = Just (WordMatch InDescription w spans) + where + w = normalise w0 + spans = descSpans w text + +-- | Where a word starts a word of the text (offset, the word's length). +descSpans :: Text -> Text -> [(Int, Int)] +descSpans w text = + [ (off, T.length w) | (off, tok) <- tokens text, w `T.isPrefixOf` T.toLower tok ] + where + -- a query word with an underscore matches across the text's underscores + tokens t + | T.any (== '_') w = wordsBy (\c -> isAlphaNum c || c == '_') t + | otherwise = wordsBy isAlphaNum t + +wordsBy :: (Char -> Bool) -> Text -> [(Int, Text)] +wordsBy keep t = go 0 (T.unpack t) + where + go _ [] = [] + go off s@(c : rest) + | keep c = let (tok, rest') = span keep s + in (off, T.pack tok) : go (off + length tok) rest' + | otherwise = go (off + 1) rest + +normalise :: Text -> Text +normalise = T.replace "-" "_" . T.toLower + +-- ============================================================================ +-- Search +-- ============================================================================ + +-- | Which text a word matched. +data Where = OnMethodName | OnParamName | OnMethodDescription | OnParamDescription + deriving stock (Show, Eq) + +data Hit = Hit + { hitEntry :: Entry + , hitWords :: [(Text, Where, WordMatch)] -- ^ per query word + , hitScore :: Double + } + deriving stock (Show, Eq) + +data Group = Methods | Parameters | Mentioned + deriving stock (Show, Eq, Ord, Enum, Bounded) + +-- | A named hit is a method or a parameter; one that needed a description +-- is mentioned. +hitGroup :: Hit -> Group +hitGroup h + | not (all named (hitWords h)) = Mentioned + | enKind (hitEntry h) == MethodEntry = Methods + | otherwise = Parameters + where named (_, wh, _) = wh `elem` [OnMethodName, OnParamName] + +-- | Which groups to keep. +data Only = OnlyAll | OnlyMethods | OnlyParams | OnlyBoth + deriving stock (Show, Eq) + +-- | Every hit for the words (all must match), best first: by score, then +-- the shorter path, then alphabetically. A mention of a method that is a +-- named hit already (itself or by a parameter) is left out. +search :: Only -> [Entry] -> [Text] -> [Hit] +search only entries ws = filter keep ranked + where + hits = mapMaybe (matchEntry (map normalise ws)) entries + namedMethods = Set.fromList [mdFullPath (enMethod (hitEntry h)) | h <- hits, hitGroup h /= Mentioned] + keep h = groupWanted (hitGroup h) + && not (hitGroup h == Mentioned && Set.member (mdFullPath (enMethod (hitEntry h))) namedMethods) + groupWanted g = case only of + OnlyAll -> True + OnlyMethods -> g == Methods + OnlyParams -> g == Parameters + OnlyBoth -> g /= Mentioned + ranked = sortOn (\h -> (negate (hitScore h), T.length (key h), key h)) hits + key h = entryLocation (hitEntry h) <> maybe "" ((" --" <>) . pdName) (enParam (hitEntry h)) + +matchEntry :: [Text] -> Entry -> Maybe Hit +matchEntry ws e = do + matched <- mapM best ws + let onParam = any (\(_, wh, _) -> wh `elem` [OnParamName, OnParamDescription]) matched + if enKind e == ParamEntry && not onParam + then Nothing + else Just (Hit e matched (sum [kindScore (wmKind m) | (_, _, m) <- matched] / fromIntegral (length matched))) + where + m = enMethod e + methodDescs = filter (not . T.null) [fromMaybe "" (mdDescription m), fromMaybe "" (mdLongDescription m)] + best w = fmap (\(wh, wm) -> (w, wh, wm)) $ pick $ case enParam e of + Nothing -> + [ (OnMethodName, matchName w (mdName m)) ] + ++ [ (OnMethodDescription, matchDescription w d) | d <- methodDescs ] + Just p -> + [ (OnParamName, matchName w (pdName p)) + , (OnMethodName, matchName w (mdName m)) ] + ++ [ (OnParamDescription, matchDescription w d) | Just d <- [pdDescription p] ] + -- the best-scoring; on a tie, the first (the parameter's own name) + pick cs = foldl' better Nothing [(wh, x) | (wh, Just x) <- cs] + better Nothing c = Just c + better (Just a@(_, x)) c@(_, y) + | kindScore (wmKind y) > kindScore (wmKind x) = Just c + | otherwise = Just a + +-- | The query as the top hit took it — a typo or an abbreviation said as +-- the name it matched — when it differs from what was typed. +takenAs :: [Hit] -> Maybe Text +takenAs [] = Nothing +takenAs (h : _) + | taken == typed = Nothing + | otherwise = Just (T.unwords taken) + where + typed = [w | (w, _, _) <- hitWords h] + taken = [ case wmKind m of { Typo _ -> wmTaken m; Subsequence -> wmTaken m; _ -> w } | (w, _, m) <- hitWords h ] + +-- ============================================================================ +-- The answer +-- ============================================================================ + +-- | What @_find@ says: its page, or one JSON object per hit (@-j@). +data Answer = Answer + { anMatched :: Bool -- ^ anything found (else the page is the nearest names) + , anText :: Text -- ^ the page + , anJson :: [Value] -- ^ the hits, at most the limit, best first + , anScope :: Text -- ^ where it looked (@menger tickets@) + } + +-- | The answer to a search: given synapse's command line (@synapse -P +-- 4455@), the backend, whether to embolden, and the IR (the caller's view). +answer :: Text -> Text -> Bool -> FindOpts -> IR -> Answer +answer program backend bold FindOpts{..} ir = Answer + { anMatched = not (null hits) + , anText = if null hits then renderNoMatch fr (nearest entries ws) else renderFind fr hits + , anJson = map (hitJson ir) (take foLimit hits) + , anScope = T.unwords (backend : path) + } + where + (path, ws) = narrowPath ir foTerms + entries = catalogEntries path ir + only = case (foMethods, foParams) of + (True, True) -> OnlyBoth + (True, False) -> OnlyMethods + (False, True) -> OnlyParams + _ -> OnlyAll + hits = search only entries ws + fr = FindRender + { frProgram = program + , frBackend = backend + , frPath = path + , frQuery = ws + , frLimit = foLimit + , frBold = bold + , frIR = ir + } + +-- ============================================================================ +-- Rendering +-- ============================================================================ + +-- | What a rendering needs beside the hits. +data FindRender = FindRender + { frProgram :: Text -- ^ synapse and its global options (@synapse -P 4455@) + , frBackend :: Text -- ^ the backend (@menger@) + , frPath :: [Text] -- ^ the activation path the search was narrowed to + , frQuery :: [Text] -- ^ the words, as typed + , frLimit :: Int + , frBold :: Bool -- ^ on a terminal: the matched characters in bold + , frIR :: IR + } + +width :: Int +width = 80 + +-- | A description keeps at least this many columns, past the 80 when the +-- columns before it are wide: a line too short to say anything is no help. +minDesc :: Int +minDesc = 36 + +-- | SYNAPSE-17: the hits in help's shape — a header (how many, for what, +-- as what), METHODS · PARAMETERS · MENTIONED IN with the locations in one +-- column and the flags in the next, the descriptions fitted to the line, +-- how many more the limit held back, and how to see the top hit's options. +renderFind :: FindRender -> [Hit] -> Text +renderFind FindRender{..} hits = T.unlines (dropTrailingBlanks body) + where + total = length hits + shown = take (max 0 frLimit) hits + scope = T.unwords (frBackend : frPath) + query = T.unwords frQuery + header = + T.pack (show total) <> (if total == 1 then " match" else " matches") + <> " for '" <> query <> "'" + <> maybe "" (\t -> " (as '" <> t <> "')") (takenAs hits) + <> " in " <> scope + + body = concat + [ [header] + , concat [ section g [h | h <- shown, hitGroup h == g] | g <- [minBound .. maxBound] ] + , [ "" | total > length shown ] + , [ T.pack (show (total - length shown)) <> " more: '--limit " <> T.pack (show total) <> "' shows them all." + | total > length shown ] + , case shown of + (h : _) -> ["", "Run '" <> frProgram <> " " <> frBackend <> " " <> entryLocation (hitEntry h) <> " --help' for its options."] + [] -> [] + ] + + section _ [] = [] + section g hs = "" : groupTitle g : concatMap row hs + + locW = maximum (0 : map (T.length . entryLocation . hitEntry) shown) + col1 = 2 + locW + 4 + paramLabels = [flagLabel frIR p | h <- shown, Just p <- [enParam (hitEntry h)]] + flagW = maximum (0 : map T.length paramLabels) + col2 = col1 + flagW + 4 + + row h = case enParam (hitEntry h) of + Nothing -> + let descW = max minDesc (width - col1) + in [ T.stripEnd (" " <> locCell h <> descCell h descW (methodText (enMethod (hitEntry h)))) ] + Just p -> + let descW = max minDesc (width - col2) + label = flagLabel frIR p + flagOff = T.length (fst (T.breakOn "--" label)) + 2 + flagSpans = [ (flagOff + o, l) | (_, OnParamName, m) <- hitWords h, (o, l) <- wmSpans m ] + flag = styled frBold label flagSpans <> T.replicate (flagW + 4 - T.length label) " " + values = case paramValuesOf frIR p of + Just vs@(_ : _) -> map (T.replicate col2 " " <>) (wrapWords descW ("[values: " <> T.intercalate ", " vs <> "]")) + _ -> [] + in T.stripEnd (" " <> locCell h <> flag <> descCell h descW (fromMaybe "" (pdDescription p))) : values + + -- the location, the method's matched characters in bold + locCell h = + let e = hitEntry h + loc = entryLocation e + nameOff = T.length loc - T.length (mdName (enMethod e)) + spans = [ (nameOff + o, l) | (_, OnMethodName, m) <- hitWords h, (o, l) <- wmSpans m ] + in styled frBold loc spans <> T.replicate (locW + 4 - T.length loc) " " + + -- a named hit's summary; a mention's shows where the word is + descCell h w text = + let descWords = [ wd | (wd, wh, _) <- hitWords h, wh `elem` [OnMethodDescription, OnParamDescription] ] + shownText = if hitGroup h == Mentioned then snippet w descWords text (matchSource h text) else fitText w (summarize text) + spans = concat [ descSpans (normalise wd) shownText | wd <- descWords ] + in styled frBold shownText spans + + methodText m = case mdDescription m of + Just d | not (T.null (T.strip d)) -> d + _ -> fromMaybe "" (mdLongDescription m) + + -- the text a mention was found in: the one shown, else (a method's) + -- its long description + matchSource h shown = case (enParam (hitEntry h), mdLongDescription (enMethod (hitEntry h))) of + (Nothing, Just long) -> shown <> "\n" <> long + _ -> shown + +groupTitle :: Group -> Text +groupTitle = \case + Methods -> "METHODS" + Parameters -> "PARAMETERS" + Mentioned -> "MENTIONED IN" + +-- | A description cut to show a word it was found by (in @source@, the +-- description and what else was searched): the summary when the word is in +-- it, else as much of the summary as fits, then @… word …@. +snippet :: Int -> [Text] -> Text -> Text -> Text +snippet w ws text source + | null ws = fitText w summary + | any (\wd -> not (null (descSpans (normalise wd) fitted))) ws = fitted + | otherwise = case firstToken of + Nothing -> fitted + Just tok -> + let tailT = " \x2026 " <> tok <> " \x2026" + room = w - T.length tailT + lead = T.dropWhileEnd (== '\x2026') (fitText room summary) + in if room >= 12 then T.stripEnd lead <> tailT else fitText w ("\x2026 " <> tok <> " \x2026") + where + summary = summarize text + fitted = fitText w summary + -- the text's word (as written) where the first of the words is found + firstToken = listToMaybe + [ T.dropAround (`elem` ("()[]{},.;:'\"`" :: String)) whole + | wd <- ws + , (off, _) <- take 1 (descSpans (normalise wd) source) + , let whole = wordAt off source + ] + wordAt off t = + let before = T.takeWhileEnd (not . isSpace') (T.take off t) + after = T.takeWhile (not . isSpace') (T.drop off t) + isSpace' c = c == ' ' || c == '\n' + in before <> after + +-- | Text with the characters at the spans in bold (when asked). +styled :: Bool -> Text -> [(Int, Int)] -> Text +styled False t _ = t +styled True t spans + | null marks = t + | otherwise = T.pack (go 0 (T.unpack t)) + where + marks = Set.fromList [ i | (o, l) <- spans, i <- [o .. o + l - 1], i >= 0, i < T.length t ] + go _ [] = [] + go i s@(_ : _) + | Set.member i marks = + let (run, rest) = splitAt (runLen i) s + in "\ESC[1m" ++ run ++ "\ESC[22m" ++ go (i + length run) rest + | otherwise = let (c : rest) = s in c : go (i + 1) rest + runLen i = length (takeWhile (`Set.member` marks) [i ..]) + +dropTrailingBlanks :: [Text] -> [Text] +dropTrailingBlanks = reverse . dropWhile (T.null . T.strip) . reverse + +-- | The three methods whose names are nearest the query (by edit distance +-- to the name or to one of its segments). +nearest :: [Entry] -> [Text] -> [Entry] +nearest entries ws = take 3 (sortOn rank candidates) + where + methods = [e | e <- entries, enKind e == MethodEntry] + -- the introspection every hub has (schema, hashes) is never what was meant + candidates = case filter ((`notElem` ["schema", "hashes"]) . mdName . enMethod) methods of + [] -> methods + cs -> cs + q = T.intercalate "_" (map normalise ws) + dist e = + let name = T.toLower (mdName (enMethod e)) + in minimum (levenshteinDistance q name : [levenshteinDistance q s | (_, s) <- segments name]) + rank e = (dist e, T.length (entryLocation e), entryLocation e) + +-- | Nothing matched: say so, then the nearest names. +renderNoMatch :: FindRender -> [Entry] -> Text +renderNoMatch FindRender{..} near = T.unlines $ + [ "No match for '" <> T.unwords frQuery <> "' in " <> T.unwords (frBackend : frPath) <> "." ] + ++ if null near then [] else + [ "", "Nearest:" ] + ++ [ T.stripEnd (" " <> T.justifyLeft (locW + 4) ' ' (entryLocation e) <> fitText (max minDesc (width - (2 + locW + 4))) (summarize (desc e))) + | e <- near ] + where + locW = maximum (0 : map (T.length . entryLocation) near) + desc e = fromMaybe "" (mdDescription (enMethod e)) + +-- | One hit as JSON, for @-j@. +hitJson :: IR -> Hit -> Value +hitJson ir h = object $ + [ "kind" .= (case enKind e of { MethodEntry -> "method"; ParamEntry -> "param" } :: Text) + , "path" .= mdFullPath m + ] + ++ case enParam e of + Just p -> + [ "param" .= pdName p + , "type" .= flagType ir (pdType p) + , "required" .= pdRequired p + , "description" .= fromMaybe "" (pdDescription p) + ] ++ maybe [] (\vs -> ["values" .= vs]) (paramValuesOf ir p) + Nothing -> [ "description" .= fromMaybe "" (mdDescription m) ] + ++ + [ "group" .= (case hitGroup h of { Methods -> "methods"; Parameters -> "parameters"; Mentioned -> "mentioned" } :: Text) + , "score" .= (fromIntegral (round (hitScore h * 100) :: Int) / 100 :: Double) + , "matched" .= T.unwords [ case wmKind wm of { Typo _ -> wmTaken wm; Subsequence -> wmTaken wm; _ -> w } | (w, _, wm) <- hitWords h ] + ] + where + e = hitEntry h + m = enMethod e 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 @@ -40,7 +40,7 @@ import Synapse.Monad import Synapse.IR.Types hiding (QualifiedName(..), qualifiedNameFull) import Synapse.IR.Types (QualifiedName(..), qualifiedNameFull, synapseVersion) -import Plexus.Schema.Recursive (DeprecationInfo, ParamSchema(..)) +import Plexus.Schema.Recursive (DeprecationInfo, ParamSchema(..), paramValues) -- ============================================================================ -- Building IR @@ -123,6 +123,15 @@ childHashes = fromMaybe Map.empty (irPluginHashes childIR) allHashes = Map.insert namespace hashInfo childHashes + -- REQ-5: capture per-plugin PlexusRequest schema (psRequest from wire schema). + -- HEADERS-1 stub: plexus-protocol's PluginSchema does not yet expose + -- psRequest (cross-repo patch pending). Treat as always-Nothing so the + -- synapse binary builds; REQ-5 rendering becomes a no-op until the field + -- lands in plexus-protocol. + let _ = schema -- suppress unused-binding warning when REQ-5 is stubbed + childRequests = fromMaybe Map.empty (irPluginRequests childIR) + allRequests = childRequests + pure $ IR { irVersion = irVersion emptyIR -- Use version from emptyIR , irBackend = irBackend emptyIR -- Will be set by buildIR @@ -132,6 +141,11 @@ , irMethods = Map.union localMethods (irMethods childIR) , irPlugins = Map.insert namespace pluginMethods (irPlugins childIR) , irPluginHashes = Just allHashes -- V2: Store hash info per plugin + , irPluginRequests = if Map.null allRequests then Nothing else Just allRequests + -- AUTH-9: this plugin's default roles, beside its children's. + , irPluginRoles = case (psRoles schema, irPluginRoles childIR) of + (Nothing, childRoles) -> childRoles + (Just roles, childRoles) -> Just (Map.insert namespace roles (fromMaybe Map.empty childRoles)) } irAlgebra (MethodF method namespace path) = do @@ -147,6 +161,8 @@ , irMethods = Map.singleton fullPath mdef , irPlugins = Map.singleton namespace [methodName method] , irPluginHashes = Nothing -- Methods don't have plugin-level hashes + , irPluginRequests = Nothing -- Methods don't carry request schemas + , irPluginRoles = Nothing -- Methods don't carry roles } -- ============================================================================ @@ -389,6 +405,11 @@ -- tags. plexus-protocol defaults this to MethodRoleRpc when -- the upstream schema omits the field, so pre-IR servers -- continue to work with no change in behaviour. + , mdGrant = methodGrant method + , mdTarget = methodTarget method + , mdLongDescription = methodLongDescription method + -- AUTH-9: what the method requires and its doc comment, lifted + -- for hub-codegen; Nothing from a pre-AUTH schema. } in (allTypes, mdef) @@ -467,6 +488,16 @@ (ps:_) -> paramDeprecation ps [] -> Nothing + -- REQ-6/REQ-9: extract @x-plexus-source@ from each property's schema. + -- Carries where the param value comes from (auth, cookie, header, + -- query, derived, rpc) so downstream renderers and codegen can + -- emit per-param annotations. Nothing means the schema had no + -- extension — treated as RPC. + extractSource :: Value -> Maybe Value + extractSource propSchema = case propSchema of + Object po -> KM.lookup "x-plexus-source" po + _ -> Nothing + -- Build param defs params = [ ParamDef @@ -476,6 +507,8 @@ , pdRequired = K.toText k `elem` required , pdDefault = extractDefault v , pdDeprecation = lookupDeprecation (K.toText k) + , pdSource = extractSource v + , pdValues = paramValues v } | (k, v) <- props ] 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 @@ -12,6 +12,7 @@ , newIRCache , lookupIR , insertIR + , irCacheKey , clearCache , getCacheStats , CacheStats(..) @@ -81,7 +82,19 @@ , cacheStats = stats } --- | Look up IR by hash +-- | AUTH-8: the key an IR is kept under — the plugin hash, qualified by +-- the caller's view when the hub has one (@VIEW_HASH@ joined with @-@, a +-- file name). Callers pass this to 'lookupIR' / 'insertIR' so two +-- callers' views of one hub never share an IR on disk. +irCacheKey :: Maybe Text -> Text -> Text +irCacheKey Nothing hash = hash +irCacheKey (Just v) hash + | T.null v = hash + | otherwise = T.map safe v <> "-" <> hash + where + safe c = if c `elem` ("/\\:" :: String) then '_' else c + +-- | Look up IR by hash (see 'irCacheKey' for a view's) lookupIR :: IRCache -> Text -> IO (Maybe IR) lookupIR IRCache{..} hash | not (cacheEnabled cacheConfig) = pure Nothing 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 @@ -62,8 +62,11 @@ import Control.Applicative ((<|>)) import Data.Aeson +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KM import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) @@ -130,10 +133,24 @@ , irMethods :: Map Text MethodDef -- ^ All methods, keyed by full path (e.g., "cone.chat") , irPlugins :: Map Text [Text] -- ^ Plugin -> method names mapping , irPluginHashes :: Maybe (Map Text PluginHashInfo) -- ^ V2: Hash information per plugin + , irPluginRequests :: Maybe (Map Text Aeson.Value) -- ^ REQ-5: per-plugin PlexusRequest JSON Schema (Nothing = no request struct) + , irPluginRoles :: Maybe (Map Text (Map Text [Text])) + -- ^ AUTH-9: per-plugin default roles (AUTH-3's @PluginSchema.roles@), + -- plugin namespace → role → the grants it lists. Omitted from the JSON + -- when 'Nothing', so an IR from a pre-AUTH schema is unchanged. } deriving stock (Show, Eq, Generic) - deriving anyclass (ToJSON, FromJSON) + deriving anyclass (FromJSON) +-- | Generic, except that @irPluginRoles@ is left out when 'Nothing' (AUTH-9): +-- an IR built from a schema without roles serializes exactly as before. +instance ToJSON IR where + toJSON ir = case genericToJSON defaultOptions ir of + Object o -> Object $ case irPluginRoles ir of + Nothing -> KM.delete "irPluginRoles" o + Just _ -> o + v -> v + -- | Empty IR for folding emptyIR :: IR emptyIR = IR @@ -145,6 +162,8 @@ , irMethods = Map.empty , irPlugins = Map.empty , irPluginHashes = Nothing + , irPluginRequests = Nothing + , irPluginRoles = Nothing } -- | Merge two IRs (for combining results from tree walk) @@ -162,6 +181,16 @@ (Just ha, Nothing) -> Just ha (Nothing, Just hb) -> Just hb (Nothing, Nothing) -> Nothing + , irPluginRequests = case (irPluginRequests a, irPluginRequests b) of + (Just ra, Just rb) -> Just (Map.union ra rb) + (Just ra, Nothing) -> Just ra + (Nothing, Just rb) -> Just rb + (Nothing, Nothing) -> Nothing + , irPluginRoles = case (irPluginRoles a, irPluginRoles b) of + (Just ra, Just rb) -> Just (Map.union ra rb) + (Just ra, Nothing) -> Just ra + (Nothing, Just rb) -> Just rb + (Nothing, Nothing) -> Nothing } -- ============================================================================ @@ -273,6 +302,14 @@ -- -- Consumed by hub-codegen (Rust field @md_role@, JSON key @mdRole@) -- to emit typed-handle clients for @DynamicChild@ methods. + , mdGrant :: Maybe Text + -- ^ AUTH-9: the method's grant (AUTH-3's @MethodSchema.grant@), + -- @.@, e.g. @tickets.set_status@. + , mdTarget :: Maybe Text + -- ^ AUTH-9: the param that locates what a call acts on (@MethodSchema.target@). + , mdLongDescription :: Maybe Text + -- ^ AUTH-9: the doc comment beside the short description + -- (@MethodSchema.long_description@). } deriving stock (Show, Eq, Generic) @@ -284,7 +321,7 @@ -- names used verbatim as JSON keys; @Maybe@ fields omitted when -- @Nothing@ to match aeson's legacy behaviour). instance ToJSON MethodDef where - toJSON MethodDef{..} = object + toJSON MethodDef{..} = object $ [ "mdName" .= mdName , "mdFullPath" .= mdFullPath , "mdNamespace" .= mdNamespace @@ -296,6 +333,12 @@ , "mdBidirResponseType" .= mdBidirResponseType , "mdBidirResponseSchema" .= mdBidirResponseSchema , "mdRole" .= mdRole + ] <> catMaybes + -- AUTH-9: present only when the schema says them, so a pre-AUTH + -- schema's IR is unchanged. + [ ("mdGrant" .=) <$> mdGrant + , ("mdTarget" .=) <$> mdTarget + , ("mdLongDescription" .=) <$> mdLongDescription ] instance FromJSON MethodDef where @@ -311,6 +354,9 @@ <*> o .:? "mdBidirResponseType" <*> o .:? "mdBidirResponseSchema" <*> o .:? "mdRole" .!= MethodRoleRpc + <*> o .:? "mdGrant" + <*> o .:? "mdTarget" + <*> o .:? "mdLongDescription" -- | A parameter definition data ParamDef = ParamDef @@ -326,6 +372,18 @@ -- Defaults to 'Nothing' when the schema lacks @param_schemas@, so -- pre-IR-5 producers and non-deprecated parameters are indistinguishable -- at the rendering layer. + , pdSource :: Maybe Value + -- ^ REQ-6/REQ-9: @x-plexus-source@ extension annotation, when the wire + -- schema declared one on this parameter. The value is the raw JSON + -- object (e.g. @{ "from": "auth", "resolver": "self.db.validate_user" }@ + -- or @{ "from": "cookie", "key": "access_token" }@). Consumers (synapse + -- renderer, hub-codegen JSDoc) read this to identify where each param + -- is sourced from. @Nothing@ means the schema lacked the extension — + -- treat as RPC-sourced. + , pdValues :: Maybe [Text] + -- ^ SYNAPSE-17: the values the parameter takes, as its schema hints them + -- (@x-plexus-values@). Omitted from the JSON when 'Nothing', so an IR + -- from a schema without the hint serializes exactly as before. } deriving stock (Show, Eq, Generic) @@ -333,14 +391,16 @@ -- deserializing IR JSON that predates IR-14. -- All other fields preserve the derivation defaults. instance ToJSON ParamDef where - toJSON ParamDef{..} = object + toJSON ParamDef{..} = object $ [ "pdName" .= pdName , "pdType" .= pdType , "pdDescription" .= pdDescription , "pdRequired" .= pdRequired , "pdDefault" .= pdDefault , "pdDeprecation" .= pdDeprecation + , "pdSource" .= pdSource ] + ++ maybe [] (\vs -> ["pdValues" .= vs]) pdValues instance FromJSON ParamDef where parseJSON = withObject "ParamDef" $ \o -> ParamDef @@ -350,6 +410,8 @@ <*> o .: "pdRequired" <*> o .:? "pdDefault" <*> o .:? "pdDeprecation" + <*> o .:? "pdSource" + <*> o .:? "pdValues" -- ============================================================================ -- Type References diff --git a/src/Synapse/Identity/Command.hs b/src/Synapse/Identity/Command.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Identity/Command.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | IDENTITY-43: the command lines. +-- +-- @ +-- synapse _key new [NAME] [--store auto|file|keychain] -- NAME defaults to "default"; never overwrites +-- synapse _key show [NAME] -- key:\ +-- synapse _key list +-- synapse [-H HOST] -P PORT _login BACKEND -- a person: the browser (AUTH-8) +-- synapse [-H HOST] -P PORT _login BACKEND [--key NAME] --as AGENT [--scope role\@SCOPE …] [--ttl SECS] +-- synapse [-H HOST] -P PORT _logout BACKEND [--as AGENT] +-- @ +-- +-- @_key@ is local and runs here; @_login@ / @_logout@ are parsed here and +-- run by the executable, which knows how to reach a backend. +module Synapse.Identity.Command + ( -- * _key + KeyCommand(..) + , keyCommandInfo + , runKeyCommand + + -- * _login / _logout + , LoginOpts(..) + , loginInfo + , LogoutOpts(..) + , logoutInfo + , splitScopes + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Options.Applicative +import System.Exit (ExitCode(..)) +import System.IO (stderr) + +import Synapse.Identity.Proof +import Synapse.Identity.Store + +-- ============================================================================ +-- _key +-- ============================================================================ + +data KeyCommand + = KeyNew Text StorePref + | KeyShow Text + | KeyList + deriving (Eq, Show) + +keyCommandInfo :: ParserInfo KeyCommand +keyCommandInfo = info (parser <**> helper) + ( fullDesc + <> header "synapse _key - the Ed25519 keys an agent proves who it is with" + <> progDesc "Kept in the OS keychain when one answers, else ~/.plexus/keys/NAME.key (0600). Read in the order: PLEXUS_KEY (base64 seed), keychain, $CREDENTIALS_DIRECTORY/NAME.key, ~/.plexus/keys/NAME.key." + ) + where + parser = hsubparser + ( command "new" (info newP (progDesc "Make a key (NAME defaults to 'default'); prints key:. Never overwrites.")) + <> command "show" (info showP (progDesc "Print a key's principal, key:")) + <> command "list" (info (pure KeyList) (progDesc "Every key synapse can find, and where")) + ) + nameArg = T.pack <$> strArgument (metavar "NAME" <> value "default" <> showDefault) + newP = KeyNew <$> nameArg <*> option storeR + ( long "store" <> metavar "auto|file|keychain" <> value StoreAuto + <> help "Where to keep it (default auto: the keychain when it answers, else the file)" ) + showP = KeyShow <$> nameArg + storeR = eitherReader $ \case + "auto" -> Right StoreAuto + "file" -> Right StoreFile + "keychain" -> Right StoreKeychain + s -> Left ("--store is auto, file or keychain, not " <> s) + +runKeyCommand :: StoreEnv -> KeyCommand -> IO ExitCode +runKeyCommand st = \case + KeyNew name pref + | not (validKeyName name) -> bad ("a key name is 1-64 of A-Z a-z 0-9 . _ - (not '" <> name <> "')") + | otherwise -> keyExists st name >>= \case + Just src -> bad ("key " <> name <> " already exists (" <> renderKeySource src <> "); synapse never overwrites a key") + Nothing -> do + seed <- generateSeed + writeKey st pref name seed >>= \case + Left e -> bad e + Right src -> do + TIO.putStrLn (principalOf seed) + TIO.hPutStrLn stderr ("synapse: key " <> name <> " kept in " <> renderKeySource src) + pure ExitSuccess + KeyShow name -> lookupKey st name >>= \case + Left e -> bad e + Right Nothing -> bad ("no key " <> name <> " (synapse _key new " <> name <> ")") + Right (Just (seed, _)) -> ExitSuccess <$ TIO.putStrLn (principalOf seed) + KeyList -> do + keys <- listKeys st + rows <- mapM describe keys + if null rows + then TIO.hPutStrLn stderr "synapse: no keys (synapse _key new)" + else mapM_ TIO.putStrLn (align' rows) + pure ExitSuccess + where + bad msg = ExitFailure 1 <$ TIO.hPutStrLn stderr ("synapse: " <> msg) + describe (name, src) = do + -- the principal from the store that listed it (PLEXUS_KEY would + -- answer for every name, so it is not asked here) + p <- lookupKey st { stEnv = \k -> if k == "PLEXUS_KEY" then pure Nothing else stEnv st k } name + let principal = case p of + Right (Just (seed, _)) -> principalOf seed + Right Nothing -> "?" + Left e -> "(" <> e <> ")" + pure (name, principal, renderKeySource src) + align' rows = + let w = maximum [T.length n | (n, _, _) <- rows] + in [T.justifyLeft w ' ' n <> " " <> p <> " " <> s | (n, p, s) <- rows] + +-- ============================================================================ +-- _login / _logout +-- ============================================================================ + +data LoginOpts = LoginOpts + { loBackend :: Text + , loKey :: Maybe Text -- ^ AUTH-8: none (and no agent named) is a person signing in through the browser + , loAs :: Maybe Text + , loScope :: [Text] + , loTtl :: Maybe Integer + } deriving (Eq, Show) + +loginInfo :: ParserInfo LoginOpts +loginInfo = info (p <**> helper) + ( fullDesc + <> header "synapse _login - sign in; later calls to this backend carry the session by themselves" + <> progDesc "A person (no --key, no --as): opens the browser to sign in and waits on a loopback port (127.0.0.1) for it to come back (auth.login's browser flow; 5 minutes). An agent (--key and/or --as): proves the key (a plexus-key proof at the upgrade) and asks auth.login for a session (session.login on a hub without auth). Either way the session is kept (keychain, else ~/.plexus/sessions/HOST_PORT/AGENT.json; a person's under the name 'me') and becomes this backend's default. Global options (-H, -P) go before _login." + ) + where + p = LoginOpts + <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The hub's name, e.g. menger")) + <*> optional (T.pack <$> strOption (long "key" <> short 'k' <> metavar "NAME" <> help "The key to prove (an agent; 'default' when only --as is given)")) + <*> optional (T.pack <$> strOption (long "as" <> metavar "AGENT" <> help "The agent id to log in as (else SYNAPSE_AS)")) + <*> (splitScopes <$> many (T.pack <$> strOption (long "scope" <> metavar "ROLE@SCOPE" <> help "The session's ceiling, e.g. editor@MENGER-12 (repeat, or commas); default: the key's own grants"))) + <*> optional (option auto (long "ttl" <> metavar "SECS" <> help "Session lifetime in seconds (the server's default 12 h, at most 24 h)")) + +data LogoutOpts = LogoutOpts + { lgBackend :: Text + , lgAs :: Maybe Text + } deriving (Eq, Show) + +logoutInfo :: ParserInfo LogoutOpts +logoutInfo = info (p <**> helper) + ( fullDesc + <> header "synapse _logout - end a session (session.logout) and forget it" + ) + where + p = LogoutOpts + <$> (T.pack <$> strArgument (metavar "BACKEND" <> help "The hub's name, e.g. menger")) + <*> optional (T.pack <$> strOption (long "as" <> metavar "AGENT" <> help "Which agent's session (else SYNAPSE_AS, else the backend's default)")) + +-- | @--scope a,b --scope c@ → @[a, b, c]@. +splitScopes :: [Text] -> [Text] +splitScopes = filter (not . T.null) . map T.strip . concatMap (T.splitOn ",") diff --git a/src/Synapse/Identity/Proof.hs b/src/Synapse/Identity/Proof.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Identity/Proof.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | IDENTITY-43: an agent's key and the proof it logs in with — IDENTITY-40's +-- "The wire", exactly. +-- +-- A key is an Ed25519 seed (32 bytes); its principal is +-- @key:\<64 lowercase hex of the public key\>@. A proof is a bearer value +-- +-- @ +-- plexus-key.\ +-- {"v":1,"key":"\<64 hex\>","aud":"\","agent":"\","nonce":"\","ts":\,"sig":"\"} +-- @ +-- +-- where @sig@ is Ed25519 over the UTF-8 bytes of exactly +-- @plexus-key-login/v1\\n\\\n\\\n\\\n\@ (no trailing +-- newline). The JSON's fields go in that order, compact, so the same +-- inputs give the same proof on every side (Ed25519 signing is +-- deterministic): see the fixed vector in @test/IdentitySpec.hs@. +module Synapse.Identity.Proof + ( -- * Keys + Seed + , seedFromBytes + , seedBytes + , generateSeed + , publicKeyHex + , principalOf + + -- * The proof + , canonicalMessage + , buildProof + , newNonce + , wsAudience + , validAgent + , validKeyName + + -- * Encodings + , b64urlNoPad + , hexText + , decodeSeedText + , encodeSeedText + ) where + +import qualified Crypto.PubKey.Ed25519 as Ed +import Crypto.Error (CryptoFailable(..)) +import Crypto.Random (getRandomBytes) +import qualified Data.Aeson.Encoding as AE +import Data.Aeson ((.=)) +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Lazy as LBS +import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Text.Printf (printf) + +-- | An Ed25519 seed: the 32 bytes a key is. +newtype Seed = Seed ByteString + deriving (Eq) + +instance Show Seed where + show _ = "Seed " + +-- | A seed from its 32 bytes, or why these are not one. +seedFromBytes :: ByteString -> Either Text Seed +seedFromBytes b + | BS.length b == 32 = Right (Seed b) + | otherwise = Left $ "a key is 32 bytes, not " <> T.pack (show (BS.length b)) + +seedBytes :: Seed -> ByteString +seedBytes (Seed b) = b + +-- | A new seed from the system's randomness. +generateSeed :: IO Seed +generateSeed = Seed <$> getRandomBytes 32 + +secretOf :: Seed -> Ed.SecretKey +secretOf (Seed b) = case Ed.secretKey b of + CryptoPassed sk -> sk + CryptoFailed e -> error ("Synapse.Identity.Proof: " <> show e) -- length is checked at construction + +publicOf :: Seed -> Ed.PublicKey +publicOf = Ed.toPublic . secretOf + +-- | The public key, 64 lowercase hex. +publicKeyHex :: Seed -> Text +publicKeyHex = hexText . BA.convert . publicOf + +-- | @key:\<64 hex\>@ — the principal a key is. +principalOf :: Seed -> Text +principalOf s = "key:" <> publicKeyHex s + +-- | The bytes the signature covers, as text: +-- @plexus-key-login/v1\\n\\\n\\\n\\\n\@. +canonicalMessage :: Text -> Text -> Text -> Integer -> Text +canonicalMessage aud agent nonce ts = + T.intercalate "\n" ["plexus-key-login/v1", aud, agent, nonce, T.pack (show ts)] + +-- | The proof for this key, audience (the ws URL dialed), agent, nonce (its +-- raw bytes; 32 of them) and time (unix seconds). +buildProof :: Seed -> Text -> Text -> ByteString -> Integer -> Text +buildProof seed aud agent nonceRaw ts = + let sk = secretOf seed + pk = Ed.toPublic sk + nonce = b64urlNoPad nonceRaw + msg = TE.encodeUtf8 (canonicalMessage aud agent nonce ts) + sig = Ed.sign sk pk msg + json = AE.encodingToLazyByteString $ AE.pairs $ mconcat + [ "v" .= (1 :: Int) + , "key" .= hexText (BA.convert pk) + , "aud" .= aud + , "agent" .= agent + , "nonce" .= nonce + , "ts" .= ts + , "sig" .= b64urlNoPad (BA.convert sig) + ] + in "plexus-key." <> b64urlNoPad (LBS.toStrict json) + +-- | 32 random bytes for a proof's nonce. +newNonce :: IO ByteString +newNonce = getRandomBytes 32 + +-- | The URL a proof's @aud@ names: the socket synapse dials, +-- @ws://HOST:PORT@ (SCAFFOLD-21: behind TLS, @wss://HOST@ — +-- 'Synapse.Endpoint.audience' says which for an address). +wsAudience :: Text -> Int -> Text +wsAudience host port = "ws://" <> host <> ":" <> T.pack (show port) + +-- | An agent id: 1–64 of @[A-Za-z0-9._-]@. +validAgent :: Text -> Bool +validAgent a = not (T.null a) && T.length a <= 64 && T.all idChar a + +-- | A key's name: the same alphabet (it names a file). +validKeyName :: Text -> Bool +validKeyName n = validAgent n && n `notElem` [".", ".."] + +idChar :: Char -> Bool +idChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("._-" :: String) + +-- | base64url without padding. +b64urlNoPad :: ByteString -> Text +b64urlNoPad = TE.decodeLatin1 . B64U.encodeUnpadded + +-- | Lowercase hex. +hexText :: ByteString -> Text +hexText = T.pack . concatMap (printf "%02x") . BS.unpack + +-- | A seed as it is kept (base64 of the 32 bytes; @PLEXUS_KEY@'s form). +encodeSeedText :: Seed -> Text +encodeSeedText (Seed b) = TE.decodeLatin1 (B64.encode b) + +-- | A kept seed back: standard or url base64, padded or not, surrounding +-- whitespace ignored. +decodeSeedText :: Text -> Either Text Seed +decodeSeedText t = + let s = TE.encodeUtf8 (T.strip t) + std = B64.decode s + url = B64U.decodeUnpadded s + urlp = B64U.decode s + in case [b | Right b <- [std, urlp, url]] of + (b : _) -> seedFromBytes b + [] -> Left "not base64" diff --git a/src/Synapse/Identity/Session.hs b/src/Synapse/Identity/Session.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Identity/Session.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | IDENTITY-43: logging in from a key, and the session every later call +-- carries by itself. +-- +-- * 'loginWithKey' opens a connection presenting a fresh proof +-- (@Authorization: Bearer plexus-key.…@) and asks @session.login@ on it. +-- * 'sessionFor' finds the session a call to @HOST:PORT@ goes with — the +-- agent named (@--as@ / @SYNAPSE_AS@) or the backend's default — and, when +-- its @expires_at@ has passed, logs in again from the key it was made +-- from before the call is sent. +-- * 'reattest' does that on demand, when the server refuses the session +-- (a 401 at the upgrade, or the "you have signed out" error): the caller +-- retries once. +-- +-- The session found for an address is remembered for the rest of the +-- process, so the discovery probe and the call carry the same token. +module Synapse.Identity.Session + ( -- * Login / logout + LoginResult(..) + , loginWithKey + , logoutWithToken + + -- * A person (AUTH-8: the loopback flow) + , loginPerson + , whoamiWith + , whoamiM + + -- * The session a call carries + , ActiveSession(..) + , sessionFor + , reattest + , reattestAgain + , canReattest + , bearer + + -- * Recognising an ended session + , isSessionEndedItem + , isSessionEndedText + , isUpgradeRefused + + -- * Within one call + , markSessionEnded + , takeSessionEnded + , notePrinted + , printedAny + , noteRefused + , wasRefused + , currentCeiling + ) where + +import Control.Exception (SomeException, try) +import Control.Monad (when) +import Data.Aeson (Value(..), object, (.=)) +import qualified Data.Aeson.KeyMap as KM +import Data.IORef +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust) +import Data.Scientific (toBoundedInteger) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Time.Clock.POSIX (getPOSIXTime) +import qualified Data.Vector as V +import System.IO (stderr) +import System.IO.Unsafe (unsafePerformIO) + +import Control.Monad.Except (catchError) + + +import Synapse.Auth (SessionGrant(..), Whoami, isMissingAuth, parseSessionGrant, parseWhoami) +import qualified Synapse.Auth.Loopback as Loopback +import Synapse.Identity.Proof +import Synapse.Identity.Store +import Synapse.Endpoint (Endpoint) +import qualified Synapse.Endpoint as E +import qualified Synapse.Log as Log +import Synapse.Monad +import Synapse.Schema.Types (HubStreamItem, pattern HubData, pattern HubError, pattern HubGuidance) +import Synapse.Transport (invoke) + +-- ============================================================================ +-- Login +-- ============================================================================ + +-- | What @session.login@ answered. +data LoginResult = LoginResult + { lrToken :: Text + , lrPrincipal :: Text + , lrAgent :: Text + , lrExpiresAt :: Maybe Integer + , lrScope :: [Text] + } deriving (Eq, Show) + +nowSecs :: IO Integer +nowSecs = round <$> getPOSIXTime + +-- | Log in to the hub @backend@ at @HOST:PORT@ as @agent@, proving the key: +-- a connection opened with the proof, and on it AUTH-5's @auth.login +-- {flow: {session: {ttl_secs?, ceiling?}}}@ — or, on a hub with no @auth@ +-- activation (every hub before AUTH), IDENTITY-42's @session.login {ttl_secs?, +-- scope?}@ on a second connection with a fresh proof (a proof works once). +loginWithKey :: Log.Logger -> Endpoint -> Text -> Seed -> Text -> [Text] -> Maybe Integer -> IO (Either Text LoginResult) +loginWithKey logger ep backend seed agent scope ttl + | not (validAgent agent) = pure (Left ("an agent id is 1-64 of A-Z a-z 0-9 . _ - (not '" <> agent <> "')")) + | otherwise = do + viaAuth <- do + proof <- freshProof + let flow = object $ + maybe [] (\t -> ["ttl_secs" .= t]) ttl + <> (if null scope then [] else ["ceiling" .= scope]) + items <- call logger ep backend (Just proof) "auth" "login" (object ["flow" .= object ["session" .= flow]]) + pure (items >>= grantItem "auth.login") + case viaAuth of + Left e | isMissingAuth e -> do + proof <- freshProof + let params = object $ + maybe [] (\t -> ["ttl_secs" .= t]) ttl + <> (if null scope then [] else ["scope" .= scope]) + items <- call logger ep backend (Just proof) "session" "login" params + pure (items >>= loginItem) + other -> pure other + where + freshProof = do + nonce <- newNonce + ts <- nowSecs + pure (buildProof seed (E.audience ep) agent nonce ts) + grantItem what items = + case [g | HubData _ _ _ v <- items, Just g <- [parseSessionGrant v]] of + (g : _) -> Right LoginResult + { lrToken = sgToken g + , lrPrincipal = sgPrincipal g + , lrAgent = maybe agent id (sgAgent g) + , lrExpiresAt = sgExpiresAt g + , lrScope = sgCeiling g + } + [] -> Left (answerError items (what <> " answered no session")) + loginItem items = + case [o | HubData _ _ _ (Object o) <- items, KM.lookup "type" o == Just (String "login")] of + (o : _) | Just (String tok) <- KM.lookup "token" o -> Right LoginResult + { lrToken = tok + , lrPrincipal = str "principal" o + , lrAgent = let a = str "agent" o in if T.null a then agent else a + , lrExpiresAt = KM.lookup "expires_at" o >>= int + , lrScope = case KM.lookup "scope" o of + Just (Array xs) -> [s | String s <- V.toList xs] + _ -> [] + } + _ -> Left (answerError items "session.login answered no login") + +-- | AUTH-8: a person signs in through the browser (the loopback flow, +-- AUTH-1 Q3). synapse listens on 127.0.0.1 (a port the OS picks), asks +-- @auth.login {flow: {browser: {redirect: http://127.0.0.1:PORT/cb}}}@ for +-- @{type: login_url, url, state}@, opens the URL (and says it, for a +-- browser elsewhere), waits up to @secs@ for @GET /cb?code=…&state=…@ with +-- that state, and trades the code: @auth.login {flow: {code: {code, +-- state}}}@ → the session. Every call here is anonymous. +loginPerson :: Log.Logger -> Endpoint -> Text -> Int -> (Text -> IO ()) -> IO (Either Text SessionGrant) +loginPerson logger ep backend secs say = + Loopback.withLoopback $ \lb -> do + let redirect = Loopback.loopbackRedirect lb + browserFlow = object ["flow" .= object ["browser" .= object ["redirect" .= redirect]]] + first' <- call logger ep backend Nothing "auth" "login" browserFlow + case first' >>= loginUrl of + Left e + | isMissingAuth e -> pure (Left (addressKey ep <> " has no auth activation, so no browser sign-in" + <> " (an agent signs in with its key: _login " <> backend <> " --key NAME --as AGENT)")) + | otherwise -> pure (Left e) + Right (url, state) -> do + opened <- Loopback.openBrowser url + say $ (if opened then "opening your browser to sign in; if it does not open, visit:" + else "to sign in, visit:") + say (" " <> url) + say ("waiting for the browser on " <> redirect <> " (" <> Loopback.durationText secs <> ") \x2026") + back <- Loopback.awaitCallback lb state secs + case back of + Left why -> pure (Left why) + Right code -> do + let codeFlow = object ["flow" .= object ["code" .= object ["code" .= code, "state" .= state]]] + done <- call logger ep backend Nothing "auth" "login" codeFlow + pure $ done >>= \items -> + case [g | HubData _ _ _ v <- items, Just g <- [parseSessionGrant v]] of + (g : _) -> Right g + [] -> Left (answerError items "auth.login answered no session for the code") + where + loginUrl items = + case [o | HubData _ _ _ (Object o) <- items, KM.lookup "type" o `elem` [Just (String "login_url"), Just (String "url")]] of + (o : _) | Just (String u) <- KM.lookup "url" o, not (T.null u) -> + case KM.lookup "state" o of + Just (String st) | not (T.null st) -> Right (u, st) + _ -> Left "auth.login gave a sign-in URL with no state; refused (the state is what binds the browser's answer to this sign-in)" + _ -> Left (answerError items "auth.login answered no sign-in URL") + +-- | AUTH-8: who a token is — @auth.whoami@, else (a hub without the auth +-- activation) @session.whoami@; Nothing when neither says. +whoamiWith :: Log.Logger -> Endpoint -> Text -> Text -> IO (Maybe Whoami) +whoamiWith logger ep backend token = do + a <- call logger ep backend (Just token) "auth" "whoami" (object []) + case a >>= firstWhoami of + Right w -> pure (Just w) + Left _ -> do + b <- call logger ep backend (Just token) "session" "whoami" (object []) + pure (either (const Nothing) Just (b >>= firstWhoami)) + +-- | 'whoamiWith' on the call's own connection (its credential, whatever it +-- is): @auth.whoami@, else @session.whoami@, else Nothing. Never fails. +whoamiM :: SynapseM (Maybe Whoami) +whoamiM = do + a <- (Just <$> invoke ["auth"] "whoami" (object [])) `catchError` \_ -> pure Nothing + case a >>= either (const Nothing) Just . firstWhoami of + Just w -> pure (Just w) + Nothing -> do + b <- (Just <$> invoke ["session"] "whoami" (object [])) `catchError` \_ -> pure Nothing + pure (b >>= either (const Nothing) Just . firstWhoami) + +firstWhoami :: [HubStreamItem] -> Either Text Whoami +firstWhoami items = case [w | HubData _ _ _ v <- items, Just w <- [parseWhoami v]] of + (w : _) -> Right w + [] -> Left (answerError items "no whoami") + +-- | End the session this token is: @auth.logout@ (AUTH-5), else — a hub +-- with no auth activation — @session.logout@. +logoutWithToken :: Log.Logger -> Endpoint -> Text -> Text -> IO (Either Text ()) +logoutWithToken logger ep backend token = do + a <- call logger ep backend (Just token) "auth" "logout" (object []) + case a >>= ended "auth.logout" of + Left e | isMissingAuth e -> do + items <- call logger ep backend (Just token) "session" "logout" (object []) + pure (items >>= ended "session.logout") + other -> pure other + where + -- an answer with no error is a logout; one that says so, certainly + ended what is + | any isLoggedOut is = Right () + | null [() | HubError{} <- is] && null (errorEvents is) && not (null [() | HubData{} <- is]) = Right () + | otherwise = Left (answerError is (what <> " answered nothing")) + isLoggedOut = \case + HubData _ _ _ (Object o) -> KM.lookup "type" o `elem` [Just (String "logged_out"), Just (String "logout")] + _ -> False + errorEvents is = [() | HubData _ _ _ (Object o) <- is, KM.lookup "type" o == Just (String "error")] + +-- | One @\.\@ call on a fresh connection presenting @cred@ +-- as @Authorization: Bearer@ (none: anonymous). +call :: Log.Logger -> Endpoint -> Text -> Maybe Text -> Text -> Text -> Value -> IO (Either Text [HubStreamItem]) +call logger ep backend cred ns method params = do + env0 <- initEnvAt ep backend logger Nothing + let env = withRequestContext [] (maybe [] (\c -> [bearer c]) cred) env0 + r <- runSynapseM env (invoke [ns] method params) + pure $ case r of + Right items -> Right items + Left (TransportErrorContext ctx) + | isUpgradeRefused (tcMessage ctx) -> Left (addressKey ep <> " refused the credential at the upgrade (401)") + | otherwise -> Left (firstLine (tcMessage ctx)) + Left (TransportError m) -> Left (firstLine m) + Left e -> Left (T.pack (show e)) + +-- | SCAFFOLD-21: the global options a sign-in at this address is typed +-- with, and the space after them (none for the default address). +loginOpts :: Endpoint -> Text +loginOpts ep = case E.cliOptions ep of + "" -> "" + o -> o <> " " + +firstLine :: Text -> Text +firstLine = T.strip . T.takeWhile (/= '\n') + +-- | The upgrade header a credential travels in. +bearer :: Text -> (Text, Text) +bearer cred = ("Authorization", "Bearer " <> cred) + +answerError :: [HubStreamItem] -> Text -> Text +answerError items fallback = + case [m | HubData _ _ _ (Object o) <- items, KM.lookup "type" o == Just (String "error"), Just (String m) <- [KM.lookup "message" o]] + <> [e | HubError _ _ e _ <- items] + <> [T.pack (show g) | HubGuidance _ _ g _ _ _ <- items] of + (m : _) -> m + [] -> fallback + +str :: KM.Key -> KM.KeyMap Value -> Text +str k o = case KM.lookup k o of + Just (String s) -> s + _ -> "" + +int :: Value -> Maybe Integer +int = \case + Number n -> fromIntegral <$> (toBoundedInteger n :: Maybe Int) + String s | [(i, "")] <- reads (T.unpack s) -> Just i + _ -> Nothing + +-- ============================================================================ +-- The session a call carries +-- ============================================================================ + +data ActiveSession = ActiveSession + { asEndpoint :: Endpoint + , asToken :: Text + , asRec :: Maybe SessionRec -- ^ Nothing: PLEXUS_SESSION, nothing to log in again from + } deriving (Eq, Show) + +{-# NOINLINE memo #-} +memo :: IORef (Map.Map Endpoint (Maybe ActiveSession)) +memo = unsafePerformIO (newIORef Map.empty) + +-- | Addresses already logged in again in this process (at most once each). +{-# NOINLINE reattested #-} +reattested :: IORef [Endpoint] +reattested = unsafePerformIO (newIORef []) + +-- | The session a call to @HOST:PORT@ carries, if any: @PLEXUS_SESSION@, +-- else the stored one for the agent asked (or the backend's default agent). +-- One past its @expires_at@ is made again from its key first. +sessionFor :: Log.Logger -> StoreEnv -> Maybe Text -> Endpoint -> IO (Maybe ActiveSession) +sessionFor logger st asked ep = do + known <- Map.lookup ep <$> readIORef memo + case known of + Just s -> pure s + Nothing -> do + s <- find + modifyIORef' memo (Map.insert ep s) + pure s + where + find = do + envTok <- stEnv st "PLEXUS_SESSION" + case envTok of + Just t | not (null t) -> pure (Just (ActiveSession ep (T.strip (T.pack t)) Nothing)) + _ -> do + agent <- maybe (readDefaultAgent st ep) (pure . Just) asked + case agent of + Nothing -> pure Nothing + Just a -> lookupSession st ep a >>= \case + Just (Right rec, _) -> do + now <- nowSecs + let active = ActiveSession ep (srToken rec) (Just rec) + if maybe False (<= now + 5) (srExpiresAt rec) + then reattestWith logger st active "had expired" + else pure (Just active) + Just (Left tok, _) -> pure (Just (ActiveSession ep tok Nothing)) + Nothing -> do + when (isJust asked) $ TIO.hPutStrLn stderr $ + "synapse: no session for " <> a <> " at " <> addressKey ep + <> " (synapse " <> loginOpts ep <> "_login --key NAME --as " <> a <> ")" + pure Nothing + +-- | Can the session in use at this address be made again from its key? +canReattest :: Endpoint -> IO Bool +canReattest ep = do + s <- Map.lookup ep <$> readIORef memo + done <- elem ep <$> readIORef reattested + pure $ case s of + -- AUTH-8: a person's session (no key) is made again only by signing in + Just (Just ActiveSession{asRec = Just r}) -> not done && not (T.null (srKey r)) + _ -> False + +-- | The server refused the session in use at this address: log in again +-- from its key (once per process). The new session, or Nothing when there +-- was none to remake or the login failed (both said on stderr). +reattest :: Log.Logger -> StoreEnv -> Endpoint -> IO (Maybe ActiveSession) +reattest logger st ep = do + ok <- canReattest ep + s <- Map.lookup ep <$> readIORef memo + case s of + Just (Just active) | ok -> do + r <- reattestWith logger st active "has ended" + pure $ case r of + Just new | asToken new /= asToken active -> Just new + _ -> Nothing + _ -> pure Nothing + +-- | SYNAPSE-20: 'reattest' for a call that outlived its session — a long +-- stream across a server restart (menger keeps sessions in memory). Its +-- reconnect loop asks at most once per outage, so the once-per-process +-- mark is lifted first. +reattestAgain :: Log.Logger -> StoreEnv -> Endpoint -> IO (Maybe ActiveSession) +reattestAgain logger st ep = do + modifyIORef' reattested (filter (/= ep)) + reattest logger st ep + +reattestWith :: Log.Logger -> StoreEnv -> ActiveSession -> Text -> IO (Maybe ActiveSession) +reattestWith logger st active why = case asRec active of + Nothing -> pure (Just active) + Just rec | T.null (srKey rec) -> do + -- AUTH-8: a person's session: there is no key to make it again from + TIO.hPutStrLn stderr $ "synapse: the session for " <> srAgent rec <> " at " + <> addressKey (asEndpoint active) <> " " <> why + <> "; sign in again: synapse " <> loginOpts (asEndpoint active) <> "_login " <> srBackend rec + pure (Just active) + Just rec -> do + let ep = asEndpoint active + who = srAgent rec <> " at " <> addressKey ep + modifyIORef' reattested (ep :) + -- SYNAPSE-15: one process at a time signs this agent in again; one + -- that waited finds the session another has just made, and takes it + withSessionLock st ep (srAgent rec) $ do + fresher <- storedFresher st active rec + case fresher of + Just active' -> do + modifyIORef' memo (Map.insert ep (Just active')) + pure (Just active') + Nothing -> mint ep who rec + where + mint ep who rec = do + key <- lookupKey st (srKey rec) + case key of + Right (Just (seed, _)) -> do + r <- loginWithKey logger ep (srBackend rec) seed (srAgent rec) (srScope rec) (srTtl rec) + case r of + Right lr -> do + let rec' = rec { srToken = lrToken lr + , srPrincipal = if T.null (lrPrincipal lr) then srPrincipal rec else lrPrincipal lr + , srExpiresAt = lrExpiresAt lr + } + active' = active { asToken = lrToken lr, asRec = Just rec' } + -- SYNAPSE-15: a session that cannot be kept is a warning; the + -- call goes on with the one it holds + kept <- try (writeSession st ep rec') + case kept of + Right _ -> pure () + Left (e :: SomeException) -> TIO.hPutStrLn stderr $ + "synapse: warning: could not keep the new session for " <> who + <> " (" <> T.pack (show e) <> "); this call goes on with it" + modifyIORef' memo (Map.insert ep (Just active')) + TIO.hPutStrLn stderr $ "synapse: the session for " <> who <> " " <> why + <> "; signed in again from key " <> srKey rec + pure (Just active') + Left e -> do + TIO.hPutStrLn stderr $ "synapse: the session for " <> who <> " " <> why + <> " and signing in again from key " <> srKey rec <> " failed: " <> e + pure (Just active) + Right Nothing -> do + TIO.hPutStrLn stderr $ "synapse: the session for " <> who <> " " <> why + <> ", and key " <> srKey rec <> " is in no store to sign in again from" + pure (Just active) + Left e -> do + TIO.hPutStrLn stderr $ "synapse: the session for " <> who <> " " <> why <> "; key " <> srKey rec <> ": " <> e + pure (Just active) + +-- | SYNAPSE-15: the agent's stored session, read again under its lock, +-- when another process has replaced the one this call holds with one that +-- is still live — then this call takes it instead of signing in again. +storedFresher :: StoreEnv -> ActiveSession -> SessionRec -> IO (Maybe ActiveSession) +storedFresher st active rec = do + stored <- try (lookupSession st (asEndpoint active) (srAgent rec)) + now <- nowSecs + pure $ case stored of + Right (Just (Right r, _)) + | srToken r /= asToken active + , not (T.null (srToken r)) + , maybe True (> now + 5) (srExpiresAt r) + -> Just active { asToken = srToken r, asRec = Just r } + Right _ -> Nothing + Left (_ :: SomeException) -> Nothing + +-- ============================================================================ +-- Recognising an ended session +-- ============================================================================ + +-- | The in-band error a hub answers a call whose session has ended with. +isSessionEndedItem :: HubStreamItem -> Bool +isSessionEndedItem = \case + HubData _ _ _ (Object o) + | KM.lookup "type" o == Just (String "error") + , Just (String m) <- KM.lookup "message" o -> isSessionEndedText m + HubError _ _ e _ -> isSessionEndedText e + _ -> False + +isSessionEndedText :: Text -> Bool +isSessionEndedText m = any (`T.isInfixOf` T.toLower m) + ["you have signed out", "your sign-in has expired"] + +-- | A transport failure that is the upgrade's 401. +isUpgradeRefused :: Text -> Bool +isUpgradeRefused m = any (`T.isInfixOf` m) ["responseCode = 401", " 401 ", "(401)", "Unauthorized"] + +-- ============================================================================ +-- Within one call: was the session refused before anything was shown? +-- ============================================================================ + +{-# NOINLINE endedRef #-} +endedRef :: IORef (Maybe Text) +endedRef = unsafePerformIO (newIORef Nothing) + +{-# NOINLINE printedRef #-} +printedRef :: IORef Bool +printedRef = unsafePerformIO (newIORef False) + +-- | Hold back the server's refusal (its words) for the retry. +markSessionEnded :: Text -> IO () +markSessionEnded = writeIORef endedRef . Just + +-- | Was the session refused, and the refusal held back? Its words; resets. +takeSessionEnded :: IO (Maybe Text) +takeSessionEnded = atomicModifyIORef' endedRef (\b -> (Nothing, b)) + +notePrinted :: IO () +notePrinted = writeIORef printedRef True + +printedAny :: IO Bool +printedAny = readIORef printedRef + +-- | AUTH-8: a refusal was shown (the call exits non-zero). +{-# NOINLINE refusedRef #-} +refusedRef :: IORef Bool +refusedRef = unsafePerformIO (newIORef False) + +noteRefused :: IO () +noteRefused = writeIORef refusedRef True + +wasRefused :: IO Bool +wasRefused = readIORef refusedRef + +-- | AUTH-8: the ceiling of the session this process carries, as asked at +-- login (@editor\@MENGER-12@ each) — what a refusal that names none is +-- said to be within. Empty when no stored session is carried. +currentCeiling :: IO [Text] +currentCeiling = do + m <- readIORef memo + pure $ case [srScope r | Just ActiveSession{asRec = Just r} <- Map.elems m] of + (c : _) -> c + [] -> [] diff --git a/src/Synapse/Identity/Store.hs b/src/Synapse/Identity/Store.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Identity/Store.hs @@ -0,0 +1,552 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | IDENTITY-43: where an agent's key and its sessions are kept — IDENTITY-40's +-- "Stores (synapse)", exactly. +-- +-- Key @NAME@, read in this order: +-- +-- 1. env @PLEXUS_KEY@ (base64 of the 32-byte seed) +-- 2. the OS keychain (@secret-tool@ attributes @service=plexus-key name=NAME@; +-- macOS @security … -s plexus-key -a NAME@) +-- 3. @$CREDENTIALS_DIRECTORY/NAME.key@ (a systemd service's credentials) +-- 4. @~\/.plexus\/keys\/NAME.key@ (0600) +-- +-- Session for (backend @HOST:PORT@, agent): +-- +-- 1. env @PLEXUS_SESSION@ (the token itself) +-- 2. the keychain (@service=plexus-session backend=HOST:PORT agent=AGENT@) +-- 3. @~\/.plexus\/sessions\/HOST_PORT\/AGENT.json@ (0600) +-- +-- SCAFFOLD-21: a backend reached any other way than plain +-- @ws://HOST:PORT/@ is keyed by its URL — @backend=wss://HOST:443/ws@ in the +-- keychain, @~\/.plexus\/sessions\/wss_HOST_443_ws\/AGENT.json@ on disk — +-- so a ws and a wss backend on one host keep sessions apart, and every +-- session stored before is found where it was. +-- +-- Writes go to the keychain when it answers, else the file. The keychain +-- is asked through its command-line tool with a 2 s limit, and a host with +-- no session bus (a server) has none — so a headless machine falls through +-- to the files at once. @PLEXUS_KEYCHAIN=off@ skips it outright. +-- +-- Everything is reached through a 'StoreEnv', so tests give it a directory, +-- an environment and a keychain of their own. +module Synapse.Identity.Store + ( -- * The environment + StoreEnv(..) + , systemStoreEnv + , Keychain(..) + , KcResult(..) + , systemKeychain + , memoryKeychain + + -- * Keys + , KeySource(..) + , renderKeySource + , lookupKey + , StorePref(..) + , writeKey + , keyExists + , listKeys + , keyFilePath + + -- * Sessions + , SessionRec(..) + , SessionSource(..) + , lookupSession + , writeSession + , removeSession + , sessionFilePath + , addressKey + , readDefaultAgent + , writeDefaultAgent + , clearDefaultAgent + + , withSessionLock + + -- * Files + , writePrivateFile + ) where + +import Control.Exception (SomeException, try, catch, finally, onException) +import Control.Monad (unless, when) +import Data.Aeson (FromJSON(..), ToJSON(..), (.:), (.:?), (.=), (.!=), object, withObject) +import qualified Data.Aeson as A +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.IORef +import qualified Data.Map.Strict as Map +import Data.List (nub, sort) +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +import System.Directory +import System.Environment (lookupEnv) +import System.Exit (ExitCode(..)) +import System.FilePath ((), takeDirectory, takeExtension, dropExtension, takeFileName) +import System.IO (hClose, openBinaryTempFile) +import qualified System.Info as Info +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Files (setFileMode) +import System.Posix.IO (createFile, closeFd) +import Foreign.C.Types (CInt(..)) +import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock_) +import System.Process (proc, readCreateProcessWithExitCode) +import System.Timeout (timeout) + +import Synapse.Identity.Proof +import Synapse.Endpoint (Endpoint) +import qualified Synapse.Endpoint as E + +-- ============================================================================ +-- Environment +-- ============================================================================ + +-- | What the stores read and write through. +data StoreEnv = StoreEnv + { stEnv :: String -> IO (Maybe String) -- ^ the process environment + , stPlexus :: FilePath -- ^ @~/.plexus@ + , stKeychain :: Maybe Keychain -- ^ the OS keychain, when there is one + } + +-- | The real thing: the process environment, @~/.plexus@ and the system +-- keychain (if it is there). +systemStoreEnv :: IO StoreEnv +systemStoreEnv = do + home <- getHomeDirectory + kc <- systemKeychain + pure StoreEnv { stEnv = lookupEnv, stPlexus = home ".plexus", stKeychain = kc } + +-- | A keychain item is a service and the attributes that name it. +data KcResult = KcFound Text | KcAbsent | KcUnavailable Text + deriving (Eq, Show) + +data Keychain = Keychain + { kcLabel :: Text + , kcLookup :: Text -> [(Text, Text)] -> IO KcResult + , kcStore :: Text -> Text -> [(Text, Text)] -> Text -> IO (Either Text ()) -- ^ label, service, attrs, secret + , kcClear :: Text -> [(Text, Text)] -> IO () + , kcNames :: Text -> Text -> IO [Text] -- ^ service, attribute → the values items hold + } + +-- | Once the keychain has failed to answer in this process, it is not +-- asked again (each ask may cost the 2 s limit). +{-# NOINLINE keychainDown #-} +keychainDown :: IORef Bool +keychainDown = unsafePerformIO (newIORef False) + +-- | The system keychain, or none: none when @PLEXUS_KEYCHAIN@ is off, when +-- its tool is not installed, or (Linux) when there is no session bus to +-- reach a secret service on. +systemKeychain :: IO (Maybe Keychain) +systemKeychain = do + off <- lookupEnv "PLEXUS_KEYCHAIN" + if fmap (T.toLower . T.pack) off `elem` map Just ["0", "off", "no", "false", "none", "file"] + then pure Nothing + else case Info.os of + "darwin" -> fmap (const macKeychain) <$> findExecutable "security" + "linux" -> do + tool <- findExecutable "secret-tool" + bus <- sessionBus + pure $ if isJust tool && bus then Just secretTool else Nothing + _ -> pure Nothing + where + sessionBus = do + addr <- lookupEnv "DBUS_SESSION_BUS_ADDRESS" + case addr of + Just a | not (null a) -> pure True + _ -> lookupEnv "XDG_RUNTIME_DIR" >>= \case + Just d -> doesPathExist (d "bus") + Nothing -> pure False + +-- | Run a keychain tool with the 2 s limit: its exit, stdout and stderr, or +-- why it did not answer. +runTool :: FilePath -> [String] -> String -> IO (Either Text (ExitCode, String, String)) +runTool exe args input = do + down <- readIORef keychainDown + if down then pure (Left "the keychain did not answer earlier") else do + r <- try (timeout 2000000 (readCreateProcessWithExitCode (proc exe args) input)) + case r of + Left (e :: SomeException) -> markDown ("could not run " <> T.pack exe <> ": " <> T.pack (show e)) + Right Nothing -> markDown (T.pack exe <> " did not answer within 2 s") + Right (Just out) -> pure (Right out) + where + markDown msg = writeIORef keychainDown True >> pure (Left msg) + +attrArgs :: Text -> [(Text, Text)] -> [String] +attrArgs service attrs = concat [[T.unpack k, T.unpack v] | (k, v) <- ("service", service) : attrs] + +-- | Linux: @secret-tool@ over the Secret Service. +secretTool :: Keychain +secretTool = Keychain + { kcLabel = "keychain (secret-tool)" + , kcLookup = \service attrs -> do + r <- runTool "secret-tool" ("lookup" : attrArgs service attrs) "" + pure $ case r of + Left msg -> KcUnavailable msg + Right (ExitSuccess, out, _) -> KcFound (T.strip (T.pack out)) + -- exit 1 with nothing said: the service answered, no such item + Right (ExitFailure 1, _, err) | all (`elem` (" \n\t" :: String)) err -> KcAbsent + Right (_, _, err) -> KcUnavailable (T.strip (T.pack err)) + , kcStore = \label service attrs secret -> do + r <- runTool "secret-tool" (["store", "--label=" <> T.unpack label] <> attrArgs service attrs) (T.unpack secret) + pure $ case r of + Left msg -> Left msg + Right (ExitSuccess, _, _) -> Right () + Right (_, _, err) -> Left (T.strip (T.pack err)) + , kcClear = \service attrs -> () <$ runTool "secret-tool" ("clear" : attrArgs service attrs) "" + , kcNames = \service attr -> do + r <- runTool "secret-tool" ["search", "--all", "service", T.unpack service] "" + pure $ case r of + Right (ExitSuccess, out, err) -> + -- secret-tool prints the attributes on stdout or stderr by version + [ T.strip v + | l <- T.lines (T.pack out <> "\n" <> T.pack err) + , Just v <- [T.stripPrefix ("attribute." <> attr <> " = ") (T.strip l)] + ] + _ -> [] + } + +-- | macOS: @security@ generic passwords; the account is the attribute +-- values joined with @/@ (a key's: its name). +macKeychain :: Keychain +macKeychain = Keychain + { kcLabel = "keychain (macOS)" + , kcLookup = \service attrs -> do + r <- runTool "security" ["find-generic-password", "-s", T.unpack service, "-a", account attrs, "-w"] "" + pure $ case r of + Left msg -> KcUnavailable msg + Right (ExitSuccess, out, _) -> KcFound (T.strip (T.pack out)) + Right (ExitFailure 44, _, _) -> KcAbsent + Right (_, _, err) -> KcUnavailable (T.strip (T.pack err)) + , kcStore = \label service attrs secret -> do + r <- runTool "security" ["add-generic-password", "-U", "-l", T.unpack label, "-s", T.unpack service, "-a", account attrs, "-w", T.unpack secret] "" + pure $ case r of + Left msg -> Left msg + Right (ExitSuccess, _, _) -> Right () + Right (_, _, err) -> Left (T.strip (T.pack err)) + , kcClear = \service attrs -> () <$ runTool "security" ["delete-generic-password", "-s", T.unpack service, "-a", account attrs] "" + , kcNames = \_ _ -> pure [] -- `security` has no cheap listing; keys in files are still listed + } + where account = T.unpack . T.intercalate "/" . map snd + +-- | An in-memory keychain, for tests. +memoryKeychain :: IO (Keychain, IORef (Map.Map (Text, [(Text, Text)]) Text)) +memoryKeychain = do + ref <- newIORef Map.empty + let kc = Keychain + { kcLabel = "keychain (memory)" + , kcLookup = \s a -> maybe KcAbsent KcFound . Map.lookup (s, a) <$> readIORef ref + , kcStore = \_ s a v -> Right () <$ modifyIORef' ref (Map.insert (s, a) v) + , kcClear = \s a -> modifyIORef' ref (Map.delete (s, a)) + , kcNames = \s attr -> do + m <- readIORef ref + pure [v | ((s', as), _) <- Map.toList m, s' == s, Just v <- [lookup attr as]] + } + pure (kc, ref) + +-- ============================================================================ +-- Keys +-- ============================================================================ + +data KeySource = KeyFromEnv | KeyFromKeychain | KeyFromCredentials FilePath | KeyFromFile FilePath + deriving (Eq, Show) + +renderKeySource :: KeySource -> Text +renderKeySource = \case + KeyFromEnv -> "PLEXUS_KEY" + KeyFromKeychain -> "keychain" + KeyFromCredentials p -> "credentials " <> T.pack p + KeyFromFile p -> "file " <> T.pack p + +keyAttrs :: Text -> [(Text, Text)] +keyAttrs name = [("name", name)] + +keyFilePath :: StoreEnv -> Text -> FilePath +keyFilePath st name = stPlexus st "keys" (T.unpack name <> ".key") + +-- | Key @NAME@ in the spec's order, or why it is not there (Left when a +-- store holds something that is not a key). +lookupKey :: StoreEnv -> Text -> IO (Either Text (Maybe (Seed, KeySource))) +lookupKey st name = do + envKey <- stEnv st "PLEXUS_KEY" + case envKey of + Just v | not (null v) -> pure $ either (Left . ("PLEXUS_KEY: " <>)) (\s -> Right (Just (s, KeyFromEnv))) (decodeSeedText (T.pack v)) + _ -> do + fromKc <- case stKeychain st of + Nothing -> pure Nothing + Just kc -> kcLookup kc "plexus-key" (keyAttrs name) >>= \case + KcFound v -> pure (Just (decodeSeedText v, KeyFromKeychain)) + _ -> pure Nothing + case fromKc of + Just (Right s, src) -> pure (Right (Just (s, src))) + Just (Left e, _) -> pure (Left ("the keychain's plexus-key " <> name <> ": " <> e)) + Nothing -> do + creds <- stEnv st "CREDENTIALS_DIRECTORY" + fromCreds <- case creds of + Just d | not (null d) -> readKeyFile (d (T.unpack name <> ".key")) KeyFromCredentials + _ -> pure (Right Nothing) + case fromCreds of + Right Nothing -> readKeyFile (keyFilePath st name) KeyFromFile + other -> pure other + where + readKeyFile p mk = do + exists <- doesFileExist p + if not exists then pure (Right Nothing) else do + bytes <- BS.readFile p + -- base64 text, or the 32 raw bytes + let parsed = case decodeSeedText (TE.decodeLatin1 bytes) of + Right s -> Right s + Left _ -> seedFromBytes bytes + pure $ case parsed of + Right s -> Right (Just (s, mk p)) + Left e -> Left (T.pack p <> ": " <> e) + +-- | Where a new key goes. +data StorePref = StoreAuto | StoreFile | StoreKeychain + deriving (Eq, Show) + +-- | Is there already a key by this name in a store synapse writes (the +-- keychain or the file)? +keyExists :: StoreEnv -> Text -> IO (Maybe KeySource) +keyExists st name = do + inKc <- case stKeychain st of + Just kc -> kcLookup kc "plexus-key" (keyAttrs name) >>= \case + KcFound _ -> pure True + _ -> pure False + Nothing -> pure False + if inKc then pure (Just KeyFromKeychain) else do + let p = keyFilePath st name + e <- doesFileExist p + pure (if e then Just (KeyFromFile p) else Nothing) + +-- | Keep a key: the keychain when it answers (and is wanted), else the file. +writeKey :: StoreEnv -> StorePref -> Text -> Seed -> IO (Either Text KeySource) +writeKey st pref name seed = do + let secret = encodeSeedText seed + toFile = do + let p = keyFilePath st name + writePrivateFile p (TE.encodeUtf8 (secret <> "\n")) + pure (Right (KeyFromFile p)) + case (pref, stKeychain st) of + (StoreFile, _) -> toFile + (StoreKeychain, Nothing) -> pure (Left "no keychain answers here") + (_, Just kc) -> do + r <- kcStore kc ("plexus key " <> name) "plexus-key" (keyAttrs name) secret + case r of + Right () -> pure (Right KeyFromKeychain) + Left e | pref == StoreKeychain -> pure (Left ("the keychain refused: " <> e)) + | otherwise -> toFile + (StoreAuto, Nothing) -> toFile + +-- | Every key synapse can see by name: (name, where). +listKeys :: StoreEnv -> IO [(Text, KeySource)] +listKeys st = do + kcNamesFound <- case stKeychain st of + Just kc -> kcNames kc "plexus-key" "name" + Nothing -> pure [] + creds <- stEnv st "CREDENTIALS_DIRECTORY" + credNames <- case creds of + Just d | not (null d) -> keyFilesIn d + _ -> pure [] + fileNames <- keyFilesIn (stPlexus st "keys") + let kcs = [(n, KeyFromKeychain) | n <- nub kcNamesFound] + cs = [(n, KeyFromCredentials p) | (n, p) <- credNames, n `notElem` map fst kcs] + fs = [(n, KeyFromFile p) | (n, p) <- fileNames, n `notElem` map fst kcs, n `notElem` map fst cs] + pure (kcs <> cs <> fs) + where + keyFilesIn d = do + e <- doesDirectoryExist d + if not e then pure [] else do + fs <- sort <$> listDirectory d + pure [(T.pack (dropExtension f), d f) | f <- fs, takeExtension f == ".key"] + +-- ============================================================================ +-- Sessions +-- ============================================================================ + +-- | A session as synapse keeps it: the token, who it is, until when, and +-- what it was made from (the key's name, the scope and ttl asked) so it +-- can be made again. +data SessionRec = SessionRec + { srToken :: Text + , srPrincipal :: Text + , srAgent :: Text + , srExpiresAt :: Maybe Integer -- ^ unix seconds + , 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@) + } deriving (Eq, Show) + +instance ToJSON SessionRec where + toJSON s = object $ + [ "token" .= srToken s + , "principal" .= srPrincipal s + , "agent" .= srAgent s + , "expires_at" .= srExpiresAt s + , "key" .= srKey s + , "scope" .= srScope s + , "backend" .= srBackend s + ] <> maybe [] (\t -> ["ttl_secs" .= t]) (srTtl s) + +instance FromJSON SessionRec where + parseJSON = withObject "session" $ \o -> SessionRec + <$> o .: "token" + <*> o .:? "principal" .!= "" + <*> o .: "agent" + <*> o .:? "expires_at" + <*> o .:? "key" .!= "default" + <*> o .:? "scope" .!= [] + <*> o .:? "ttl_secs" + <*> o .:? "backend" .!= "" + +data SessionSource = SessionFromEnv | SessionFromKeychain | SessionFromFile FilePath + deriving (Eq, Show) + +-- | @HOST:PORT@, the backend a session belongs to (SCAFFOLD-21: the +-- whole URL for an address that is not plain @ws://HOST:PORT/@ — see +-- 'Synapse.Endpoint.addressKey'). +addressKey :: Endpoint -> Text +addressKey = E.addressKey + +sessionDir :: StoreEnv -> Endpoint -> FilePath +sessionDir st ep = stPlexus st "sessions" E.dirName ep + +sessionFilePath :: StoreEnv -> Endpoint -> Text -> FilePath +sessionFilePath st ep agent = sessionDir st ep (T.unpack agent <> ".json") + +sessionAttrs :: Endpoint -> Text -> [(Text, Text)] +sessionAttrs ep agent = [("backend", addressKey ep), ("agent", agent)] + +-- | The session for this backend and agent. @PLEXUS_SESSION@ is the token +-- alone: no record, nothing to sign in again from. +lookupSession :: StoreEnv -> Endpoint -> Text -> IO (Maybe (Either Text SessionRec, SessionSource)) +lookupSession st ep agent = do + envTok <- stEnv st "PLEXUS_SESSION" + case envTok of + Just t | not (null t) -> pure (Just (Left (T.strip (T.pack t)), SessionFromEnv)) + _ -> do + fromKc <- case stKeychain st of + Nothing -> pure Nothing + Just kc -> kcLookup kc "plexus-session" (sessionAttrs ep agent) >>= \case + KcFound v -> pure (A.decodeStrict (TE.encodeUtf8 v)) + _ -> pure Nothing + case fromKc of + Just r -> pure (Just (Right r, SessionFromKeychain)) + Nothing -> do + let p = sessionFilePath st ep agent + e <- doesFileExist p + if not e then pure Nothing else do + r <- A.decodeFileStrict p + pure ((\s -> (Right s, SessionFromFile p)) <$> r) + +-- | Keep a session: the keychain when it answers, else the file. +writeSession :: StoreEnv -> Endpoint -> SessionRec -> IO SessionSource +writeSession st ep s = do + let json = TE.decodeUtf8 (LBS.toStrict (A.encode s)) + p = sessionFilePath st ep (srAgent s) + toFile = do + writePrivateFile p (LBS.toStrict (A.encode s)) + pure (SessionFromFile p) + case stKeychain st of + Nothing -> toFile + Just kc -> do + r <- kcStore kc ("plexus session " <> addressKey ep <> " " <> srAgent s) + "plexus-session" (sessionAttrs ep (srAgent s)) json + case r of + Right () -> do + -- a stale file would shadow nothing (the keychain is read first) + -- but would outlive a logout's intent; drop it + removeIfExists p + pure SessionFromKeychain + Left _ -> toFile + +-- | Forget a session, wherever it is kept. +removeSession :: StoreEnv -> Endpoint -> Text -> IO () +removeSession st ep agent = do + mapM_ (\kc -> kcClear kc "plexus-session" (sessionAttrs ep agent)) (stKeychain st) + removeIfExists (sessionFilePath st ep agent) + +defaultAgentPath :: StoreEnv -> Endpoint -> FilePath +defaultAgentPath st ep = sessionDir st ep "default" + +-- | The agent a backend's calls go as when none is named. +readDefaultAgent :: StoreEnv -> Endpoint -> IO (Maybe Text) +readDefaultAgent st ep = do + let p = defaultAgentPath st ep + e <- doesFileExist p + if not e then pure Nothing else do + t <- T.strip <$> TIO.readFile p + pure (if validAgent t then Just t else Nothing) + +writeDefaultAgent :: StoreEnv -> Endpoint -> Text -> IO () +writeDefaultAgent st ep agent = + writePrivateFile (defaultAgentPath st ep) (TE.encodeUtf8 (agent <> "\n")) + +-- | Drop the default when it names this agent. +clearDefaultAgent :: StoreEnv -> Endpoint -> Text -> IO () +clearDefaultAgent st ep agent = do + cur <- readDefaultAgent st ep + when (cur == Just agent) $ removeIfExists (defaultAgentPath st ep) + +-- ============================================================================ +-- Files +-- ============================================================================ + +-- | Write a file only its owner can read: its directory 0700, the file +-- 0600 from the moment it exists, replaced atomically. +-- +-- SYNAPSE-15: each writer has a temporary file of its own +-- (@NAME.tmpNNN@, created with O_EXCL and 0600 by 'openBinaryTempFile'), +-- renamed over the target; parallel writers never touch each other's +-- file, and the last rename wins. Before, every writer used @NAME.tmp@, +-- and one removed another's between its write and its rename. +writePrivateFile :: FilePath -> BS.ByteString -> IO () +writePrivateFile p bytes = do + let dir = takeDirectory p + privateDir dir + (tmp, h) <- openBinaryTempFile dir (takeFileName p <> ".tmp") + (do setFileMode tmp 0o600 + BS.hPut h bytes + hClose h + renameFile tmp p) + `onException` (hClose h >> removeIfExists tmp) + +foreign import ccall safe "sys/file.h flock" c_flock :: CInt -> CInt -> IO CInt + +-- | flock's LOCK_EX. +lockEx :: CInt +lockEx = 2 + +-- | A directory only its owner can enter, made if missing. +privateDir :: FilePath -> IO () +privateDir dir = do + existed <- doesDirectoryExist dir + createDirectoryIfMissing True dir + unless existed $ setFileMode dir 0o700 + +-- | SYNAPSE-15: hold the agent's session lock at this backend (an advisory +-- lock on @AGENT.lock@ beside its session) for the action — so of the +-- processes that find the session stale at once, one signs in again and +-- the others, waiting here, find its new session when they read again. +withSessionLock :: StoreEnv -> Endpoint -> Text -> IO a -> IO a +withSessionLock st ep agent act = do + let lockPath = sessionDir st ep (T.unpack agent <> ".lock") + -- flock on a descriptor of our own (not a GHC handle: GHC refuses a + -- second writer of one file within a process): processes and threads + -- alike wait their turn; closing the descriptor lets the next one in + opened <- try (privateDir (takeDirectory lockPath) >> createFile lockPath 0o600) + case opened of + -- a lock that cannot be had (a read-only store) is no reason to fail + -- the call: it goes on unserialised, as before + Left (_ :: SomeException) -> act + Right fd -> flip finally (closeFd fd) $ do + throwErrnoIfMinus1RetryMayBlock_ "flock" (c_flock (fromIntegral fd) lockEx) (pure ()) + act + +removeIfExists :: FilePath -> IO () +removeIfExists p = removeFile p `catch` \(_ :: SomeException) -> pure () diff --git a/src/Synapse/Monad.hs b/src/Synapse/Monad.hs --- a/src/Synapse/Monad.hs +++ b/src/Synapse/Monad.hs @@ -20,8 +20,14 @@ -- * Environment , SynapseEnv(..) + , seHost + , sePort , initEnv + , initEnvAt , defaultEnv + , withRequestContext + , withViewKey + , viewQualified -- * Errors , SynapseError(..) @@ -61,18 +67,21 @@ import Synapse.Schema.Types import Synapse.Backend.Discovery (Backend(..)) +import Synapse.Endpoint (Endpoint(..), plainAt) import qualified Synapse.Log as Log import qualified Katip -- | Environment for Synapse operations data SynapseEnv = SynapseEnv - { seHost :: !Text -- ^ Hub host - , sePort :: !Int -- ^ Hub port + { seEndpoint :: !Endpoint -- ^ Where the hub 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 , seLogger :: !Log.Logger -- ^ Structured logger , seToken :: !(Maybe Text) -- ^ JWT sent as Cookie: access_token= + , 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 } -- | Errors that can occur during Synapse operations @@ -137,21 +146,46 @@ env <- defaultEnv backend logger runSynapseM env action --- | Initialize environment with given host/port/backend/logger/token +-- | The hub's host. +seHost :: SynapseEnv -> Text +seHost = epHost . seEndpoint + +-- | The hub'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). +-- 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 backend logger token = do +initEnv host port = initEnvAt (plainAt host port) + +-- | SCAFFOLD-21: 'initEnv' for a hub 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 pure SynapseEnv - { seHost = host - , sePort = port + { seEndpoint = ep , seBackend = backend , seCache = cache , seVisited = visited , seLogger = logger , seToken = token + , seCookies = [] + , seHeaders = [] + , seViewKey = Nothing } +-- | Augment a SynapseEnv with extra cookies and headers for the WS upgrade. +-- (SAFE-S04/REQ-5: --cookie/--header CLI flags and SYNAPSE_COOKIE_*/SYNAPSE_HEADER_* env) +withRequestContext :: [(Text, Text)] -> [(Text, Text)] -> SynapseEnv -> SynapseEnv +withRequestContext cookies headers env = env + { seCookies = seCookies env ++ cookies + , seHeaders = seHeaders env ++ headers + } + -- | Default environment (localhost:4444, requires backend and logger) defaultEnv :: Text -> Log.Logger -> IO SynapseEnv defaultEnv backend logger = initEnv "127.0.0.1" 4444 backend logger Nothing @@ -209,14 +243,30 @@ lookupCache :: PluginHash -> SynapseM (Maybe PluginSchema) lookupCache hash = do cacheRef <- asks seCache + key <- asks (\e -> viewQualified (seViewKey e) hash) cache <- liftIO $ readIORef cacheRef - pure $ HM.lookup hash cache + pure $ HM.lookup key cache -- | Insert a schema into the cache insertCache :: PluginHash -> PluginSchema -> SynapseM () insertCache hash schema = do cacheRef <- asks seCache - liftIO $ modifyIORef' cacheRef (HM.insert hash schema) + key <- asks (\e -> viewQualified (seViewKey e) hash) + 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 +-- both. +viewQualified :: Maybe Text -> Text -> Text +viewQualified Nothing hash = hash +viewQualified (Just v) hash + | T.null v = hash + | otherwise = v <> "/" <> hash + +-- | AUTH-8: the view this env's calls see (from @_info@). +withViewKey :: Maybe Text -> SynapseEnv -> SynapseEnv +withViewKey v env = env { seViewKey = v } -- ============================================================================ -- Logging and Config diff --git a/src/Synapse/Reconnect.hs b/src/Synapse/Reconnect.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Reconnect.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | SYNAPSE-20: synapse rides out an outage. +-- +-- A lost connection is noticed by the client (plexus-protocol's +-- 'Plexus.Client': a close, a reset, or a keepalive ping unanswered), and +-- reported as 'PT.ConnectionLost'. Here is what synapse does about it: +-- +-- * it tries again for the reconnect window (@--reconnect-for@, +-- @SYNAPSE_RECONNECT_FOR@; ten minutes unless told), backing off from +-- 0.5 s, doubling, to 15 s, and saying so on stderr — never stdout; +-- * a read is sent again; a write whose request went out is not — the +-- write may have happened, so synapse says so and exits 'exitWriteUnknown'; +-- a write whose request never left is sent when the connection is back; +-- * a stream is subscribed again with the same params — and with +-- @since@ set to when the call began, when the method takes one and the +-- caller gave none (@await_reply@), so nothing said during the outage is +-- 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. +module Synapse.Reconnect + ( -- * The window + setReconnectWindow + , reconnectWindow + , defaultWindow + , parseDuration + , renderDuration + + -- * What a call is + , CallShape(..) + , callShape + , readNames + + -- * Running a call through an outage + , Resumed(..) + , Ending(..) + , resilientCall + , retrying + , awaitBackend + , isOutage + , isOutageText + , giveUp + , reportEnding + + -- * Exit codes + , exitUnreachable + , exitWriteUnknown + ) where + +import Control.Concurrent (threadDelay) +import Data.Aeson (Value(..)) +import qualified Data.Aeson.KeyMap as KM +import Data.Char (isDigit) +import Data.IORef +import Data.List (find) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Time.Clock.POSIX (getPOSIXTime) +import GHC.Clock (getMonotonicTime) +import System.Exit (ExitCode(..), exitWith) +import System.IO (hFlush, stderr) +import System.IO.Unsafe (unsafePerformIO) + +import Plexus.Schema.Recursive (MethodSchema(..)) +import qualified Plexus.Types as PT + +-- --------------------------------------------------------------------------- +-- The window + +-- | Ten minutes (owner, 2026-10-17: "at least 10 minutes of outage"). +defaultWindow :: Double +defaultWindow = 600 + +{-# NOINLINE windowRef #-} +windowRef :: IORef Double +windowRef = unsafePerformIO (newIORef defaultWindow) + +-- | Set once, at start, from @--reconnect-for@ / @SYNAPSE_RECONNECT_FOR@. +setReconnectWindow :: Double -> IO () +setReconnectWindow = writeIORef windowRef . max 0 + +reconnectWindow :: IO Double +reconnectWindow = readIORef windowRef + +-- | @10m@, @90s@, @1h@, @1m30s@, @600@ (seconds), @0@ (never). +parseDuration :: Text -> Maybe Double +parseDuration t0 = case T.unpack (T.toLower (T.strip t0)) of + "" -> Nothing + s | all isDigit s -> Just (read s) + | otherwise -> go 0 s + where + go acc [] = Just acc + go acc s = case span isDigit s of + ([], _) -> Nothing + (ds, u : rest) | Just k <- unit u -> go (acc + read ds * k) rest + _ -> Nothing + unit 'h' = Just 3600 + unit 'm' = Just 60 + unit 's' = Just 1 + unit _ = Nothing + +-- | @2m10s@, @10m@, @45s@, @1h@. +renderDuration :: Double -> Text +renderDuration d = + let n = max 0 (round d) :: Int + (h, r) = n `divMod` 3600 + (m, s) = r `divMod` 60 + part v u = if v > 0 then T.pack (show v) <> u else "" + in if n == 0 then "0s" else part h "h" <> part m "m" <> part s "s" + +-- --------------------------------------------------------------------------- +-- What a call is + +-- | What decides how a call rides out an outage. +data CallShape = CallShape + { csStream :: Bool -- ^ the method streams (a watch, await_reply) + , csRead :: Bool -- ^ sending it again is safe + , csSince :: Bool -- ^ it takes a @since@ a resumed call can carry + } deriving (Eq, Show) + +-- | A method's shape from its schema: a read when its group says @read@ +-- (menger's methods do), else when its name is a read's; anything else — +-- and anything bidirectional — is a write, never sent twice. +callShape :: MethodSchema -> CallShape +callShape m = CallShape + { csStream = methodStreaming m + , csRead = not (methodBidirectional m) && isRead + , csSince = takesSince (methodParams m) + } + where + isRead = case methodGroup m of + Just "read" -> True + Just "write" -> False + _ -> methodName m `elem` readNames + takesSince (Just (Object o)) + | Just (Object props) <- KM.lookup "properties" o = KM.member "since" props + takesSince _ = False + +-- | Method names that only read, for a schema that groups nothing. +readNames :: [Text] +readNames = + [ "schema", "hash", "hashes", "health", "get", "list", "find", "search", "show" + , "history", "watch", "await_reply", "await_message", "queued", "whoami" + , "providers", "mine", "requests", "counts", "tree", "groups", "extents" + , "facets", "member", "ready", "waves", "waves_under", "waves_to", "blockers" + , "messages", "candidates", "environments", "running", "for_ticket" + , "theme_for", "roles", "requires", "waiting" + ] + +-- --------------------------------------------------------------------------- +-- Outages + +-- | A failure that is the backend being away, not a fault in the call. +isOutage :: PT.TransportError -> Bool +isOutage = \case + PT.ConnectionRefused{} -> True + PT.ConnectionTimeout{} -> True + PT.ConnectionLost{} -> True + PT.NetworkError msg -> isOutageText msg + PT.ProtocolError msg -> tooMany msg || gatewayDown msg + +-- | The server's connection limits (ACCESS-29): a 429 at the upgrade. +tooMany :: Text -> Bool +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. +gatewayDown :: Text -> Bool +gatewayDown msg = any (`T.isInfixOf` T.toLower msg) + ["responsecode = 502", "responsecode = 503", "responsecode = 504"] + +-- | The same, read from a message (the probe says why as text). A refused +-- upgrade (401, 403, 421) is not an outage. +isOutageText :: Text -> Bool +isOutageText msg = any (`T.isInfixOf` T.toLower msg) + [ "refused", "timed out", "timeout", "reset by peer", "connectionlost" + , "connection lost", "broken pipe", "connectionclosed", "end of file" + , "no route to host", "network is unreachable", "does not exist (connection" + -- 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 + , "responsecode = 502", "responsecode = 503", "responsecode = 504" + ] + +-- | The upgrade's 401: the credential refused (IDENTITY-43's test). +upgradeRefused :: PT.TransportError -> Bool +upgradeRefused e = any (`T.isInfixOf` reasonOf e) ["responseCode = 401", " 401 ", "(401)", "Unauthorized"] + +-- | Whether a lost call's request had gone out. +sentOf :: PT.TransportError -> Bool +sentOf (PT.ConnectionLost _ s) = s +sentOf _ = False + +reasonOf :: PT.TransportError -> Text +reasonOf = \case + PT.ConnectionRefused{} -> "connection refused" + PT.ConnectionTimeout{} -> "connection timed out" + PT.ConnectionLost m _ -> m + PT.NetworkError m -> m + PT.ProtocolError m -> m + +-- | A reason as a person says it (the probe's is a shown error). +plainReason :: Text -> Text +plainReason why + | "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" + | otherwise = why + +-- | An outage under way: when it began, how many tries, the next pause. +data Outage = Outage + { oStart :: Double + , oAttempts :: Int + , oDelay :: Double + } + +say :: Text -> IO () +say t = TIO.hPutStrLn stderr ("synapse: " <> t) >> hFlush stderr + +-- | Pause before the next try, or 'Nothing' when the window is spent. +pause :: Text -> Double -> Text -> Maybe Outage -> IO (Maybe Outage) +pause = pauseAs True + +-- | 'pause', saying the outage began as a lost connection or (at start) a +-- backend not reached. +pauseAs :: Bool -> Text -> Double -> Text -> Maybe Outage -> IO (Maybe Outage) +pauseAs lost whereTo window why mo = do + now <- getMonotonicTime + o <- case mo of + Just o -> pure o + Nothing -> do + say $ (if lost then "connection to " <> whereTo <> " lost (" else "cannot reach " <> whereTo <> " (") + <> plainReason why <> ") — " <> (if lost then "reconnecting" else "waiting") + <> " for up to " <> renderDuration window + pure (Outage now 0 0.5) + let elapsed = now - oStart o + left = window - elapsed + if left <= 0 + then pure Nothing + else do + let d = min (oDelay o) left + say $ "retrying " <> whereTo <> " in " <> renderDuration' d <> " (" + <> renderDuration elapsed <> " of " <> renderDuration window <> ")" + threadDelay (round (d * 1000000)) + pure (Just o { oAttempts = oAttempts o + 1, oDelay = min 15 (oDelay o * 2) }) + where + renderDuration' d | d < 1 = T.pack (show (fromIntegral (round (d * 10) :: Int) / 10 :: Double)) <> "s" + | otherwise = renderDuration d + +-- --------------------------------------------------------------------------- +-- Running a call through an outage + +-- | A call that resumed after it had delivered something: how long the +-- outage was, how many tries it took, and the @since@ it carried (if it did). +data Resumed = Resumed + { rsOutageSecs :: Double + , rsAttempts :: Int + , rsSince :: Maybe Integer + } deriving (Eq, Show) + +-- | How a call ended. +data Ending + = Finished + | 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 + deriving (Eq, Show) + +-- | Run a call, one attempt at a time, through any outage within the +-- window. @attempt params onSubscribed onItem@ is one try. @onResume@ is +-- told, as soon as a try after an outage is taken by the server, that the +-- call resumed — for a stream always (what was said in the gap may be +-- missing, unless it carried @since@), for a unary read when it had +-- already delivered part of its answer. +resilientCall + :: Text + -> CallShape + -> (Value -> IO () -> (PT.PlexusStreamItem -> IO ()) -> IO (Either PT.TransportError ())) + -> IO Bool + -- ^ after an outage, the server refused the credential at the upgrade + -- (it lost its sessions in the restart): sign in again, True when a new + -- credential is in place for the next try + -> Value + -> (Resumed -> IO ()) + -> (PT.PlexusStreamItem -> IO ()) + -> IO Ending +resilientCall whereTo shape attempt reauth params0 onResume onItem = do + window <- reconnectWindow + began <- (floor <$> getPOSIXTime) :: IO Integer + everDelivered <- newIORef False + let 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 + unset Nothing = True + unset (Just Null) = True + unset _ = False + paramsFor n = case (sinceFor n, params0) of + (Just s, Object o) -> Object (KM.insert "since" (Number (fromInteger s)) o) + _ -> params0 + go n outage = goAuth n outage False + goAuth n outage reauthed = do + taken <- newIORef False + let subscribed = do + writeIORef taken True + case outage of + Just o -> do + now <- getMonotonicTime + say $ "reconnected to " <> whereTo <> " after " <> renderDuration (now - oStart o) + before <- readIORef everDelivered + 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 + r <- attempt (paramsFor n) subscribed item + 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 + | Just _ <- outage', not reauthed, upgradeRefused e -> do + -- the server came back without the session: once per + -- outage, sign in again and try at once + ok <- reauth + if ok then goAuth (n + 1) outage' True else pure (Failed e) + | not (isOutage e) -> pure (Failed e) + | sentOf e && not (csRead shape) -> pure (WriteUnknown (reasonOf e)) + | window <= 0 -> pure (Failed e) + | otherwise -> do + next <- pause whereTo window (reasonOf e) outage' + case next of + Nothing -> pure (GaveUp window (reasonOf e)) + Just o -> goAuth (n + 1) (Just o) (reauthed && not t) + go 0 Nothing + +-- | A call that is safe to repeat (a schema fetch), tried through an +-- outage within the window; when the window runs out, synapse exits. +retrying :: Text -> IO (Either PT.TransportError a) -> IO (Either PT.TransportError a) +retrying whereTo act = do + window <- reconnectWindow + let go outage = do + r <- act + case r of + Left e | isOutage e, window > 0 -> do + next <- pause whereTo window (reasonOf e) outage + case next of + Nothing -> giveUp whereTo window (reasonOf e) + Just o -> go (Just o) + _ -> do + case (r, outage) of + (Right _, Just o) -> do + now <- getMonotonicTime + say $ "reconnected to " <> whereTo <> " after " <> renderDuration (now - oStart o) + _ -> pure () + pure r + go Nothing + +-- | The probe at start, tried through an outage within the window: while +-- it fails as an outage does (refused, timed out, reset), wait and try +-- again; any other answer is the caller's. +awaitBackend :: (Text -> Bool) -> Text -> IO (Either Text a) -> IO (Either Text a) +awaitBackend outage whereTo act = do + window <- reconnectWindow + let go o0 = do + r <- act + case r of + Left why | outage why, window > 0 -> do + next <- pauseAs False whereTo window why o0 + case next of + Nothing -> giveUp whereTo window (plainReason why) + Just o -> go (Just o) + _ -> do + case (r, o0) of + (Right _, Just o) -> do + now <- getMonotonicTime + say $ "reconnected to " <> whereTo <> " after " <> renderDuration (now - oStart o) + _ -> pure () + pure r + go Nothing + +-- --------------------------------------------------------------------------- +-- Endings + +-- | sysexits' EX_UNAVAILABLE: the backend stayed away for the whole window. +exitUnreachable :: Int +exitUnreachable = 69 + +-- | sysexits' EX_TEMPFAIL: a write went out and its answer never came; it +-- may have happened. +exitWriteUnknown :: Int +exitWriteUnknown = 75 + +giveUp :: Text -> Double -> Text -> IO a +giveUp whereTo window why = do + say $ whereTo <> " unreachable for " <> renderDuration window <> " (" <> why + <> ") — giving up; --reconnect-for sets how long to wait" + exitWith (ExitFailure exitUnreachable) + +-- | The endings that are synapse's to report: a spent window and a write +-- of unknown outcome exit here; the others go back to the caller. +reportEnding :: Text -> Ending -> IO (Either PT.TransportError ()) +reportEnding whereTo = \case + Finished -> pure (Right ()) + Failed e -> pure (Left e) + GaveUp window why -> giveUp whereTo window why + WriteUnknown why -> do + say $ "connection to " <> whereTo <> " lost before an answer (" <> why + <> ") — the write may have happened; check before sending it again" + exitWith (ExitFailure exitWriteUnknown) diff --git a/src/Synapse/Self.hs b/src/Synapse/Self.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Public surface for the per-backend defaults store. +-- +-- Defaults live at @~\/.plexus\/\\/defaults.json@ (see 'defaultsPath'). +-- The file is a manifest of credential *references* — URIs like +-- @keychain:\/\/svc\/account@ or @literal:raw-value@ — that a resolver +-- registry ('Synapse.Self.Resolve') dereferences at dispatch time. +-- +-- This ticket (SELF-1) establishes the types, file format, and resolver +-- API. Actual IO wiring lives in SELF-2 (read), SELF-4 (CLI), SELF-5 +-- (write), SELF-7 (core resolvers), SELF-8 (keychain). +module Synapse.Self + ( -- * File path + defaultsPath + + -- * On-disk types and encoding + , StoredDefaults(..) + , CredentialRef(..) + , ScopedDefaults(..) + , emptyStoredDefaults + , currentVersion + , encodeDefaults + , decodeDefaults + + -- * Resolver API + , ParsedUri(..) + , ParsedUriBody(..) + , parseUri + , Resolver(..) + , ResolveFn + , NamedResolver(..) + , ResolverRegistry(..) + , emptyRegistry + , registerResolver + , registerNamedResolver + , lookupResolver + , resolveRef + , ResolveError(..) + + -- * Core resolvers + , literalResolver + , envResolver + , fileResolver + , keychainResolver + , storeInKeychain + , deleteFromKeychain + , isKeychainPlatform + , defaultRegistry + + -- * Read path (SELF-2): load, resolve, merge + , ResolvedDefaults(..) + , emptyResolvedDefaults + , MethodPath + , Cookies + , Headers + , loadDefaults + , resolveAll + , merge + + -- * Write path (SELF-4 stub; SELF-5 tightens) + , writeDefaults + + -- * Token sugar (SELF-6) + , resolveToken + ) where + +import qualified Control.Exception as E +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Map.Strict as Map +import System.FilePath (()) + +import Synapse.Self.IO + ( Cookies + , Headers + , MethodPath + , ResolvedDefaults(..) + , emptyResolvedDefaults + , loadDefaults + , merge + , resolveAll + , writeDefaults + ) +import Synapse.Self.Resolve +import Synapse.Self.Resolve.Default (defaultRegistry) +import Synapse.Self.Resolve.Env (envResolver) +import Synapse.Self.Resolve.File (fileResolver) +import Synapse.Self.Resolve.Keychain + ( deleteFromKeychain + , isKeychainPlatform + , keychainResolver + , storeInKeychain + ) +import Synapse.Self.Resolve.Literal (literalResolver) +import Synapse.Self.Types + +-- | Path to a backend\'s defaults file: @~\/.plexus\/\\/defaults.json@. +-- +-- The returned path is relative to @~@ only in the sense that it begins +-- with the literal string @~\/@ — callers wanting the absolute path should +-- expand via 'System.Directory.getHomeDirectory'. This split lets pure +-- code compute the path without IO; the disk IO wiring (SELF-2 / SELF-5) +-- performs the expansion. +defaultsPath :: Text -> FilePath +defaultsPath backend = + "~" ".plexus" T.unpack backend "defaults.json" + +-- | Resolve the @cookies.access_token@ entry from a backend's defaults +-- store. Returns 'Nothing' when the file is missing, the cookie is +-- absent, or the ref fails to resolve. +-- +-- This is the \"sugar\" seam SELF-6 uses to collapse +-- @SynapseCC.Auth.resolveToken@'s final fallback onto 'Synapse.Self'. +-- It is deliberately conservative: +-- +-- * IO errors on 'loadDefaults' (permissions, corrupt JSON, etc.) +-- swallow to 'Nothing'. Callers that care can still use +-- 'loadDefaults' + 'resolveRef' directly for loud behavior. +-- * Resolve errors swallow to 'Nothing' for the same reason. +-- * An empty resolved value is treated as \"not set\" ('Nothing'). +-- +-- The loud variant (exit on IO / resolve failure) lives in +-- @buildEnv@ in the synapse executable because that path *must* fail +-- an unauthenticated request rather than silently drop the token. +-- Here — the fallback path, invoked only after explicit CLI / env +-- sources have been exhausted — a soft 'Nothing' is the right default. +resolveToken :: Text -> IO (Maybe Text) +resolveToken backend = do + eStored <- E.try (loadDefaults backend) :: IO (Either E.IOException StoredDefaults) + case eStored of + Left _ -> pure Nothing + Right stored -> case Map.lookup "access_token" (sdCookies stored) of + Nothing -> pure Nothing + Just ref -> do + r <- resolveRef defaultRegistry ref + case r of + Right tok | not (T.null tok) -> pure (Just tok) + _ -> pure Nothing diff --git a/src/Synapse/Self/Command.hs b/src/Synapse/Self/Command.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Command.hs @@ -0,0 +1,1020 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} + +-- | The @synapse _self \ \ ...@ command tree (SELF-4). +-- +-- This module is the user-facing surface of the per-backend defaults store +-- introduced in SELF-1 / SELF-2 / SELF-7. It exposes: +-- +-- * A 'SelfCommand' ADT covering every verb in the ticket spec. +-- * A single 'runSelfCommand' entry point that returns an 'ExitCode' so +-- callers don't have to know the (stdout / stderr / exit status) +-- contract of each individual verb. +-- * 'parseSelfCommand' — an optparse-applicative parser the executable +-- wires into @app\/Main.hs@. +-- +-- Keeping the handlers here (rather than in @app@) lets @synapse-cc@ +-- reuse the same code via SELF-6 without duplicating parsing or output +-- logic. +-- +-- __Verbs:__ +-- +-- @ +-- show [--json] +-- set cookie|header \ \ +-- set-from-stdin cookie|header \ +-- set-secret cookie|header \ -- friendly error until SELF-8 +-- unset cookie|header \ [--yes] [--no-delete-from-keychain] +-- resolve cookie|header \ +-- upgrade-to-keychain [cookie|header] [\] -- friendly error until SELF-8 +-- clear [--yes] +-- import-token \ [--to-keychain] -- --to-keychain requires SELF-8 +-- @ +module Synapse.Self.Command + ( -- * Command ADT + SelfCommand(..) + , SelfKind(..) + , kindLabel + , renderKind + + -- * Execution + , runSelfCommand + + -- * Parser (optparse-applicative) + , parseSelfCommand + , selfCommandInfo + + -- * Set-value heuristic (exported for testing) + , knownSchemes + , wrapAsLiteralIfNeeded + + -- * JWT inspection (exported for testing) + , JwtSummary(..) + , JwtClaim(..) + , decodeJwt + , renderJwtSummary + , renderRelativeExpiry + ) where + +import Control.Exception (IOException) +import qualified Control.Exception as E +import Data.Aeson (Value(..), (.=), object, eitherDecodeStrict') +import Data.Aeson.Encode.Pretty (Config(..), Indent(..), NumberFormat(..), encodePretty') +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Format (defaultTimeLocale, formatTime) +import Options.Applicative +import System.Directory (doesFileExist, removeFile) +import System.Exit (ExitCode(..)) +import System.IO (hFlush, isEOF, stderr, stdout) + +import Synapse.Self + ( CredentialRef(..) + , ParsedUri(..) + , ParsedUriBody(..) + , ResolveError(..) + , ResolverRegistry + , StoredDefaults(..) + , defaultRegistry + , defaultsPath + , deleteFromKeychain + , emptyStoredDefaults + , isKeychainPlatform + , loadDefaults + , parseUri + , resolveRef + , storeInKeychain + , writeDefaults + ) +import qualified Synapse.Self.IO as SelfIO + +-- | Keychain service name for items created by @_self@ verbs. +-- Constant across backends — the per-backend key lives in the account. +keychainService :: Text +keychainService = "plexus" + +-- | Keychain account name for a given (backend, kind, name). +-- Convention: @\\/\\/\@. +keychainAccountFor :: Text -> SelfKind -> Text -> Text +keychainAccountFor backend k name = + backend <> "/" <> renderKind k <> "/" <> name + +-- ============================================================================ +-- ADT +-- ============================================================================ + +-- | Cookies vs. headers. The defaults file carries both; every verb +-- except @clear@ / @show@ / @import-token@ / bare @upgrade-to-keychain@ +-- requires a kind. +data SelfKind = Cookie | Header + deriving (Show, Eq) + +-- | The 'StoredDefaults' field name for a kind — @"cookies"@ or @"headers"@. +kindLabel :: SelfKind -> Text +kindLabel Cookie = "cookies" +kindLabel Header = "headers" + +-- | Singular noun for messages. +renderKind :: SelfKind -> Text +renderKind Cookie = "cookie" +renderKind Header = "header" + +-- | Every verb in the @_self@ subcommand tree. Each value fully +-- determines the resulting 'IO' behavior — 'runSelfCommand' is a pure +-- dispatcher over this type. +data SelfCommand + = CmdShow !Text !Bool + -- ^ @show [--json]@. Backend, jsonMode. + | CmdSet !Text !SelfKind !Text !Text + -- ^ @set cookie|header \ \@. + -- The value goes through 'wrapAsLiteralIfNeeded' before storage. + | CmdSetFromStdin !Text !SelfKind !Text + -- ^ @set-from-stdin cookie|header \@. Reads full stdin, + -- stores as @literal:\@ regardless of scheme prefix. + | CmdSetSecret !Text !SelfKind !Text + -- ^ @set-secret cookie|header \@. Requires SELF-8; emits a + -- friendly error until then. + | CmdUnset !Text !SelfKind !Text !Bool !Bool + -- ^ @unset cookie|header \@. Flags: @--yes@, + -- @--no-delete-from-keychain@. + | CmdResolve !Text !SelfKind !Text + -- ^ @resolve cookie|header \@. Prints resolved value to + -- stdout; errors to stderr; exits non-zero on failure. + | CmdUpgrade !Text !(Maybe SelfKind) !(Maybe Text) + -- ^ @upgrade-to-keychain [cookie|header] [\]@. Friendly error + -- until SELF-8 regardless of arguments. + | CmdClear !Text !Bool + -- ^ @clear [--yes]@. Deletes the backend\'s defaults.json (not the + -- directory). + | CmdImportToken !Text !Text !Bool + -- ^ @import-token \ [--to-keychain]@. Path @"-"@ = stdin. + -- @--to-keychain@ requires SELF-8. + deriving (Show, Eq) + +-- ============================================================================ +-- Known schemes (static; see SELF-4 ticket) +-- ============================================================================ + +-- | The set of scheme prefixes a @set\@ argument can +-- carry to skip the literal wrapper. Static on purpose: this must not +-- depend on the runtime registry because SELF-8 (keychain) wires in +-- its resolver dynamically, and SELF-4 predates that. +-- +-- Bare strings matching none of these get wrapped as @literal:\@. +knownSchemes :: [Text] +knownSchemes = + [ "literal:" + , "env://" + , "file://" + , "keychain://" + , "vault://" + , "aws-secrets://" + , "gcp-secret://" + ] + +-- | Wrap a value as @literal:\@ unless it begins with one of +-- the 'knownSchemes'. Preserves leading\/trailing whitespace so pasted +-- tokens round-trip byte-for-byte through @set@ / @resolve@. +wrapAsLiteralIfNeeded :: Text -> Text +wrapAsLiteralIfNeeded v + | any (`T.isPrefixOf` v) knownSchemes = v + | otherwise = "literal:" <> v + +-- ============================================================================ +-- Parser +-- ============================================================================ + +-- | Full @ParserInfo@ for @_self@. The executable attaches this under +-- its top-level @_self@ subcommand; @synapse-cc@ does the same. +selfCommandInfo :: ParserInfo SelfCommand +selfCommandInfo = info (parseSelfCommand <**> helper) + ( fullDesc + <> progDesc "Manage per-backend defaults (cookies, headers, credentials)" + <> header "synapse _self - backend credential management" + ) + +-- | The @\ \ ...@ parser. Exposed separately so the +-- @_self@ level can be folded under a parent @synapse ...@ parser +-- without double-@helper@. +parseSelfCommand :: Parser SelfCommand +parseSelfCommand = + mkCmd <$> backendArg <*> verbSub + where + mkCmd b f = f b + + backendArg = argument (T.pack <$> str) + ( metavar "BACKEND" + <> help "Backend name (directory under ~/.plexus/)" + ) + + verbSub :: Parser (Text -> SelfCommand) + verbSub = hsubparser + ( command "show" (info showCmd (progDesc "Show effective defaults with resolved values")) + <> command "set" (info setCmd (progDesc "Set a cookie or header to a value or URI")) + <> command "set-from-stdin" (info setFromStdinCmd (progDesc "Set a cookie or header from stdin (always literal:)")) + <> command "set-secret" (info setSecretCmd (progDesc "Push stdin to keychain and store a keychain:// ref")) + <> command "unset" (info unsetCmd (progDesc "Remove a cookie or header entry")) + <> command "resolve" (info resolveCmd (progDesc "Resolve and print a cookie or header value")) + <> command "upgrade-to-keychain" (info upgradeCmd (progDesc "Move literal: refs into the keychain")) + <> command "clear" (info clearCmd (progDesc "Delete this backend's defaults.json")) + <> command "import-token" (info importTokenCmd (progDesc "Import a JWT from file or stdin as access_token")) + ) + + showCmd = (\j b -> CmdShow b j) + <$> switch (long "json" <> help "Emit JSON (machine-readable)") + setCmd = (\k n v b -> CmdSet b k n v) + <$> kindArg + <*> nameArg + <*> argument (T.pack <$> str) (metavar "VALUE-OR-URI" <> help "Raw value, or a scheme-prefixed URI (literal:, env://, file://, keychain://, vault://)") + setFromStdinCmd = (\k n b -> CmdSetFromStdin b k n) <$> kindArg <*> nameArg + setSecretCmd = (\k n b -> CmdSetSecret b k n) <$> kindArg <*> nameArg + unsetCmd = (\k n y nk b -> CmdUnset b k n y nk) + <$> kindArg + <*> nameArg + <*> switch (long "yes" <> short 'y' <> help "Skip confirmation prompts") + <*> switch (long "no-delete-from-keychain" <> help "If ref was keychain://, do not attempt to delete the keychain item") + resolveCmd = (\k n b -> CmdResolve b k n) <$> kindArg <*> nameArg + upgradeCmd = (\k n b -> CmdUpgrade b k n) + <$> optional kindArg + <*> optional nameArg + clearCmd = (\y b -> CmdClear b y) + <$> switch (long "yes" <> short 'y' <> help "Skip confirmation") + importTokenCmd = (\p kc b -> CmdImportToken b p kc) + <$> argument (T.pack <$> str) (metavar "PATH-OR--" <> help "Path to a JWT file; \"-\" reads from stdin") + <*> switch (long "to-keychain" <> help "Push token to keychain and store a keychain:// ref (requires SELF-8)") + + kindArg = argument kindReader (metavar "KIND" <> help "cookie | header") + nameArg = argument (T.pack <$> str) (metavar "NAME" <> help "Cookie or header name") + + kindReader = eitherReader $ \case + "cookie" -> Right Cookie + "cookies" -> Right Cookie + "header" -> Right Header + "headers" -> Right Header + s -> Left ("expected 'cookie' or 'header', got: " <> s) + +-- ============================================================================ +-- Execution +-- ============================================================================ + +-- | Run a parsed 'SelfCommand'. Returns an 'ExitCode' rather than +-- calling 'exitWith' so callers can compose. +runSelfCommand :: SelfCommand -> IO ExitCode +runSelfCommand = \case + CmdShow b jsonMode -> runShow b jsonMode + CmdSet b k n v -> runSet b k n (wrapAsLiteralIfNeeded v) + CmdSetFromStdin b k n -> runSetFromStdin b k n + CmdSetSecret b k n + | isKeychainPlatform -> runSetSecret b k n + | otherwise -> keychainUnavailable "set-secret" + CmdUnset b k n yes noKeychain -> runUnset b k n yes noKeychain + CmdResolve b k n -> runResolve b k n + CmdUpgrade b mk mn + | isKeychainPlatform -> runUpgrade b mk mn + | otherwise -> keychainUnavailable "upgrade-to-keychain" + CmdClear b yes -> runClear b yes + CmdImportToken b path toKc -> runImportToken b path toKc + +-- --------------------------------------------------------------------------- +-- Helpers shared by verbs +-- --------------------------------------------------------------------------- + +keychainUnavailable :: Text -> IO ExitCode +keychainUnavailable verb = do + TIO.hPutStrLn stderr $ T.concat + [ "Error: `", verb, "` requires the keychain resolver, which is not " + , "available in this build.\n" + , "\n" + , "The keychain integration lands with SELF-8. In the meantime:\n" + , " - Use `set` with an explicit scheme (env://, file://, literal:) to avoid keychain.\n" + , " - Or store the value in your OS keychain by hand and reference it\n" + , " directly with `keychain://...` once SELF-8 ships.\n" + ] + pure (ExitFailure 2) + +-- | Pretty-print a 'ResolveError' for stderr, reusing the CLI's style +-- but slightly more verbose (names the failing URI for every error +-- variant). +renderResolveErrorText :: ResolveError -> Text +renderResolveErrorText = \case + ResolveUnknownScheme s -> + "unknown credential scheme `" <> s + <> "` (no resolver registered; built-in schemes: literal, env, file)" + ResolveNotFound (CredentialRef uri) -> + "credential not found: " <> uri + ResolveBackendError (CredentialRef uri) msg -> + "credential backend error for " <> uri <> ": " <> msg + ResolveParseError msg -> + "malformed credential reference: " <> msg + +-- | Loud load: either return the 'StoredDefaults', or print the IO +-- exception and exit. Used by every verb that reads the file. +loadOrExit :: Text -> IO StoredDefaults +loadOrExit backend = do + r <- E.try (loadDefaults backend) :: IO (Either E.IOException StoredDefaults) + case r of + Right sd -> pure sd + Left e -> do + TIO.hPutStrLn stderr $ + "Error: failed to load defaults for backend `" <> backend <> "`: " + <> T.pack (show e) + _ <- E.throwIO e + pure emptyStoredDefaults -- unreachable; throwIO terminates + +-- | Pull the map a kind refers to out of a 'StoredDefaults'. +kindMap :: SelfKind -> StoredDefaults -> Map Text CredentialRef +kindMap Cookie = sdCookies +kindMap Header = sdHeaders + +-- | Replace a kind's map inside a 'StoredDefaults'. +setKindMap :: SelfKind -> Map Text CredentialRef -> StoredDefaults -> StoredDefaults +setKindMap Cookie m sd = sd { sdCookies = m } +setKindMap Header m sd = sd { sdHeaders = m } + +-- --------------------------------------------------------------------------- +-- show +-- --------------------------------------------------------------------------- + +-- | Entry for `_self show [--json]`. Loads, resolves each +-- entry against 'defaultRegistry', then emits either a human-readable +-- table or a JSON blob. +runShow :: Text -> Bool -> IO ExitCode +runShow backend jsonMode = do + sd <- loadOrExit backend + now <- getCurrentTime + entries <- buildShowEntries defaultRegistry sd + if jsonMode + then do + LBS.putStr (encodePrettyJson (entriesToJson backend entries)) + BS8.putStrLn "" + pure ExitSuccess + else do + renderShowText backend sd now entries + pure ExitSuccess + +-- | An entry in the `show` output — one cookie or header. +data ShowEntry = ShowEntry + { seKind :: !SelfKind + , seName :: !Text + , seRef :: !CredentialRef + , seResolver :: !Text + , seResult :: !(Either ResolveError Text) + } + +-- | Best-effort resolver name for a URI. Falls back to the raw scheme +-- string on unparseable URIs (which will also surface as a resolve +-- error later; this only feeds the per-line resolver label). +resolverName :: CredentialRef -> Text +resolverName ref = case parseUri ref of + Left _ -> "?" + Right p -> puScheme p + +buildShowEntries :: ResolverRegistry -> StoredDefaults -> IO [ShowEntry] +buildShowEntries reg sd = do + let pull k = [ (kn, cref) | (kn, cref) <- Map.toAscList (kindMap k sd) ] + let allRefs = [(Cookie, n, r) | (n, r) <- pull Cookie] + ++ [(Header, n, r) | (n, r) <- pull Header] + mapM (\(k, n, r) -> do + res <- resolveRef reg r + pure ShowEntry + { seKind = k + , seName = n + , seRef = r + , seResolver = resolverName r + , seResult = res + }) allRefs + +renderShowText :: Text -> StoredDefaults -> UTCTime -> [ShowEntry] -> IO () +renderShowText backend _sd now entries = do + let path = defaultsPath backend + TIO.putStrLn $ "Backend: " <> backend + TIO.putStrLn $ "Path: " <> T.pack path + let (cookies, headers) = partitionKinds entries + renderSection "Cookies" cookies now + renderSection "Headers" headers now + case (null cookies, null headers) of + (True, True) -> TIO.putStrLn "\n(no defaults configured for this backend)" + _ -> pure () + +partitionKinds :: [ShowEntry] -> ([ShowEntry], [ShowEntry]) +partitionKinds = foldr step ([], []) + where + step e (cs, hs) = case seKind e of + Cookie -> (e : cs, hs) + Header -> (cs, e : hs) + +renderSection :: Text -> [ShowEntry] -> UTCTime -> IO () +renderSection _ [] _ = pure () +renderSection title es now = do + TIO.putStrLn "" + TIO.putStrLn $ title <> ":" + mapM_ (renderShowEntry now) es + +renderShowEntry :: UTCTime -> ShowEntry -> IO () +renderShowEntry now ShowEntry{..} = do + let CredentialRef uri = seRef + TIO.putStrLn $ " " <> seName <> " -> " <> uri <> " [" <> seResolver <> "]" + case seResult of + Left err -> do + TIO.putStrLn $ " x " <> renderResolveErrorText err + Right val -> do + TIO.putStrLn " ok resolved" + case decodeJwt val of + Nothing -> pure () -- Not a JWT; don't print the value (might be a secret). + Just summary -> mapM_ (TIO.putStrLn . (" " <>)) (renderJwtSummary now summary) + +-- | Machine-readable JSON form of the full show output. +entriesToJson :: Text -> [ShowEntry] -> Value +entriesToJson backend entries = + let (cookies, headers) = partitionKinds entries + in object + [ "backend" .= backend + , "path" .= defaultsPath backend + , "cookies" .= fmap entryToJson cookies + , "headers" .= fmap entryToJson headers + ] + +entryToJson :: ShowEntry -> Value +entryToJson ShowEntry{..} = + let CredentialRef uri = seRef + base = + [ "name" .= seName + , "uri" .= uri + , "resolver" .= seResolver + ] + outcome = case seResult of + Left err -> + [ "resolved" .= False + , "error" .= renderResolveErrorText err + ] + Right val -> + let jwt = decodeJwt val + jwtPairs = case jwt of + Nothing -> [] + Just s -> [ "jwt" .= jwtToJson s ] + in [ "resolved" .= True + -- NEVER include the resolved value in JSON either — JWT + -- claims go through jwtToJson (sans signature) and other + -- secrets stay on disk. + ] <> jwtPairs + in object (base <> outcome) + +encodePrettyJson :: Value -> LBS.ByteString +encodePrettyJson = encodePretty' Config + { confIndent = Spaces 2 + , confCompare = compare + , confNumFormat = Generic + , confTrailingNewline = False + } + +-- --------------------------------------------------------------------------- +-- set / set-from-stdin +-- --------------------------------------------------------------------------- + +-- | Implement @set@ (after the heuristic has already been applied by +-- 'runSelfCommand'). +runSet :: Text -> SelfKind -> Text -> Text -> IO ExitCode +runSet backend k name rawRef = do + sd <- loadOrExit backend + let m = kindMap k sd + m' = Map.insert name (CredentialRef rawRef) m + writeDefaults backend (setKindMap k m' sd) + TIO.putStrLn $ "Stored " <> renderKind k <> " `" <> name + <> "` -> " <> rawRef <> " for backend `" <> backend <> "`." + pure ExitSuccess + +-- | Implement @set-from-stdin@: read entire stdin, wrap as @literal:@ +-- regardless of content, then delegate to 'runSet'. +-- +-- A single trailing newline is stripped — users invoking this via +-- @echo value | ...@ almost always mean "the value is @value@, not +-- @value\\n@." Mirrors the file resolver's newline handling +-- ('Synapse.Self.Resolve.File') for consistency. +runSetFromStdin :: Text -> SelfKind -> Text -> IO ExitCode +runSetFromStdin backend k name = do + value <- T.pack <$> getContents + let trimmed = stripTrailingNewline value + runSet backend k name ("literal:" <> trimmed) + +stripTrailingNewline :: Text -> Text +stripTrailingNewline t = case T.unsnoc t of + Just (pfx, '\n') -> pfx + _ -> t + +-- --------------------------------------------------------------------------- +-- unset +-- --------------------------------------------------------------------------- + +-- | Implement @unset@. If the removed ref had a @keychain://@ scheme +-- and the user doesn't opt out, prompt to "also delete from keychain" +-- — but the actual deletion is a no-op until SELF-8 lands. +runUnset :: Text -> SelfKind -> Text -> Bool -> Bool -> IO ExitCode +runUnset backend k name yes noKeychain = do + sd <- loadOrExit backend + let m = kindMap k sd + case Map.lookup name m of + Nothing -> do + TIO.hPutStrLn stderr $ + "No " <> renderKind k <> " named `" <> name + <> "` in backend `" <> backend <> "`." + pure (ExitFailure 1) + Just ref@(CredentialRef uri) -> do + let m' = Map.delete name m + writeDefaults backend (setKindMap k m' sd) + TIO.putStrLn $ "Removed " <> renderKind k <> " `" <> name + <> "` (was " <> uri <> ")." + -- Keychain cleanup prompt (no-op until SELF-8; prompt still fires + -- so users see consistent behavior across versions). + let isKeychainRef = case parseUri ref of + Right (ParsedUri "keychain" _) -> True + _ -> False + if isKeychainRef && not noKeychain + then do + shouldDelete <- + if yes + then pure True + else promptYesNo "Also delete keychain item? [Y/n] " True + if shouldDelete + then case parseUri ref of + Right (ParsedUri "keychain" + (HierarchicalBody svc path _)) -> + case T.stripPrefix "/" path of + Just account | not (T.null account) -> do + r <- deleteFromKeychain svc account + case r of + Right () -> TIO.putStrLn "Deleted keychain item." + Left err -> TIO.hPutStrLn stderr $ + "Warning: keychain delete failed: " <> err + _ -> TIO.hPutStrLn stderr + "Warning: malformed keychain URI — cannot delete item." + _ -> TIO.hPutStrLn stderr + "Warning: could not parse keychain URI — skipped delete." + else TIO.putStrLn "(kept the keychain entry on disk)" + else pure () + pure ExitSuccess + +-- | Prompt yes/no. Default used when the user hits Enter. +promptYesNo :: Text -> Bool -> IO Bool +promptYesNo prompt defaultYes = do + TIO.putStr prompt + hFlush stdout + done <- isEOF + if done + then pure defaultYes + else do + line <- TIO.getLine + let trimmed = T.toLower (T.strip line) + pure $ case trimmed of + "" -> defaultYes + "y" -> True + "yes" -> True + "n" -> False + "no" -> False + _ -> defaultYes + +-- --------------------------------------------------------------------------- +-- resolve +-- --------------------------------------------------------------------------- + +-- | Implement @resolve@. Prints the URI to stdout (first line) and the +-- resolved value (second line) on success. On failure, the URI still +-- goes to stdout (useful for diagnostics) and the error goes to +-- stderr, with a non-zero exit. +-- +-- Unlike @show@, @resolve@ *does* print the resolved value — this is +-- the command users run when they explicitly want to see the secret +-- (e.g. for comparison, or to pipe into another tool). +runResolve :: Text -> SelfKind -> Text -> IO ExitCode +runResolve backend k name = do + sd <- loadOrExit backend + let m = kindMap k sd + case Map.lookup name m of + Nothing -> do + TIO.hPutStrLn stderr $ + "No " <> renderKind k <> " named `" <> name + <> "` in backend `" <> backend <> "`." + pure (ExitFailure 1) + Just ref@(CredentialRef uri) -> do + TIO.putStrLn uri + r <- resolveRef defaultRegistry ref + case r of + Right val -> do + TIO.putStrLn val + pure ExitSuccess + Left err -> do + TIO.hPutStrLn stderr $ "Error: " <> renderResolveErrorText err + pure (ExitFailure 1) + +-- --------------------------------------------------------------------------- +-- clear +-- --------------------------------------------------------------------------- + +-- | Implement @clear@. Prompts unless @--yes@. Deletes the defaults +-- file only; never removes the parent @~\/.plexus\/\@ +-- directory (might hold unrelated files). +runClear :: Text -> Bool -> IO ExitCode +runClear backend yes = do + path <- SelfIO.absDefaultsPath backend + exists <- doesFileExist path + if not exists + then do + TIO.putStrLn $ "No defaults file to clear for backend `" <> backend + <> "` (path: " <> T.pack path <> ")." + pure ExitSuccess + else do + proceed <- + if yes + then pure True + else promptYesNo + ("Delete " <> T.pack path <> "? [y/N] ") False + if proceed + then do + r <- E.try (removeFile path) :: IO (Either IOException ()) + case r of + Right () -> do + TIO.putStrLn $ "Cleared defaults for backend `" <> backend <> "`." + pure ExitSuccess + Left e -> do + TIO.hPutStrLn stderr $ "Error: " <> T.pack (show e) + pure (ExitFailure 1) + else do + TIO.putStrLn "Aborted." + pure (ExitFailure 1) + +-- --------------------------------------------------------------------------- +-- import-token +-- --------------------------------------------------------------------------- + +-- | Implement @import-token@. Reads a file (or stdin if @"-"@). By +-- default stores the content as @literal:\@ under +-- @cookies.access_token@. With @--to-keychain@ on a supported platform, +-- pushes the token into the OS keychain and stores a @keychain://@ +-- reference instead. +runImportToken :: Text -> Text -> Bool -> IO ExitCode +runImportToken backend path toKeychain + | toKeychain, not isKeychainPlatform = + keychainUnavailable "import-token --to-keychain" + | otherwise = do + token <- readTokenSource path + let trimmed = T.strip token + if T.null trimmed + then do + TIO.hPutStrLn stderr "Error: token source is empty." + pure (ExitFailure 1) + else if toKeychain + then do + let account = keychainAccountFor backend Cookie "access_token" + r <- storeInKeychain keychainService account trimmed + case r of + Left err -> do + TIO.hPutStrLn stderr $ "Error: " <> err + pure (ExitFailure 1) + Right () -> do + sd <- loadOrExit backend + let refUri = "keychain://" <> keychainService + <> "/" <> account + m = sdCookies sd + m' = Map.insert "access_token" + (CredentialRef refUri) m + writeDefaults backend (sd { sdCookies = m' }) + TIO.putStrLn $ + "Imported access_token for backend `" <> backend + <> "` (stored in keychain as " <> refUri <> ")." + pure ExitSuccess + else do + sd <- loadOrExit backend + let m = sdCookies sd + m' = Map.insert "access_token" + (CredentialRef ("literal:" <> trimmed)) m + writeDefaults backend (sd { sdCookies = m' }) + TIO.putStrLn $ "Imported access_token for backend `" <> backend + <> "` (stored as literal:). " + <> "Consider `_self " <> backend + <> " upgrade-to-keychain` for a more secure posture." + pure ExitSuccess + +-- --------------------------------------------------------------------------- +-- set-secret +-- --------------------------------------------------------------------------- + +-- | Implement @set-secret@. Reads stdin, pushes the value into the OS +-- keychain under @service=plexus@ and +-- @account=\\/\\/\@, then stores a +-- @keychain://@ reference in @defaults.json@. +-- +-- Called only when 'isKeychainPlatform' is True; the dispatch in +-- 'runSelfCommand' routes non-macOS to 'keychainUnavailable'. +runSetSecret :: Text -> SelfKind -> Text -> IO ExitCode +runSetSecret backend k name = do + raw <- T.pack <$> getContents + let value = T.strip raw + if T.null value + then do + TIO.hPutStrLn stderr "Error: stdin is empty; nothing to store." + pure (ExitFailure 1) + else do + let account = keychainAccountFor backend k name + r <- storeInKeychain keychainService account value + case r of + Left err -> do + TIO.hPutStrLn stderr $ "Error: " <> err + pure (ExitFailure 1) + Right () -> do + sd <- loadOrExit backend + let refUri = "keychain://" <> keychainService <> "/" <> account + m = kindMap k sd + m' = Map.insert name (CredentialRef refUri) m + writeDefaults backend (setKindMap k m' sd) + TIO.putStrLn $ "Stored " <> renderKind k <> " `" <> name + <> "` as " <> refUri + pure ExitSuccess + +-- --------------------------------------------------------------------------- +-- upgrade-to-keychain +-- --------------------------------------------------------------------------- + +-- | Implement @upgrade-to-keychain@. For each matching @literal:@ ref, +-- push the value into the OS keychain and rewrite the stored ref as +-- @keychain://@. Non-literal refs are left alone (they're already +-- indirect). Scope: +-- +-- * @upgrade-to-keychain@ — every literal: entry, both kinds +-- * @upgrade-to-keychain cookie@ — every literal: cookie +-- * @upgrade-to-keychain cookie NAME@ — that single entry +-- +-- Called only when 'isKeychainPlatform' is True; dispatch routes +-- non-macOS to 'keychainUnavailable'. +runUpgrade :: Text -> Maybe SelfKind -> Maybe Text -> IO ExitCode +runUpgrade backend mKind mName = do + sd <- loadOrExit backend + let kindsToWalk = case mKind of + Just k -> [k] + Nothing -> [Cookie, Header] + (sd', upgraded, skipped, errs) <- + foldlIOM (sd, 0 :: Int, 0 :: Int, [] :: [Text]) kindsToWalk $ + \(accSd, u, s, es) k -> do + let m = kindMap k accSd + entries = case mName of + Just n -> [(kn, v) | (kn, v) <- Map.toAscList m, kn == n] + Nothing -> Map.toAscList m + foldlIOM (accSd, u, s, es) entries $ \(iterSd, iu, isk, ies) (kn, ref) -> + case stripLiteralPrefix ref of + Nothing -> pure (iterSd, iu, isk + 1, ies) + Just value -> do + let account = keychainAccountFor backend k kn + r <- storeInKeychain keychainService account value + case r of + Left err -> + pure (iterSd, iu, isk, ("`" <> kn <> "`: " <> err) : ies) + Right () -> do + let refUri = "keychain://" <> keychainService + <> "/" <> account + m' = Map.insert kn (CredentialRef refUri) + (kindMap k iterSd) + iterSd' = setKindMap k m' iterSd + pure (iterSd', iu + 1, isk, ies) + -- Only rewrite the file if anything changed. + if upgraded > 0 + then writeDefaults backend sd' + else pure () + case mName of + Just n | upgraded == 0 && null errs -> + TIO.hPutStrLn stderr $ + "No literal: entry named `" <> n <> "` to upgrade." + _ -> pure () + TIO.putStrLn $ T.concat + [ "Upgraded ", T.pack (show upgraded), " ref(s) to keychain; skipped " + , T.pack (show skipped), " non-literal entries." + ] + case errs of + [] -> pure () + _ -> do + TIO.hPutStrLn stderr "Some entries failed:" + mapM_ (\e -> TIO.hPutStrLn stderr $ " - " <> e) (reverse errs) + pure (if null errs then ExitSuccess else ExitFailure 1) + +-- | Return @Just value@ if a 'CredentialRef' is @literal:\@, +-- else 'Nothing'. +stripLiteralPrefix :: CredentialRef -> Maybe Text +stripLiteralPrefix (CredentialRef uri) = T.stripPrefix "literal:" uri + +-- | Monadic left fold for IO, no external library. Accumulator threads +-- through each step; returns the final accumulator. +foldlIOM :: acc -> [a] -> (acc -> a -> IO acc) -> IO acc +foldlIOM acc [] _ = pure acc +foldlIOM acc (x:xs) f = do + acc' <- f acc x + foldlIOM acc' xs f + +-- | Read a token from a path. @"-"@ means stdin; all other strings are +-- paths on disk. A trailing newline is preserved here — the caller +-- trims before storage. +readTokenSource :: Text -> IO Text +readTokenSource "-" = T.pack <$> getContents +readTokenSource p = TIO.readFile (T.unpack p) + +-- ============================================================================ +-- JWT inspection +-- ============================================================================ + +-- | Structured summary of a JWT. We only record fields the CLI prints. +-- Signatures are never stored. +data JwtSummary = JwtSummary + { jsAlg :: !(Maybe Text) + , jsKid :: !(Maybe Text) + , jsIss :: !(Maybe Text) + , jsAud :: !(Maybe Text) -- ^ Rendered: first aud entry if array. + , jsSub :: !(Maybe Text) + , jsExp :: !(Maybe UTCTime) + , jsIat :: !(Maybe UTCTime) + , jsUsername :: !(Maybe Text) -- ^ @preferred_username@ + , jsEmail :: !(Maybe Text) + , jsExtraClaims :: ![JwtClaim] -- ^ Retained for future; unused in v1. + } + deriving (Show, Eq) + +-- | A single JWT claim, name + rendered value. Reserved for future +-- extension (e.g. scope, roles). Currently unused — the named fields +-- on 'JwtSummary' cover everything we print. +data JwtClaim = JwtClaim + { jcName :: !Text + , jcValue :: !Text + } + deriving (Show, Eq) + +-- | Attempt to decode a string as a JWT. Returns 'Nothing' on anything +-- that isn't JWT-shaped. A "JWT-shaped" value has exactly two dots, +-- each of the three segments base64-decodes cleanly (URL-safe, with or +-- without padding), and the header JSON has an @alg@ field. +-- +-- Decoding never fails loudly: a value that looks JWT-shaped but has +-- a non-JSON payload yields 'Nothing'. +decodeJwt :: Text -> Maybe JwtSummary +decodeJwt t = case T.splitOn "." t of + [h, p, _sig] + | not (T.null h), not (T.null p) -> do + headerJson <- decodeSegment h + payloadJson <- decodeSegment p + -- Header must have an `alg` field to count as a JWT. + case headerJson of + Object o | KM.member "alg" o -> Just (buildSummary headerJson payloadJson) + _ -> Nothing + _ -> Nothing + +decodeSegment :: Text -> Maybe Value +decodeSegment seg = + let bs = TE.encodeUtf8 seg + -- JWT uses URL-safe base64 with padding stripped. + padded = padBase64 bs + in case B64U.decode padded of + Left _ -> Nothing + Right raw -> case eitherDecodeStrict' raw :: Either String Value of + Left _ -> Nothing + Right v -> Just v + +-- | Re-pad a URL-safe base64 string to a multiple of 4. @base64-bytestring@ +-- requires padding for decoding; JWTs strip it. +padBase64 :: BS.ByteString -> BS.ByteString +padBase64 bs = + let n = BS.length bs + r = n `mod` 4 + pad = case r of + 0 -> 0 + 2 -> 2 + 3 -> 1 + _ -> 0 -- 1 is invalid; let decode fail on it + in bs <> BS8.replicate pad '=' + +buildSummary :: Value -> Value -> JwtSummary +buildSummary header payload = JwtSummary + { jsAlg = stringClaim header "alg" + , jsKid = stringClaim header "kid" + , jsIss = stringClaim payload "iss" + , jsAud = audClaim payload + , jsSub = stringClaim payload "sub" + , jsExp = timeClaim payload "exp" + , jsIat = timeClaim payload "iat" + , jsUsername = stringClaim payload "preferred_username" + , jsEmail = stringClaim payload "email" + , jsExtraClaims = [] + } + +-- | Pull a string claim out of a JSON object. Returns 'Nothing' for +-- non-object values, missing fields, or fields that aren't strings. +stringClaim :: Value -> Text -> Maybe Text +stringClaim (Object o) k = case KM.lookup (Key.fromText k) o of + Just (String s) -> Just s + _ -> Nothing +stringClaim _ _ = Nothing + +-- | @aud@ can be either a string or an array of strings. We render the +-- first element in either case. +audClaim :: Value -> Maybe Text +audClaim (Object o) = case KM.lookup "aud" o of + Just (String s) -> Just s + Just (Array arr) -> case foldMap stringOf arr of + [] -> Nothing + (x:_) -> Just x + _ -> Nothing + where + stringOf (String s) = [s] + stringOf _ = [] +audClaim _ = Nothing + +-- | Integer seconds-since-epoch as a 'UTCTime'. +timeClaim :: Value -> Text -> Maybe UTCTime +timeClaim (Object o) k = case KM.lookup (Key.fromText k) o of + Just (Number n) -> Just (posixSecondsToUTCTime (realToFrac n)) + _ -> Nothing +timeClaim _ _ = Nothing + +-- | Render a JWT summary as a list of aligned label/value lines. +-- Never emits the signature; never emits raw claim bodies. +renderJwtSummary :: UTCTime -> JwtSummary -> [Text] +renderJwtSummary now JwtSummary{..} = catMaybes + [ fmap (labelled "alg") jsAlg + , fmap (labelled "kid" . truncateKid) jsKid + , fmap (labelled "iss") jsIss + , fmap (labelled "aud") jsAud + , fmap (labelled "sub") jsSub + , fmap (\t -> + labelled "exp" + (T.pack (formatISO8601 t) <> " (" <> renderRelativeExpiry now t <> ")")) + jsExp + , fmap (\t -> labelled "iat" (T.pack (formatISO8601 t))) jsIat + , case (jsUsername, jsEmail) of + (Just u, Just e) -> Just $ labelled "user" (u <> " (" <> e <> ")") + (Just u, Nothing) -> Just $ labelled "user" u + (Nothing, Just e) -> Just $ labelled "user" e + (Nothing, Nothing) -> Nothing + ] + where + labelled label val = label <> padTo 5 label <> val + padTo n lab = T.replicate (max 1 (n - T.length lab)) " " + +-- | Long `kid` values are typically random key-IDs that add visual +-- noise without aiding identification. Keep the first 6 chars and +-- elide the tail. +truncateKid :: Text -> Text +truncateKid t + | T.length t > 16 = T.take 6 t <> "..." <> T.takeEnd 4 t + | otherwise = t + +formatISO8601 :: UTCTime -> String +formatISO8601 = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" + +-- | Render @exp - now@ as a human-readable relative duration: +-- "expired 16d 4h ago" for past, "valid for 4m 32s" for future. +-- +-- Uses the two largest non-zero units (d/h, h/m, m/s, or just s for +-- sub-minute), which matches the operator-facing prose the ticket asks +-- for: glance-readable, enough precision to act on. +renderRelativeExpiry :: UTCTime -> UTCTime -> Text +renderRelativeExpiry now exp_ = + let delta = diffUTCTime exp_ now + secs :: Integer + secs = floor (realToFrac delta :: Double) + absSecs = abs secs + (d, r1) = absSecs `divMod` 86400 + (h, r2) = r1 `divMod` 3600 + (m, s) = r2 `divMod` 60 + unitPair = case (d, h, m, s) of + _ | d > 0 && h > 0 -> T.pack (show d) <> "d " <> T.pack (show h) <> "h" + _ | d > 0 -> T.pack (show d) <> "d" + _ | h > 0 && m > 0 -> T.pack (show h) <> "h " <> T.pack (show m) <> "m" + _ | h > 0 -> T.pack (show h) <> "h" + _ | m > 0 && s > 0 -> T.pack (show m) <> "m " <> T.pack (show s) <> "s" + _ | m > 0 -> T.pack (show m) <> "m" + _ -> T.pack (show s) <> "s" + in if secs < 0 + then "expired " <> unitPair <> " ago" + else "valid for " <> unitPair + +-- | Minimal JSON render of a 'JwtSummary' for the @--json@ output path. +jwtToJson :: JwtSummary -> Value +jwtToJson JwtSummary{..} = object $ catMaybes + [ fmap ("alg" .=) jsAlg + , fmap ("kid" .=) jsKid + , fmap ("iss" .=) jsIss + , fmap ("aud" .=) jsAud + , fmap ("sub" .=) jsSub + , fmap (\t -> "exp" .= formatISO8601 t) jsExp + , fmap (\t -> "iat" .= formatISO8601 t) jsIat + , fmap ("preferred_username" .=) jsUsername + , fmap ("email" .=) jsEmail + ] diff --git a/src/Synapse/Self/Commands.hs b/src/Synapse/Self/Commands.hs --- a/src/Synapse/Self/Commands.hs +++ b/src/Synapse/Self/Commands.hs @@ -21,7 +21,7 @@ import Synapse.Backend.Discovery (getBackendAt) import qualified Synapse.Self.Template as Template import qualified Synapse.Self.Debugger as Debugger -import Plexus.Client (SubstrateConfig(..)) +import Synapse.Endpoint (substrateConfig) -- | Dispatch to a specific _self subcommand dispatch :: Text -> [Text] -> [(Text, Text)] -> SynapseM () @@ -48,20 +48,13 @@ let methodParams = filter (\(k, _) -> k /= "allow_unknown" && k /= "raw") params -- Get connection settings from environment (set by -H/-P flags) - host <- asks seHost - port <- asks sePort + ep <- asks seEndpoint backend <- asks seBackend case rest of methodParts | not (null methodParts) -> do let method = T.intercalate "." methodParts - let config = SubstrateConfig - { substrateHost = T.unpack host - , substratePort = port - , substratePath = "/" - , substrateBackend = backend - , substrateHeaders = [] - } + let config = substrateConfig ep backend [] liftIO $ Debugger.testMethod config method methodParams allowUnknown rawJson _ -> throwParse "Usage: synapse [options] _self test [--allow-unknown] [--raw ] [--param value ...]\n Note: Use -H/--host and -P/--port flags to set connection (default: 127.0.0.1:4444)" diff --git a/src/Synapse/Self/IO.hs b/src/Synapse/Self/IO.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/IO.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | IO glue for the per-backend defaults store (SELF-2). +-- +-- Three pieces live here: +-- +-- * 'loadDefaults' — read @~\/.plexus\/\\/defaults.json@ from disk. +-- * 'resolveAll' — dispatch every 'CredentialRef' in a 'StoredDefaults' +-- through a 'ResolverRegistry', yielding a +-- 'ResolvedDefaults' with concrete values. +-- * 'merge' — pure left-biased merge of CLI-provided cookies\/headers +-- over the resolved stored defaults. CLI wins per key. +-- +-- The three compose into the read path that synapse\'s request builder uses +-- on every invocation: load → resolve → merge → hand to the upgrade. +-- +-- == Platform notes +-- +-- POSIX mode semantics (@chmod 0600@ on sensitive files, @0700@ on the +-- parent dir, permission-sniffing on read) apply only on Unix. On +-- Windows ('System.Info.os' == @"mingw32"@) those steps are skipped — +-- the atomic temp-file + rename dance still happens, but permission +-- enforcement is a platform gap tracked by the SELF-5 ticket's \"Out of +-- scope\" list (no ACL story yet). +module Synapse.Self.IO + ( -- * Resolved defaults (concrete values, not refs) + ResolvedDefaults(..) + , emptyResolvedDefaults + + -- * Aliases used by the pipeline + , MethodPath + , Cookies + , Headers + + -- * Load / resolve / merge + , loadDefaults + , resolveAll + , merge + + -- * Write path (atomic rename + mode-aware chmod; SELF-5) + , writeDefaults + , absDefaultsPath + ) where + +import Control.Exception (IOException, bracketOnError, throwIO, try) +import qualified Control.Exception as E +import qualified Data.ByteString as BS +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getHomeDirectory + , removeFile + , renameFile + ) +import System.FilePath ((), takeDirectory) +import System.IO (hPutStrLn, stderr) +import System.IO.Error (ioeGetErrorString, isDoesNotExistError, userError) +import qualified System.Info +import System.Posix.Files (FileStatus, fileMode, getFileStatus, setFileMode) +import System.Posix.Types (FileMode) +import Data.Bits ((.&.)) + +import Synapse.Self.Resolve + ( ResolveError(..) + , ResolverRegistry + , resolveRef + ) +import Synapse.Self.Types + ( CredentialRef(..) + , StoredDefaults(..) + , decodeDefaults + , encodeDefaults + , emptyStoredDefaults + ) + +-- ============================================================================ +-- Types used by the request-building pipeline +-- ============================================================================ + +-- | A method path. v1 ignores the contents entirely — it exists so SELF-7+ +-- can introduce scope matching without a signature change. +type MethodPath = [Text] + +-- | Cookies attached to the WebSocket upgrade, keyed by name. +type Cookies = Map Text Text + +-- | Extra HTTP headers attached to the upgrade, keyed by name. +type Headers = Map Text Text + +-- | A 'StoredDefaults' after every 'CredentialRef' has been dereferenced +-- through a 'ResolverRegistry'. Parallels the on-disk shape but carries +-- concrete 'Text' values instead of refs. +data ResolvedDefaults = ResolvedDefaults + { rdCookies :: !Cookies + , rdHeaders :: !Headers + } + deriving stock (Show, Eq) + +-- | Empty resolved defaults — what 'resolveAll' returns for +-- 'emptyStoredDefaults'. +emptyResolvedDefaults :: ResolvedDefaults +emptyResolvedDefaults = ResolvedDefaults + { rdCookies = Map.empty + , rdHeaders = Map.empty + } + +-- ============================================================================ +-- loadDefaults +-- ============================================================================ + +-- | Compute the absolute path to a backend's defaults file, expanding @~@ +-- via 'getHomeDirectory'. 'Synapse.Self.defaultsPath' returns the +-- tilde-prefixed form for pure code; this is the IO-side expansion. +absDefaultsPath :: Text -> IO FilePath +absDefaultsPath backend = do + home <- getHomeDirectory + pure (home ".plexus" T.unpack backend "defaults.json") + +-- | Read a backend's defaults file. +-- +-- * Missing file → 'emptyStoredDefaults' (NOT an error — absence means +-- "no defaults configured for this backend"). +-- * Parse failure → 'IOException' naming the file path and the decoder's +-- message. +-- * Other IO errors (permission denied, …) → propagate as-is so the caller +-- gets a clear platform error. +-- +-- __SELF-5:__ after a successful decode, inspect the file contents and +-- its Unix mode. If the encoded bytes contain a @literal:@ substring +-- (i.e. a raw credential value lives in the file) AND the mode has any +-- group- or world-accessible bits set (@mode .&. 0o077 \/= 0@), emit a +-- stderr WARN line recommending @chmod 600 \@. The read still +-- succeeds — the warning is a nudge, not a failure. +-- +-- Files that contain only @keychain:\/\/@ \/ @env:\/\/@ \/ @file:\/\/@ +-- refs are strictly a manifest and are safe at any mode; no warning is +-- emitted for those regardless of permissions. On Windows the mode +-- check is skipped entirely (no POSIX mode semantics). +loadDefaults :: Text -> IO StoredDefaults +loadDefaults backend = do + -- SELF-3: on entry, migrate the legacy ~/.plexus/tokens/ file + -- to the new defaults.json (or delete it if it's stale / empty). After + -- migration completes (or is a no-op), the body below reads the new + -- file naturally — no double-work for the caller. + migrateIfNeeded backend + path <- absDefaultsPath backend + exists <- doesFileExist path + if not exists + then pure emptyStoredDefaults + else do + result <- try (BS.readFile path) :: IO (Either IOException BS.ByteString) + case result of + Left ioErr + | isDoesNotExistError ioErr -> pure emptyStoredDefaults + | otherwise -> + throwIO $ userError $ + "loadDefaults: failed to read " <> path + <> ": " <> ioeGetErrorString ioErr + Right bs -> case decodeDefaults bs of + Left err -> + throwIO $ userError $ + "loadDefaults: failed to parse " <> path + <> ": " <> T.unpack err + Right sd -> do + warnIfInsecureMode path bs + pure sd + +-- ============================================================================ +-- migrateIfNeeded (SELF-3: legacy ~/.plexus/tokens/ → defaults.json) +-- ============================================================================ + +-- | Compute the absolute path to the legacy per-backend token file +-- (@~\/.plexus\/tokens\/\@). +-- +-- This is the /only/ call site in synapse that references +-- @~\/.plexus\/tokens\/@. Every other read-path has been routed through +-- 'loadDefaults'; the legacy path lives here solely so first-boot +-- migration can drain it. Grep enforcement: after SELF-3, +-- @git grep -n 'plexus\/tokens'@ should return zero hits outside this +-- function (and the ticket's own plans\/ docs). +legacyTokenPath :: Text -> IO FilePath +legacyTokenPath backend = do + home <- getHomeDirectory + pure (home ".plexus" "tokens" T.unpack backend) + +-- | First-boot migration of the legacy plaintext token file into a +-- @defaults.json@ manifest with a @literal:\@ ref. +-- +-- Runs at the top of every 'loadDefaults' invocation but is effectively +-- a no-op in steady state (fast path: the legacy file does not exist). +-- Three cases: +-- +-- 1. New file absent, legacy absent → nothing to do. +-- 2. New file present, legacy present → legacy is stale; delete it +-- unread and leave the new file untouched. Log INFO. +-- 3. New file absent, legacy present → migrate: +-- * Read the legacy file; trim leading\/trailing whitespace. +-- * If the trimmed contents are empty: delete legacy silently and +-- return (the existing 'loadDefaults' body then sees no file and +-- returns 'emptyStoredDefaults'). +-- * Otherwise: construct a 'StoredDefaults' with +-- @cookies.access_token = CredentialRef "literal:\"@, +-- write it via 'writeDefaults' (SELF-5 atomic + 0600 chmod), +-- delete the legacy file, and log INFO suggesting +-- @synapse _self \ upgrade-to-keychain@. +-- +-- Security note: migration target is deliberately @literal:@, not +-- @keychain:\/\/@. A silent permission escalation would surprise users +-- and could trigger an OS keychain prompt. Opt-in upgrade is the +-- @_self \ upgrade-to-keychain@ verb. +migrateIfNeeded :: Text -> IO () +migrateIfNeeded backend = do + newPath <- absDefaultsPath backend + legacyPath <- legacyTokenPath backend + newExists <- doesFileExist newPath + legacyExists <- doesFileExist legacyPath + case (newExists, legacyExists) of + (_, False) -> pure () -- no legacy → nothing to do + (True, True) -> do + -- Stale legacy file: new defaults.json wins. Delete the legacy + -- file unread so it doesn't masquerade as authoritative state. + E.handle (\(_ :: IOException) -> pure ()) (removeFile legacyPath) + hPutStrLn stderr $ + "[INFO] removed stale legacy token file " <> legacyPath + <> " (superseded by defaults.json)" + (False, True) -> do + -- Real migration. Read, trim, decide empty vs non-empty. + readResult <- try (BS.readFile legacyPath) + :: IO (Either IOException BS.ByteString) + case readResult of + Left _ -> pure () -- unreadable legacy file: leave it; next run retries + Right raw -> do + let trimmed = T.strip (TE.decodeUtf8 raw) + if T.null trimmed + then + -- Empty / whitespace-only legacy: drop it silently. No + -- new file is created — the existing 'loadDefaults' body + -- returns 'emptyStoredDefaults'. + E.handle (\(_ :: IOException) -> pure ()) (removeFile legacyPath) + else do + let sd = emptyStoredDefaults + { sdCookies = Map.singleton "access_token" + (CredentialRef ("literal:" <> trimmed)) + } + writeDefaults backend sd + E.handle (\(_ :: IOException) -> pure ()) (removeFile legacyPath) + hPutStrLn stderr $ + "[INFO] migrated legacy token file " <> legacyPath + <> " to " <> newPath + <> " (stored as literal:). Consider: synapse _self " + <> T.unpack backend <> " upgrade-to-keychain" + +-- | Emit a stderr WARN when the file contains a @literal:@ value AND +-- its mode is group-\/world-accessible. Silent on Windows (mode is +-- meaningless) and on non-literal-only manifests (safe at any mode). +-- +-- A failure to stat the file (e.g. race with deletion) is swallowed — +-- the caller has already read the bytes, so there is no state to +-- recover from here. +warnIfInsecureMode :: FilePath -> BS.ByteString -> IO () +warnIfInsecureMode path bs + | System.Info.os == "mingw32" = pure () + | not (BS.isInfixOf "literal:" bs) = pure () + | otherwise = do + mSt <- try (getFileStatus path) :: IO (Either IOException FileStatus) + case mSt of + Left _ -> pure () + Right st -> do + let m = fileMode st + if m .&. (0o077 :: FileMode) /= 0 + then hPutStrLn stderr $ + "[WARN] " <> path <> " contains literal: credentials " + <> "and is group/world accessible; recommend `chmod 600 " + <> path <> "`." + else pure () + +-- ============================================================================ +-- resolveAll +-- ============================================================================ + +-- | Resolve every 'CredentialRef' in a 'StoredDefaults' through the +-- registry. Dispatch is sequential: the first failure short-circuits and +-- the partial map is discarded — we never send a half-authenticated +-- request. +-- +-- The 'MethodPath' is threaded unchanged for forward compatibility with +-- scope matching. v1 ignores it; backend-level defaults are the only ones +-- consulted. +-- +-- Returns 'Right' with a fully-populated 'ResolvedDefaults' on success, +-- 'Left' with the first 'ResolveError' encountered on failure. +resolveAll + :: ResolverRegistry + -> StoredDefaults + -> MethodPath + -> IO (Either ResolveError ResolvedDefaults) +resolveAll reg StoredDefaults{..} _methodPath = do + eCookies <- resolveMap reg sdCookies + case eCookies of + Left err -> pure (Left err) + Right cookies -> do + eHeaders <- resolveMap reg sdHeaders + case eHeaders of + Left err -> pure (Left err) + Right headers -> pure $ Right ResolvedDefaults + { rdCookies = cookies + , rdHeaders = headers + } + +-- | Resolve every value in a @Map Text CredentialRef@, short-circuiting +-- on the first failure. Preserves input keys. +resolveMap + :: ResolverRegistry + -> Map Text CredentialRef + -> IO (Either ResolveError (Map Text Text)) +resolveMap reg = go . Map.toAscList + where + go [] = pure (Right Map.empty) + go ((k, ref) : rest) = do + r <- resolveRef reg ref + case r of + Left err -> pure (Left err) + Right v -> do + rest' <- go rest + case rest' of + Left err -> pure (Left err) + Right m -> pure $ Right (Map.insert k v m) + +-- ============================================================================ +-- merge +-- ============================================================================ + +-- | Pure left-biased merge of CLI cookies\/headers over the resolved +-- stored defaults. CLI wins per key. +-- +-- The caller is responsible for wrapping each CLI @--cookie KEY=VALUE@ and +-- @--header KEY=VALUE@ into the 'Cookies'\/'Headers' maps before calling +-- 'merge'; there is no special casing for the source of a value inside +-- this function. +merge + :: ResolvedDefaults + -> Cookies -- ^ from CLI flags (wins on conflict) + -> Headers -- ^ from CLI flags (wins on conflict) + -> (Cookies, Headers) +merge ResolvedDefaults{..} cliCookies cliHeaders = + ( Map.union cliCookies rdCookies + , Map.union cliHeaders rdHeaders + ) + +-- ============================================================================ +-- writeDefaults (SELF-5: atomic rename + mode-aware chmod) +-- ============================================================================ + +-- | Write a 'StoredDefaults' to disk for @backend@. +-- +-- The write is atomic and mode-aware: +-- +-- 1. Ensure the parent directory exists. If it was freshly created by +-- this call, chmod it to @0700@. If it already existed with +-- group-\/world-accessible bits set, emit a stderr WARN but leave it +-- alone (the user may have structure we shouldn\'t disturb). +-- 2. Encode the 'StoredDefaults' to JSON. +-- 3. Write the encoded bytes to a sibling temp file +-- @\\/.defaults.json.tmp@ (hidden dotfile so visually +-- distinct if ever stuck). +-- 4. If the encoded content contains the substring @"literal:"@ anywhere, +-- chmod the temp file to @0600@ before rename. Otherwise @0644@ is +-- acceptable (manifest-only, no secrets in-file). +-- 5. Atomically 'renameFile' the temp into place — this wraps the +-- platform @rename(2)@ syscall and is the only step that makes the +-- write visible to other readers. +-- 6. On any failure at steps 3-5, remove the temp file (if it exists) +-- and propagate the original exception. No partial @defaults.json@ +-- is ever left behind. +-- +-- On Windows (@System.Info.os == "mingw32"@) the chmod steps are +-- skipped; the atomic rename still happens. +writeDefaults :: Text -> StoredDefaults -> IO () +writeDefaults backend sd = do + path <- absDefaultsPath backend + let dir = takeDirectory path + tmpPath = dir ".defaults.json.tmp" + bytes = encodeDefaults sd + sensitive = BS.isInfixOf "literal:" bytes + + -- Step 1: parent dir. Track whether we created it so we only chmod + -- freshly-created dirs (existing dirs with wide mode get a WARN). + dirPreexisted <- doesDirectoryExist dir + createDirectoryIfMissing True dir + if not dirPreexisted + then setFileModeUnix dir 0o700 + else warnIfWideDir dir + + -- Steps 2-5: atomic temp write + chmod + rename. `bracketOnError` + -- removes the temp file on any exception from the write or rename; + -- on success no cleanup runs. + bracketOnError + (pure tmpPath) + (\p -> E.handle (\(_ :: IOException) -> pure ()) (removeFileIfExists p)) + (\p -> do + BS.writeFile p bytes + setFileModeUnix p (if sensitive then 0o600 else 0o644) + renameFile p path) + +-- | Remove a file, ignoring "does not exist" errors but propagating +-- anything else. Used by the 'bracketOnError' cleanup — we don\'t want +-- cleanup-of-nonexistent-tmp to hide the real failure. +removeFileIfExists :: FilePath -> IO () +removeFileIfExists p = do + exists <- doesFileExist p + if exists then removeFile p else pure () + +-- | 'setFileMode' on Unix, no-op on Windows. Matches the platform gating +-- in 'warnIfInsecureMode' / 'warnIfWideDir'. +setFileModeUnix :: FilePath -> FileMode -> IO () +setFileModeUnix p m + | System.Info.os == "mingw32" = pure () + | otherwise = setFileMode p m + +-- | WARN when a pre-existing parent dir has group-\/world-accessible +-- bits. We never tighten an existing dir\'s mode — users may have +-- structure under @~\/.plexus@ we shouldn\'t perturb. Silent on +-- Windows and on already-tight dirs. +warnIfWideDir :: FilePath -> IO () +warnIfWideDir dir + | System.Info.os == "mingw32" = pure () + | otherwise = do + mSt <- try (getFileStatus dir) :: IO (Either IOException FileStatus) + case mSt of + Left _ -> pure () + Right st -> do + let m = fileMode st + if m .&. (0o077 :: FileMode) /= 0 + then hPutStrLn stderr $ + "[WARN] " <> dir <> " has group/world access bits set; " + <> "recommend `chmod 700 " <> dir <> "` to tighten." + else pure () diff --git a/src/Synapse/Self/Protocol/TestRunner.hs b/src/Synapse/Self/Protocol/TestRunner.hs --- a/src/Synapse/Self/Protocol/TestRunner.hs +++ b/src/Synapse/Self/Protocol/TestRunner.hs @@ -73,6 +73,7 @@ , substratePath = "/" , substrateBackend = backend , substrateHeaders = [] + , substrateTls = Nothing } -- Run all test suites @@ -357,6 +358,8 @@ "Protocol error: " <> msg formatTransportError (PT.NetworkError msg) = "Network error: " <> msg +formatTransportError (PT.ConnectionLost msg _) = + "Connection lost: " <> msg -- | Simple timeout implementation -- Returns Nothing if timeout occurs, Just result otherwise diff --git a/src/Synapse/Self/Resolve.hs b/src/Synapse/Self/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Resolve.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | URI parsing and resolver registry for credential references. +-- +-- A 'CredentialRef' on disk is one of: +-- +-- * Opaque: @literal:\@ — value taken verbatim after the first +-- colon. No URL-encoding so JWTs / base64 fit cleanly. +-- * Hierarchical: @scheme:\/\/authority\/path[?query]@ — interpretation +-- is scheme-specific. +-- +-- Parsing is shape-only: 'parseUri' accepts any well-formed URI. Scheme +-- validity is enforced at *resolve* time via the registry, so the file +-- parses even when a scheme\'s backend (e.g. @vault@) is not wired up. +-- +-- The registry is an open map; concrete resolvers (e.g. @keychain@, +-- @env@, @file@) are registered by their owning packages via simple +-- 'Map' insertion. An empty registry (@mempty@) returns +-- 'ResolveUnknownScheme' for every lookup. +module Synapse.Self.Resolve + ( -- * Parsed URI shape + ParsedUri(..) + , ParsedUriBody(..) + , parseUri + + -- * Resolver interface + , Resolver(..) + , ResolveFn + , NamedResolver(..) + + -- * Registry + , ResolverRegistry(..) + , emptyRegistry + , registerResolver + , registerNamedResolver + , lookupResolver + , resolveRef + + -- * Errors + , ResolveError(..) + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy) +import Data.Text (Text) +import qualified Data.Text as T + +import Synapse.Self.Types (CredentialRef(..)) + +-- ============================================================================ +-- Parsed URI +-- ============================================================================ + +-- | Body of a parsed URI. +-- +-- We keep this deliberately simple — this is not RFC 3986. We only need +-- to separate the opaque escape hatch from the @scheme://authority/path@ +-- shape, plus a light query split so @env:\/\/VAR?fallback=x@ style +-- extensions are possible later without another parser pass. +data ParsedUriBody + = OpaqueBody Text + -- ^ Everything after the first @:@ for non-hierarchical URIs. + | HierarchicalBody + { puAuthority :: Text + , puPath :: Text + , puQuery :: [(Text, Text)] + } + deriving stock (Show, Eq) + +-- | A parsed credential URI. +data ParsedUri = ParsedUri + { puScheme :: Text + , puBody :: ParsedUriBody + } + deriving stock (Show, Eq) + +-- | Parse a 'CredentialRef' URI. +-- +-- Splits on the first @:@ to extract the scheme. If the remainder starts +-- with @\/\/@ we treat it as hierarchical (authority + path + optional +-- query); otherwise the remainder is taken verbatim as the opaque body. +-- +-- Rejected shapes: +-- +-- * bare strings with no scheme (e.g. @"abc"@) +-- * empty scheme (e.g. @":foo"@) +parseUri :: CredentialRef -> Either Text ParsedUri +parseUri (CredentialRef raw) = + case T.breakOn ":" raw of + (_, "") -> Left ("missing scheme in credential reference: " <> raw) + (scheme, colonRest) + | T.null scheme -> Left ("empty scheme in credential reference: " <> raw) + | otherwise -> + let rest = T.drop 1 colonRest + in case T.stripPrefix "//" rest of + Just hier -> Right (ParsedUri scheme (parseHierarchical hier)) + Nothing -> Right (ParsedUri scheme (OpaqueBody rest)) + +-- | Split @authority/path?query@. Path and authority are empty when absent. +parseHierarchical :: Text -> ParsedUriBody +parseHierarchical s = + let (beforeQ, afterQ) = T.breakOn "?" s + query = if T.null afterQ then [] else parseQuery (T.drop 1 afterQ) + (authority, path) = case T.breakOn "/" beforeQ of + (a, "") -> (a, "") + (a, slash) -> (a, slash) + in HierarchicalBody + { puAuthority = authority + , puPath = path + , puQuery = query + } + +-- | Parse @k1=v1&k2=v2@. No URL-decoding — keys and values are taken +-- verbatim. Missing @=@ yields an empty value. +parseQuery :: Text -> [(Text, Text)] +parseQuery s = map splitPair (T.splitOn "&" s) + where + splitPair pair = case T.breakOn "=" pair of + (k, "") -> (k, "") + (k, eqRest) -> (k, T.drop 1 eqRest) + +-- ============================================================================ +-- Resolver interface +-- ============================================================================ + +-- | The shape resolvers implement. @IO@ because most backends +-- (keychain, filesystem, vault) are inherently effectful. +type ResolveFn = ParsedUri -> IO (Either ResolveError Text) + +-- | A 'Resolver' knows its own scheme and how to dereference a URI. +-- +-- Kept as a typeclass for ergonomic instance declarations, but the +-- registry stores the bare 'ResolveFn' so resolvers defined outside +-- this package (e.g. a future @plexus-vault@) compose without any +-- typeclass gymnastics. +class Resolver r where + scheme :: Proxy r -> Text + resolve :: r -> ResolveFn + +-- | A named resolver for debugging / diagnostics — pair the scheme +-- string with its 'ResolveFn' without going through the typeclass. +data NamedResolver = NamedResolver + { nrScheme :: Text + , nrResolve :: ResolveFn + } + +-- ============================================================================ +-- Registry +-- ============================================================================ + +-- | Map from scheme to resolver function. Construction via 'mempty' +-- yields an empty registry that always returns 'ResolveUnknownScheme'. +newtype ResolverRegistry = ResolverRegistry + { schemes :: Map Text ResolveFn + } + +instance Semigroup ResolverRegistry where + -- Right-biased union matches 'Map.union'\'s left-bias when read as + -- @a <> b == a@ wins: we flip it so later registrations override. + ResolverRegistry a <> ResolverRegistry b = ResolverRegistry (Map.union b a) + +instance Monoid ResolverRegistry where + mempty = ResolverRegistry Map.empty + +-- | An empty registry. Equivalent to 'mempty'; provided for discoverability. +emptyRegistry :: ResolverRegistry +emptyRegistry = mempty + +-- | Register a resolver function under a scheme. Last write wins. +registerResolver :: Text -> ResolveFn -> ResolverRegistry -> ResolverRegistry +registerResolver s fn (ResolverRegistry m) = + ResolverRegistry (Map.insert s fn m) + +-- | Register a 'NamedResolver'. Convenience for the typeclass-free path. +registerNamedResolver :: NamedResolver -> ResolverRegistry -> ResolverRegistry +registerNamedResolver NamedResolver{..} = registerResolver nrScheme nrResolve + +-- | Look up the resolver for a scheme. +lookupResolver :: Text -> ResolverRegistry -> Maybe ResolveFn +lookupResolver s (ResolverRegistry m) = Map.lookup s m + +-- | Resolve a 'CredentialRef' end-to-end: parse, dispatch, and report +-- either the resolved value or a structured 'ResolveError'. Parse +-- failures surface as 'ResolveParseError' so callers get a single error +-- channel. +resolveRef :: ResolverRegistry -> CredentialRef -> IO (Either ResolveError Text) +resolveRef reg ref = + case parseUri ref of + Left err -> pure (Left (ResolveParseError err)) + Right parsed -> + case lookupResolver (puScheme parsed) reg of + Nothing -> pure (Left (ResolveUnknownScheme (puScheme parsed))) + Just fn -> fn parsed + +-- ============================================================================ +-- Errors +-- ============================================================================ + +-- | Operator-facing failure modes for credential reference resolution. +-- +-- These are what @_self resolve@ (SELF-4) surfaces — structured so UIs +-- can render @"keychain item 'uscis/access_token' not found"@ instead of +-- @"error 127"@. +data ResolveError + = ResolveUnknownScheme Text + -- ^ No resolver registered for this scheme. + | ResolveNotFound CredentialRef + -- ^ Scheme resolved but the underlying item is absent + -- (keychain miss, env var unset, file doesn\'t exist). + | ResolveBackendError CredentialRef Text + -- ^ Scheme resolver hit an unexpected error from its backend. + | ResolveParseError Text + -- ^ The reference URI itself was malformed. + deriving stock (Show, Eq) diff --git a/src/Synapse/Self/Resolve/Default.hs b/src/Synapse/Self/Resolve/Default.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Resolve/Default.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The default 'ResolverRegistry' for the baseline deployment shapes. +-- +-- Registers the four resolvers every deployment needs: +-- +-- * @literal:\@ — opaque escape hatch (see 'literalResolver'). +-- * @env:\/\/\@ — environment variable (see 'envResolver'). +-- * @file:\/\/\@ — file contents (see 'fileResolver'). +-- * @keychain:\/\/\\/\@ — OS keychain (see 'keychainResolver'; +-- full support on macOS, clear error on other platforms). +-- +-- Registering @keychain@ unconditionally (including on platforms where +-- it's a stub) lets @_self show@ list @keychain:\/\/@ refs with a +-- specific "not implemented on " error instead of the less +-- helpful "unknown scheme" error. +-- +-- Callers extend via 'registerResolver': +-- +-- > let reg = registerResolver "vault" myVaultResolver defaultRegistry +module Synapse.Self.Resolve.Default + ( defaultRegistry + ) where + +import Synapse.Self.Resolve + ( ResolverRegistry + , emptyRegistry + , registerResolver + ) +import Synapse.Self.Resolve.Env (envResolver) +import Synapse.Self.Resolve.File (fileResolver) +import Synapse.Self.Resolve.Keychain (keychainResolver) +import Synapse.Self.Resolve.Literal (literalResolver) + +-- | A registry pre-populated with the four baseline resolvers: +-- @literal@, @env@, @file@, @keychain@. +defaultRegistry :: ResolverRegistry +defaultRegistry = + registerResolver "literal" literalResolver + $ registerResolver "env" envResolver + $ registerResolver "file" fileResolver + $ registerResolver "keychain" keychainResolver + $ emptyRegistry diff --git a/src/Synapse/Self/Resolve/Env.hs b/src/Synapse/Self/Resolve/Env.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Resolve/Env.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The @env:\/\/\@ resolver — read credentials from environment +-- variables. +-- +-- The authority slot carries the variable name; path and query are +-- ignored. @env:\/\/USCIS_JWT@ looks up @USCIS_JWT@ via +-- 'System.Environment.lookupEnv': +-- +-- * set → 'Right' value +-- * unset → 'ResolveNotFound' +-- +-- Using the authority slot for the variable name is a slight RFC 3986 +-- stretch (authority is supposed to be host:port) but it reads right. +-- Alternatives like @env:VAR@ (opaque) or @env:\/\/\/VAR@ (path) were +-- uglier for no gain. +module Synapse.Self.Resolve.Env + ( envResolver + ) where + +import qualified Data.Text as T +import System.Environment (lookupEnv) + +import Synapse.Self.Resolve + ( ParsedUri(..) + , ParsedUriBody(..) + , ResolveError(..) + , ResolveFn + ) +import Synapse.Self.Types (CredentialRef(..)) + +-- | Resolver for @env:\/\/\@. +-- +-- Dispatches only on 'HierarchicalBody'. An opaque @env:VAR@ form is a +-- shape error surfaced as 'ResolveBackendError'. +envResolver :: ResolveFn +envResolver ParsedUri{puScheme, puBody} = + case puBody of + HierarchicalBody{puAuthority = varName} + | T.null varName -> + pure $ Left $ ResolveBackendError + (CredentialRef (puScheme <> "://")) + "env: missing variable name (expected env://VAR)" + | otherwise -> do + mVal <- lookupEnv (T.unpack varName) + case mVal of + Just v -> pure (Right (T.pack v)) + Nothing -> pure $ Left $ + ResolveNotFound (CredentialRef (puScheme <> "://" <> varName)) + OpaqueBody body -> + pure $ Left $ ResolveBackendError + (CredentialRef (puScheme <> ":" <> body)) + "env: scheme must be hierarchical (env://VAR), not opaque (env:VAR)" diff --git a/src/Synapse/Self/Resolve/File.hs b/src/Synapse/Self/Resolve/File.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Resolve/File.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The @file:\/\/\@ resolver — read credentials from a file. +-- +-- Generalization of the existing @--token-file@ idiom. The path is +-- reconstructed from the parsed URI (authority ++ path), supports @~@ +-- expansion, and a single trailing newline is stripped so cleanly +-- concatenated @printf \'%s\\n\' \> token@ files Just Work. Interior +-- whitespace is preserved. +-- +-- Error mapping: +-- +-- * Missing file → 'ResolveNotFound' +-- * Other IO errors (permission denied, is-a-directory, …) → +-- 'ResolveBackendError' with the IOError message. +module Synapse.Self.Resolve.File + ( fileResolver + ) where + +import Control.Exception (IOException, try) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import System.Directory (getHomeDirectory) +import System.IO.Error (isDoesNotExistError) + +import Synapse.Self.Resolve + ( ParsedUri(..) + , ParsedUriBody(..) + , ResolveError(..) + , ResolveFn + ) +import Synapse.Self.Types (CredentialRef(..)) + +-- | Resolver for @file:\/\/\@. +-- +-- Dispatches on 'HierarchicalBody'. Reconstructs the path as +-- @authority ++ path@, expands a leading @~@ to the user\'s home +-- directory, reads the file as UTF-8, and strips a single trailing +-- newline. +fileResolver :: ResolveFn +fileResolver ParsedUri{puScheme, puBody} = + case puBody of + HierarchicalBody{puAuthority = auth, puPath = p} -> do + let raw = auth <> p + canonical = CredentialRef (puScheme <> "://" <> raw) + if T.null raw + then pure $ Left $ ResolveBackendError canonical + "file: missing path (expected file:///abs or file://~/rel)" + else do + expanded <- expandHome (T.unpack raw) + readWithStrip canonical expanded + OpaqueBody body -> + pure $ Left $ ResolveBackendError + (CredentialRef (puScheme <> ":" <> body)) + "file: scheme must be hierarchical (file://path), not opaque" + +-- | Expand a leading @~@ or @~\/@ to the user\'s home directory. Any +-- other @~@ (e.g. @~user@) is left alone — that form would need +-- platform-specific getpwnam logic we don\'t want to pull in here. +expandHome :: FilePath -> IO FilePath +expandHome path = case path of + "~" -> getHomeDirectory + '~':'/':rest -> do + home <- getHomeDirectory + pure (home <> "/" <> rest) + _ -> pure path + +-- | Read @path@ and strip a single trailing @\\n@ if present. All other +-- bytes (including interior newlines and leading\/trailing spaces) are +-- preserved verbatim. +readWithStrip :: CredentialRef -> FilePath -> IO (Either ResolveError T.Text) +readWithStrip ref path = do + result <- try (TIO.readFile path) :: IO (Either IOException T.Text) + case result of + Right contents -> pure $ Right (stripTrailingNewline contents) + Left e + | isDoesNotExistError e -> pure $ Left $ ResolveNotFound ref + | otherwise -> + pure $ Left $ ResolveBackendError ref (T.pack (show e)) + +-- | Strip a single trailing @\\n@. No-op if the file has no trailing +-- newline, and only one is removed even if the file ends in @\\n\\n@. +stripTrailingNewline :: T.Text -> T.Text +stripTrailingNewline t = case T.unsnoc t of + Just (prefix, '\n') -> prefix + _ -> t diff --git a/src/Synapse/Self/Resolve/Keychain.hs b/src/Synapse/Self/Resolve/Keychain.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Resolve/Keychain.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The @keychain:\/\/\\/\@ resolver — OS-managed +-- credential storage. +-- +-- Elevates the credentials store out of plaintext into OS-managed +-- credential storage. With keychain refs, @defaults.json@ is a manifest +-- of references and contains no secrets — safe to commit to personal +-- dotfiles. +-- +-- __Platforms:__ +-- +-- * macOS — full support via the @security@ CLI (shell-out, no FFI). +-- * Linux — stub. Returns 'ResolveBackendError' with a clear +-- "not implemented; PR welcome" message. +-- * Windows — stub. Same. +-- +-- Platform dispatch is runtime via 'System.Info.os' so the module +-- compiles identically on every platform. +-- +-- __URI form:__ +-- +-- > keychain:/// +-- +-- The authority is the keychain service; everything after the leading +-- @\/@ in the path is the account. Slashes in the account are preserved +-- (keychain accepts them); e.g. @keychain:\/\/plexus\/uscis\/cookie\/access_token@ +-- resolves with @service = "plexus"@ and @account = "uscis\/cookie\/access_token"@. +-- +-- __macOS implementation:__ +-- +-- Shells out to: +-- +-- @ +-- security find-generic-password -s \ -a \ -w +-- security add-generic-password -s \ -a \ -w \ -U +-- security delete-generic-password -s \ -a \ +-- @ +-- +-- Exit code 44 from @security@ means "item not found" and surfaces as +-- 'ResolveNotFound'. Other non-zero exits surface as 'ResolveBackendError' +-- with the captured stderr. The @security -w@ command appends a single +-- trailing newline to stdout — stripped exactly once. +module Synapse.Self.Resolve.Keychain + ( -- * Resolver + keychainResolver + + -- * Mutations (for SELF-4 verbs) + , storeInKeychain + , deleteFromKeychain + + -- * Platform probe + , isKeychainPlatform + , platformName + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import System.Exit (ExitCode(..)) +import qualified System.Info as Info +import System.Process (readProcessWithExitCode) + +import Synapse.Self.Resolve + ( ParsedUri(..) + , ParsedUriBody(..) + , ResolveError(..) + , ResolveFn + ) +import Synapse.Self.Types (CredentialRef(..)) + +-- ============================================================================ +-- Platform detection +-- ============================================================================ + +-- | True iff the current platform has a working keychain backend. +-- Only macOS returns True today. +isKeychainPlatform :: Bool +isKeychainPlatform = Info.os == "darwin" + +-- | Human-readable platform name, for error messages. +platformName :: Text +platformName = case Info.os of + "darwin" -> "macOS" + "linux" -> "Linux" + "mingw32" -> "Windows" + "mingw64" -> "Windows" + "cygwin32" -> "Windows" + other -> T.pack other + +-- ============================================================================ +-- Resolver +-- ============================================================================ + +-- | Resolver for @keychain:\/\/\\/\@. +keychainResolver :: ResolveFn +keychainResolver ParsedUri{puScheme, puBody} = case puBody of + OpaqueBody body -> + pure $ Left $ ResolveBackendError + (CredentialRef (puScheme <> ":" <> body)) + "keychain: scheme must be hierarchical (keychain://service/account), not opaque" + HierarchicalBody{puAuthority = service, puPath = rawPath} -> + case parseServiceAccount service rawPath of + Left err -> pure (Left err) + Right (s, a) + | isKeychainPlatform -> resolveMacOS s a + | otherwise -> pure (Left (stubError (canonicalRef s a))) + +-- | Split the ParsedUri pieces into @(service, account)@ or a structured +-- 'ResolveParseError' naming what's missing. +parseServiceAccount + :: Text -- ^ authority + -> Text -- ^ raw path (leading @\/@ expected) + -> Either ResolveError (Text, Text) +parseServiceAccount service rawPath + | T.null service = + Left $ ResolveParseError + "service missing in keychain:///" + | otherwise = + case T.stripPrefix "/" rawPath of + Nothing -> + Left $ ResolveParseError + "account missing in keychain:///" + Just account + | T.null account -> + Left $ ResolveParseError + "account missing in keychain:///" + | otherwise -> Right (service, account) + +-- | The canonical URI we echo back in 'ResolveError' payloads. +canonicalRef :: Text -> Text -> CredentialRef +canonicalRef service account = + CredentialRef ("keychain://" <> service <> "/" <> account) + +-- | Error returned on platforms without a keychain backend. +stubError :: CredentialRef -> ResolveError +stubError ref = + ResolveBackendError ref $ T.concat + [ "keychain backend not implemented on " + , platformName + , "; PR welcome." + ] + +-- ============================================================================ +-- macOS: shell out to `security` +-- ============================================================================ + +-- | macOS exit code returned by @security@ when an item is not found. +-- Documented under @errSecItemNotFound@ in the @security(1)@ manpage. +securityNotFoundExitCode :: Int +securityNotFoundExitCode = 44 + +-- | Resolve via @security find-generic-password -s \ -a \ -w@. +resolveMacOS :: Text -> Text -> IO (Either ResolveError Text) +resolveMacOS service account = do + let args = + [ "find-generic-password" + , "-s", T.unpack service + , "-a", T.unpack account + , "-w" + ] + ref = canonicalRef service account + (code, out, err) <- readProcessWithExitCode "security" args "" + case code of + ExitSuccess -> + pure $ Right (stripOneTrailingNewline (T.pack out)) + ExitFailure c + | c == securityNotFoundExitCode -> + pure $ Left (ResolveNotFound ref) + | otherwise -> + pure $ Left $ ResolveBackendError ref $ T.concat + [ "security exited with code " + , T.pack (show c) + , renderStderr err + ] + +-- | Strip exactly one trailing newline if present. +-- @security -w@ appends one newline; interior bytes are preserved. +stripOneTrailingNewline :: Text -> Text +stripOneTrailingNewline t = case T.unsnoc t of + Just (pfx, '\n') -> pfx + _ -> t + +-- | Append stderr to an error message if non-empty. +renderStderr :: String -> Text +renderStderr "" = "" +renderStderr s = ": " <> T.strip (T.pack s) + +-- ============================================================================ +-- Mutations (exposed for SELF-4) +-- ============================================================================ + +-- | Store @value@ under @service@/@account@ in the OS keychain. +-- +-- Uses @security add-generic-password -U@ so an existing item is updated +-- in place. Returns @Right ()@ on success. On non-macOS platforms, +-- returns @Left@ with a "not implemented" message. +storeInKeychain + :: Text -- ^ service + -> Text -- ^ account + -> Text -- ^ value to store + -> IO (Either Text ()) +storeInKeychain service account value + | not isKeychainPlatform = pure $ Left $ T.concat + [ "keychain backend not implemented on " + , platformName + , "; cannot store secret. PR welcome." + ] + | otherwise = do + let args = + [ "add-generic-password" + , "-s", T.unpack service + , "-a", T.unpack account + , "-w", T.unpack value + , "-U" + ] + (code, _out, err) <- readProcessWithExitCode "security" args "" + case code of + ExitSuccess -> pure (Right ()) + ExitFailure c -> + pure $ Left $ T.concat + [ "security add-generic-password exited with code " + , T.pack (show c) + , renderStderr err + ] + +-- | Delete @service@/@account@ from the OS keychain. +-- +-- Exit code 44 (not found) is treated as success — the intent ("no such +-- item remains") is already true. +deleteFromKeychain + :: Text -- ^ service + -> Text -- ^ account + -> IO (Either Text ()) +deleteFromKeychain service account + | not isKeychainPlatform = pure $ Left $ T.concat + [ "keychain backend not implemented on " + , platformName + , "; cannot delete secret. PR welcome." + ] + | otherwise = do + let args = + [ "delete-generic-password" + , "-s", T.unpack service + , "-a", T.unpack account + ] + (code, _out, err) <- readProcessWithExitCode "security" args "" + case code of + ExitSuccess -> pure (Right ()) + ExitFailure c + | c == securityNotFoundExitCode -> pure (Right ()) + | otherwise -> + pure $ Left $ T.concat + [ "security delete-generic-password exited with code " + , T.pack (show c) + , renderStderr err + ] diff --git a/src/Synapse/Self/Resolve/Literal.hs b/src/Synapse/Self/Resolve/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Resolve/Literal.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The @literal:\@ resolver — the opaque escape hatch. +-- +-- Everything after @literal:@ is returned verbatim. No URL-decoding, no +-- trimming: @literal: foo @ yields @" foo "@ (leading\/trailing spaces +-- preserved). @literal:@ (empty body) yields @""@. +-- +-- This is the dumbest possible resolver on purpose: the common case is +-- "paste a JWT, don\'t make me think about encoding." +module Synapse.Self.Resolve.Literal + ( literalResolver + ) where + +import qualified Data.Text as T + +import Synapse.Self.Resolve + ( ParsedUri(..) + , ParsedUriBody(..) + , ResolveError(..) + , ResolveFn + ) +import Synapse.Self.Types (CredentialRef(..)) + +-- | Resolver for @literal:\@. +-- +-- Only dispatches on 'OpaqueBody' — a hierarchical @literal:\/\/x@ shape +-- is a shape error, reported as 'ResolveBackendError' (the scheme is +-- registered; the caller just used the wrong form). +literalResolver :: ResolveFn +literalResolver ParsedUri{puScheme, puBody} = + case puBody of + OpaqueBody body -> pure (Right body) + HierarchicalBody{} -> + pure $ Left $ ResolveBackendError + (CredentialRef (puScheme <> ":")) + (T.concat + [ "literal: scheme must be opaque (literal:), " + , "not hierarchical (literal://...)" + ]) diff --git a/src/Synapse/Self/Types.hs b/src/Synapse/Self/Types.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Self/Types.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | On-disk types and file format for per-backend defaults. +-- +-- The defaults store is a manifest of credential *references* (URIs), +-- not plaintext credentials. A resolver registry ('Synapse.Self.Resolve') +-- dereferences the URIs at dispatch time. +-- +-- This module defines: +-- +-- * 'StoredDefaults' — in-memory shape of the on-disk file. +-- * 'CredentialRef' — an opaque URI string carried verbatim. +-- * 'ScopedDefaults' — reserved for per-namespace / per-method overrides; +-- parsed but unused in v1. +-- * Pure 'encodeDefaults' / 'decodeDefaults' functions with deterministic +-- key ordering and two-space indent. +-- +-- The file format is versioned; unknown top-level fields are tolerated for +-- forward compatibility, but unknown versions are rejected loudly. +module Synapse.Self.Types + ( -- * On-disk shape + StoredDefaults(..) + , CredentialRef(..) + , ScopedDefaults(..) + , emptyStoredDefaults + , currentVersion + + -- * Encoding + , encodeDefaults + , decodeDefaults + ) where + +import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), (.=), (.:), (.:?), (.!=), object, withObject, withText) +import qualified Data.Aeson as Aeson +import Data.Aeson.Encode.Pretty (Config(..), Indent(..), NumberFormat(..), encodePretty') +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T + +-- | Current on-disk format version. +-- +-- Incremented whenever the file shape changes in a non-backward-compatible +-- way. Decoders reject anything that is not exactly this version with a +-- structured error; see 'decodeDefaults'. +currentVersion :: Int +currentVersion = 1 + +-- | A raw credential reference URI, carried verbatim. +-- +-- The wrapper exists so we never accidentally confuse a URI with a resolved +-- secret value. Parsing into scheme + body is deferred to 'Synapse.Self.Resolve.parseUri' +-- because the file parses as long as the shape is right — invalid schemes +-- should only surface when we try to actually resolve them. +newtype CredentialRef = CredentialRef { unCredentialRef :: Text } + deriving stock (Show, Eq, Ord) + +instance ToJSON CredentialRef where + toJSON = String . unCredentialRef + +instance FromJSON CredentialRef where + parseJSON = withText "CredentialRef" (pure . CredentialRef) + +-- | Per-scope overrides. v1 carries the shape through verbatim but does +-- not consume it — resolution ignores scopes for now. Defined here so the +-- file format is stable when scope semantics land. +data ScopedDefaults = ScopedDefaults + { sdsCookies :: Map Text CredentialRef + , sdsHeaders :: Map Text CredentialRef + } + deriving stock (Show, Eq) + +instance ToJSON ScopedDefaults where + toJSON ScopedDefaults{..} = object + [ "cookies" .= sdsCookies + , "headers" .= sdsHeaders + ] + +instance FromJSON ScopedDefaults where + parseJSON = withObject "ScopedDefaults" $ \o -> do + cookies <- o .:? "cookies" .!= Map.empty + headers <- o .:? "headers" .!= Map.empty + pure ScopedDefaults + { sdsCookies = cookies + , sdsHeaders = headers + } + +-- | The on-disk defaults store for a single backend. +-- +-- Values in 'sdCookies' / 'sdHeaders' are 'CredentialRef's — URIs like +-- @keychain:\/\/svc\/account@ or @literal:raw-value@. The resolver registry +-- dereferences them at dispatch time. +data StoredDefaults = StoredDefaults + { sdVersion :: Int + , sdCookies :: Map Text CredentialRef + , sdHeaders :: Map Text CredentialRef + , sdScopes :: Map Text ScopedDefaults + } + deriving stock (Show, Eq) + +-- | An empty defaults file at the current version. +emptyStoredDefaults :: StoredDefaults +emptyStoredDefaults = StoredDefaults + { sdVersion = currentVersion + , sdCookies = Map.empty + , sdHeaders = Map.empty + , sdScopes = Map.empty + } + +instance ToJSON StoredDefaults where + toJSON StoredDefaults{..} = object + [ "version" .= sdVersion + , "defaults" .= object + [ "cookies" .= sdCookies + , "headers" .= sdHeaders + ] + , "scopes" .= sdScopes + ] + +instance FromJSON StoredDefaults where + parseJSON = withObject "StoredDefaults" $ \o -> do + version <- o .: "version" + defaultsObj <- o .:? "defaults" .!= object [] + (cookies, headers) <- flip (withObject "defaults") defaultsObj $ \d -> do + c <- d .:? "cookies" .!= Map.empty + h <- d .:? "headers" .!= Map.empty + pure (c, h) + scopes <- o .:? "scopes" .!= Map.empty + pure StoredDefaults + { sdVersion = version + , sdCookies = cookies + , sdHeaders = headers + , sdScopes = scopes + } + +-- | Serialize 'StoredDefaults' with deterministic key order and two-space +-- indent. Callers can hash the result for change detection and expect +-- byte-stable output across runs. +encodeDefaults :: StoredDefaults -> ByteString +encodeDefaults sd = LBS.toStrict (encodePretty' config (toJSON sd)) + where + config = Config + { confIndent = Spaces 2 + , confCompare = compare + , confNumFormat = Generic + , confTrailingNewline = False + } + +-- | Parse a defaults file. Tolerates unknown top-level keys for forward +-- compatibility, treats a missing @defaults@ object as empty, and rejects +-- unknown versions with a structured message. +decodeDefaults :: ByteString -> Either Text StoredDefaults +decodeDefaults bs = + case Aeson.eitherDecodeStrict' bs of + Left err -> Left (T.pack err) + Right value -> case value of + Object o -> do + version <- lookupInt "version" o + if version /= currentVersion + then Left ("unsupported version: " <> T.pack (show version) + <> ", expected " <> T.pack (show currentVersion)) + else case Aeson.fromJSON value of + Aeson.Success sd -> Right sd + Aeson.Error e -> Left (T.pack e) + _ -> Left "expected top-level JSON object" + where + lookupInt name o = case KM.lookup (Key.fromText name) o of + Nothing -> Left ("missing required field: " <> name) + Just v -> case Aeson.fromJSON v of + Aeson.Success n -> Right n + Aeson.Error e -> Left ("field " <> name <> ": " <> T.pack e) diff --git a/src/Synapse/Transport.hs b/src/Synapse/Transport.hs --- a/src/Synapse/Transport.hs +++ b/src/Synapse/Transport.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Transport layer for Synapse @@ -19,21 +20,31 @@ -- * Bidirectional Response , sendResponse + + -- * Upgrade headers (IDENTITY-16: discovery probes carry them too) + , mergeUpgradeHeaders ) where import Control.Monad.IO.Class (liftIO) +import Data.IORef (newIORef, readIORef, modifyIORef') import Control.Monad.Reader (asks) import Data.Aeson (Value) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.CaseInsensitive as CI +import qualified Data.List as List import Data.Text (Text) import qualified Data.Text as T +import qualified Network.WebSockets as WS -import Plexus.Client (SubstrateConfig(..), cookieHeader) +import Plexus.Client (SubstrateConfig(..), cookieHeader, hostHeader) import qualified Plexus.Transport as ST import qualified Plexus.Types as PT import Synapse.Schema.Types import Synapse.Monad +import Synapse.Endpoint (substrateConfig) import qualified Synapse.Log as Log +import qualified Synapse.Reconnect as R -- | Fetch the root schema fetchSchema :: SynapseM PluginSchema @@ -42,21 +53,71 @@ Log.logInfo logger Log.SubsystemSchema "Fetching root schema" fetchSchemaAt [] --- | Convert plexus-protocol TransportError to error message +-- | Convert plexus-protocol TransportError to error message. +-- +-- SAFE-5 + REQ-5: detect embedded JSON-RPC semantic error codes in the +-- protocol-error message and rewrite them with meaningful prefixes. +-- The wire format wraps RpcError as @"Subscription error: RpcErrorObj +-- {errCode = N, errMessage = \\"...\\", errData = ...}"@; we parse N +-- to render semantic prefixes for the four documented codes: +-- +-- * @-32001@ Authentication required (REQ-5 hint added downstream) +-- * @-32602@ Invalid parameters +-- * @-32601@ Method not found +-- * @-32000@ Execution error transportErrorToText :: PT.TransportError -> Text transportErrorToText (PT.ConnectionRefused host port) = "Connection refused to " <> host <> ":" <> T.pack (show port) transportErrorToText (PT.ConnectionTimeout host port) = "Connection timeout to " <> host <> ":" <> T.pack (show port) -transportErrorToText (PT.ProtocolError msg) = "Protocol error: " <> msg +transportErrorToText (PT.ProtocolError msg) = renderProtocolError msg transportErrorToText (PT.NetworkError msg) = "Network error: " <> msg +transportErrorToText (PT.ConnectionLost msg _) = "Connection lost: " <> msg +-- | Inspect a protocol-error message for an embedded JSON-RPC error code +-- and rewrite with a semantic prefix. Falls back to the original message +-- when no recognized code is found. +renderProtocolError :: Text -> Text +renderProtocolError msg = + case extractErrCode msg of + Just (-32001) -> "Authentication required: " <> extractErrMessage msg + <> "\nHint: pass --token , set SYNAPSE_TOKEN, or store an access_token ref in ~/.plexus//defaults.json (see `synapse _self`)" + Just (-32602) -> "Invalid parameters: " <> extractErrMessage msg + <> "\nHint: run with --help for the method to see expected params" + Just (-32601) -> "Method not found: " <> extractErrMessage msg + <> "\nHint: run 'synapse ' to list available methods" + Just (-32000) -> "Execution error: " <> extractErrMessage msg + _ -> "Protocol error: " <> msg + +-- | Pull the @errCode = N@ integer out of a 'show'-ed RpcErrorObj. +extractErrCode :: Text -> Maybe Int +extractErrCode msg = + case T.breakOn "errCode = " msg of + (_, rest) | not (T.null rest) -> + let after = T.drop (T.length "errCode = ") rest + digits = T.takeWhile (\c -> c == '-' || (c >= '0' && c <= '9')) after + in case T.unpack digits of + "" -> Nothing + d -> Just (read d) + _ -> Nothing + +-- | Pull the @errMessage = "..."@ string out of a 'show'-ed RpcErrorObj. +-- Returns the empty string if no message can be parsed. +extractErrMessage :: Text -> Text +extractErrMessage msg = + case T.breakOn "errMessage = \"" msg of + (_, rest) | not (T.null rest) -> + let after = T.drop (T.length "errMessage = \"") rest + in T.takeWhile (/= '"') after + _ -> "" + -- | Convert plexus-protocol TransportError to TransportCategory transportErrorToCategory :: PT.TransportError -> TransportErrorCategory transportErrorToCategory (PT.ConnectionRefused _ _) = ConnectionRefused transportErrorToCategory (PT.ConnectionTimeout _ _) = ConnectionTimeout transportErrorToCategory (PT.ProtocolError _) = ProtocolError transportErrorToCategory (PT.NetworkError _) = UnknownTransportError +transportErrorToCategory (PT.ConnectionLost _ _) = UnknownTransportError -- | Fetch schema at a specific path fetchSchemaAt :: Path -> SynapseM PluginSchema @@ -65,7 +126,7 @@ cfg <- getConfig Log.logDebug logger Log.SubsystemSchema $ "Fetching schema at path: " <> T.pack (show path) - result <- liftIO $ ST.fetchSchemaAt cfg path + result <- liftIO $ R.retrying (whereOf cfg) $ ST.fetchSchemaAt cfg path case result of Left err -> do Log.logInfo logger Log.SubsystemSchema $ @@ -81,7 +142,7 @@ fetchMethodSchema :: Path -> Text -> SynapseM MethodSchema fetchMethodSchema path methodName = do cfg <- getConfig - result <- liftIO $ ST.fetchMethodSchemaAt cfg path methodName + result <- liftIO $ R.retrying (whereOf cfg) $ ST.fetchMethodSchemaAt cfg path methodName case result of Left err -> throwNav $ FetchError (transportErrorToText err) path Right schema -> pure schema @@ -186,14 +247,18 @@ -- the response is sent back via {backend}.respond (if the handler returns Just). -- If the handler returns Nothing (BidirRespond mode), no response is sent immediately. invokeStreamingWithBidir - :: Path + :: R.CallShape -- ^ SYNAPSE-20: how it rides out an outage + -> IO (Maybe WS.Headers) -- ^ SYNAPSE-20: sign in again; the upgrade's new headers + -> (R.Resumed -> IO ()) -- ^ told when a stream resumed after a gap + -> Path -> Text -> Value -> (HubStreamItem -> IO ()) -- ^ Handler for non-request items -> (Text -> PT.Request Value -> IO (Maybe (PT.Response Value))) -- ^ Handler for bidirectional requests -> SynapseM () -invokeStreamingWithBidir namespacePath method params onItem onBidirRequest = do +invokeStreamingWithBidir shape refreshAuth onResume namespacePath method params onItem onBidirRequest = do cfg <- getConfig + cfgRef <- liftIO $ newIORef cfg let wrappedHandler item = case item of PT.StreamRequest _ _ reqId reqData _timeout -> do -- Handle the bidirectional request @@ -205,7 +270,17 @@ pure () Nothing -> pure () -- agent will respond via separate call _ -> onItem item - result <- liftIO $ ST.invokeMethodStreaming cfg namespacePath method params wrappedHandler + attempt ps subscribed h = do + c <- readIORef cfgRef + ST.invokeMethodStreamingWith c subscribed namespacePath method ps h + reauth = refreshAuth >>= \case + Just hs -> True <$ modifyIORef' cfgRef (\c -> c { substrateHeaders = hs }) + Nothing -> pure False + -- SYNAPSE-20: through an outage — a read sent again, a stream resumed + -- (with since when it takes one), a write that went out never repeated + result <- liftIO $ + R.resilientCall (whereOf cfg) shape attempt reauth params onResume wrappedHandler + >>= R.reportEnding (whereOf cfg) case result of Left transportErr -> do backend <- asks seBackend @@ -228,6 +303,13 @@ getPort (PT.ConnectionTimeout _ p) _ = p getPort _ c = substratePort c +-- | SYNAPSE-20: @host:port@, for what synapse says about an outage +-- (SCAFFOLD-21: the URL, for an address behind TLS or on a path). +whereOf :: SubstrateConfig -> Text +whereOf c = case (substrateTls c, substratePath c) of + (Nothing, "/") -> T.pack (substrateHost c) <> ":" <> T.pack (show (substratePort c)) + (tls, path) -> maybe "ws" (const "wss") tls <> "://" <> T.pack (hostHeader c) <> T.pack path + -- | Send a response for a bidirectional request sendResponse :: Text -> PT.Response Value -> SynapseM () sendResponse requestId response = do @@ -250,14 +332,30 @@ -- | Get SubstrateConfig from environment getConfig :: SynapseM SubstrateConfig getConfig = do - host <- asks seHost - port <- asks sePort + ep <- asks seEndpoint backend <- asks seBackend mToken <- asks seToken - pure $ SubstrateConfig - { substrateHost = T.unpack host - , substratePort = port - , substratePath = "/" - , substrateBackend = backend - , substrateHeaders = maybe [] cookieHeader mToken - } + cks <- asks seCookies + hdrs <- asks seHeaders + -- SAFE-S04: merge token Cookie + arbitrary --cookie/--header upgrade context. + -- SCAFFOLD-21: the endpoint's scheme (ws / wss) and path come along. + pure $ substrateConfig ep backend (mergeUpgradeHeaders mToken cks hdrs) + +-- | Build the WS upgrade Headers list from optional token + extra cookies + extra headers. +-- Cookies are concatenated into a single Cookie header as @key=value; key=value@. +-- Token (when present) becomes a @access_token=...@ cookie entry merged with the rest. +mergeUpgradeHeaders :: Maybe Text -> [(Text, Text)] -> [(Text, Text)] -> WS.Headers +mergeUpgradeHeaders mToken extraCookies extraHeaders = + let allCookies = case mToken of + Just tok -> ("access_token", tok) : extraCookies + Nothing -> extraCookies + cookieHdr = if null allCookies + then [] + else + let kv (k, v) = T.unpack k <> "=" <> T.unpack v + joined = BS8.pack $ List.intercalate "; " (map kv allCookies) + in [(CI.mk "Cookie", joined)] + otherHdrs = [ (CI.mk (BS8.pack (T.unpack k)), BS8.pack (T.unpack v)) + | (k, v) <- extraHeaders + ] + in cookieHdr ++ otherHdrs diff --git a/test/AuthSpec.hs b/test/AuthSpec.hs new file mode 100644 --- /dev/null +++ b/test/AuthSpec.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE LambdaCase #-} + +-- | 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; +-- * 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 +-- 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. +-- +-- @SYNAPSE_MOCK_HUB=today|anonymous|caller@ runs the mock hub instead of +-- the tests (it prints its port), for transcripts by hand. +module Main (main) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad (void) +import Data.Aeson (Value, fromJSON, Result(..), toJSON, decode) +import qualified Data.Aeson as A +import Data.Aeson.QQ.Simple (aesonQQ) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Katip +import qualified Network.Socket as N +import qualified Network.Socket.ByteString as NB +import System.Environment (lookupEnv, setEnv) +import Test.Hspec + +import Plexus.Auth +import Plexus.Schema.Recursive (ChildSummary(..), MethodSchema(..), PluginSchema(..), MethodRole(..), hasAuthColumns) +import Plexus.Types (PlexusStreamItem(..), itemRefusal) +import Synapse.Endpoint (plainAt) +import Synapse.Algebra.Render (renderSchema, renderSchemaFor, defaultStyle) +import Synapse.Auth +import Synapse.Auth.Loopback +import Synapse.Identity.Proof (generateSeed) +import qualified Synapse.Identity.Session as Session +import qualified Synapse.Log as Log + +import MockHub + +main :: IO () +main = do + serve <- lookupEnv "SYNAPSE_MOCK_HUB" + 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) + _ -> do + setEnv "SYNAPSE_NO_BROWSER" "1" + hspec spec + +-- ============================================================================ +-- Fixtures +-- ============================================================================ + +parse :: A.FromJSON a => Value -> a +parse v = case fromJSON v of + Success x -> x + Error e -> error e + +-- AUTH-3/4: a caller's tickets schema +callerTickets :: PluginSchema +callerTickets = parse [aesonQQ|{ + "namespace": "tickets", "version": "0.5.0", "description": "Plans as data", "hash": "v-9a77", + "view": "caller", + "roles": {"viewer": ["tickets.get", "tickets.list"], "editor": ["tickets.get", "tickets.list", "tickets.set_status"]}, + "methods": [ + {"name": "get", "description": "One ticket by id", "hash": "g", "grant": "tickets.get", "target": "id", "held_on": ["MENGER"]}, + {"name": "list", "description": "Tickets, filtered and paged", "hash": "l", "grant": "tickets.list", "held_on": ["MENGER"]}, + {"name": "set_status", "description": "Change a ticket's status", "hash": "s", + "long_description": "Moves it through Pending → Ready → Coding → In Review → Complete; a doc has no lifecycle and is refused.", + "grant": "tickets.set_status", "target": "id", "held_on": ["MENGER-12"]} + ]}|] + +-- today's: no grant, no view +todaysTickets :: PluginSchema +todaysTickets = parse [aesonQQ|{ + "namespace": "tickets", "version": "0.5.0", "description": "Plans as data", "hash": "t0", + "methods": [ + {"name": "get", "description": "One ticket by id", "hash": "g"}, + {"name": "set_status", "description": "Change a ticket's status", "hash": "s"} + ]}|] + +methodNamed :: Text -> PluginSchema -> MethodSchema +methodNamed n ps = head [m | m <- psMethods ps, methodName m == n] + +worker :: Whoami +worker = Whoami + { whoPrincipal = "key:ac79e0f3b1c24d5e6f708192a3b4c5d6e7f8091a2b3c4d5e6f708192a3b4c5d6" + , whoName = Just "worker-1", whoAgent = Just "worker-1" + , whoMemberships = [("editor", "MENGER")], whoCeiling = ["editor@MENGER-12"] } + +-- AUTH-2's refusal, as the subscription notification's result carries it +refusalItem :: Value +refusalItem = [aesonQQ|{"type":"error","error_kind":"forbidden", + "grant":"tickets.set_status","scope":"IDENTITY", + "roles":["editor","admin"],"held_on":["MENGER"], + "message":"needs tickets.set_status on IDENTITY", + "metadata":{"provenance":["menger"],"plexus_hash":"h","timestamp":0}}|] + +logger :: IO Log.Logger +logger = Log.makeLogger Katip.ErrorS + +-- ============================================================================ +-- The spec +-- ============================================================================ + +spec :: Spec +spec = do + describe "plexus-protocol: the method schema (AUTH-3/4)" $ do + it "reads grant, target, held_on and long_description" $ do + let m = methodNamed "set_status" callerTickets + methodGrant m `shouldBe` Just "tickets.set_status" + methodTarget m `shouldBe` Just "id" + methodHeldOn m `shouldBe` Just ["MENGER-12"] + methodLongDescription m `shouldSatisfy` maybe False ("Moves it through" `T.isPrefixOf`) + methodTarget (methodNamed "list" callerTickets) `shouldBe` Nothing + it "reads their absence as nothing (today's schemas)" $ do + let m = methodNamed "set_status" todaysTickets + (methodGrant m, methodTarget m, methodHeldOn m, methodLongDescription m, methodPublic m) + `shouldBe` (Nothing, Nothing, Nothing, Nothing, False) + (psRoles todaysTickets, psView todaysTickets) `shouldBe` (Nothing, Nothing) + hasAuthColumns todaysTickets `shouldBe` False + it "reads roles and the view on a caller's plugin schema" $ do + psView callerTickets `shouldBe` Just Caller + fmap (Map.lookup "viewer") (psRoles callerTickets) `shouldBe` Just (Just ["tickets.get", "tickets.list"]) + hasAuthColumns callerTickets `shouldBe` True + it "reads an anonymous view's bare schema (a method named and public, children without hashes)" $ do + let root = parse [aesonQQ|{"namespace":"menger","hash":"v-anon-3c1f", + "children":[{"namespace":"auth","methods":[{"name":"providers","public":true},{"name":"login","public":true}]}]}|] :: PluginSchema + map csNamespace (maybe [] id (psChildren root)) `shouldBe` ["auth"] + psVersion root `shouldBe` "" + let m = parse [aesonQQ|{"name":"login","public":true}|] :: MethodSchema + (methodName m, methodPublic m, methodDescription m, methodRole m) `shouldBe` ("login", True, "", MethodRoleRpc) + it "writes the new fields back only when present" $ do + let v = toJSON (methodNamed "set_status" todaysTickets) + (decode (A.encode v) :: Maybe MethodSchema) `shouldBe` Just (methodNamed "set_status" todaysTickets) + show v `shouldNotContain` "grant" + (fromJSON (toJSON callerTickets) :: Result PluginSchema) `shouldBe` Success callerTickets + + describe "plexus-protocol: _info's view and auth block (AUTH-4)" $ do + it "today's _info: no view, no auth" $ do + let i = parseBackendInfo [aesonQQ|{"backend":"menger","auth_capabilities":{"mechanisms":[{"kind":"anonymous"}]}}|] + i `shouldBe` Just (BackendInfo "menger" Nothing Nothing Nothing) + it "an anonymous _info: the door's methods and the resource metadata" $ do + let i = parseBackendInfo [aesonQQ|{"backend":"menger","view":"anonymous", + "auth":{"methods":["auth.providers","auth.login","auth.signup"], + "resource_metadata":"http://127.0.0.1:4456/.well-known/oauth-protected-resource"}}|] + fmap infoView i `shouldBe` Just (Just Anonymous) + fmap (fmap authMethods . infoAuth) i `shouldBe` Just (Just ["auth.providers", "auth.login", "auth.signup"]) + fmap (fmap authResourceMetadata . infoAuth) i `shouldBe` Just (Just (Just "http://127.0.0.1:4456/.well-known/oauth-protected-resource")) + it "a caller's _info, its view's hash as view_hash, hash, or inside a view object" $ do + fmap infoViewHash (parseBackendInfo [aesonQQ|{"backend":"m","view":"caller","view_hash":"v-9a77"}|]) `shouldBe` Just (Just "v-9a77") + fmap infoViewHash (parseBackendInfo [aesonQQ|{"backend":"m","view":"caller","hash":"v-1"}|]) `shouldBe` Just (Just "v-1") + let o = parseBackendInfo [aesonQQ|{"backend":"m","view":{"kind":"caller","hash":"v-2"}}|] + fmap (\i -> (infoView i, infoViewHash i)) o `shouldBe` Just (Just Caller, Just "v-2") + it "a view it cannot read is no view, never a failed _info" $ + fmap infoView (parseBackendInfo [aesonQQ|{"backend":"m","view":"sideways","auth":7}|]) `shouldBe` Just Nothing + + describe "plexus-protocol: the refusal item (AUTH-2)" $ do + it "an error item with error_kind forbidden carries its grant, scope, roles and held_on" $ do + let item = parse refusalItem :: PlexusStreamItem + itemRefusal item `shouldBe` Just Refusal + { refusalGrant = Just "tickets.set_status", refusalScope = Just "IDENTITY" + , refusalRoles = ["editor", "admin"], refusalHeldOn = ["MENGER"], refusalCeiling = [] + , refusalMessage = "needs tickets.set_status on IDENTITY" } + case item of + StreamError _ _ msg _ -> msg `shouldBe` "needs tickets.set_status on IDENTITY" + _ -> expectationFailure "a refusal is still an error item" + it "parses as written in the ticket, without metadata" $ do + let bare = parse [aesonQQ|{"type":"error","error_kind":"forbidden","grant":"tickets.set_status", + "scope":"IDENTITY","roles":["editor","admin"],"held_on":["MENGER"], + "message":"needs tickets.set_status on IDENTITY"}|] :: PlexusStreamItem + fmap refusalGrant (itemRefusal bare) `shouldBe` Just (Just "tickets.set_status") + it "any other error has no refusal, and builds as before" $ do + let plain = parse [aesonQQ|{"type":"error","message":"Activation not found: auth", + "metadata":{"provenance":["menger"],"plexus_hash":"h","timestamp":0},"recoverable":false}|] + itemRefusal plain `shouldBe` Nothing + itemRefusal (StreamError "h" (parse [aesonQQ|["m"]|]) "boom" False) `shouldBe` Nothing + it "keeps a refusal's fields when written back" $ do + let item = parse refusalItem :: PlexusStreamItem + fmap itemRefusal (decode (A.encode item)) `shouldBe` Just (itemRefusal item) + it "a data item whose content is a refusal is one too; one missing every field is still read" $ do + let d = parse [aesonQQ|{"type":"data","content_type":"tickets.set_status", + "metadata":{"provenance":["menger"],"plexus_hash":"h","timestamp":0}, + "content":{"type":"error","error_kind":"forbidden","grant":"tickets.create","scope":"MENGER"}}|] + fmap refusalMessage (itemRefusal d) `shouldBe` Just "needs tickets.create on MENGER" + parseRefusal [aesonQQ|{"error_kind":"forbidden"}|] `shouldBe` Just (Refusal Nothing Nothing [] [] [] "forbidden") + parseRefusal [aesonQQ|{"error_kind":"invalid_params","message":"x"}|] `shouldBe` Nothing + + describe "the anonymous page" $ do + it "renders the ticket's transcript" $ do + let page = AnonPage "menger" (Just "1.0.0") + (anonymousMethods (Just (AuthInfo ["auth.providers", "auth.login", "auth.signup"] Nothing)) Nothing) + "synapse -P 4455" + renderAnonymousPage page `shouldBe` T.unlines + [ "menger v1.0.0" + , " Sign in to see what you can do here." + , "" + , "auth" + , " login Sign in \x2014 a person through the browser, an agent with its key" + , " signup Create an account, or ask for access" + , " providers The ways in this server offers" + , "" + , " synapse -P 4455 _login menger # a person" + , " synapse -P 4455 _login menger --key agent-7 --as w-1 # an agent" + ] + it "takes the door's methods from _info, else the auth schema's public ones, else its own three" $ do + let authS = parse [aesonQQ|{"namespace":"auth","methods":[ + {"name":"login","description":"Sign in here","public":true}, + {"name":"whoami","description":"Who","public":false}, + {"name":"magic","description":"A link by mail","public":true}]}|] + anonymousMethods Nothing (Just authS) `shouldBe` [("login", "Sign in here"), ("magic", "A link by mail")] + map fst (anonymousMethods (Just (AuthInfo ["auth.signup"] Nothing)) (Just authS)) `shouldBe` ["signup"] + map fst (anonymousMethods Nothing Nothing) `shouldBe` ["login", "signup", "providers"] + it "names no version when the view shows none" $ + head (T.lines (renderAnonymousPage (AnonPage "menger" Nothing [] "synapse"))) `shouldBe` "menger" + + describe "the caller's header" $ do + it "says who, what role where, and within what" $ + renderCallerHeader worker `shouldBe` "you are worker-1 (key:ac79\x2026) \x00B7 editor on MENGER, within MENGER-12" + it "parses auth.whoami's shape" $ + parseWhoami [aesonQQ|{"type":"whoami","principal":"key:ac79e0f3b1c24d5e6f708192a3b4c5d6e7f8091a2b3c4d5e6f708192a3b4c5d6", + "name":"worker-1","agent":"worker-1", + "memberships":[{"role":"editor","scope":"MENGER"}],"ceiling":["editor@MENGER-12"]}|] + `shouldBe` Just worker + it "reads memberships as role@SCOPE strings and a ceiling as objects" $ do + let w = parseWhoami [aesonQQ|{"principal":"oidc:workos/user_01M4QXZ7ABCDEF","name":"Ada Lovelace", + "memberships":["admin@*","viewer@IDENTITY","viewer@AUTH"], + "ceiling":[{"role":"viewer","scope":"AUTH"}]}|] + fmap renderCallerHeader w `shouldBe` + Just "you are Ada Lovelace (oidc:workos/user_01M4\x2026) \x00B7 admin on *; viewer on IDENTITY, AUTH, within AUTH" + it "falls back to session.whoami's identity (roles with no scope)" $ + fmap renderCallerHeader (parseWhoami [aesonQQ|{"type":"identity","principal":"idp:1234","name":"ada","roles":["admin"],"tenant":null}|]) + `shouldBe` Just "you are ada (idp:1234) \x00B7 admin" + it "an anonymous whoami is no one" $ do + parseWhoami [aesonQQ|{"type":"anonymous"}|] `shouldBe` Nothing + parseWhoami [aesonQQ|{"type":"identity","principal":""}|] `shouldBe` Nothing + it "shortens a long principal and leaves a short one" $ do + abbreviatePrincipal "key:ac79e0f3b1c24d5e6f708192a3b4c5d6" `shouldBe` "key:ac79\x2026" + abbreviatePrincipal "oidc:workos/user_01M4QXZ7ABCDEF" `shouldBe` "oidc:workos/user_01M4\x2026" + abbreviatePrincipal "idp:1234" `shouldBe` "idp:1234" + + describe "help in a caller's view" $ do + let out = renderSchemaFor defaultStyle (Just (renderCallerHeader worker)) callerTickets + ls = T.lines out + lineOf n = head [l | l <- ls, (" " <> n <> " ") `T.isPrefixOf` l] + colOf needle l = T.length (fst (T.breakOn needle l)) + it "puts who the caller is under the description" $ + take 3 ls `shouldBe` + [ "tickets v0.5.0", " Plans as data" + , " you are worker-1 (key:ac79\x2026) \x00B7 editor on MENGER, within MENGER-12" ] + it "shows each method's grant and where it is held, in aligned columns" $ do + lineOf "get" `shouldSatisfy` T.isInfixOf "tickets.get" + T.stripEnd (lineOf "set_status") `shouldSatisfy` T.isSuffixOf "tickets.set_status MENGER-12" + let grantCols = [colOf "tickets." (lineOf n) | n <- ["get", "list", "set_status"]] + heldCols = [colOf "MENGER" (T.drop (colOf "tickets." (lineOf n)) (lineOf n)) + colOf "tickets." (lineOf n) | n <- ["get", "list", "set_status"]] + length (filter (== head grantCols) grantCols) `shouldBe` 3 + length (filter (== head heldCols) heldCols) `shouldBe` 3 + it "renders a schema with no grants exactly as before AUTH, header or not" $ do + renderSchemaFor defaultStyle Nothing todaysTickets `shouldBe` renderSchema todaysTickets + T.lines (renderSchemaFor defaultStyle Nothing callerTickets) `shouldNotContain` + [" you are worker-1 (key:ac79\x2026) \x00B7 editor on MENGER, within MENGER-12"] + + describe "the refusal block" $ do + let r = Refusal (Just "tickets.set_status") (Just "IDENTITY") ["editor", "admin"] ["MENGER"] [] "needs tickets.set_status on IDENTITY" + it "renders the ticket's transcript, the ceiling from the session" $ + renderRefusal ["editor@MENGER-12"] r `shouldBe` T.unlines + [ "refused: needs tickets.set_status on IDENTITY" + , " roles with it editor, admin" + , " you hold it on MENGER (within MENGER-12)" ] + it "prefers the refusal's own ceiling, and says so without one" $ do + T.lines (renderRefusal ["editor@X"] r { refusalCeiling = ["editor@MENGER-7"] }) !! 2 + `shouldBe` " you hold it on MENGER (within MENGER-7)" + T.lines (renderRefusal [] r) !! 2 `shouldBe` " you hold it on MENGER" + it "says nowhere when the caller holds it nowhere, and leaves out roles it was not told" $ + renderRefusal [] (Refusal (Just "auth.role_set") (Just "*") [] [] [] "x") `shouldBe` T.unlines + [ "refused: needs auth.role_set on *", " you hold it on nowhere" ] + + describe "the loopback: a request and its state" $ do + let req s = parseRequestLine (BS8.pack s) + it "reads the request line's path and query, percent-decoded" $ + req "GET /cb?code=c_19ab&state=s%2F7f2c HTTP/1.1\r\nHost: x\r\n\r\n" + `shouldBe` Just ("GET", "/cb", [("code", "c_19ab"), ("state", "s/7f2c")]) + it "takes the code only with the state it handed out" $ do + fmap (checkCallback "s_7f2c") (req "GET /cb?code=c_1&state=s_7f2c HTTP/1.1") `shouldBe` Just (CallbackCode "c_1") + fmap (checkCallback "s_7f2c") (req "GET /cb?code=c_1&state=s_evil HTTP/1.1") `shouldSatisfy` refused + fmap (checkCallback "s_7f2c") (req "GET /cb?code=c_1 HTTP/1.1") `shouldSatisfy` refused + fmap (checkCallback "s_7f2c") (req "GET /cb?state=s_7f2c HTTP/1.1") `shouldSatisfy` refused + fmap (checkCallback "s_7f2c") (req "GET /cb?error=access_denied&state=s_7f2c HTTP/1.1") `shouldSatisfy` refused + it "ignores anything but /cb" $ + fmap (checkCallback "s") (req "GET /favicon.ico HTTP/1.1") `shouldBe` Just CallbackIgnored + it "listens on 127.0.0.1 and answers the browser" $ withLoopback $ \lb -> do + loopbackRedirect lb `shouldSatisfy` T.isPrefixOf "http://127.0.0.1:" + void $ forkIO $ do + threadDelay 100000 + _ <- httpGet (loopbackPort lb) "/favicon.ico" + reply <- httpGet (loopbackPort lb) "/cb?code=c_1&state=s_ok" + reply `shouldSatisfy` BS8.isPrefixOf "HTTP/1.1 200" + awaitCallback lb "s_ok" 5 `shouldReturn` Right "c_1" + it "refuses a browser back with another state, and ends the wait" $ withLoopback $ \lb -> do + void $ forkIO $ threadDelay 100000 >> void (httpGet (loopbackPort lb) "/cb?code=c_1&state=s_other") + r <- awaitCallback lb "s_ok" 5 + r `shouldSatisfy` either ("state" `T.isInfixOf`) (const False) + 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 + 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 + 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 + `shouldBe` Right ("mgs_person", Just "Ada Lovelace", "oidc:workos/user_01M4QXZ7ABCDEF") + 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 + 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 + 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 + 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 + 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 + lg <- logger + Session.whoamiWith lg (plainAt "127.0.0.1" port) "menger" "mgs_x" `shouldReturn` Just worker + withMockHub todaysHub $ \port -> do + lg <- logger + w <- Session.whoamiWith lg (plainAt "127.0.0.1" port) "menger" "mgs_x" + isJust w `shouldBe` False + where + refused = \case + Just (CallbackRefused _) -> True + _ -> False + +-- | A GET to the loopback, as a browser sends it; the reply's first bytes. +httpGet :: Int -> String -> IO BS8.ByteString +httpGet port path = do + 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 (BS8.pack ("GET " <> path <> " HTTP/1.1\r\nHost: 127.0.0.1\r\n\r\n")) + r <- NB.recv sock 4096 + N.close sock + pure r diff --git a/test/DeprecationSpec.hs b/test/DeprecationSpec.hs --- a/test/DeprecationSpec.hs +++ b/test/DeprecationSpec.hs @@ -67,6 +67,7 @@ , methodDeprecation = Nothing , methodParamSchemas = Nothing , methodRole = MethodRoleRpc + , methodLongDescription = Nothing, methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False, methodGroup = Nothing, methodExamples = [] } deprecatedMethod :: MethodSchema @@ -91,6 +92,7 @@ , psMethods = [deprecatedMethod, plainMethod] , psChildren = Nothing , psDeprecation = Nothing + , psRoles = Nothing, psView = Nothing } deprecatedPlugin :: PluginSchema @@ -309,7 +311,9 @@ describe "renderMethodHelp (IR-14 per-parameter deprecation in Help.hs)" $ do it "prepends the warning marker on the deprecated parameter's flag line" $ do let (_, rendered) = helpFixture - ls = T.lines rendered + -- SYNAPSE-13: the options, not the usage line or an example's + -- command line, which name the flag as it is typed + ls = takeWhile (not . T.isPrefixOf "Example") (dropWhile (/= "Options:") (T.lines rendered)) pathLines = filter (T.isInfixOf "--path") ls pathLines `shouldSatisfy` (not . null) all (T.isInfixOf deprecationMarker) pathLines `shouldBe` True diff --git a/test/EndpointSpec.hs b/test/EndpointSpec.hs new file mode 100644 --- /dev/null +++ b/test/EndpointSpec.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | SCAFFOLD-21: where a hub 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. +module Main (main) where + +import Data.Either (isLeft) +import qualified Data.Text as T +import Test.Hspec + +import Plexus.Client (SubstrateConfig(..), TlsOptions(..), hostHeader) +import Synapse.Endpoint + +main :: IO () +main = hspec $ do + describe "parseUrl" $ do + it "reads a hosted app's socket: wss, the default port, the path" $ + parseUrl "wss://hostdemo.menger.sh/ws" `shouldBe` + Right (Endpoint "hostdemo.menger.sh" 443 True "/ws" []) + it "reads ws with a port and no path as /" $ + parseUrl "ws://127.0.0.1:4455" `shouldBe` Right (plainAt "127.0.0.1" 4455) + it "defaults ws to 80 and keeps an explicit wss port" $ do + fmap epPort (parseUrl "ws://example.org/ws") `shouldBe` Right 80 + fmap epPort (parseUrl "wss://example.org:8443/ws") `shouldBe` Right 8443 + it "lowercases the host, trims a trailing slash, takes WSS in any case" $ + parseUrl "WSS://App.Example/ws/" `shouldBe` Right (Endpoint "app.example" 443 True "/ws" []) + it "reads a bracketed IPv6 literal" $ + parseUrl "wss://[::1]:8443/ws" `shouldBe` Right (Endpoint "::1" 8443 True "/ws" []) + it "refuses http(s), a missing scheme, a query, a credential, a bad port" $ do + parseUrl "https://hostdemo.menger.sh/ws" `shouldSatisfy` isLeft + parseUrl "http://hostdemo.menger.sh" `shouldSatisfy` isLeft + parseUrl "hostdemo.menger.sh/ws" `shouldSatisfy` isLeft + parseUrl "wss://h/ws?x=1" `shouldSatisfy` isLeft + parseUrl "wss://u:p@h/ws" `shouldSatisfy` isLeft + parseUrl "wss://h:99999/ws" `shouldSatisfy` isLeft + parseUrl "wss://h:/ws" `shouldSatisfy` isLeft + parseUrl "wss:///ws" `shouldSatisfy` isLeft + it "says what https:// would have meant" $ + parseUrl "https://app.example/ws" `shouldBe` + Left "--url takes ws:// or wss://, not https:// (the socket of an https page is wss://app.example/ws)" + + describe "normalisePath" $ + it "makes /PATH of any spelling" $ do + map normalisePath ["", "/", "ws", "/ws", "/ws/", "//a/b//"] `shouldBe` ["/", "/", "/ws", "/ws", "/ws", "/a/b"] + + describe "the session store's keys" $ do + it "keeps a plain address's key and directory exactly as before (no stored session moves)" $ do + addressKey (plainAt "127.0.0.1" 4455) `shouldBe` "127.0.0.1:4455" + dirName (plainAt "127.0.0.1" 4455) `shouldBe` "127.0.0.1_4455" + it "keys a wss address by its URL, port and path included" $ do + let ep = Endpoint "hostdemo.menger.sh" 443 True "/ws" [] + addressKey ep `shouldBe` "wss://hostdemo.menger.sh:443/ws" + dirName ep `shouldBe` "wss_hostdemo.menger.sh_443_ws" + it "never gives a ws and a wss backend on one host, or two paths, one key" $ do + let eps = + [ plainAt "h" 443 + , Endpoint "h" 443 True "/" [] + , Endpoint "h" 443 True "/ws" [] + , Endpoint "h" 443 True "/ws/a" [] + , Endpoint "h" 443 False "/ws" [] + , Endpoint "h" 443 True "/ws_a" [] + ] + distinct xs = length xs == length (foldr (\x acc -> if x `elem` acc then acc else x : acc) [] xs) + map addressKey eps `shouldSatisfy` distinct + map dirName eps `shouldSatisfy` distinct + it "writes anything outside [A-Za-z0-9.-] in a path as %XX, never a separator" $ do + dirName (Endpoint "h" 443 True "/a b/ü" []) `shouldBe` "wss_h_443_a%20b_%c3%bc" + dirName (Endpoint "h" 443 True "/../x" []) `shouldBe` "wss_h_443_.._x" + dirName (Endpoint "h" 443 True "/../x" []) `shouldNotSatisfy` ('/' `elem`) + it "ignores the CA files (they say how to trust the server, not which it is)" $ + addressKey (Endpoint "h" 443 True "/ws" ["/tmp/ca.pem"]) `shouldBe` addressKey (Endpoint "h" 443 True "/ws" []) + + 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 + audience (Endpoint "hostdemo.menger.sh" 443 True "/ws" []) `shouldBe` "wss://hostdemo.menger.sh" + audience (Endpoint "localhost" 8443 True "/ws" []) `shouldBe` "wss://localhost:8443" + + describe "cliOptions (what a message tells the reader to type)" $ do + it "says nothing for the default address, -P / -H for a plain one" $ do + cliOptions (plainAt "127.0.0.1" 4444) `shouldBe` "" + cliOptions (plainAt "127.0.0.1" 4455) `shouldBe` "-P 4455" + cliOptions (plainAt "box" 4455) `shouldBe` "-H box -P 4455" + it "says --url, in its short form, for the rest (and each --cacert)" $ do + cliOptions (Endpoint "hostdemo.menger.sh" 443 True "/ws" []) `shouldBe` "--url wss://hostdemo.menger.sh/ws" + cliOptions (Endpoint "localhost" 8443 True "/ws" ["ca.pem"]) `shouldBe` "--url wss://localhost:8443/ws --cacert ca.pem" + cliOptions (Endpoint "h" 8080 False "/ws" []) `shouldBe` "--url ws://h:8080/ws" + it "round-trips through parseUrl" $ + mapM_ (\ep -> case T.words (cliOptions ep) of + ("--url" : u : _) -> parseUrl u `shouldBe` Right ep + other -> expectationFailure ("no --url in " <> show other)) + [ Endpoint "hostdemo.menger.sh" 443 True "/ws" [] + , Endpoint "localhost" 8443 True "/" [] + , Endpoint "h" 8080 False "/ws" [] ] + + describe "substrateConfig" $ do + it "dials plain ws with no TLS for a plain address" $ do + let c = substrateConfig (plainAt "127.0.0.1" 4455) "menger" [] + (substrateHost c, substratePort c, substratePath c, substrateTls c) `shouldBe` ("127.0.0.1", 4455, "/", Nothing) + it "dials wss at the path, the CA files carried, the Host header without :443" $ do + let c = substrateConfig (Endpoint "hostdemo.menger.sh" 443 True "/ws" ["ca.pem"]) "hostdemo" [] + (substratePath c, substrateTls c) `shouldBe` ("/ws", Just (TlsOptions ["ca.pem"])) + hostHeader c `shouldBe` "hostdemo.menger.sh" + hostHeader c { substratePort = 8443 } `shouldBe` "hostdemo.menger.sh:8443" diff --git a/test/FindSpec.hs b/test/FindSpec.hs new file mode 100644 --- /dev/null +++ b/test/FindSpec.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | SYNAPSE-17: @synapse _find@. +-- +-- * 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 +-- 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 +-- of running the tests (it prints its port), for transcripts by hand. +module Main (main) where + +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.IORef (readIORef) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Katip +import System.Directory (getTemporaryDirectory, createDirectoryIfMissing, removeDirectoryRecursive, doesDirectoryExist) +import System.Environment (lookupEnv) +import System.FilePath (()) +import Test.Hspec + +import Synapse.Algebra.Render (fitText, summarize) +import Synapse.Find +import Synapse.IR.Cache (CacheConfig(..), newIRCache) +import Synapse.IR.Types +import qualified Synapse.Log as Log +import Synapse.Monad (initEnv, runSynapseM, withViewKey) + +import MockHub + +main :: IO () +main = do + serve <- lookupEnv "SYNAPSE_MOCK_HUB" + dump <- lookupEnv "SYNAPSE_FIND_DUMP" + case (serve, dump) of + (Just "catalog", _) -> serveMockHub (catalogHub NoView) + (Just "catalog-caller", _) -> serveMockHub (catalogHub CallerView) + (_, Just _) -> dumpAll + _ -> hspec spec + +-- ============================================================================ +-- Fixtures +-- ============================================================================ + +-- | The catalog as a view of the mock hub has it (no cache). +catalog :: ViewMode -> IO IR +catalog v = withMockHub (catalogHub 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 + r <- runSynapseM env (loadCatalog Nothing) + either (\e -> fail (show e)) pure r + +opts :: [Text] -> FindOpts +opts ws = FindOpts "menger" ws defaultLimit False False + +-- | _find menger WORDS, as synapse -P 4455 says it, piped or on a terminal. +page :: IR -> Bool -> FindOpts -> Text +page ir bold fo = anText (answer "synapse -P 4455" "menger" bold fo ir) + +stripEsc :: Text -> Text +stripEsc = T.replace "\ESC[1m" "" . T.replace "\ESC[22m" "" + +-- | The ticket's examples: how each is typed, its golden file, the opts, +-- and a stretch of its terminal page that must be bold. +examples :: [(String, FilePath, FindOpts, Text)] +examples = + [ ("snooze", "snooze", opts ["snooze"], "tickets \ESC[1msnooze\ESC[22m") + , ("comit", "comit", opts ["comit"], "link_\ESC[1mcommit\ESC[22ms") + , ("queue urgency", "queue-urgency", opts ["queue", "urgency"], "--\ESC[1murgency\ESC[22m ") + , ("tickets setpar", "tickets-setpar", opts ["tickets", "setpar"], "\ESC[1mset\ESC[22m_\ESC[1mpar\ESC[22ment") + , ("--params filter", "params-filter", (opts ["filter"]) { foParams = True }, "[--\ESC[1mfilter\ESC[22m ]") + , ("reschedule", "reschedule", opts ["reschedule"], "") + -- a quoted example is never cut inside: 'category in (active, review)' + -- does not fit, so the line ends before it + , ("watch filter", "watch-filter", opts ["watch", "filter"], "--\ESC[1mfilter\ESC[22m ") + ] + +golden :: FilePath -> FilePath +golden name = "test/fixtures/find-golden" name <> ".txt" + +-- | Write the goldens again (SYNAPSE_FIND_DUMP=1), from the pages as they +-- render now: read them before committing. +dumpAll :: IO () +dumpAll = do + ir <- catalog NoView + createDirectoryIfMissing True "test/fixtures/find-golden" + mapM_ (\(_, file, fo, _) -> TIO.writeFile (golden file) (page ir False fo)) examples + LBS.writeFile (golden "rationale-json") (LBS.unlines (map encode (anJson (answer "synapse -P 4455" "menger" False (opts ["rationale"]) ir)))) + +-- | A method as the IR has it, for the ranking's synthetic catalog. +method :: Text -> Text -> Text -> MethodDef +method ns name desc = MethodDef + { mdName = name, mdFullPath = ns <> "." <> name, mdNamespace = ns + , mdDescription = Just desc, mdStreaming = False, mdParams = [] + , mdReturns = RefUnknown, mdBidirType = Nothing, mdBidirResponseType = Nothing + , mdBidirResponseSchema = Nothing, mdRole = MethodRoleRpc + , mdGrant = Nothing, mdTarget = Nothing, mdLongDescription = Nothing + } + +synthetic :: IR +synthetic = emptyIR { irMethods = Map.fromList [ (mdFullPath m, m) | m <- ms ] } + where + ms = + [ method "tickets" "find" "One by id" + , method "x" "find" "One by id, elsewhere" + , method "tickets" "find_all" "Every one" + , method "tickets" "fi_nder" "A finder" + , method "tickets" "fine" "A fine" + , method "tickets" "lookup" "Find things by name" + , method "tickets" "other" "Nothing to see" + ] + +kinds :: Text -> Text -> Maybe MatchKind +kinds w n = wmKind <$> matchName w n + +-- ============================================================================ +-- The spec +-- ============================================================================ + +spec :: Spec +spec = do + describe "the matcher" $ do + it "an exact name" $ + kinds "snooze" "snooze" `shouldBe` Just Exact + it "a prefix of the name, a segment, a segment's start" $ do + kinds "snooze" "snoozed" `shouldBe` Just Prefix + kinds "commits" "link_commits" `shouldBe` Just SegmentExact + kinds "commit" "link_commits" `shouldBe` Just SegmentPrefix + it "a typo of 4-7 letters: one edit, said as the name it meant" $ do + fmap (\m -> (wmKind m, wmTaken m)) (matchName "comit" "link_commits") `shouldBe` Just (Typo 1, "commit") + kinds "snoze" "snooze" `shouldBe` Just (Typo 1) + kinds "unlnik" "unlink_commits" `shouldBe` Nothing -- two edits at 6 letters + it "a typo beyond 7 letters: two edits" $ do + kinds "ratoinale" "rationale" `shouldBe` Just (Typo 2) + kinds "rationle" "rationale" `shouldBe` Just (Typo 1) + kinds "rtoinael" "rationale" `shouldBe` Nothing + it "no typo under 4 letters" $ do + typoLimit 3 `shouldBe` 0 + (typoLimit 4, typoLimit 7, typoLimit 8) `shouldBe` (1, 1, 2) + kinds "snz" "snooze" `shouldBe` Nothing + it "a snake_case subsequence: prefixes of its segments, in order" $ do + matchName "setpar" "set_parent" `shouldBe` Just (WordMatch Subsequence "set_parent" [(0, 3), (4, 3)]) + kinds "lc" "link_commits" `shouldBe` Just Subsequence + kinds "parset" "set_parent" `shouldBe` Nothing + it "a word of a description, or its start" $ do + fmap wmSpans (matchDescription "snooze" "Include the snoozed ones") `shouldBe` Just [(12, 6)] + matchDescription "zz" "zz top" `shouldBe` Nothing + it "every word must match" $ do + ir <- catalog NoView + let hits ws = search OnlyAll (catalogEntries [] ir) ws + where' h = (entryLocation (hitEntry h), pdName <$> enParam (hitEntry h)) + map where' (hits ["queue", "urgency"]) `shouldBe` [("tickets queue", Just "urgency")] + hits ["queue", "zzzz"] `shouldBe` [] + it "ranks exact > prefix > subsequence / typo > description; ties by the shorter path, then alphabetically" $ do + let ranked = map (entryLocation . hitEntry) (search OnlyAll (catalogEntries [] synthetic) ["find"]) + ranked `shouldBe` ["x find", "tickets find", "tickets find_all", "tickets fi_nder", "tickets fine", "tickets lookup"] + + describe "a description cut to the line (fitText): never inside a quote" $ do + let watchFilter = "A filter, e.g. 'category in (active, review)' (optional): adds Entered / Left for each ticket a write moves into or out of it, or Recount past 256" + it "ends before a quote that does not fit, its brackets untouched" $ do + fitText 36 (summarize watchFilter) `shouldBe` "A filter, e.g.\x2026" + fitText 50 (summarize watchFilter) `shouldBe` "A filter, e.g. 'category in (active, review)'" + it "a quote that fits stays whole" $ + fitText 40 "A filter, e.g. 'not category done' (optional)" `shouldBe` "A filter, e.g. 'not category done'" + it "a backtick span is a quote too; an apostrophe is not" $ do + fitText 26 "Run `set_status (x, y)` with the ticket's id (optional)" `shouldBe` "Run `set_status (x, y)`\x2026" + fitText 30 "The ticket's own words (optional) and more words" `shouldBe` "The ticket's own words and\x2026" + 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 + mapM_ (\(typed, file, fo, boldBit) -> do + it ("_find menger " <> typed <> ", piped: as pinned, no colour codes") $ do + ir <- catalog NoView + want <- TIO.readFile (golden file) + let got = page ir False fo + got `shouldBe` want + T.any (== '\ESC') got `shouldBe` False + it ("_find menger " <> typed <> ", on a terminal: the same, the matched characters bold") $ do + ir <- catalog NoView + want <- TIO.readFile (golden file) + let got = page ir True fo + stripEsc got `shouldBe` want + if T.null boldBit then pure () else T.isInfixOf boldBit got `shouldBe` True + ) examples + + it "-j: one JSON object per hit, best first" $ do + ir <- catalog NoView + want <- LBS.readFile (golden "rationale-json") + LBS.unlines (map encode (anJson (answer "synapse -P 4455" "menger" False (opts ["rationale"]) ir))) `shouldBe` want + + it "--limit: at most N, and the footer says how many more" $ do + ir <- catalog NoView + let t = page ir False ((opts ["filter"]) { foParams = True, foLimit = 3 }) + T.lines t `shouldContain` ["6 more: '--limit 9' shows them all."] + length (filter (" tickets " `T.isPrefixOf`) (T.lines t)) `shouldBe` 3 + + it "--methods: only methods" $ do + ir <- catalog NoView + let t = page ir False ((opts ["commit"]) { foMethods = True }) + T.lines t `shouldContain` ["METHODS"] + T.lines t `shouldNotContain` ["PARAMETERS"] + + it "a description's match is MENTIONED IN, the word shown" $ do + ir <- catalog NoView + let t = page ir False (opts ["rationale"]) + T.lines t `shouldContain` ["MENTIONED IN"] + T.isInfixOf "rationale" (T.unlines (dropWhile (/= "MENTIONED IN") (T.lines t))) `shouldBe` True + + describe "under login (a caller's view)" $ do + it "a method outside the caller's view is never a hit" $ do + outside <- catalog NoView + inside <- catalog CallerView + let paths ir = [ mdFullPath (enMethod (hitEntry h)) | h <- search OnlyAll (catalogEntries [] ir) ["delete"] ] + paths outside `shouldContain` ["tickets.delete"] + paths inside `shouldNotContain` ["tickets.delete"] + anJson (answer "synapse" "menger" False (opts ["delete"]) inside) `shouldSatisfy` all (not . T.isInfixOf "tickets.delete" . T.pack . LBS.unpack . encode) + + describe "the schema, from the IR cache when its hash is current" $ do + it "a second search costs one schema call: the hash check" $ do + tmp <- getTemporaryDirectory + let dir = tmp "synapse-find-test-cache" + exists <- doesDirectoryExist dir + if exists then removeDirectoryRecursive dir else pure () + cache <- newIRCache (CacheConfig True 100 True dir) + withMockHub (catalogHub 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 + cache' <- newIRCache (CacheConfig True 100 True dir) + Right second <- runSynapseM env (loadCatalog (Just cache')) + after <- readIORef schemaCalls + (middle - before) `shouldSatisfy` (>= 3) + (after - middle) `shouldBe` 1 + Map.keys (irMethods second) `shouldBe` Map.keys (irMethods first) + page second False (opts ["comit"]) `shouldBe` page first False (opts ["comit"]) diff --git a/test/IR12MethodRoleSpec.hs b/test/IR12MethodRoleSpec.hs --- a/test/IR12MethodRoleSpec.hs +++ b/test/IR12MethodRoleSpec.hs @@ -30,8 +30,12 @@ , MethodSchema(..) ) +import qualified Data.Map.Strict as Map +import Synapse.IR.Builder (extractMethodDef) import Synapse.IR.Types - ( MethodDef(..) + ( IR(..) + , emptyIR + , MethodDef(..) , TypeRef(..) ) @@ -49,6 +53,9 @@ , mdBidirResponseType = Nothing , mdBidirResponseSchema = Nothing , mdRole = MethodRoleRpc + , mdGrant = Nothing + , mdTarget = Nothing + , mdLongDescription = Nothing } -- | Build a JSON @MethodSchema@ with an optional @role@ key. Passing @@ -168,3 +175,41 @@ 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. + describe "AUTH-9: grant, target, long_description and roles in the IR" $ do + let schemaWith extra = object $ + [ "name" .= ("set_status" :: String) + , "description" .= ("Change a ticket's status" :: String) + , "hash" .= ("h" :: String) + ] <> extra + lifted j = case Aeson.fromJSON j :: Aeson.Result MethodSchema of + Aeson.Error e -> error e + Aeson.Success ms -> snd (extractMethodDef "tickets" "tickets" ms) + keysOf v = case v of + Object o -> o + _ -> KM.empty + + it "lifts the schema's grant, target and long_description onto the method" $ do + let md = lifted $ schemaWith + [ "grant" .= ("tickets.set_status" :: String) + , "target" .= ("id" :: String) + , "long_description" .= ("Moves it through Pending → Ready." :: String) + ] + o = keysOf (Aeson.toJSON md) + (mdGrant md, mdTarget md) `shouldBe` (Just "tickets.set_status", Just "id") + KM.lookup "mdGrant" o `shouldBe` Just (String "tickets.set_status") + KM.lookup "mdTarget" o `shouldBe` Just (String "id") + KM.lookup "mdLongDescription" o `shouldBe` Just (String "Moves it through Pending → Ready.") + fmap mdTarget (eitherDecode (encode md)) `shouldBe` Right (Just "id") + + it "a pre-AUTH schema's method carries none of the keys" $ do + let o = keysOf (Aeson.toJSON (lifted (schemaWith []))) + map (`KM.member` o) ["mdGrant", "mdTarget", "mdLongDescription"] `shouldBe` [False, False, False] + + it "irPluginRoles is emitted only when some plugin has roles" $ do + KM.member "irPluginRoles" (keysOf (Aeson.toJSON emptyIR)) `shouldBe` False + let roles = Map.singleton "tickets" (Map.singleton "editor" ["tickets.set_status"]) + withRoles = emptyIR { irPluginRoles = Just roles } + KM.lookup "irPluginRoles" (keysOf (Aeson.toJSON withRoles)) `shouldBe` Just (Aeson.toJSON roles) + fmap irPluginRoles (eitherDecode (encode withRoles)) `shouldBe` Right (Just roles) diff --git a/test/IRSpec.hs b/test/IRSpec.hs --- a/test/IRSpec.hs +++ b/test/IRSpec.hs @@ -106,8 +106,9 @@ forM_ (Map.elems $ irMethods ir) $ \method -> do let helpText = renderMethodHelp ir method T.length helpText `shouldSatisfy` (> 0) - -- Help should contain method name - helpText `shouldSatisfy` T.isInfixOf (mdFullPath method) + -- Help should contain method name (SYNAPSE-13: in its usage line, + -- as it is typed: synapse ) + helpText `shouldSatisfy` T.isInfixOf (mdName method) it "all type refs resolve" $ forM_ (Map.elems $ irMethods ir) $ \method -> do diff --git a/test/IdentitySpec.hs b/test/IdentitySpec.hs new file mode 100644 --- /dev/null +++ b/test/IdentitySpec.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | IDENTITY-43: an agent's key, its proof, and where synapse keeps both. +-- +-- * the canonical message the signature covers, byte for byte; +-- * a FIXED proof vector (seed 0x01..0x20, aud ws://127.0.0.1:4460, agent +-- worker-3, nonce 32 × 0x07, ts 1791600000) — printed, and pinned, so the +-- Rust side (IDENTITY-41/42) can check it computes the same string; +-- * the stores' order — PLEXUS_KEY, the keychain (an in-memory one here), +-- $CREDENTIALS_DIRECTORY, ~/.plexus/keys — and the session store's, all in +-- a directory of the test's own: nothing touches ~/.plexus, the real +-- keychain or a socket. +module Main (main) where + +import qualified Data.Aeson as A +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.URL as B64U +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (mapConcurrently) +import Control.Exception (SomeException, try) +import Data.IORef (readIORef, newIORef, atomicModifyIORef') +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +import System.Directory (createDirectoryIfMissing, doesFileExist, listDirectory) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Files (fileMode, getFileStatus, intersectFileModes) +import Test.Hspec + +import Synapse.Endpoint (plainAt) +import Synapse.Identity.Command (splitScopes) +import Synapse.Identity.Proof +import Synapse.Identity.Store + +-- ============================================================================ +-- The fixed vector +-- ============================================================================ + +vectorSeed :: Seed +vectorSeed = either (error . T.unpack) id (seedFromBytes (BS.pack [1 .. 32])) + +vectorAud, vectorAgent :: Text +vectorAud = "ws://127.0.0.1:4460" +vectorAgent = "worker-3" + +vectorNonce :: BS.ByteString +vectorNonce = BS.replicate 32 7 + +vectorTs :: Integer +vectorTs = 1791600000 + +vectorProof :: Text +vectorProof = buildProof vectorSeed vectorAud vectorAgent vectorNonce vectorTs + +-- | The proof the vector gives, pinned. Ed25519 signing is deterministic, +-- so this never changes unless the wire does. +expectedProof :: Text +expectedProof = + "plexus-key.eyJ2IjoxLCJrZXkiOiI3OWI1NTYyZThmZTY1NGY5NDA3OGIxMTJlOGE5OGJhNzkwMWY4NTNhZTY5NWJlZDdlMGUzOTEwYmFkMDQ5NjY0IiwiYXVkIjoid3M6Ly8xMjcuMC4wLjE6NDQ2MCIsImFnZW50Ijoid29ya2VyLTMiLCJub25jZSI6IkJ3Y0hCd2NIQndjSEJ3Y0hCd2NIQndjSEJ3Y0hCd2NIQndjSEJ3Y0hCd2MiLCJ0cyI6MTc5MTYwMDAwMCwic2lnIjoiSlJxSGx6VEd2WGZubm8zQWlsMWhudU9wZ2J6SzlyNFZPa0l6OHNRbmpkVzZwWlk4S1h5YlR4QlBBcmdaclFkeFR1M3NvaWtwSkxRMURSaDN3SVFLQVEifQ" + +-- | Its JSON, for reading. +-- +-- > {"v":1,"key":"79b5562e8fe654f94078b112e8a98ba7901f853ae695bed7e0e3910bad049664","aud":"ws://127.0.0.1:4460","agent":"worker-3","nonce":"BwcHBwcHBwcHBwcHBwcHBwcHBwcHBwcHBwcHBwcHBwc","ts":1791600000,"sig":"JRqHlzTGvXfnno3Ail1hnuOpgbzK9r4VOkIz8sQnjdW6pZY8KXybTxBPArgZrQdxTu3soikpJLQ1DRh3wIQKAQ"} + +-- ============================================================================ +-- Stores in a sandbox +-- ============================================================================ + +sandbox :: [(String, String)] -> Maybe Keychain -> FilePath -> StoreEnv +sandbox env kc dir = StoreEnv + { stEnv = \k -> pure (lookup k env) + , stPlexus = dir ".plexus" + , stKeychain = kc + } + +seedOf :: Int -> Seed +seedOf n = either (error . T.unpack) id (seedFromBytes (BS.replicate 32 (fromIntegral n))) + +mode :: FilePath -> IO Int +mode p = fromIntegral . intersectFileModes 0o777 . fileMode <$> getFileStatus p + +main :: IO () +main = do + TIO.putStrLn "" + TIO.putStrLn "IDENTITY-43 fixed vector:" + TIO.putStrLn (" seed 0x01..0x20 -> " <> principalOf vectorSeed) + TIO.putStrLn (" aud " <> vectorAud) + TIO.putStrLn (" agent " <> vectorAgent) + TIO.putStrLn (" nonce 32 x 0x07 -> " <> b64urlNoPad vectorNonce) + TIO.putStrLn (" ts " <> T.pack (show vectorTs)) + TIO.putStrLn (" message " <> T.pack (show (canonicalMessage vectorAud vectorAgent (b64urlNoPad vectorNonce) vectorTs))) + TIO.putStrLn (" proof " <> vectorProof) + TIO.putStrLn "" + hspec spec + +spec :: Spec +spec = do + describe "keys" $ do + it "derives the RFC 8032 public key (test 1) from its seed" $ do + let Right s = seedFromBytes (hexBytes "9d61b19deffd5a60ba844af492ec2cc44449c5697b326919703bac031cae7f60") + publicKeyHex s `shouldBe` "d75a980182b10ab7d54bfed3c964073a0ee172f3daa62325af021a68f707511a" + principalOf s `shouldBe` "key:d75a980182b10ab7d54bfed3c964073a0ee172f3daa62325af021a68f707511a" + + it "refuses a seed that is not 32 bytes" $ do + seedFromBytes (BS.replicate 31 0) `shouldSatisfy` either (const True) (const False) + + it "keeps a seed as base64 and reads it back (and url base64, unpadded)" $ do + decodeSeedText (encodeSeedText vectorSeed) `shouldBe` Right vectorSeed + decodeSeedText (b64urlNoPad (seedBytes vectorSeed)) `shouldBe` Right vectorSeed + decodeSeedText (" " <> encodeSeedText vectorSeed <> "\n") `shouldBe` Right vectorSeed + + it "admits agent ids of 1-64 of [A-Za-z0-9._-]" $ do + map validAgent ["worker-3", "a", "A.b_c-9", T.replicate 64 "x"] `shouldBe` [True, True, True, True] + map validAgent ["", T.replicate 65 "x", "a b", "a/b", "ä", "a:b"] `shouldBe` replicate 6 False + + describe "the canonical message" $ do + it "is plexus-key-login/v1, aud, agent, nonce, ts — newline-joined, no trailing newline" $ + canonicalMessage "ws://127.0.0.1:4455" "worker-3" "AAAA" 1791600000 + `shouldBe` "plexus-key-login/v1\nws://127.0.0.1:4455\nworker-3\nAAAA\n1791600000" + + it "names the socket dialed as the audience" $ + wsAudience "127.0.0.1" 4455 `shouldBe` "ws://127.0.0.1:4455" + + describe "the proof" $ do + it "is plexus-key. + base64url-nopad of the JSON, fields in the wire's order" $ do + let Just body = T.stripPrefix "plexus-key." vectorProof + Right json = B64U.decodeUnpadded (TE.encodeUtf8 body) + keys = map (T.takeWhile (/= '"')) (T.splitOn ",\"" (T.drop 2 (TE.decodeUtf8 json))) + T.any (== '=') body `shouldBe` False + keys `shouldBe` ["v", "key", "aud", "agent", "nonce", "ts", "sig"] + let Just (A.Object o) = A.decodeStrict json + KM.lookup "v" o `shouldBe` Just (A.Number 1) + KM.lookup "key" o `shouldBe` Just (A.String (publicKeyHex vectorSeed)) + KM.lookup "aud" o `shouldBe` Just (A.String vectorAud) + KM.lookup "agent" o `shouldBe` Just (A.String vectorAgent) + KM.lookup "nonce" o `shouldBe` Just (A.String (b64urlNoPad vectorNonce)) + KM.lookup "ts" o `shouldBe` Just (A.Number 1791600000) + case KM.lookup "sig" o of + Just (A.String sig) -> fmap BS.length (B64U.decodeUnpadded (TE.encodeUtf8 sig)) `shouldBe` Right 64 + other -> expectationFailure ("sig: " <> show other) + + it "is the pinned string for the fixed vector" $ + vectorProof `shouldBe` expectedProof + + it "changes with every input" $ do + let other = [ buildProof (seedOf 9) vectorAud vectorAgent vectorNonce vectorTs + , buildProof vectorSeed "ws://127.0.0.1:4455" vectorAgent vectorNonce vectorTs + , buildProof vectorSeed vectorAud "worker-4" vectorNonce vectorTs + , buildProof vectorSeed vectorAud vectorAgent (BS.replicate 32 8) vectorTs + , buildProof vectorSeed vectorAud vectorAgent vectorNonce (vectorTs + 1) + ] + filter (== vectorProof) other `shouldBe` [] + + describe "the key store" $ do + it "reads PLEXUS_KEY before the keychain, the credentials directory and the file" $ + withSystemTempDirectory "identity" $ \dir -> do + (kc, _) <- memoryKeychain + let st0 = sandbox [("CREDENTIALS_DIRECTORY", dir "creds")] (Just kc) dir + Right _ <- writeKey st0 StoreFile "a" (seedOf 4) + createDirectoryIfMissing True (dir "creds") + BS.writeFile (dir "creds" "a.key") (TE.encodeUtf8 (encodeSeedText (seedOf 3))) + Right KeyFromKeychain <- writeKey st0 StoreKeychain "a" (seedOf 2) + let withEnv = sandbox [("PLEXUS_KEY", T.unpack (encodeSeedText (seedOf 1))), ("CREDENTIALS_DIRECTORY", dir "creds")] (Just kc) dir + fmap (fmap fst) <$> lookupKey withEnv "a" `shouldReturn` Right (Just (seedOf 1)) + fmap (fmap snd) <$> lookupKey withEnv "a" `shouldReturn` Right (Just KeyFromEnv) + -- no env: the keychain + fmap (fmap fst) <$> lookupKey st0 "a" `shouldReturn` Right (Just (seedOf 2)) + -- no keychain: the credentials directory + let noKc = sandbox [("CREDENTIALS_DIRECTORY", dir "creds")] Nothing dir + fmap (fmap fst) <$> lookupKey noKc "a" `shouldReturn` Right (Just (seedOf 3)) + -- none of those: the file + let fileOnly = sandbox [] Nothing dir + fmap (fmap fst) <$> lookupKey fileOnly "a" `shouldReturn` Right (Just (seedOf 4)) + fmap (fmap snd) <$> lookupKey fileOnly "a" `shouldReturn` Right (Just (KeyFromFile (dir ".plexus" "keys" "a.key"))) + lookupKey fileOnly "b" `shouldReturn` Right Nothing + + it "writes to the keychain when it answers, else a 0600 file in a 0700 directory" $ + withSystemTempDirectory "identity" $ \dir -> do + (kc, ref) <- memoryKeychain + writeKey (sandbox [] (Just kc) dir) StoreAuto "k" (seedOf 5) `shouldReturn` Right KeyFromKeychain + Map.keys <$> readIORef ref `shouldReturn` [("plexus-key", [("name", "k")])] + let p = dir ".plexus" "keys" "f.key" + writeKey (sandbox [] Nothing dir) StoreAuto "f" (seedOf 6) `shouldReturn` Right (KeyFromFile p) + mode p `shouldReturn` 0o600 + mode (dir ".plexus" "keys") `shouldReturn` 0o700 + writeKey (sandbox [] Nothing dir) StoreKeychain "g" (seedOf 6) >>= (`shouldSatisfy` either (const True) (const False)) + + it "falls back to the file when the keychain refuses a write" $ + withSystemTempDirectory "identity" $ \dir -> do + (kc, _) <- memoryKeychain + let refusing = kc { kcStore = \_ _ _ _ -> pure (Left "locked") } + writeKey (sandbox [] (Just refusing) dir) StoreAuto "k" (seedOf 5) + `shouldReturn` Right (KeyFromFile (dir ".plexus" "keys" "k.key")) + + it "says when a name is taken, and lists keys with where they are" $ + withSystemTempDirectory "identity" $ \dir -> do + (kc, _) <- memoryKeychain + let st = sandbox [] (Just kc) dir + keyExists st "a" `shouldReturn` Nothing + _ <- writeKey st StoreKeychain "a" (seedOf 1) + _ <- writeKey st StoreFile "b" (seedOf 2) + keyExists st "a" `shouldReturn` Just KeyFromKeychain + keyExists st "b" `shouldReturn` Just (KeyFromFile (dir ".plexus" "keys" "b.key")) + map fst <$> listKeys st `shouldReturn` ["a", "b"] + + describe "the session store" $ do + let rec = SessionRec + { srToken = "mgs_abc", srPrincipal = "key:00", srAgent = "worker-3" + , srExpiresAt = Just 1791643200, srKey = "agent-7", srScope = ["editor@MENGER-12"] + , srTtl = Nothing, srBackend = "menger" } + + it "reads PLEXUS_SESSION first, then the keychain, then the file" $ + withSystemTempDirectory "identity" $ \dir -> do + (kc, _) <- memoryKeychain + let fileSt = sandbox [] Nothing dir + p = dir ".plexus" "sessions" "127.0.0.1_4455" "worker-3.json" + writeSession fileSt (plainAt "127.0.0.1" 4455) rec `shouldReturn` SessionFromFile p + mode p `shouldReturn` 0o600 + lookupSession fileSt (plainAt "127.0.0.1" 4455) "worker-3" `shouldReturn` Just (Right rec, SessionFromFile p) + let kcSt = sandbox [] (Just kc) dir + rec2 = rec { srToken = "mgs_def" } + writeSession kcSt (plainAt "127.0.0.1" 4455) rec2 `shouldReturn` SessionFromKeychain + lookupSession kcSt (plainAt "127.0.0.1" 4455) "worker-3" `shouldReturn` Just (Right rec2, SessionFromKeychain) + -- a keychain write drops the stale file + doesFileExist p `shouldReturn` False + let envSt = sandbox [("PLEXUS_SESSION", "mgs_env\n")] (Just kc) dir + lookupSession envSt (plainAt "127.0.0.1" 4455) "worker-3" `shouldReturn` Just (Left "mgs_env", SessionFromEnv) + lookupSession kcSt (plainAt "127.0.0.1" 4455) "worker-4" `shouldReturn` Nothing + lookupSession kcSt (plainAt "127.0.0.1" 4456) "worker-3" `shouldReturn` Nothing + + it "keeps the key name, scope and backend a re-login needs" $ + withSystemTempDirectory "identity" $ \dir -> do + let st = sandbox [] Nothing dir + _ <- writeSession st (plainAt "127.0.0.1" 4455) rec + raw <- BS.readFile (dir ".plexus" "sessions" "127.0.0.1_4455" "worker-3.json") + let Just (A.Object o) = A.decodeStrict raw + map (`KM.member` o) ["token", "principal", "agent", "expires_at", "key", "scope", "backend"] + `shouldBe` replicate 7 True + + it "forgets a session from both stores, and the default agent with it" $ + withSystemTempDirectory "identity" $ \dir -> do + (kc, ref) <- memoryKeychain + let st = sandbox [] (Just kc) dir + _ <- writeSession st (plainAt "127.0.0.1" 4455) rec + writeDefaultAgent st (plainAt "127.0.0.1" 4455) "worker-3" + readDefaultAgent st (plainAt "127.0.0.1" 4455) `shouldReturn` Just "worker-3" + removeSession st (plainAt "127.0.0.1" 4455) "worker-3" + clearDefaultAgent st (plainAt "127.0.0.1" 4455) "worker-3" + Map.null <$> readIORef ref `shouldReturn` True + lookupSession st (plainAt "127.0.0.1" 4455) "worker-3" `shouldReturn` Nothing + readDefaultAgent st (plainAt "127.0.0.1" 4455) `shouldReturn` Nothing + + describe "parallel writers (SYNAPSE-15)" $ do + let rec = SessionRec + { srToken = "mgs_0", srPrincipal = "key:00", srAgent = "worker-3" + , srExpiresAt = Just 1791643200, srKey = "agent-7", srScope = [] + , srTtl = Nothing, srBackend = "menger" } + + it "32 writers of one session at once all succeed, and leave one session, 0600, and no temporary file" $ + withSystemTempDirectory "identity" $ \dir -> do + let st = sandbox [] Nothing dir + sdir = dir ".plexus" "sessions" "127.0.0.1_4455" + rs <- mapConcurrently (\i -> try (writeSession st (plainAt "127.0.0.1" 4455) rec { srToken = "mgs_" <> T.pack (show i) })) + [1 .. 32 :: Int] + [e | Left (e :: SomeException) <- rs] `shouldSatisfy` null + Just (Right r, _) <- lookupSession st (plainAt "127.0.0.1" 4455) "worker-3" + srToken r `shouldSatisfy` (`elem` ["mgs_" <> T.pack (show i) | i <- [1 .. 32 :: Int]]) + mode (sdir "worker-3.json") `shouldReturn` 0o600 + listDirectory sdir `shouldReturn` ["worker-3.json"] + + it "the session lock lets one holder in at a time" $ + withSystemTempDirectory "identity" $ \dir -> do + let st = sandbox [] Nothing dir + inside <- newIORef (0 :: Int) + most <- newIORef (0 :: Int) + _ <- mapConcurrently (\_ -> withSessionLock st (plainAt "127.0.0.1" 4455) "worker-3" $ do + n <- atomicModifyIORef' inside (\k -> (k + 1, k + 1)) + atomicModifyIORef' most (\m -> (max m n, ())) + threadDelay 20000 + atomicModifyIORef' inside (\k -> (k - 1, ()))) + [1 .. 8 :: Int] + readIORef most `shouldReturn` 1 + + describe "_login's --scope" $ + it "takes the flag repeated or comma-separated" $ + splitScopes ["editor@MENGER-12,viewer@PLEXUS", " admin@* "] `shouldBe` ["editor@MENGER-12", "viewer@PLEXUS", "admin@*"] + +hexBytes :: Text -> BS.ByteString +hexBytes = BS.pack . go . T.unpack + where + go (a : b : rest) = fromIntegral (read ['0', 'x', a, b] :: Int) : go rest + go _ = [] diff --git a/test/KeychainSpec.hs b/test/KeychainSpec.hs new file mode 100644 --- /dev/null +++ b/test/KeychainSpec.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | SELF-8 opt-in keychain tests. +-- +-- This test-suite shells out to the macOS @security@ CLI and touches the +-- real keychain. It's gated behind the @build-keychain-tests@ cabal flag: +-- +-- > cabal test plexus-synapse:keychain-test -f build-keychain-tests +-- +-- Default @cabal test@ runs do NOT include this suite. +-- +-- Tests use a unique per-run service name (@plexus-selftest-@) so +-- they don't collide with real synapse/synapse-cc keychain items. All +-- created items are cleaned up in 'finally' blocks regardless of test +-- outcome. +module Main (main) where + +import Control.Exception (finally) +import qualified Data.Text as T +import Data.UUID (toText) +import Data.UUID.V4 (nextRandom) +import System.Info (os) + +import Synapse.Self + ( CredentialRef(..) + , ResolveError(..) + , deleteFromKeychain + , isKeychainPlatform + , resolveRef + , storeInKeychain + ) +import Synapse.Self.Resolve (registerResolver, emptyRegistry) +import Synapse.Self.Resolve.Keychain (keychainResolver) + +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "Synapse.Self.Resolve.Keychain (SELF-8)" $ do + if not isKeychainPlatform + then it ("skipped: keychain backend not implemented on " ++ os) pending + else keychainMacOSSpec + +keychainMacOSSpec :: Spec +keychainMacOSSpec = do + describe "platform probe" $ do + it "reports macOS as a keychain platform" $ + isKeychainPlatform `shouldBe` True + + describe "resolveRef via defaultRegistry entry" $ do + it "returns ResolveNotFound for a keychain item that doesn't exist" $ do + run <- runId + let service = "plexus-selftest-" <> run + reg = registerResolver "keychain" keychainResolver emptyRegistry + ref = CredentialRef $ + "keychain://" <> service <> "/no-such-account" + r <- resolveRef reg ref + r `shouldBe` Left (ResolveNotFound ref) + + describe "store -> resolve -> delete round trip" $ do + it "stores a value, reads it back, then deletes" $ do + run <- runId + let service = "plexus-selftest-" <> run + account = "roundtrip/access_token" + value = "eyJhbGciOiJIUzI1NiJ9.fake" + ref = CredentialRef $ + "keychain://" <> service <> "/" <> account + reg = registerResolver "keychain" keychainResolver emptyRegistry + (do + rs <- storeInKeychain service account value + rs `shouldBe` Right () + + rr <- resolveRef reg ref + rr `shouldBe` Right value + + rd <- deleteFromKeychain service account + rd `shouldBe` Right () + + rr2 <- resolveRef reg ref + rr2 `shouldBe` Left (ResolveNotFound ref) + ) + `finally` + -- Belt-and-suspenders cleanup (no-op if delete already ran). + deleteFromKeychain service account + + describe "update-in-place (-U)" $ do + it "overwrites an existing item when stored again" $ do + run <- runId + let service = "plexus-selftest-" <> run + account = "update/access_token" + v1 = "first" + v2 = "second" + ref = CredentialRef $ + "keychain://" <> service <> "/" <> account + reg = registerResolver "keychain" keychainResolver emptyRegistry + (do + _ <- storeInKeychain service account v1 + _ <- storeInKeychain service account v2 + r <- resolveRef reg ref + r `shouldBe` Right v2 + ) + `finally` + deleteFromKeychain service account + + describe "delete idempotency" $ do + it "deleting a non-existent item returns Right ()" $ do + run <- runId + let service = "plexus-selftest-" <> run + account = "never-created" + r <- deleteFromKeychain service account + r `shouldBe` Right () + + describe "URI shape errors" $ do + let reg = registerResolver "keychain" keychainResolver emptyRegistry + + it "rejects opaque keychain:foo" $ do + r <- resolveRef reg (CredentialRef "keychain:foo") + case r of + Left (ResolveBackendError _ msg) -> + ("must be hierarchical" `T.isInfixOf` msg) `shouldBe` True + other -> expectationFailure ("expected ResolveBackendError, got " + <> show other) + + it "rejects empty service" $ do + r <- resolveRef reg (CredentialRef "keychain:///account") + case r of + Left (ResolveParseError msg) -> + ("service missing" `T.isInfixOf` msg) `shouldBe` True + other -> expectationFailure ("expected ResolveParseError, got " + <> show other) + + it "rejects empty account" $ do + r <- resolveRef reg (CredentialRef "keychain://svc") + case r of + Left (ResolveParseError msg) -> + ("account missing" `T.isInfixOf` msg) `shouldBe` True + other -> expectationFailure ("expected ResolveParseError, got " + <> show other) + +-- | Short stable id for each test's service name. Using a UUID fragment +-- keeps tests isolated across parallel runs and across dev/CI machines. +runId :: IO T.Text +runId = do + u <- nextRandom + pure $ T.take 8 (toText u) diff --git a/test/MockHub.hs b/test/MockHub.hs new file mode 100644 --- /dev/null +++ b/test/MockHub.hs @@ -0,0 +1,320 @@ +{-# 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/ParseSpec.hs b/test/ParseSpec.hs --- a/test/ParseSpec.hs +++ b/test/ParseSpec.hs @@ -11,11 +11,32 @@ import qualified Data.Vector as V import Test.Hspec +import Synapse.CLI.Help (renderParamHelp) import Synapse.CLI.Parse +import Synapse.CLI.Transform (TransformEnv(..), envExpansion, injectBooleanDefaults) import Synapse.IR.Types main :: IO () main = hspec $ do + describe "envExpansion (SYNAPSE-6): $VAR is substituted in path parameters only" $ do + let env = TransformEnv + { teCwd = "/work", teHome = Just "/home/alice" + , teEnv = [("HOME", "/home/alice"), ("PROJECT", "/home/alice/proj")] } + expand k v = envExpansion env (k, v) + + it "a ticket body keeps $HOME literally" $ + expand "body" "costs $HOME and $PROJECT" `shouldReturn` ("body", "costs $HOME and $PROJECT") + + it "a title, a message, any non-path value keeps it too" $ do + expand "title" "$HOME" `shouldReturn` ("title", "$HOME") + expand "message" "Hello $PROJECT" `shouldReturn` ("message", "Hello $PROJECT") + + it "a path parameter still expands" $ + expand "path" "$PROJECT/src" `shouldReturn` ("path", "/home/alice/proj/src") + + it "an unset variable in a path parameter is left as written" $ + expand "working_dir" "$NOPE/x" `shouldReturn` ("working_dir", "$NOPE/x") + describe "groupByPrefix" $ do it "groups dotted keys by prefix" $ do let input = [("identifier.type", "by_name"), ("identifier.name", "foo"), ("prompt", "hi")] @@ -79,6 +100,339 @@ let kvs = [] buildParamValue emptyIR param kvs `shouldSatisfy` isLeft + -- SYNAPSE-2: each flag value of a list of scalars is a comma-separated + -- record with double-quote quoting. One test per row of the ticket's table. + describe "buildParamValue with comma-separated list values" $ do + let strings = listParam "tags" (RefArray (RefPrimitive "string" Nothing)) + ints = listParam "ids" (RefArray (RefPrimitive "integer" Nothing)) + one p val = buildParamValue listIR p [("", val)] + + describe "string list" $ do + it "a,b,c,e -> a b c e" $ + one strings "a,b,c,e" `shouldBe` strs ["a", "b", "c", "e"] + it "a -> a (unchanged)" $ + one strings "a" `shouldBe` strs ["a"] + it "\"a,b,c,d\",\"e,f,g\" -> two elements (a quoted field keeps its commas)" $ + one strings "\"a,b,c,d\",\"e,f,g\"" `shouldBe` strs ["a,b,c,d", "e,f,g"] + it "\"say \"\"hi\"\"\",b -> say \"hi\" and b (a doubled quote is one quote)" $ + one strings "\"say \"\"hi\"\"\",b" `shouldBe` strs ["say \"hi\"", "b"] + it "a, b ,c -> a b c (space around an unquoted field is dropped)" $ + one strings "a, b ,c" `shouldBe` strs ["a", "b", "c"] + it "a,,b, -> a b (an empty unquoted field is dropped)" $ + one strings "a,,b," `shouldBe` strs ["a", "b"] + it "\"\",a -> the empty string and a" $ + one strings "\"\",a" `shouldBe` strs ["", "a"] + it "\"a,b is an error naming the parameter and the value" $ + one strings "\"a,b" `shouldBe` + Left (MalformedListValue "tags" "\"a,b" "a quoted element has no closing quote") + it "\"a\"x,b is an error naming the parameter and the value" $ + one strings "\"a\"x,b" `shouldBe` + Left (MalformedListValue "tags" "\"a\"x,b" "a closing quote must be followed by a comma or the end") + + describe "integer list (elements typed as before)" $ do + it "1,2,3 -> 1 2 3" $ + one ints "1,2,3" `shouldBe` nums [1, 2, 3] + it "1 -> 1 (unchanged)" $ + one ints "1" `shouldBe` nums [1] + it "\"1,2\",\"3\" -> two elements (a quoted field keeps its commas)" $ + one ints "\"1,2\",\"3\"" `shouldBe` arr [String "1,2", Number 3] + it "\"4\"\"2\",5 -> 4\"2 and 5 (a doubled quote is one quote)" $ + one ints "\"4\"\"2\",5" `shouldBe` arr [String "4\"2", Number 5] + it "1, 2 ,3 -> 1 2 3 (space around an unquoted field is dropped)" $ + one ints "1, 2 ,3" `shouldBe` nums [1, 2, 3] + it "1,,2, -> 1 2 (an empty unquoted field is dropped)" $ + one ints "1,,2," `shouldBe` nums [1, 2] + it "\"\",1 -> the empty string and 1" $ + one ints "\"\",1" `shouldBe` arr [String "", Number 1] + it "\"1,2 is an error naming the parameter and the value" $ + one ints "\"1,2" `shouldBe` + Left (MalformedListValue "ids" "\"1,2" "a quoted element has no closing quote") + it "\"1\"x,2 is an error naming the parameter and the value" $ + one ints "\"1\"x,2" `shouldBe` + Left (MalformedListValue "ids" "\"1\"x,2" "a closing quote must be followed by a comma or the end") + + describe "which lists split" $ do + it "an optional list splits like a list" $ do + let blockedBy = listParam "blocked_by" (RefOptional (RefArray (RefPrimitive "string" Nothing))) + one blockedBy "MNG-1,MNG-2" `shouldBe` strs ["MNG-1", "MNG-2"] + one blockedBy "\"a,b\",\"c\"" `shouldBe` strs ["a,b", "c"] + + it "a list of a named scalar type splits" $ + one (listParam "refs" (RefArray (named "TicketId"))) "MNG-1,MNG-2" + `shouldBe` strs ["MNG-1", "MNG-2"] + + it "a list of a string enum splits" $ + one (listParam "statuses" (RefArray (named "Status"))) "open,closed" + `shouldBe` strs ["open", "closed"] + + it "a list of objects is not split: each flag value is one element" $ + one (listParam "links" (RefArray (named "Link"))) "{\"id\":\"a\",\"kind\":\"b\"}" + `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"] + + it "a list of lists is not split" $ + one (listParam "rows" (RefArray (RefArray (RefPrimitive "string" Nothing)))) "a,b" + `shouldBe` strs ["a,b"] + + it "a non-list parameter keeps its commas" $ + buildParamValue listIR (listParam "title" (RefPrimitive "string" Nothing)) [("", "a, b")] + `shouldBe` Right (String "a, b") + + describe "repeated flags" $ do + it "--x a,b --x c -> a b c, in order" $ + buildParamValue listIR strings [("", "a,b"), ("", "c")] `shouldBe` strs ["a", "b", "c"] + + it "mix plain, comma-separated and quoted values, in order" $ + buildParamValue listIR strings [("", "a"), ("", "b, c"), ("", "\"d,e\",f")] + `shouldBe` strs ["a", "b", "c", "d,e", "f"] + + it "one malformed value fails the whole parameter" $ + buildParamValue listIR strings [("", "a"), ("", "\"b")] + `shouldBe` Left (MalformedListValue "tags" "\"b" "a quoted element has no closing quote") + + describe "parseParams" $ do + let method = methodWith + [ listParam "blocked_by" (RefOptional (RefArray (RefPrimitive "string" Nothing))) + , listParam "title" (RefPrimitive "string" Nothing) + ] + it "splits the list and leaves other parameters alone" $ + parseParams listIR method [("blocked_by", "MNG-1,MNG-2"), ("title", "t, u")] + `shouldBe` Right (object + [ (K.fromText "blocked_by", Array (V.fromList [String "MNG-1", String "MNG-2"])) + , (K.fromText "title", String "t, u") + ]) + it "a malformed list value fails the parse, so nothing is sent" $ + parseParams listIR method [("blocked_by", "\"a,b"), ("title", "t")] + `shouldBe` Left [MalformedListValue "blocked_by" "\"a,b" "a quoted element has no closing quote"] + + describe "help for list parameters" $ do + it "a list of scalars names the comma form" $ + renderParamHelp listIR (listParam "blocked_by" (RefOptional (RefArray (RefPrimitive "string" Nothing)))) + `shouldSatisfy` elem " Repeat the flag or use commas: --blocked-by a,b" + it "a list of objects only repeats" $ + renderParamHelp listIR (listParam "links" (RefArray (named "Link"))) + `shouldSatisfy` elem " Repeat the flag for each element" + + -- SYNAPSE-4: a flag that takes a value takes the next argument whatever it + -- begins with, and --key=value is a flag and its value. One group per row + -- of the ticket's table, run through both passes and parseParams. + describe "flag values that begin with dashes" $ do + describe "a parameter that takes a value takes the next argument, whatever it begins with" $ do + it "--body '---\\nid: X\\n---' (frontmatter)" $ + invoke ["--body", frontmatter] `shouldBe` sends [("body", String frontmatter)] + it "--body --force" $ + invoke ["--body", "--force"] `shouldBe` sends [("body", "--force")] + it "--offset -5" $ + invoke ["--offset", "-5"] `shouldBe` sends [("offset", Number (-5))] + it "--body -- (exactly two dashes)" $ + invoke ["--body", "--"] `shouldBe` sends [("body", "--")] + it "--body '' (empty)" $ + invoke ["--body", ""] `shouldBe` sends [("body", "")] + it "the flag after such a value is still a flag" $ + invoke ["--body", "---", "--id", "MNG-1"] `shouldBe` sends [("body", "---"), ("id", "MNG-1")] + + describe "--key=value" $ do + it "--body='---\\nid: X\\n---'" $ + invoke ["--body=" <> frontmatter] `shouldBe` sends [("body", String frontmatter)] + it "--body= (empty)" $ + invoke ["--body="] `shouldBe` sends [("body", "")] + it "--body=a=b (the value keeps every = after the first)" $ + invoke ["--body=a=b"] `shouldBe` sends [("body", "a=b")] + it "--body=--force" $ + invoke ["--body=--force"] `shouldBe` sends [("body", "--force")] + it "--id=MNG-1 --offset=-5" $ + invoke ["--id=MNG-1", "--offset=-5"] `shouldBe` sends [("id", "MNG-1"), ("offset", Number (-5))] + + describe "a boolean, bare" $ do + it "--summary --limit 3 -> summary true, limit 3" $ + invoke ["--summary", "--limit", "3"] `shouldBe` sends [("summary", Bool True), ("limit", Number 3)] + it "--limit 3 --summary (last) -> summary true" $ + invoke ["--limit", "3", "--summary"] `shouldBe` sends [("summary", Bool True), ("limit", Number 3)] + + describe "a boolean with an explicit value" $ do + it "--summary true --limit 3" $ + invoke ["--summary", "true", "--limit", "3"] `shouldBe` sends [("summary", Bool True), ("limit", Number 3)] + it "--summary false" $ + invoke ["--summary", "false"] `shouldBe` sends [("summary", Bool False)] + it "--summary=false" $ + invoke ["--summary=false"] `shouldBe` sends [("summary", Bool False)] + it "--summary 0 (a spelling already read as a boolean)" $ + invoke ["--summary", "0"] `shouldBe` sends [("summary", Bool False)] + it "--summary yes: yes is not its value, and no flag takes it" $ + invoke ["--summary", "yes"] `shouldBe` Left [UnexpectedArgument "yes"] + + describe "a list parameter (SYNAPSE-2, unchanged)" $ do + it "--commits a,b --commits c" $ + invoke ["--commits", "a,b", "--commits", "c"] `shouldBe` sends [("commits", strings ["a", "b", "c"])] + it "--commits=a,b" $ + invoke ["--commits=a,b"] `shouldBe` sends [("commits", strings ["a", "b"])] + it "--blocked-by=MNG-1,MNG-2 --blocked-by MNG-3" $ + invoke ["--blocked-by=MNG-1,MNG-2", "--blocked-by", "MNG-3"] + `shouldBe` sends [("blocked_by", strings ["MNG-1", "MNG-2", "MNG-3"])] + + describe "a dotted key" $ do + it "--identifier.type by_name --identifier.name foo (unchanged)" $ + invoke ["--identifier.type", "by_name", "--identifier.name", "foo"] + `shouldBe` sends [("identifier", object [("type", "by_name"), ("name", "foo")])] + it "--identifier.name takes a value that begins with dashes" $ + invoke ["--identifier.type", "by_name", "--identifier.name", "--x"] + `shouldBe` sends [("identifier", object [("type", "by_name"), ("name", "--x")])] + it "a bare boolean field does not swallow the next flag" $ + invoke ["--options.verbose", "--limit", "3"] + `shouldBe` sends [("options", object [("verbose", Bool True), ("label", Null)]), ("limit", Number 3)] + + describe "a flag that names no parameter" $ do + it "--no-such x: Unknown parameter, named as typed" $ + invoke ["--no-such", "x"] `shouldBe` Left [UnknownParam "no-such" []] + it "--no-such=---x: named without its value" $ + invoke ["--no-such=---x"] `shouldBe` Left [UnknownParam "no-such" []] + it "--bodyy x: still suggests the parameter" $ + invoke ["--bodyy", "x"] `shouldBe` Left [UnknownParam "bodyy" ["body"]] + it "takes the next argument unless it begins with --, as before" $ + invoke ["--no-such", "--body", "b"] `shouldBe` Left [UnknownParam "no-such" []] + + describe "keys are normalized, values never" $ do + it "--blocked-by MNG-1 -> blocked_by" $ + invoke ["--blocked-by", "MNG-1"] `shouldBe` sends [("blocked_by", strings ["MNG-1"])] + it "--title --a-b-c keeps its dashes" $ + invoke ["--title", "--a-b-c"] `shouldBe` sends [("title", "--a-b-c")] + it "--title=--a-b-c keeps its dashes" $ + invoke ["--title=--a-b-c"] `shouldBe` sends [("title", "--a-b-c")] + + describe "parsePathAndParams (before the method is known)" $ do + it "finds the path when a value begins with dashes" $ do + let (path, _, flags, helpReq) = parsePathAndParams ["tickets", "amend", "--body", frontmatter, "--id", "MNG-1"] + (path, flags, helpReq) `shouldBe` (["tickets", "amend"], ["--body", frontmatter, "--id", "MNG-1"], False) + it "a value of exactly -- is not a path segment" $ + parsePathAndParams ["tickets", "amend", "--body", "--"] + `shouldBe` (["tickets", "amend"], [("body", "--")], ["--body", "--"], False) + it "--key=value takes nothing after it" $ + parsePathAndParams ["--id=MNG-1", "tickets", "get"] + `shouldBe` (["tickets", "get"], [("id", "MNG-1")], ["--id=MNG-1"], False) + it "--help is still help, even after a flag" $ + parsePathAndParams ["tickets", "amend", "--body", "--help"] + `shouldBe` (["tickets", "amend"], [("body", "")], ["--body"], True) + isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft (Right _) = False + +-- ============================================================================ +-- Fixtures for list values +-- ============================================================================ + +-- | A required parameter of the given type +listParam :: Text -> TypeRef -> ParamDef +listParam name ty = ParamDef + { pdName = name + , pdType = ty + , pdDescription = Nothing + , pdRequired = True + , pdDefault = Nothing + , pdDeprecation = Nothing + , pdSource = Nothing + , pdValues = Nothing + } + +-- | A method with the given parameters +methodWith :: [ParamDef] -> MethodDef +methodWith params = MethodDef + { mdName = "create" + , mdFullPath = "t.create" + , mdNamespace = "t" + , mdDescription = Nothing + , mdStreaming = False + , mdParams = params + , mdReturns = RefAny + , mdBidirType = Nothing + , mdBidirResponseType = Nothing + , mdBidirResponseSchema = Nothing + , mdRole = MethodRoleRpc + , mdGrant = Nothing + , mdTarget = Nothing + , mdLongDescription = Nothing + } + +-- | A reference to a type in 'listIR' +named :: Text -> TypeRef +named = RefNamed . QualifiedName "t" + +-- | An IR with a named scalar, a string enum and an object type +listIR :: IR +listIR = emptyIR + { irTypes = Map.fromList + [ ("t.TicketId", TypeDef "TicketId" "t" Nothing (KindPrimitive "string" Nothing)) + , ("t.Status", TypeDef "Status" "t" Nothing (KindStringEnum ["open", "closed"])) + , ("t.Link", TypeDef "Link" "t" Nothing (KindStruct + [ FieldDef "id" (RefPrimitive "string" Nothing) Nothing True Nothing + , FieldDef "kind" (RefPrimitive "string" Nothing) Nothing True Nothing + ])) + ] + } + +arr :: [Value] -> Either ParseError Value +arr = Right . Array . V.fromList + +strs :: [Text] -> Either ParseError Value +strs = arr . map String + +nums :: [Integer] -> Either ParseError Value +nums = arr . map (Number . fromInteger) + +-- ============================================================================ +-- Fixtures for flag values +-- ============================================================================ + +-- | A method's flag arguments as synapse reads them once the method is known: +-- both passes, then 'parseParams' (no backend needed) +invoke :: [Text] -> Either [ParseError] Value +invoke args = + let (_, _, flags, _) = parsePathAndParams ("tickets" : "amend" : args) + in pairFlags dashIR dashMethod flags + >>= parseParams dashIR dashMethod . injectBooleanDefaults dashIR dashMethod + +-- | The object 'parseParams' builds from these fields +sends :: [(Text, Value)] -> Either [ParseError] Value +sends fields = Right $ object [(K.fromText k, v) | (k, v) <- fields] + +strings :: [Text] -> Value +strings = Array . V.fromList . map String + +frontmatter :: Text +frontmatter = "---\nid: X\n---\nbody" + +-- | An optional parameter of the given type +optParam :: Text -> TypeRef -> ParamDef +optParam name ty = (listParam name ty) { pdRequired = False } + +-- | menger's amend/list/link_commits parameters, plus a dotted enum and struct +dashMethod :: MethodDef +dashMethod = methodWith + [ optParam "body" (RefOptional (RefPrimitive "string" Nothing)) + , optParam "id" (RefPrimitive "string" Nothing) + , optParam "title" (RefOptional (RefPrimitive "string" Nothing)) + , optParam "summary" (RefOptional (RefPrimitive "boolean" Nothing)) + , optParam "limit" (RefOptional (RefPrimitive "integer" (Just "uint32"))) + , optParam "offset" (RefPrimitive "integer" Nothing) + , optParam "commits" (RefArray (RefPrimitive "string" Nothing)) + , optParam "blocked_by" (RefOptional (RefArray (RefPrimitive "string" Nothing))) + , optParam "identifier" (named "Identifier") + , optParam "options" (named "Options") + ] + +-- | An IR with a discriminated enum and a struct with a boolean field +dashIR :: IR +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] + ])) + , ("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/PathNormalizationSpec.hs b/test/PathNormalizationSpec.hs --- a/test/PathNormalizationSpec.hs +++ b/test/PathNormalizationSpec.hs @@ -3,36 +3,9 @@ -- | Unit tests for path and parameter normalization module Main where -import Data.Text (Text) -import qualified Data.Text as T import Test.Hspec --- Copy of parsePathAndParams for testing --- We can't import from Main, so we replicate the logic -parsePathAndParams :: [Text] -> ([Text], [(Text, Text)], Bool) -parsePathAndParams = go [] [] False - where - go path params helpReq [] = (reverse path, reverse params, helpReq) - go path params helpReq (x:xs) - -- --help flag: mark help requested, don't add as param - | x == "--help" || x == "-h" = - go path params True xs - -- --key value pair (value must not start with --) - | Just key <- T.stripPrefix "--" x - , not (T.null key) - , (val:rest) <- xs - , not (T.isPrefixOf "--" val) = - let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case - in go path ((normalizedKey, val) : params) helpReq rest - -- --key with no value or next arg is another flag (boolean flag) - | Just key <- T.stripPrefix "--" x - , not (T.null key) = - let normalizedKey = T.replace "-" "_" key -- Normalize kebab-case to snake_case - in go path ((normalizedKey, "") : params) helpReq xs - -- Regular path segment - split on dots to support plexus.cone.chat syntax - | otherwise = - let segments = map (T.replace "-" "_") $ filter (not . T.null) $ T.splitOn "." x - in go (reverse segments ++ path) params helpReq xs +import Synapse.CLI.Parse (parsePathAndParams) main :: IO () main = hspec $ do @@ -40,49 +13,49 @@ it "normalizes hyphens in simple path segments" $ do let input = ["changelog", "queue-add", "--help"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` ["changelog", "queue_add"] params `shouldBe` [] helpReq `shouldBe` True it "normalizes hyphens in dot-notation paths" $ do let input = ["plexus.cone.queue-add", "--name", "test"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` ["plexus", "cone", "queue_add"] params `shouldBe` [("name", "test")] helpReq `shouldBe` False it "normalizes hyphens in parameter names" $ do let input = ["cone", "create", "--working-dir", "/tmp", "--dry-run"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` ["cone", "create"] params `shouldBe` [("working_dir", "/tmp"), ("dry_run", "")] helpReq `shouldBe` False it "handles mixed hyphens in path and params" $ do let input = ["cone", "queue-list", "--max-count", "10", "--sort-by", "date"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` ["cone", "queue_list"] params `shouldBe` [("max_count", "10"), ("sort_by", "date")] helpReq `shouldBe` False it "normalizes complex dot-notation with hyphens" $ do let input = ["plexus.arbor.tree-create", "--tree-id", "abc-123"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` ["plexus", "arbor", "tree_create"] params `shouldBe` [("tree_id", "abc-123")] -- Value NOT normalized, only key helpReq `shouldBe` False it "handles underscore paths unchanged" $ do let input = ["changelog", "queue_add", "--description", "test"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` ["changelog", "queue_add"] params `shouldBe` [("description", "test")] helpReq `shouldBe` False it "normalizes nested parameter paths" $ do let input = ["cone", "chat", "--identifier.type", "by-name", "--identifier.name", "test"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` ["cone", "chat"] params `shouldBe` [("identifier.type", "by-name"), ("identifier.name", "test")] -- Note: parameter suffixes (after .) are NOT normalized in parsePathAndParams @@ -91,7 +64,7 @@ it "normalizes _self template commands" $ do let input = ["_self", "template", "show", "cone.queue-add"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input -- Note: "cone.queue-add" splits on dot and normalizes hyphens path `shouldBe` ["_self", "template", "show", "cone", "queue_add"] params `shouldBe` [] @@ -99,7 +72,7 @@ it "handles repeated array parameters with hyphens" $ do let input = ["queue-add", "--tags", "backend", "--tags", "critical", "--max-items", "5"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` ["queue_add"] params `shouldBe` [("tags", "backend"), ("tags", "critical"), ("max_items", "5")] helpReq `shouldBe` False @@ -108,21 +81,21 @@ it "handles empty input" $ do let input = [] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` [] params `shouldBe` [] helpReq `shouldBe` False it "preserves hyphens in parameter values" $ do let input = ["cone", "create", "--name", "my-test-cone"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` ["cone", "create"] params `shouldBe` [("name", "my-test-cone")] -- Value preserved helpReq `shouldBe` False it "handles boolean flags with hyphens" $ do let input = ["test", "--verbose", "--dry-run", "--force"] - let (path, params, helpReq) = parsePathAndParams input + let (path, params, _, helpReq) = parsePathAndParams input path `shouldBe` ["test"] params `shouldBe` [("verbose", ""), ("dry_run", ""), ("force", "")] helpReq `shouldBe` False diff --git a/test/ReconnectSpec.hs b/test/ReconnectSpec.hs new file mode 100644 --- /dev/null +++ b/test/ReconnectSpec.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 +-- says: answered, dropped mid-stream, dropped before any answer, or taken +-- and then silent), on ports of its own: +-- +-- * the client fails a call whose connection closes or goes silent — +-- '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. +module Main (main) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (SomeException, bracket, try) +import Control.Monad (forever, void) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import Data.IORef +import Data.Text (Text) +import qualified Network.Socket as N +import qualified Network.WebSockets as WS +import System.Environment (setEnv, unsetEnv) +import System.Timeout (timeout) +import Test.Hspec + +import Plexus.Client (SubstrateConfig(..)) +import Plexus.Schema.Recursive (MethodSchema(..), MethodRole(..)) +import qualified Plexus.Transport as ST +import qualified Plexus.Types as PT +import Synapse.Reconnect + +-- --------------------------------------------------------------------------- +-- The flaky hub + +-- | How the hub 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 + } + +withHub :: [Mode] -> (Hub -> IO a) -> IO a +withHub modes act = do + ms <- newIORef modes + calls <- newIORef [] + bracket (open ms calls) (N.close . fst) (\(_, h) -> act h) + where + open ms calls = 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 sock ms calls + pure (sock, Hub port ms calls) + +acceptLoop :: N.Socket -> IORef [Mode] -> IORef [Value] -> IO () +acceptLoop sock ms calls = do + r <- try (N.accept sock) + case r of + Left (_ :: SomeException) -> pure () + Right (conn, _) -> do + void $ forkIO $ do + _ <- try (session conn) :: IO (Either SomeException ()) + N.close conn + acceptLoop sock ms calls + where + session conn = do + pending <- WS.makePendingConnection conn WS.defaultConnectionOptions + c <- WS.acceptRequest pending + forever $ do + msg <- WS.receiveData c + case decode msg of + Just (Object o) -> handle c o + _ -> pure () + handle c o = do + let rid = KM.lookup "id" o + params = case KM.lookup "params" o of { Just (Object p) -> p; _ -> KM.empty } + inner = maybe Null id (KM.lookup "params" params) + send = WS.sendTextData c . encode + confirm = send (object ["jsonrpc" .= ("2.0" :: Text), "id" .= rid, "result" .= (7 :: Int)]) + 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)] + 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]) + mode <- atomicModifyIORef' ms $ \case + [m] -> ([m], m) + (m : rest) -> (rest, m) + [] -> ([], Answer) + case mode of + Answer -> confirm >> dat >> done + DropMid -> confirm >> dat >> threadDelay 50000 >> ioError (userError "dropped") + DropNow -> ioError (userError "dropped") + Silent -> confirm >> forever (threadDelay 1000000) + +cfgFor :: Int -> SubstrateConfig +cfgFor port = SubstrateConfig "127.0.0.1" port "/" "t" [] Nothing + +-- | One try, as synapse makes it. +attemptAt :: Int -> Value -> IO () -> (PT.PlexusStreamItem -> IO ()) -> IO (Either PT.TransportError ()) +attemptAt port ps subscribed onItem = + ST.invokeMethodStreamingWith (cfgFor port) subscribed ["t"] "m" ps onItem + +noReauth :: IO Bool +noReauth = pure False + +-- | A port nothing listens on. +deadPort :: IO Int +deadPort = do + sock <- N.socket N.AF_INET N.Stream N.defaultProtocol + N.bind sock (N.SockAddrInet 0 (N.tupleToHostAddress (127, 0, 0, 1))) + port <- fromIntegral <$> N.socketPort sock + N.close sock + pure port + +isData :: PT.PlexusStreamItem -> Bool +isData PT.StreamData{} = True +isData _ = False + +readShape, writeShape, sinceShape :: CallShape +readShape = CallShape False True False +writeShape = CallShape False False False +sinceShape = CallShape True True True + +method :: Text -> Maybe Text -> Maybe Value -> MethodSchema +method name grp params = MethodSchema + { methodName = name, methodDescription = "", methodHash = "h", methodParams = params + , methodReturns = Nothing, methodStreaming = False, methodBidirectional = False + , methodRequestType = Nothing, methodResponseType = Nothing, methodDeprecation = Nothing + , methodParamSchemas = Nothing, methodRole = MethodRoleRpc, methodLongDescription = Nothing + , methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False + , methodGroup = grp, methodExamples = [] } + +-- | Never hang a test: a call that waits forever fails it. +within :: Int -> IO a -> IO a +within secs act = timeout (secs * 1000000) act >>= maybe (expectationFailure "hung" >> error "hung") pure + +main :: IO () +main = hspec $ do + describe "the window" $ do + it "reads its spellings" $ do + map parseDuration ["10m", "90s", "1h", "1m30s", "600", "0", "", "ten", "5x"] + `shouldBe` [Just 600, Just 90, Just 3600, Just 90, Just 600, Just 0, Nothing, Nothing, Nothing] + it "says a duration short" $ + map renderDuration [0, 45, 130, 600, 3600] `shouldBe` ["0s", "45s", "2m10s", "10m", "1h"] + + describe "a method's shape" $ do + it "is a read when its group says so, a write when it says write" $ do + csRead (callShape (method "get" (Just "read") Nothing)) `shouldBe` True + csRead (callShape (method "get" (Just "write") Nothing)) `shouldBe` False + it "falls back on a read's name, and anything else is a write" $ do + csRead (callShape (method "list" (Just "inputs") Nothing)) `shouldBe` True + csRead (callShape (method "answer" (Just "inputs") Nothing)) `shouldBe` False + csRead (callShape (method "post" Nothing Nothing)) `shouldBe` False + it "is never a read when bidirectional" $ + csRead (callShape ((method "get" (Just "read") Nothing) { methodBidirectional = True })) `shouldBe` False + it "takes since when its params have one" $ do + let ps = object ["type" .= ("object" :: Text), "properties" .= object ["since" .= object [], "id" .= object []]] + csSince (callShape (method "await_reply" (Just "read") (Just ps))) `shouldBe` True + csSince (callShape (method "get" (Just "read") Nothing)) `shouldBe` False + + 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 + 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 + + 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 ()) + 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 ()) + r `shouldSatisfy` \case + Left (PT.ConnectionLost _ True) -> True + _ -> False + it "notices a silent peer by its keepalive" $ + withHub [Silent] $ \h -> do + setEnv "PLEXUS_KEEPALIVE" "1,1" + r <- within 10 $ attemptAt (hubPort 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" + other -> expectationFailure (show other) + + 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 + setReconnectWindow 10 + items <- newIORef (0 :: Int) + resumed <- newIORef [] + e <- within 20 $ resilientCall "hub" readShape (attemptAt (hubPort 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 + it "resumes a stream with since set to when it began" $ + withHub [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]) + (\r -> modifyIORef' resumed (r :)) (\_ -> pure ()) + e `shouldBe` Finished + [first, second] <- readIORef (hubCalls 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 + setReconnectWindow 10 + _ <- within 20 $ resilientCall "hub" sinceShape (attemptAt (hubPort h)) noReauth (object ["since" .= (42 :: Int)]) + (\_ -> pure ()) (\_ -> pure ()) + readIORef (hubCalls 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 + setReconnectWindow 10 + e <- within 20 $ resilientCall "hub" writeShape (attemptAt (hubPort h)) noReauth (object []) (\_ -> pure ()) (\_ -> pure ()) + e `shouldSatisfy` \case { WriteUnknown _ -> True; _ -> False } + length <$> readIORef (hubCalls h) `shouldReturn` 1 + it "sends a write that never left once the backend is back" $ do + port <- deadPort + setReconnectWindow 20 + -- the backend comes up on that port 2 s later + r <- newEmptyIORef + void $ forkIO $ do + threadDelay 2000000 + withHubAt 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 ()) + 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 `shouldSatisfy` \case { GaveUp 2 _ -> True; _ -> False } + it "with no window, reports the loss as before" $ + withHub [DropMid] $ \h -> do + setReconnectWindow 0 + e <- within 20 $ resilientCall "hub" readShape (attemptAt (hubPort h)) noReauth (object []) (\_ -> pure ()) (\_ -> pure ()) + e `shouldSatisfy` \case { Failed (PT.ConnectionLost _ True) -> True; _ -> False } + where + 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 + ms <- newIORef modes + calls <- newIORef [] + bracket (open ms calls) N.close (\_ -> act (Hub port ms calls)) + where + open ms calls = do + sock <- N.socket N.AF_INET N.Stream N.defaultProtocol + N.setSocketOption sock N.ReuseAddr 1 + N.bind sock (N.SockAddrInet (fromIntegral port) (N.tupleToHostAddress (127, 0, 0, 1))) + N.listen sock 16 + void $ forkIO $ acceptLoop sock ms calls + pure sock diff --git a/test/RenderSpec.hs b/test/RenderSpec.hs new file mode 100644 --- /dev/null +++ b/test/RenderSpec.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | SYNAPSE-13: a backend's help in the gh / cargo shape. +-- +-- A listing (@synapse … menger tickets@) is a usage line, then one line per +-- activation and per method — its name and summary, no flags — the methods +-- in their groups, and how to see a method's options. A method's page +-- (@… tickets set_status --help@) is the description, the long description, +-- 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. +module Main (main) where + +import Data.Aeson (Value) +import Data.Aeson.QQ.Simple (aesonQQ) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Test.Hspec + +import Plexus.Schema.Recursive (ChildSummary(..), MethodExample(..), MethodRole(..), MethodSchema(..), PluginSchema(..)) +import Synapse.Algebra.Render (Listing(..), renderListing, renderSchema, defaultStyle, summarize, fitText) +import Synapse.CLI.Help (MethodPage(..), renderMethodPage, renderExample, shellQuote) +import Synapse.IR.Builder (extractMethodDef) +import Synapse.IR.Types + +method :: Text -> Text -> Maybe Value -> MethodSchema +method name desc params = MethodSchema + { methodName = name, methodDescription = desc, methodHash = "h", methodParams = params + , methodReturns = Nothing, methodStreaming = True, methodBidirectional = False + , methodRequestType = Nothing, methodResponseType = Nothing, methodDeprecation = Nothing + , methodParamSchemas = Nothing, methodRole = MethodRoleRpc + , methodLongDescription = Nothing, methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False + , methodGroup = Nothing, methodExamples = [] } + +grouped :: Text -> MethodSchema -> MethodSchema +grouped g m = m { methodGroup = Just g } + +-- --------------------------------------------------------------------------- +-- Fixtures +-- --------------------------------------------------------------------------- + +-- | A hub with children and ungrouped methods (an older hub's shape). +hub :: PluginSchema +hub = PluginSchema + { psNamespace = "menger", psVersion = "1.0.0" + , psDescription = "Central routing and introspection" + , psLongDescription = Nothing, psHash = "h0" + , psMethods = + [ method "hash" "Get plexus configuration hash (from the recursive schema) This hash changes whenever any method or child plugin changes" Nothing + , method "call" "Route a call to a registered activation" (Just findParams) + ] + , psChildren = Just + [ ChildSummary "tickets" "Plans as data — create, query, and watch the work DAG" "h1" + , ChildSummary "comments" "Comments on the app and on ticket bodies — add, list (filtered), resolve, reopen, watch" "h2" + ] + , psDeprecation = Nothing + , psRoles = Nothing, psView = Nothing + } + +-- | A leaf whose methods say their groups (declaration order: read, write, +-- inputs), one saying none. +tickets :: PluginSchema +tickets = PluginSchema + { psNamespace = "tickets", psVersion = "0.5.0" + , psDescription = "Plans as data — create, query, and watch the work DAG" + , psLongDescription = Nothing, psHash = "t0" + , psMethods = + [ grouped "read" (method "list" "List tickets, optionally filtered by epic, status, parent and/or a filter; paged with after + limit" (Just findParams)) + , grouped "write" (method "set_status" "Set a ticket's status (not a doc's: a doc has no lifecycle)" (Just setStatusParams)) + , grouped "read" (method "get" "Get one ticket by id, or by path address SHORTCODE/path (e.g. PLEXUS/_MENGER/board)" Nothing) + , grouped "inputs" (method "answer" "Answer an input: record a value (checked against its kind and options) with a rationale" Nothing) + , grouped "write" (method "create" "Create a ticket; allocates the next EPIC-N id" Nothing) + , method "schema" "Get plugin or method schema. Pass {\"method\": \"name\"} for a specific method." Nothing + ] + , psChildren = Nothing + , psDeprecation = Nothing + , psRoles = Nothing, psView = Nothing + } + +findParams, setStatusParams, answerParams :: Value +findParams = [aesonQQ|{ + "type": "object", + "properties": { + "after": {"type": ["string", "null"], "description": "Cursor: start strictly after this ticket id, e.g. MNG-9 (optional)"}, + "limit": {"type": ["integer", "null"], "format": "uint64", "description": "At most this many tickets (default 50); the page event carries the next cursor (optional)"}, + "query": {"type": "string", "description": "Substring of the ticket id or title, case-insensitive (ASCII), trimmed; empty matches every ticket"} + }, + "required": ["query"] +}|] +setStatusParams = [aesonQQ|{ + "type": "object", + "properties": { + "id": {"type": "string", "description": "Ticket id, e.g. MNG-2"}, + "status": {"type": "string", "description": "New status (case-insensitive; `active` is Coding)", + "x-plexus-values": ["Pending", "Ready", "Coding", "In Review", "Blocked", "Complete"]}, + "note": {"type": ["string", "null"], "description": "Why (optional)"} + }, + "required": ["id", "status"] +}|] +answerParams = [aesonQQ|{ + "type": "object", + "properties": { + "ticket": {"type": "string", "description": "Ticket id, e.g. INPUT-9"}, + "value": {"type": "object", "description": "Typed by the input's kind"}, + "commits": {"type": ["array", "null"], "items": {"type": "string"}, "description": "Commits"}, + "rationale": {"type": ["string", "null"], "description": "Why (optional)"} + }, + "required": ["ticket", "value"] +}|] + +-- | set_status as a hub 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." + , methodGrant = Just "tickets.set_status", methodTarget = Just "id", methodHeldOn = Just ["MENGER"] + , methodGroup = Just "write" + , methodExamples = + [ MethodExample [aesonQQ|{"id": "MENGER-40", "status": "Coding"}|] (Just "start work on MENGER-40") + , MethodExample [aesonQQ|{"id": "MENGER-40", "status": "In Review"}|] Nothing + ] + } + +pageOf :: Bool -> MethodSchema -> (MethodDef, Text) +pageOf caller ms = + let (types, md) = extractMethodDef "tickets" "tickets" ms + ir = emptyIR { irMethods = Map.singleton (mdFullPath md) md, irTypes = types } + page = MethodPage + { mpProgram = "synapse -P 4455", mpTarget = "menger tickets " <> methodName ms + , mpSchema = Just ms, mpCaller = caller } + in (md, renderMethodPage page ir md) + +-- | An older hub's set_status: no long description, examples, values, +-- grant or group — and only the IR (no schema) at hand. +oldPage :: Text +oldPage = + let old = (method "set_status" "Set a ticket's status" (Just [aesonQQ|{ + "type": "object", + "properties": {"id": {"type": "string", "description": "Ticket id, e.g. MNG-2"}, + "status": {"type": "string", "description": "New status"}}, + "required": ["id", "status"]}|])) + (types, md) = extractMethodDef "tickets" "tickets" old + ir = emptyIR { irMethods = Map.singleton (mdFullPath md) md, irTypes = types } + page = MethodPage { mpProgram = "synapse", mpTarget = "menger tickets set_status", mpSchema = Nothing, mpCaller = False } + in renderMethodPage page ir md + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +linesOf :: Text -> [Text] +linesOf = T.lines + +lineWith :: [Text] -> Text -> Text +lineWith ls needle = fromJust (lookupLine needle) + where lookupLine n = case filter (T.isInfixOf n) ls of { (l : _) -> Just l; [] -> Nothing } + +indexOf :: [Text] -> Text -> Int +indexOf ls needle = length (takeWhile (not . T.isInfixOf needle) ls) + +col :: Text -> Text -> Int +col needle l = T.length (fst (T.breakOn needle l)) + +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 + (_, page) = pageOf False setStatus + (_, callerPage) = pageOf True setStatus + mapM_ TIO.putStrLn [listing, hubListing, page, callerPage, oldPage] + hspec $ do + describe "a listing (gh's shape)" $ do + let ls = linesOf listing + it "is the name, version and description, a usage line, then its sections" $ do + take 2 ls `shouldBe` ["tickets v0.5.0", " Plans as data \x2014 create, query, and watch the work DAG"] + lineWith ls "USAGE" `shouldBe` "USAGE" + ls !! (indexOf ls "USAGE" + 1) `shouldBe` " synapse -P 4455 menger tickets [flags]" + + it "groups the methods in the order their groups first appear, the ungrouped last" $ + filter (\l -> not (T.null l) && T.toUpper l == l && not (" " `T.isPrefixOf` l)) ls + `shouldBe` ["USAGE", "READ", "WRITE", "INPUTS", "OTHER"] + + it "lists each group alphabetically" $ do + let at n = indexOf ls (" " <> n <> " ") + (at "get" < at "list", at "create" < at "set_status") `shouldBe` (True, True) + (indexOf ls "READ" < at "get", at "list" < indexOf ls "WRITE") `shouldBe` (True, True) + + it "is one line per method — its summary, no flags" $ do + lineWith ls " create " `shouldSatisfy` T.isSuffixOf "Create a ticket" + lineWith ls " answer " `shouldSatisfy` T.isSuffixOf "Answer an input" + lineWith ls " schema " `shouldSatisfy` T.isSuffixOf "Get plugin or method schema" + filter (T.isInfixOf "--") (takeWhile (not . T.isPrefixOf "Run ") ls) `shouldBe` [] + length (filter (T.isPrefixOf " ") ls) `shouldBe` 2 + length (psMethods tickets) -- the description, the usage, a line each + + it "starts every summary in one column" $ do + let cols = [col "Create a ticket" (lineWith ls " create "), col "Answer" (lineWith ls " answer "), col "Set a ticket" (lineWith ls " set_status ")] + cols `shouldSatisfy` (\cs -> and (zipWith (==) cs (drop 1 cs))) + + it "ends with how to see a method's options" $ + last ls `shouldBe` "Run 'synapse -P 4455 menger tickets --help' for its options." + + it "fits in 80 columns and never leaves two blank lines in a row" $ do + 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 + 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) + it "says how to reach both" $ do + ls `shouldContain` [" synapse -P 4455 menger [flags]", " synapse -P 4455 menger [flags]"] + ls `shouldContain` ["Run 'synapse -P 4455 menger ' for its methods.", "Run 'synapse -P 4455 menger --help' for its options."] + it "keeps a long summary to its line" $ do + lineWith ls " comments " `shouldSatisfy` T.isSuffixOf "Comments on the app and on ticket bodies" + filter ((> 80) . T.length) ls `shouldBe` [] + + describe "a listing in a caller's view (AUTH-8)" $ do + let caller = PluginSchema + { psNamespace = "tickets", psVersion = "0.5.0", psDescription = "Plans as data" + , psLongDescription = Nothing, psHash = "c", psChildren = Nothing, psDeprecation = Nothing + , psRoles = Nothing, psView = Nothing + , psMethods = [ setStatus, grouped "read" (method "get" "One ticket by id" Nothing) { methodGrant = Just "tickets.get", methodHeldOn = Just ["MENGER", "PLEXUS"] } ] } + ls = linesOf (renderListing defaultStyle (Listing "synapse menger tickets" (Just "you are worker-1 \x00B7 editor on MENGER")) caller) + it "keeps who the caller is under the description" $ + take 3 ls `shouldBe` ["tickets v0.5.0", " Plans as data", " you are worker-1 \x00B7 editor on MENGER"] + it "ends each method's one line with its grant and where it is held, aligned" $ do + let g = lineWith ls " get " + s = lineWith ls " set_status " + T.stripEnd g `shouldSatisfy` T.isSuffixOf "tickets.get MENGER, PLEXUS" + T.stripEnd s `shouldSatisfy` T.isSuffixOf "tickets.set_status MENGER" + col "tickets." g `shouldBe` col "tickets." s + it "shows no grant column outside a caller's view" $ + renderListing defaultStyle (Listing "synapse menger tickets" Nothing) caller { psMethods = [setStatus { methodHeldOn = Nothing }] } + `shouldSatisfy` (not . T.isInfixOf "tickets.set_status") + + describe "a summary" $ do + it "is the first sentence, outside brackets, not stopping at e.g." $ do + summarize "Create a ticket; allocates the next id" `shouldBe` "Create a ticket" + summarize "Answer an input: record a value" `shouldBe` "Answer an input" + summarize "Get plugin or method schema. Pass {\"method\": \"name\"}." `shouldBe` "Get plugin or method schema" + summarize "Set a ticket's status (not a doc's: a doc has no lifecycle)" `shouldBe` "Set a ticket's status (not a doc's: a doc has no lifecycle)" + summarize "Get one ticket, e.g. MNG-2. More" `shouldBe` "Get one ticket, e.g. MNG-2" + summarize "Heartbeat \x2014 version, unix time" `shouldBe` "Heartbeat \x2014 version, unix time" + it "fits its column: without parentheticals, at a dash, else cut with an ellipsis" $ do + fitText 40 "Get one ticket by id, or by path address SHORTCODE/path (e.g. PLEXUS/_MENGER/board)" + `shouldBe` "Get one ticket by id, or by path\x2026" + fitText 60 "Comments on the app (and bodies) \x2014 add, list (filtered), resolve, reopen, watch" + `shouldBe` "Comments on the app \x2014 add, list, resolve, reopen, watch" + fitText 30 "Each shortcode's last sequence \x2014 where each one ends" `shouldBe` "Each shortcode's last sequence" + T.length (fitText 20 "a very long single sentence without any stops in it at all") `shouldSatisfy` (<= 20) + + describe "a method's page (cargo's shape)" $ do + let ls = linesOf page + opts = drop (indexOf ls "Options:") ls + it "is the description, then the long description in its paragraphs" $ do + head ls `shouldBe` "Set a ticket's status (not a doc's: a doc has no lifecycle)" + take 4 (drop 1 ls) `shouldBe` ["", "Yields exactly one event: `StatusChanged`, `NotFound`, or `Error`.", "", "A doc has no lifecycle."] + it "has a usage line naming the required flags, then [OPTIONS]" $ + lineWith ls "Usage:" `shouldBe` "Usage: synapse -P 4455 menger tickets set_status --id --status [OPTIONS]" + it "aligns the options, required first, optional in brackets, each with its type" $ do + let i = indexOf ls "Options:" + take 3 (map (T.takeWhile (/= '>')) (filter (" -" `T.isPrefixOf`) (drop i ls) ++ filter (" [" `T.isPrefixOf`) (drop i ls))) + `shouldBe` [" --id and (zipWith (==) cs (drop 1 cs))) + it "says the values a param takes, under its description" $ do + let i = indexOf opts "--status <" + opts !! (i + 1) `shouldSatisfy` T.isInfixOf "[values: Pending, Ready, Coding, In Review, Blocked," + T.length (T.takeWhile (== ' ') (opts !! (i + 1))) `shouldBe` col "New status" (opts !! i) + it "renders the schema's examples as command lines under their notes" $ do + lineWith ls "Examples:" `shouldBe` "Examples:" + ls `shouldContain` + [ " # start work on MENGER-40" + , " synapse -P 4455 menger tickets set_status --id MENGER-40 --status Coding" ] + lineWith ls "In Review'" `shouldBe` " synapse -P 4455 menger tickets set_status --id MENGER-40 --status 'In Review'" + it "says nothing of grants outside a caller's view" $ + page `shouldSatisfy` (not . T.isInfixOf "Requires:") + it "says what it requires in a caller's view" $ + last (linesOf callerPage) `shouldBe` "Requires: tickets.set_status on the scope of --id (you hold it on MENGER)" + 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 + 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 " + lineWith (drop (indexOf ls "Options:") ls) "--status <" `shouldSatisfy` T.isInfixOf "New status" + it "synthesises one example from the required options (an e.g. where it gives one)" $ do + lineWith ls "Example:" `shouldBe` "Example:" + lineWith ls " synapse " `shouldBe` " synapse menger tickets set_status --id MNG-2 --status " + oldPage `shouldSatisfy` (not . T.isInfixOf "values:") + + describe "an example as a command line" $ do + let (md, _) = pageOf False ((method "answer" "Answer" (Just answerParams))) + run = renderExample "synapse -P 4455" "menger tickets answer" md + it "puts required params first, an object's fields dotted with its type first" $ + run [aesonQQ|{"rationale": "holds are real", "value": {"type": "choice", "option": "archive"}, "ticket": "R-13"}|] + `shouldBe` "synapse -P 4455 menger tickets answer --ticket R-13 --value.type choice --value.option archive --rationale 'holds are real'" + it "joins a list with commas, an element holding one in double quotes (SYNAPSE-2)" $ do + run [aesonQQ|{"ticket": "R-13", "commits": ["a1b2c3d", "x@4f7114a"]}|] + `shouldBe` "synapse -P 4455 menger tickets answer --ticket R-13 --commits a1b2c3d,x@4f7114a" + run [aesonQQ|{"ticket": "R-13", "commits": ["a,b", "c"]}|] + `shouldBe` "synapse -P 4455 menger tickets answer --ticket R-13 --commits '\"a,b\",c'" + it "sends a list inside an object whole, with -p before the backend (SYNAPSE-9)" $ + run [aesonQQ|{"ticket": "R-13", "value": {"type": "multi", "options": ["unit", "wire"]}}|] + `shouldBe` "synapse -P 4455 -p '{\"ticket\":\"R-13\",\"value\":{\"options\":[\"unit\",\"wire\"],\"type\":\"multi\"}}' menger tickets answer" + it "quotes what the shell would split" $ do + map shellQuote ["MENGER-40", "In Review", "it's", "#/ticket/D-2", "", "$HOME", ""] + `shouldBe` ["MENGER-40", "'In Review'", "\"it's\"", "'#/ticket/D-2'", "", "'$HOME'", "''"] + + describe "renderSchema (the listing, reached by its namespace)" $ + it "is the listing with synapse as its usage" $ + renderSchema tickets `shouldSatisfy` T.isInfixOf " synapse tickets [flags]" diff --git a/test/Req8RenderSpec.hs b/test/Req8RenderSpec.hs new file mode 100644 --- /dev/null +++ b/test/Req8RenderSpec.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | REQ-8 acceptance: synapse renderer shows per-param x-plexus-source +-- annotations inline when rendering a method's help. +-- +-- SYNAPSE-13: a listing no longer shows parameters (one line per method), +-- so the annotations are pinned on the method's page, built from the IR. +module Main where + +import Data.Aeson (Value) +import Data.Aeson.QQ.Simple (aesonQQ) +import qualified Data.IORef as IORef +import qualified Data.Text as T +import Data.Text (Text) +import System.Exit (exitFailure, exitSuccess) + +import qualified Plexus.Schema.Recursive +import Plexus.Schema.Recursive + ( PluginSchema(..), MethodSchema(..) ) +import qualified Data.Map.Strict as Map +import Synapse.CLI.Help (renderMethodHelp) +import Synapse.IR.Builder (extractMethodDef) +import Synapse.IR.Types (IR(..), MethodDef(..), emptyIR) + +-- ─── Fixture ────────────────────────────────────────────────── + +-- A plugin with one method that has three params: +-- - user: x-plexus-source.from = auth (resolver) +-- - origin: x-plexus-source.from = derived +-- - search: no annotation (RPC param) +fixture :: PluginSchema +fixture = PluginSchema + { psNamespace = "svc" + , psVersion = "1.0.0" + , psDescription = "Test service" + , psLongDescription = Nothing + , psHash = "h1" + , psMethods = [method1] + , psChildren = Nothing + , psDeprecation = Nothing + , psRoles = Nothing, psView = Nothing + } + where + method1 = MethodSchema + { methodName = "list" + , methodDescription = "List things" + , methodHash = "h2" + , methodParams = Just paramsSchema + , methodReturns = Nothing + , methodStreaming = False + , methodBidirectional = False + , methodRequestType = Nothing + , methodResponseType = Nothing + , methodDeprecation = Nothing + , methodParamSchemas = Nothing + , methodRole = defaultRole + , methodLongDescription = Nothing, methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False, methodGroup = Nothing, methodExamples = [] + } + +-- | Stub role — renderSchema doesn't branch on role for this test. +defaultRole :: Plexus.Schema.Recursive.MethodRole +defaultRole = Plexus.Schema.Recursive.MethodRoleRpc + +paramsSchema :: Value +paramsSchema = [aesonQQ|{ + "type": "object", + "properties": { + "user": { + "type": "object", + "x-plexus-source": { + "from": "auth", + "resolver": "self.db.validate_user" + } + }, + "origin": { + "type": "object", + "x-plexus-source": { "from": "derived" } + }, + "search": { + "type": "string" + } + }, + "required": ["search"] +}|] + +-- ─── Runner ─────────────────────────────────────────────────── + +data TestResult = Pass String | Fail String String + +main :: IO () +main = do + failures <- IORef.newIORef (0 :: Int) + let run (Pass name) = putStrLn $ " [PASS] " <> name + run (Fail name reason) = do + putStrLn $ " [FAIL] " <> name <> ": " <> reason + IORef.modifyIORef' failures (+ 1) + + let (types, md) = extractMethodDef "svc" "svc" (head (psMethods fixture)) + ir = emptyIR { irMethods = Map.singleton (mdFullPath md) md, irTypes = types } + out = renderMethodHelp ir md + + putStrLn "=== REQ-8: per-param source annotations in renderer ===" + putStrLn "(rendered output)" + putStrLn "---" + putStrLn $ T.unpack out + putStrLn "---" + + run $ assertContains out "list" "method name appears" + run $ assertContains out "user" "auth-sourced param name appears" + run $ assertContains out "origin" "derived-sourced param name appears" + run $ assertContains out "--search" "RPC param emitted as --flag" + run $ assertContains out "auth: self.db.validate_user" + "auth resolver expression appears on the auth-sourced param" + run $ assertContains out "server-derived" + "derived source is labeled 'server-derived'" + run $ assertNotContains out "--user" + "auth-sourced param is NOT emitted as --flag (server-extracted)" + run $ assertNotContains out "--origin" + "derived-sourced param is NOT emitted as --flag" + + fc <- IORef.readIORef failures + if fc == 0 + then putStrLn "\nREQ-8: ALL TESTS PASSED" >> exitSuccess + else putStrLn ("\nREQ-8: " <> show fc <> " test(s) failed") >> exitFailure + +assertContains :: Text -> Text -> String -> TestResult +assertContains hay needle name = + if needle `T.isInfixOf` hay + then Pass name + else Fail name ("expected output to contain: " <> T.unpack needle) + +assertNotContains :: Text -> Text -> String -> TestResult +assertNotContains hay needle name = + if needle `T.isInfixOf` hay + then Fail name ("unexpected substring present: " <> T.unpack needle) + else Pass name diff --git a/test/SchemaDecodeSpec.hs b/test/SchemaDecodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/SchemaDecodeSpec.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | REQ-S10 spike: verify Plexus.Schema.Recursive.PluginSchema decodes +-- the new optional psRequest field losslessly, including x-plexus-source +-- extension nodes. +module Main where + +import Data.Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.QQ.Simple (aesonQQ) +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Maybe (isJust, isNothing, fromJust) +import qualified Data.Vector as V +import System.Exit (exitFailure, exitSuccess) +import qualified Data.IORef as IORef + +import Plexus.Schema.Recursive (PluginSchema(..)) + +-- ============================================================================ +-- Fixtures +-- ============================================================================ + +fixtureWithRequest :: Value +fixtureWithRequest = [aesonQQ|{ + "namespace": "clients", + "version": "1.0.0", + "description": "Client management", + "hash": "abc123", + "methods": [], + "request": { + "type": "object", + "properties": { + "auth_token": { + "type": "string", + "description": "JWT from Keycloak", + "x-plexus-source": { "from": "cookie", "key": "access_token" } + }, + "origin": { + "type": "string", + "x-plexus-source": { "from": "header", "key": "origin" } + }, + "peer_addr": { + "type": "string", + "x-plexus-source": { "from": "derived" } + } + }, + "required": ["auth_token"] + } +}|] + +fixtureWithoutRequest :: Value +fixtureWithoutRequest = [aesonQQ|{ + "namespace": "forms", + "version": "1.0.0", + "description": "Forms (no auth required)", + "hash": "def456", + "methods": [] +}|] + +fixtureEmptyRequest :: Value +fixtureEmptyRequest = [aesonQQ|{ + "namespace": "edge", + "version": "1.0.0", + "description": "Edge case", + "hash": "ghi789", + "methods": [], + "request": {} +}|] + +-- ============================================================================ +-- Test runner +-- ============================================================================ + +data TestResult = Pass String | Fail String String + +runTest :: String -> Bool -> String -> TestResult +runTest name True _ = Pass name +runTest name False why = Fail name why + +main :: IO () +main = do + failures <- IORef.newIORef (0 :: Int) + let run :: TestResult -> IO () + run (Pass name) = putStrLn $ " [PASS] " <> name + run (Fail name reason) = do + putStrLn $ " [FAIL] " <> name <> ": " <> reason + IORef.modifyIORef' failures (+ 1) + + putStrLn "=== REQ-S10: PluginSchema psRequest decoding ===" + + -- Pass condition 1: fixtureWithRequest decodes to psRequest = Just _ + -- and x-plexus-source.from on auth_token is "cookie" + case fromJSON fixtureWithRequest :: Result PluginSchema of + Error e -> run (Fail "fixture-with-request decodes" e) + Success schema -> do + run $ runTest "fixture-with-request: psRequest = Just _" + (isJust (psRequest schema)) + "expected Just, got Nothing" + let cookieFrom = do + req <- psRequest schema + obj <- valueToObject req + props <- KeyMap.lookup "properties" obj + propsObj <- valueToObject props + authTok <- KeyMap.lookup "auth_token" propsObj + atObj <- valueToObject authTok + src <- KeyMap.lookup "x-plexus-source" atObj + srcObj <- valueToObject src + from <- KeyMap.lookup "from" srcObj + valueToString from + run $ runTest "fixture-with-request: auth_token x-plexus-source.from == 'cookie'" + (cookieFrom == Just "\"cookie\"") + ("got: " <> show cookieFrom) + + -- Pass condition 2: fixtureWithoutRequest decodes to psRequest = Nothing + case fromJSON fixtureWithoutRequest :: Result PluginSchema of + Error e -> run (Fail "fixture-without-request decodes" e) + Success schema -> + run $ runTest "fixture-without-request: psRequest = Nothing" + (isNothing (psRequest schema)) + ("expected Nothing, got: " <> show (psRequest schema)) + + -- Pass condition 3: fixtureEmptyRequest decodes to psRequest = Just (Object empty) + case fromJSON fixtureEmptyRequest :: Result PluginSchema of + Error e -> run (Fail "fixture-empty-request decodes" e) + Success schema -> do + let isEmptyObject = case psRequest schema of + Just (Object km) -> KeyMap.null km + _ -> False + run $ runTest "fixture-empty-request: psRequest = Just (Object empty)" + isEmptyObject + ("got: " <> show (psRequest schema)) + + -- Pass condition 4: lossless roundtrip on all three fixtures + let roundtripCheck name fixture = + case fromJSON fixture :: Result PluginSchema of + Error e -> Fail (name <> " decode for roundtrip") e + Success original -> + case decode (encode original) :: Maybe PluginSchema of + Nothing -> Fail (name <> " roundtrip decode") "encode/decode failed" + Just decoded -> + runTest (name <> " roundtrip lossless") + (decoded == original) + "decoded /= original" + + run $ roundtripCheck "fixture-with-request" fixtureWithRequest + run $ roundtripCheck "fixture-without-request" fixtureWithoutRequest + run $ roundtripCheck "fixture-empty-request" fixtureEmptyRequest + + -- Pass condition 5: x-plexus-source survives roundtrip on all three field types + case fromJSON fixtureWithRequest :: Result PluginSchema of + Error _ -> run (Fail "x-plexus-source roundtrip" "decode failed") + Success original -> do + let reEncoded = encode original + case decode reEncoded :: Maybe PluginSchema of + Nothing -> run (Fail "x-plexus-source roundtrip decode" "decode-after-encode failed") + Just decoded -> do + let extractFrom propName = do + req <- psRequest decoded + obj <- valueToObject req + props <- KeyMap.lookup "properties" obj >>= valueToObject + prop <- KeyMap.lookup (Key.fromString propName) props >>= valueToObject + src <- KeyMap.lookup "x-plexus-source" prop >>= valueToObject + from <- KeyMap.lookup "from" src + valueToString from + run $ runTest "x-plexus-source roundtrip: cookie field" + (extractFrom "auth_token" == Just "\"cookie\"") (show $ extractFrom "auth_token") + run $ runTest "x-plexus-source roundtrip: header field" + (extractFrom "origin" == Just "\"header\"") (show $ extractFrom "origin") + run $ runTest "x-plexus-source roundtrip: derived field" + (extractFrom "peer_addr" == Just "\"derived\"") (show $ extractFrom "peer_addr") + + fc <- IORef.readIORef failures + if fc == 0 + then do + putStrLn "\nREQ-S10: ALL TESTS PASSED" + exitSuccess + else do + putStrLn $ "\nREQ-S10: " <> show fc <> " test(s) failed" + exitFailure + +-- helpers +valueToObject :: Value -> Maybe Object +valueToObject (Object o) = Just o +valueToObject _ = Nothing + +valueToString :: Value -> Maybe String +valueToString (String t) = Just (show t) -- show wraps in quotes; we compare against quoted strings below +valueToString _ = Nothing diff --git a/test/SelfCommandSpec.hs b/test/SelfCommandSpec.hs new file mode 100644 --- /dev/null +++ b/test/SelfCommandSpec.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for 'Synapse.Self.Command' (SELF-4). +-- +-- Two layers: +-- +-- 1. Pure tests: the set-value heuristic ('wrapAsLiteralIfNeeded'), +-- JWT decode + relative-expiry rendering, and exit-code behavior +-- for keychain-gated verbs. +-- +-- 2. Integration tests: exercise 'runSelfCommand' against a tmp HOME +-- so the on-disk @~\/.plexus\/\\/defaults.json@ lifecycle +-- is covered end-to-end. +-- +-- The integration tests use 'withSystemTempDirectory' + 'withEnv "HOME"' +-- (mirroring the pattern in SelfSpec.hs) so they never touch the +-- developer's real @~\/.plexus@. +module SelfCommandSpec (spec) where + +import Control.Exception (bracket_) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import System.Directory (doesFileExist, getHomeDirectory, removeFile) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.Exit (ExitCode(..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + +import Synapse.Self + ( CredentialRef(..) + , StoredDefaults(..) + , decodeDefaults + , emptyStoredDefaults + ) +import Synapse.Self.Command + +spec :: Spec +spec = do + describe "wrapAsLiteralIfNeeded" $ do + it "wraps a bare string with no scheme" $ + wrapAsLiteralIfNeeded "abc123" `shouldBe` "literal:abc123" + + it "preserves a literal: prefix" $ + wrapAsLiteralIfNeeded "literal:already" `shouldBe` "literal:already" + + it "preserves env:// refs" $ + wrapAsLiteralIfNeeded "env://FOO" `shouldBe` "env://FOO" + + it "preserves keychain:// refs" $ + wrapAsLiteralIfNeeded "keychain://svc/acct" `shouldBe` "keychain://svc/acct" + + it "preserves file:// refs" $ + wrapAsLiteralIfNeeded "file:///etc/token" `shouldBe` "file:///etc/token" + + it "preserves vault:// refs" $ + wrapAsLiteralIfNeeded "vault://secret" `shouldBe` "vault://secret" + + it "wraps a JWT (bare) as literal:" $ + wrapAsLiteralIfNeeded "eyJhbGc.eyJzdWIi.sig" + `shouldBe` "literal:eyJhbGc.eyJzdWIi.sig" + + it "wraps a string containing a scheme-like substring mid-value" $ + -- The heuristic only matches on *prefix*; this is a bare string. + wrapAsLiteralIfNeeded "xyz env://FOO" + `shouldBe` "literal:xyz env://FOO" + + describe "decodeJwt" $ do + it "returns Nothing for a non-JWT bare string" $ + decodeJwt "hello-world" `shouldBe` Nothing + + it "returns Nothing for a 2-segment value (missing signature slot)" $ + decodeJwt "eyJhbGc.eyJzdWIi" `shouldBe` Nothing + + it "returns Nothing when the header has no alg field" $ do + let h = encodeSeg "{\"typ\":\"JWT\"}" + p = encodeSeg "{\"sub\":\"x\"}" + decodeJwt (h <> "." <> p <> ".sig") `shouldBe` Nothing + + it "decodes a minimal well-formed JWT" $ do + let h = encodeSeg "{\"alg\":\"HS256\",\"kid\":\"k1\"}" + p = encodeSeg "{\"sub\":\"jdoe\",\"iss\":\"https://idp.example/realms/r\"}" + jwt = h <> "." <> p <> ".sig" + case decodeJwt jwt of + Nothing -> expectationFailure "expected Just, got Nothing" + Just s -> do + jsAlg s `shouldBe` Just "HS256" + jsKid s `shouldBe` Just "k1" + jsSub s `shouldBe` Just "jdoe" + jsIss s `shouldBe` Just "https://idp.example/realms/r" + + it "handles aud as an array (first element wins)" $ do + let h = encodeSeg "{\"alg\":\"RS256\"}" + p = encodeSeg "{\"aud\":[\"account\",\"app\"]}" + case decodeJwt (h <> "." <> p <> ".sig") of + Just s -> jsAud s `shouldBe` Just "account" + Nothing -> expectationFailure "expected Just" + + it "extracts preferred_username and email" $ do + let h = encodeSeg "{\"alg\":\"HS256\"}" + p = encodeSeg "{\"preferred_username\":\"ben\",\"email\":\"ben@x.dev\"}" + case decodeJwt (h <> "." <> p <> ".sig") of + Just s -> do + jsUsername s `shouldBe` Just "ben" + jsEmail s `shouldBe` Just "ben@x.dev" + Nothing -> expectationFailure "expected Just" + + it "decodes exp as a UTCTime" $ do + let h = encodeSeg "{\"alg\":\"HS256\"}" + p = encodeSeg "{\"exp\":1700000000}" + case decodeJwt (h <> "." <> p <> ".sig") of + Just s -> jsExp s `shouldBe` + Just (posixSecondsToUTCTime 1700000000) + Nothing -> expectationFailure "expected Just" + + it "tolerates URL-safe base64 with stripped padding" $ do + -- Construct a header/payload whose un-padded base64url has length + -- not divisible by 4. + let headerBs = "{\"alg\":\"HS256\"}" :: BS.ByteString + payloadBs = "{\"sub\":\"x\"}" :: BS.ByteString + h = T.dropWhileEnd (== '=') (TE.decodeUtf8 (B64U.encode headerBs)) + p = T.dropWhileEnd (== '=') (TE.decodeUtf8 (B64U.encode payloadBs)) + case decodeJwt (h <> "." <> p <> ".sig") of + Just s -> jsSub s `shouldBe` Just "x" + Nothing -> expectationFailure "expected Just" + + describe "renderRelativeExpiry" $ do + let now = posixSecondsToUTCTime 1_700_000_000 + + it "renders 'expired Nm Ns ago' for a recently-expired token" $ do + let past = addUTCTime (-(60 * 4 + 32)) now -- 4m 32s ago + renderRelativeExpiry now past `shouldBe` "expired 4m 32s ago" + + it "renders 'valid for Nm Ns' for a near-future token" $ do + let future = addUTCTime (60 * 4 + 32) now + renderRelativeExpiry now future `shouldBe` "valid for 4m 32s" + + it "uses days+hours for old tokens" $ do + let past = addUTCTime (-(16 * 86400 + 4 * 3600)) now + renderRelativeExpiry now past `shouldBe` "expired 16d 4h ago" + + it "falls back to seconds-only for sub-minute deltas" $ do + let future = addUTCTime 5 now + renderRelativeExpiry now future `shouldBe` "valid for 5s" + + it "hours-only when minutes are zero" $ do + let future = addUTCTime (3 * 3600) now + renderRelativeExpiry now future `shouldBe` "valid for 3h" + + -- SELF-8: keychain-touching verbs (set-secret, upgrade-to-keychain, + -- import-token --to-keychain) live behind an opt-in test-suite + -- (plexus-synapse:keychain-test, gated on the `build-keychain-tests` + -- cabal flag). They shell out to the `security` CLI on macOS, which + -- we don't want firing during a default `cabal test` run. The + -- keychain-unavailable error paths (non-macOS platforms) are verified + -- there too, so this block is intentionally empty. + pure () + + -- ========================================================================== + -- Integration: round-trip against a tmp HOME + -- ========================================================================== + + describe "runSelfCommand: integration round-trip" $ do + it "set -> show-readable -> resolve -> unset -> clear" $ + withTmpHome $ \tmpHome -> do + let backend = "itest" + defaultsFile = tmpHome ".plexus" T.unpack backend + "defaults.json" + + -- 1. Set two values. + _ <- runSelfCommand + (CmdSet backend Cookie "access_token" "literal:abc123") + _ <- runSelfCommand + (CmdSet backend Header "X-Trace" "env://NONEXISTENT_ENV_SELF4") + + -- The file now exists and decodes round-trip. + exists <- doesFileExist defaultsFile + exists `shouldBe` True + bytes <- BS.readFile defaultsFile + case decodeDefaults bytes of + Left err -> expectationFailure ("decode failed: " <> T.unpack err) + Right sd -> do + Map.lookup "access_token" (sdCookies sd) + `shouldBe` Just (CredentialRef "literal:abc123") + Map.lookup "X-Trace" (sdHeaders sd) + `shouldBe` Just (CredentialRef "env://NONEXISTENT_ENV_SELF4") + + -- 2. resolve access_token prints the value. + code <- runSelfCommand (CmdResolve backend Cookie "access_token") + code `shouldBe` ExitSuccess + + -- 3. unset removes it. + _ <- runSelfCommand + (CmdUnset backend Cookie "access_token" True False) + bytes' <- BS.readFile defaultsFile + case decodeDefaults bytes' of + Right sd -> Map.member "access_token" (sdCookies sd) `shouldBe` False + Left err -> expectationFailure ("decode failed: " <> T.unpack err) + + -- 4. clear --yes deletes the file. + _ <- runSelfCommand (CmdClear backend True) + stillThere <- doesFileExist defaultsFile + stillThere `shouldBe` False + + it "set wraps a bare value as literal: on disk" $ + withTmpHome $ \tmpHome -> do + let backend = "itest-wrap" + path = tmpHome ".plexus" T.unpack backend "defaults.json" + -- Bare JWT-looking value (three dot-separated segments) should + -- still be wrapped — the prefix heuristic doesn't look like any + -- known scheme. + _ <- runSelfCommand + (CmdSet backend Cookie "t" "eyJhbGc.eyJzdWIi.sig") + bytes <- BS.readFile path + case decodeDefaults bytes of + Right sd -> Map.lookup "t" (sdCookies sd) `shouldBe` + Just (CredentialRef "literal:eyJhbGc.eyJzdWIi.sig") + Left err -> expectationFailure ("decode failed: " <> T.unpack err) + + it "clear on a missing file is a no-op (succeeds)" $ + withTmpHome $ \_tmp -> do + code <- runSelfCommand (CmdClear "never-touched" True) + code `shouldBe` ExitSuccess + + it "resolve on a missing entry exits non-zero" $ + withTmpHome $ \_tmp -> do + code <- runSelfCommand (CmdResolve "ghost" Cookie "nope") + code `shouldBe` ExitFailure 1 + + it "unset on a missing entry exits non-zero" $ + withTmpHome $ \_tmp -> do + code <- runSelfCommand (CmdUnset "ghost" Cookie "nope" True False) + code `shouldBe` ExitFailure 1 + + it "import-token (from file) stores literal:" $ + withTmpHome $ \tmpHome -> do + let backend = "itest-import" + tokenFile = tmpHome "tok.jwt" + defaultsFile = tmpHome ".plexus" T.unpack backend + "defaults.json" + TIO.writeFile tokenFile "eyJhbGc.eyJzdWIi.sig\n" + _ <- runSelfCommand + (CmdImportToken backend (T.pack tokenFile) False) + bytes <- BS.readFile defaultsFile + case decodeDefaults bytes of + Right sd -> Map.lookup "access_token" (sdCookies sd) `shouldBe` + Just (CredentialRef "literal:eyJhbGc.eyJzdWIi.sig") + Left err -> expectationFailure ("decode failed: " <> T.unpack err) + +-- ============================================================================ +-- helpers +-- ============================================================================ + +-- | Run @action@ with @HOME@ set to a fresh temp directory; restore on exit. +withTmpHome :: (FilePath -> IO a) -> IO a +withTmpHome action = + withSystemTempDirectory "synapse-self4-test-" $ \tmp -> do + prior <- lookupEnv "HOME" + bracket_ + (setEnv "HOME" tmp) + (case prior of + Just v -> setEnv "HOME" v + Nothing -> unsetEnv "HOME") + (action tmp) + +-- | Encode a JSON string as URL-safe base64 without padding (JWT style). +encodeSeg :: BS.ByteString -> Text +encodeSeg bs = + T.dropWhileEnd (== '=') (TE.decodeUtf8 (B64U.encode bs)) diff --git a/test/SelfMigrationSpec.hs b/test/SelfMigrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/SelfMigrationSpec.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for the SELF-3 legacy token migration in 'Synapse.Self.IO': +-- +-- * Legacy @~\/.plexus\/tokens\/\@ present, no new +-- @defaults.json@ → on 'loadDefaults': legacy removed, new file written +-- with @cookies.access_token = \"literal:\\"@, returned +-- 'StoredDefaults' carries that ref, file mode is @0600@, INFO logged. +-- * Legacy + new both present → legacy removed unread, new file +-- untouched, returned 'StoredDefaults' matches the new file. +-- * Neither file → 'emptyStoredDefaults', no files created. +-- * Empty legacy file → deleted silently, no new file created. +-- * Whitespace-only legacy → deleted silently, no new file created. +-- * INFO log line matches the expected wording (including the +-- \"Consider: synapse _self\" upgrade hint). +-- +-- Every test isolates filesystem state via 'withSystemTempDirectory' + +-- a bracketed @setEnv "HOME" tmp@. No OS keychain, no external process +-- invocation. This spec follows the SELF-5 test pattern. +module SelfMigrationSpec (spec) where + +import Control.Exception (bracket, bracket_) +import qualified Control.Exception as E +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Bits ((.&.)) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + ) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.FilePath (()) +import qualified System.Info +import System.IO (IOMode(..), hClose, hFlush, openFile, stderr) +import GHC.IO.Handle (hDuplicate, hDuplicateTo) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Files (fileMode, getFileStatus) +import System.Posix.Types (FileMode) +import Test.Hspec + +import Synapse.Self + ( CredentialRef(..) + , StoredDefaults(..) + , emptyStoredDefaults + , encodeDefaults + , loadDefaults + ) + +-- | True on Unix-style platforms where POSIX modes have meaning. +isUnix :: Bool +isUnix = System.Info.os /= "mingw32" + +-- | File mode masked to the permission bits (drop file-type bits). +permBits :: FileMode -> FileMode +permBits m = m .&. 0o777 + +-- | Run @act@ with @HOME@ pointed at @tmp@, restoring the prior @HOME@ +-- (or unsetting it if there was none) after. +withHome :: FilePath -> IO a -> IO a +withHome tmp act = do + prior <- lookupEnv "HOME" + bracket_ + (setEnv "HOME" tmp) + (case prior of + Just v -> setEnv "HOME" v + Nothing -> unsetEnv "HOME") + act + +-- | Capture whatever is written to stderr during @act@. Writes to a +-- fresh file under the supplied scratch dir. Restores the original +-- stderr — even if @act@ throws — before reading the captured bytes +-- back. +captureStderrInto :: FilePath -> IO a -> IO (a, String) +captureStderrInto scratchDir act = do + let capPath = scratchDir "captured-stderr.txt" + hFlush stderr + origStderr <- hDuplicate stderr + r <- bracket + (openFile capPath WriteMode) + (\h -> do + hFlush stderr + hDuplicateTo origStderr stderr + hClose origStderr + hClose h) + (\h -> do + hDuplicateTo h stderr + act) + bs <- BS.readFile capPath + let captured = T.unpack + (T.pack (map (toEnum . fromIntegral) (BS.unpack bs))) + pure (r, captured) + +-- | Backend name used across these specs. Unique suffix so we never +-- collide with the developer's real @~\/.plexus\/@ tree even if the +-- HOME redirection ever failed. +testBackend :: Text +testBackend = "self3-test-bk" + +-- | Place @bytes@ at @tmp/.plexus/tokens/\@, creating the +-- parent directory if needed. +placeLegacy :: FilePath -> Text -> BS.ByteString -> IO () +placeLegacy tmp backend bytes = do + let tokensDir = tmp ".plexus" "tokens" + createDirectoryIfMissing True tokensDir + BS.writeFile (tokensDir T.unpack backend) bytes + +-- | Absolute path to the legacy token file under the sandboxed HOME. +legacyPath :: FilePath -> Text -> FilePath +legacyPath tmp backend = tmp ".plexus" "tokens" T.unpack backend + +-- | Absolute path to the new defaults.json under the sandboxed HOME. +newPath :: FilePath -> Text -> FilePath +newPath tmp backend = + tmp ".plexus" T.unpack backend "defaults.json" + +-- | True when @needle@ is a substring of @haystack@. +containsSubstring :: String -> String -> Bool +containsSubstring needle haystack = + T.isInfixOf (T.pack needle) (T.pack haystack) + +-- | A realistic-looking JWT for the migrated value (shape only). +sampleJwt :: Text +sampleJwt = "eyJhbGciOiJIUzI1NiJ9.eyJzdWIiOiJ0ZXN0In0.sig" + +spec :: Spec +spec = do + describe "SELF-3 legacy token migration" $ do + + it "migrates a legacy token to literal: ref and removes legacy" $ + withSystemTempDirectory "synapse-self3" $ \tmp -> + withHome tmp $ do + placeLegacy tmp testBackend (TE.encodeUtf8 sampleJwt) + (loaded, _err) <- captureStderrInto tmp $ loadDefaults testBackend + -- Legacy removed. + doesFileExist (legacyPath tmp testBackend) `shouldReturn` False + -- New file exists with the expected content. + doesFileExist (newPath tmp testBackend) `shouldReturn` True + bs <- BS.readFile (newPath tmp testBackend) + BS8.unpack bs `shouldSatisfy` + containsSubstring ("literal:" <> T.unpack sampleJwt) + -- Returned defaults match. + sdCookies loaded `shouldBe` + Map.singleton "access_token" + (CredentialRef ("literal:" <> sampleJwt)) + sdHeaders loaded `shouldBe` Map.empty + + it "trims surrounding whitespace from the legacy token" $ + withSystemTempDirectory "synapse-self3" $ \tmp -> + withHome tmp $ do + placeLegacy tmp testBackend + (TE.encodeUtf8 (" \n" <> sampleJwt <> "\n ")) + (loaded, _err) <- captureStderrInto tmp $ loadDefaults testBackend + sdCookies loaded `shouldBe` + Map.singleton "access_token" + (CredentialRef ("literal:" <> sampleJwt)) + + it "writes the migrated defaults.json with mode 0600 (literal: content)" $ + if not isUnix + then pendingWith "POSIX-only semantics" + else withSystemTempDirectory "synapse-self3" $ \tmp -> + withHome tmp $ do + placeLegacy tmp testBackend (TE.encodeUtf8 sampleJwt) + _ <- captureStderrInto tmp $ loadDefaults testBackend + st <- getFileStatus (newPath tmp testBackend) + permBits (fileMode st) `shouldBe` 0o600 + + it "deletes the legacy file unread when the new file already exists" $ + withSystemTempDirectory "synapse-self3" $ \tmp -> + withHome tmp $ do + -- Stage an authoritative new defaults.json first. + let existing = emptyStoredDefaults + { sdCookies = Map.fromList + [ ("session", CredentialRef "literal:from-new-file") ] + } + newDir = tmp ".plexus" T.unpack testBackend + createDirectoryIfMissing True newDir + BS.writeFile (newPath tmp testBackend) (encodeDefaults existing) + -- Stage a legacy file too — must be ignored. + placeLegacy tmp testBackend (TE.encodeUtf8 "ignored-legacy-jwt") + + (loaded, err) <- captureStderrInto tmp $ loadDefaults testBackend + -- Legacy removed. + doesFileExist (legacyPath tmp testBackend) `shouldReturn` False + -- New file preserved byte-for-byte. + bsAfter <- BS.readFile (newPath tmp testBackend) + bsAfter `shouldBe` encodeDefaults existing + -- Returned defaults = new file contents (NOT the legacy jwt). + loaded `shouldBe` existing + -- INFO line names the stale legacy file. + err `shouldSatisfy` containsSubstring "[INFO]" + err `shouldSatisfy` containsSubstring "stale legacy token file" + err `shouldSatisfy` + containsSubstring (legacyPath tmp testBackend) + + it "returns empty defaults and creates no files when neither exists" $ + withSystemTempDirectory "synapse-self3" $ \tmp -> + withHome tmp $ do + (loaded, _err) <- captureStderrInto tmp $ loadDefaults testBackend + loaded `shouldBe` emptyStoredDefaults + doesFileExist (legacyPath tmp testBackend) `shouldReturn` False + doesFileExist (newPath tmp testBackend) `shouldReturn` False + -- Backend subdir is not created on the empty path. + doesDirectoryExist (tmp ".plexus" T.unpack testBackend) + `shouldReturn` False + + it "silently deletes an empty legacy file without creating a new one" $ + withSystemTempDirectory "synapse-self3" $ \tmp -> + withHome tmp $ do + placeLegacy tmp testBackend BS.empty + (loaded, err) <- captureStderrInto tmp $ loadDefaults testBackend + loaded `shouldBe` emptyStoredDefaults + doesFileExist (legacyPath tmp testBackend) `shouldReturn` False + doesFileExist (newPath tmp testBackend) `shouldReturn` False + -- Silent: no INFO line about migration on an empty file. + err `shouldNotSatisfy` containsSubstring "migrated legacy" + + it "silently deletes a whitespace-only legacy file without creating a new one" $ + withSystemTempDirectory "synapse-self3" $ \tmp -> + withHome tmp $ do + placeLegacy tmp testBackend (BS8.pack " \n\t\n ") + (loaded, err) <- captureStderrInto tmp $ loadDefaults testBackend + loaded `shouldBe` emptyStoredDefaults + doesFileExist (legacyPath tmp testBackend) `shouldReturn` False + doesFileExist (newPath tmp testBackend) `shouldReturn` False + err `shouldNotSatisfy` containsSubstring "migrated legacy" + + it "emits an INFO line with the full migration hint wording" $ + withSystemTempDirectory "synapse-self3" $ \tmp -> + withHome tmp $ do + placeLegacy tmp testBackend (TE.encodeUtf8 sampleJwt) + (_loaded, err) <- captureStderrInto tmp $ loadDefaults testBackend + err `shouldSatisfy` containsSubstring "[INFO]" + err `shouldSatisfy` containsSubstring "migrated legacy token file" + err `shouldSatisfy` + containsSubstring (legacyPath tmp testBackend) + err `shouldSatisfy` + containsSubstring (newPath tmp testBackend) + err `shouldSatisfy` containsSubstring "(stored as literal:)" + err `shouldSatisfy` containsSubstring "Consider: synapse _self " + err `shouldSatisfy` containsSubstring (T.unpack testBackend) + err `shouldSatisfy` containsSubstring "upgrade-to-keychain" + + it "is idempotent: running loadDefaults twice yields the same result" $ + withSystemTempDirectory "synapse-self3" $ \tmp -> + withHome tmp $ do + placeLegacy tmp testBackend (TE.encodeUtf8 sampleJwt) + (loaded1, _err1) <- captureStderrInto tmp $ loadDefaults testBackend + -- After the first call, the legacy file is gone. The second + -- call sees only the new defaults.json and returns the same + -- StoredDefaults. This exercises the "new file absent, legacy + -- absent" fast path as a follow-up to migration. + doesFileExist (legacyPath tmp testBackend) `shouldReturn` False + (loaded2, _err2) <- captureStderrInto tmp $ loadDefaults testBackend + loaded2 `shouldBe` loaded1 diff --git a/test/SelfSafeWriteSpec.hs b/test/SelfSafeWriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/SelfSafeWriteSpec.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for the SELF-5 safe-write path in 'Synapse.Self.IO': +-- +-- * Atomic rename via temp file (@.defaults.json.tmp@). +-- * Content-aware chmod (@0600@ with @literal:@ values, @0644@ without). +-- * Parent directory created mode @0700@ when freshly created. +-- * Pre-existing wide parent directory → WARN, dir untouched. +-- * Simulated mid-write failure → temp file cleaned up, no partial +-- @defaults.json@. +-- * 'loadDefaults' permission sniffing: WARN on world-readable files +-- with @literal:@ content; silent on manifest-only files regardless +-- of mode. +-- +-- Every test isolates filesystem state via 'withSystemTempDirectory' + +-- a bracketed @setEnv "HOME" tmp@. No OS keychain, no external process +-- invocation. Mode checks are skipped on Windows (POSIX-only semantics). +module SelfSafeWriteSpec (spec) where + +import Control.Exception (bracket, bracket_, try) +import qualified Control.Exception as E +import qualified Data.ByteString as BS +import Data.Bits ((.&.)) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory + ( createDirectoryIfMissing + , doesFileExist + ) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.FilePath (()) +import qualified System.Info +import System.IO (IOMode(..), hClose, hFlush, openFile, stderr) +import GHC.IO.Handle (hDuplicate, hDuplicateTo) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Files (fileMode, getFileStatus, setFileMode) +import System.Posix.Types (FileMode) +import Test.Hspec + +import Synapse.Self + ( CredentialRef(..) + , StoredDefaults(..) + , emptyStoredDefaults + , loadDefaults + , writeDefaults + ) + +-- | True on Unix-style platforms where POSIX modes have meaning. +isUnix :: Bool +isUnix = System.Info.os /= "mingw32" + +-- | Run @act@ with @HOME@ pointed at @tmp@, restoring the prior @HOME@ +-- (or unsetting it if there was none) after. +withHome :: FilePath -> IO a -> IO a +withHome tmp act = do + prior <- lookupEnv "HOME" + bracket_ + (setEnv "HOME" tmp) + (case prior of + Just v -> setEnv "HOME" v + Nothing -> unsetEnv "HOME") + act + +-- | Capture whatever is written to stderr during @act@. Writes to a +-- fresh file under the supplied scratch dir (caller threads one in so +-- capture output stays inside the test\'s temp-dir sandbox). Restores +-- the original stderr — even if @act@ throws — before reading the +-- captured bytes back. +captureStderrInto :: FilePath -> IO a -> IO (a, String) +captureStderrInto scratchDir act = do + let capPath = scratchDir "captured-stderr.txt" + hFlush stderr + origStderr <- hDuplicate stderr + r <- bracket + (openFile capPath WriteMode) + (\h -> do + hFlush stderr + hDuplicateTo origStderr stderr + hClose origStderr + hClose h) + (\h -> do + hDuplicateTo h stderr + act) + bs <- BS.readFile capPath + let captured = T.unpack + (T.pack (map (toEnum . fromIntegral) (BS.unpack bs))) + pure (r, captured) + +-- | Backend name used across these specs — unique suffix so we never +-- collide with the developer\'s real @~\/.plexus\/@ tree even if the +-- HOME redirection ever failed. +testBackend :: Text +testBackend = "self5-test-bk" + +-- | File mode masked to the permission bits (drop file-type bits). +permBits :: FileMode -> FileMode +permBits m = m .&. 0o777 + +spec :: Spec +spec = do + describe "SELF-5 safe write" $ do + + -- ======================================================================== + -- writeDefaults: mode-aware chmod + -- ======================================================================== + describe "chmod policy" $ do + it "sets 0600 when any value starts with literal:" $ + withSystemTempDirectory "synapse-self5" $ \tmp -> + withHome tmp $ do + let sd = emptyStoredDefaults + { sdCookies = Map.fromList + [ ("access_token", CredentialRef "literal:secret-token") ] + } + writeDefaults testBackend sd + let path = tmp ".plexus" T.unpack testBackend "defaults.json" + exists <- doesFileExist path + exists `shouldBe` True + if isUnix + then do + st <- getFileStatus path + permBits (fileMode st) `shouldBe` 0o600 + else pure () + + it "sets 0644 when values are only non-literal refs" $ + withSystemTempDirectory "synapse-self5" $ \tmp -> + withHome tmp $ do + let sd = emptyStoredDefaults + { sdCookies = Map.fromList + [ ("access_token", CredentialRef "keychain://svc/tok") ] + , sdHeaders = Map.fromList + [ ("X-Key", CredentialRef "env://API_KEY") ] + } + writeDefaults testBackend sd + let path = tmp ".plexus" T.unpack testBackend "defaults.json" + if isUnix + then do + st <- getFileStatus path + permBits (fileMode st) `shouldBe` 0o644 + else pure () + + it "sets 0600 when any one of several refs is literal" $ + withSystemTempDirectory "synapse-self5" $ \tmp -> + withHome tmp $ do + let sd = emptyStoredDefaults + { sdCookies = Map.fromList + [ ("session", CredentialRef "keychain://svc/session") + , ("backup", CredentialRef "literal:emergency-value") + ] + } + writeDefaults testBackend sd + let path = tmp ".plexus" T.unpack testBackend "defaults.json" + if isUnix + then do + st <- getFileStatus path + permBits (fileMode st) `shouldBe` 0o600 + else pure () + + -- ======================================================================== + -- writeDefaults: parent directory mode + -- ======================================================================== + describe "parent directory" $ do + it "creates a fresh parent directory with mode 0700" $ + withSystemTempDirectory "synapse-self5" $ \tmp -> + withHome tmp $ do + writeDefaults testBackend emptyStoredDefaults + let dir = tmp ".plexus" T.unpack testBackend + if isUnix + then do + st <- getFileStatus dir + permBits (fileMode st) `shouldBe` 0o700 + else pure () + + it "leaves an existing wide parent directory untouched and WARNs" $ + if not isUnix + then pendingWith "POSIX-only semantics" + else withSystemTempDirectory "synapse-self5" $ \tmp -> + withHome tmp $ do + let dir = tmp ".plexus" T.unpack testBackend + createDirectoryIfMissing True dir + setFileMode dir 0o755 -- intentionally wide + (_, err) <- captureStderrInto tmp $ writeDefaults testBackend emptyStoredDefaults + st <- getFileStatus dir + -- Mode untouched. + permBits (fileMode st) `shouldBe` 0o755 + -- WARN emitted. + err `shouldSatisfy` containsSubstring "[WARN]" + err `shouldSatisfy` containsSubstring dir + + -- ======================================================================== + -- writeDefaults: atomicity + -- ======================================================================== + describe "atomicity" $ do + it "leaves no temp file and no partial defaults.json when the write fails" $ + if not isUnix + then pendingWith "needs POSIX mode to stage the failure" + else withSystemTempDirectory "synapse-self5" $ \tmp -> + withHome tmp $ do + let dir = tmp ".plexus" T.unpack testBackend + tmpFile = dir ".defaults.json.tmp" + path = dir "defaults.json" + createDirectoryIfMissing True dir + -- Make the parent dir read-only so writeFile to the tmp + -- path fails. Restore 0700 in the cleanup so the temp + -- directory teardown itself succeeds. + bracket_ + (setFileMode dir 0o500) + (setFileMode dir 0o700) + $ do + let sd = emptyStoredDefaults + { sdCookies = Map.fromList + [ ("t", CredentialRef "literal:foo") ] + } + r <- try (writeDefaults testBackend sd) + :: IO (Either E.SomeException ()) + case r of + Left _ -> pure () -- expected: write failed + Right _ -> expectationFailure + "writeDefaults should have failed on a read-only parent dir" + -- Neither artifact should exist after the failure. + doesFileExist tmpFile `shouldReturn` False + doesFileExist path `shouldReturn` False + + it "rename is atomic: final file appears only after a complete write" $ + withSystemTempDirectory "synapse-self5" $ \tmp -> + withHome tmp $ do + let sd = emptyStoredDefaults + { sdCookies = Map.fromList + [ ("t", CredentialRef "literal:value") ] + } + dir = tmp ".plexus" T.unpack testBackend + tmpFile = dir ".defaults.json.tmp" + path = dir "defaults.json" + writeDefaults testBackend sd + -- After a successful write, the temp file is gone and the + -- final file exists. + doesFileExist tmpFile `shouldReturn` False + doesFileExist path `shouldReturn` True + + -- ======================================================================== + -- loadDefaults: permission sniffing + -- ======================================================================== + describe "loadDefaults permission sniffing" $ do + it "WARNs on world-readable file with literal: content" $ + if not isUnix + then pendingWith "POSIX-only semantics" + else withSystemTempDirectory "synapse-self5" $ \tmp -> + withHome tmp $ do + let sd = emptyStoredDefaults + { sdCookies = Map.fromList + [ ("t", CredentialRef "literal:oops-wide-open") ] + } + path = tmp ".plexus" T.unpack testBackend "defaults.json" + writeDefaults testBackend sd + -- Intentionally loosen the file to simulate a user who + -- chmod-ed it by hand. + setFileMode path 0o644 + (loaded, err) <- captureStderrInto tmp $ loadDefaults testBackend + loaded `shouldBe` sd + err `shouldSatisfy` containsSubstring "[WARN]" + err `shouldSatisfy` containsSubstring path + err `shouldSatisfy` containsSubstring "chmod 600" + + it "does NOT WARN on world-readable file with only non-literal refs" $ + if not isUnix + then pendingWith "POSIX-only semantics" + else withSystemTempDirectory "synapse-self5" $ \tmp -> + withHome tmp $ do + let sd = emptyStoredDefaults + { sdCookies = Map.fromList + [ ("t", CredentialRef "keychain://svc/token") ] + , sdHeaders = Map.fromList + [ ("X", CredentialRef "env://API_KEY") ] + } + path = tmp ".plexus" T.unpack testBackend "defaults.json" + writeDefaults testBackend sd + setFileMode path 0o644 -- wide, but file is manifest-only + (loaded, err) <- captureStderrInto tmp $ loadDefaults testBackend + loaded `shouldBe` sd + err `shouldNotSatisfy` containsSubstring "[WARN]" + + it "does NOT WARN on a tight (0600) file with literal: content" $ + if not isUnix + then pendingWith "POSIX-only semantics" + else withSystemTempDirectory "synapse-self5" $ \tmp -> + withHome tmp $ do + let sd = emptyStoredDefaults + { sdCookies = Map.fromList + [ ("t", CredentialRef "literal:tight-and-tidy") ] + } + writeDefaults testBackend sd + -- writeDefaults already set 0600 on this file. + (loaded, err) <- captureStderrInto tmp $ loadDefaults testBackend + loaded `shouldBe` sd + err `shouldNotSatisfy` containsSubstring "[WARN]" + +-- | True when @needle@ is a substring of @haystack@. +containsSubstring :: String -> String -> Bool +containsSubstring needle haystack = + T.isInfixOf (T.pack needle) (T.pack haystack) diff --git a/test/SelfSpec.hs b/test/SelfSpec.hs new file mode 100644 --- /dev/null +++ b/test/SelfSpec.hs @@ -0,0 +1,629 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Unit tests for Synapse.Self (SELF-1, SELF-2, SELF-7). +-- +-- Covers: +-- - StoredDefaults roundtrip encode/decode with mixed URI schemes +-- - Version mismatch rejection +-- - Unknown top-level field tolerance (forward compatibility) +-- - Missing "defaults" object treated as empty +-- - parseUri shape coverage (literal, env, keychain, file, bare-string reject) +-- - Deterministic key ordering from encodeDefaults +-- - Empty resolver registry returns ResolveUnknownScheme +-- - SELF-7: literalResolver, envResolver, fileResolver, defaultRegistry +-- - SELF-2: loadDefaults / resolveAll / merge +module Main where + +import Control.Exception (bracket, bracket_, finally, try) +import qualified Control.Exception as E +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +import System.Directory + ( createDirectoryIfMissing + , getHomeDirectory + , getTemporaryDirectory + , removeFile + , removePathForcibly + ) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.FilePath (()) +import System.IO (hClose, openTempFile) +import qualified System.IO as IO +import Test.Hspec + +import Synapse.Self +import qualified SelfCommandSpec +import qualified SelfMigrationSpec +import qualified SelfSafeWriteSpec + +main :: IO () +main = hspec $ do + describe "Synapse.Self.Command (SELF-4)" SelfCommandSpec.spec + SelfSafeWriteSpec.spec + SelfMigrationSpec.spec + + describe "defaultsPath" $ do + it "returns ~/.plexus//defaults.json" $ do + defaultsPath "substrate" `shouldBe` "~/.plexus/substrate/defaults.json" + + it "handles backends with dashes" $ do + defaultsPath "my-backend" `shouldBe` "~/.plexus/my-backend/defaults.json" + + describe "parseUri" $ do + it "parses literal: as opaque body" $ do + parseUri (CredentialRef "literal:abc123") `shouldBe` + Right (ParsedUri "literal" (OpaqueBody "abc123")) + + it "preserves colons in opaque bodies (e.g. JWTs)" $ do + parseUri (CredentialRef "literal:eyJhbGciOi.JJWT.sig") `shouldBe` + Right (ParsedUri "literal" (OpaqueBody "eyJhbGciOi.JJWT.sig")) + + it "parses env://VAR" $ do + parseUri (CredentialRef "env://USCIS_API_KEY") `shouldBe` + Right (ParsedUri "env" (HierarchicalBody "USCIS_API_KEY" "" [])) + + it "parses keychain://service/account" $ do + parseUri (CredentialRef "keychain://uscis/access_token") `shouldBe` + Right (ParsedUri "keychain" (HierarchicalBody "uscis" "/access_token" [])) + + it "parses file:///abs/path" $ do + parseUri (CredentialRef "file:///etc/plexus/token") `shouldBe` + Right (ParsedUri "file" (HierarchicalBody "" "/etc/plexus/token" [])) + + it "parses hierarchical URIs with query strings" $ do + parseUri (CredentialRef "env://FOO?fallback=bar&retry=3") `shouldBe` + Right (ParsedUri "env" + (HierarchicalBody "FOO" "" [("fallback", "bar"), ("retry", "3")])) + + it "rejects bare strings with no scheme" $ do + case parseUri (CredentialRef "abc123") of + Left _ -> pure () + Right p -> expectationFailure ("expected Left, got Right " <> show p) + + it "rejects empty scheme" $ do + case parseUri (CredentialRef ":foo") of + Left _ -> pure () + Right p -> expectationFailure ("expected Left, got Right " <> show p) + + describe "encodeDefaults / decodeDefaults" $ do + let mixed = StoredDefaults + { sdVersion = 1 + , sdCookies = Map.fromList + [ ("access_token", CredentialRef "keychain://uscis/access_token") + , ("session", CredentialRef "literal:raw-session-cookie") + ] + , sdHeaders = Map.fromList + [ ("X-Trace-Id", CredentialRef "literal:abc123") + , ("X-API-Key", CredentialRef "env://USCIS_API_KEY") + , ("X-Token", CredentialRef "file:///etc/plexus/token") + ] + , sdScopes = Map.empty + } + + it "roundtrips a file with mixed URI schemes" $ do + let encoded = encodeDefaults mixed + decodeDefaults encoded `shouldBe` Right mixed + + it "produces deterministic output across calls" $ do + encodeDefaults mixed `shouldBe` encodeDefaults mixed + + it "uses two-space indentation" $ do + let encoded = TE.decodeUtf8 (encodeDefaults mixed) + -- Nested fields should be indented with exactly 2 spaces per level. + -- We check that no tab characters appear and that indented lines + -- begin with 2-space multiples. + T.any (== '\t') encoded `shouldBe` False + let firstIndent = dropWhile (/= '\n') (T.unpack encoded) + take 3 (drop 1 firstIndent) `shouldBe` " \"" + + it "orders keys deterministically (ascending)" $ do + let encoded = TE.decodeUtf8 (encodeDefaults mixed) + -- "cookies" should appear before "headers", and within cookies + -- "access_token" before "session". + let cookiesIx = T.breakOn "cookies" encoded + headersIx = T.breakOn "headers" encoded + accessIx = T.breakOn "access_token" encoded + sessionIx = T.breakOn "session" encoded + T.length (fst cookiesIx) `shouldSatisfy` (< T.length (fst headersIx)) + T.length (fst accessIx) `shouldSatisfy` (< T.length (fst sessionIx)) + + it "treats missing defaults object as empty" $ do + let raw = BS8.pack "{\"version\": 1}" + case decodeDefaults raw of + Right sd -> do + sdVersion sd `shouldBe` 1 + sdCookies sd `shouldBe` Map.empty + sdHeaders sd `shouldBe` Map.empty + sdScopes sd `shouldBe` Map.empty + Left err -> expectationFailure ("unexpected error: " <> T.unpack err) + + it "tolerates unknown top-level fields (forward compat)" $ do + let raw = BS8.pack + "{\"version\": 1, \"future_feature\": {\"some\": \"thing\"}, \ + \\"defaults\": {\"cookies\": {\"c\": \"literal:v\"}}}" + case decodeDefaults raw of + Right sd -> + Map.lookup "c" (sdCookies sd) `shouldBe` Just (CredentialRef "literal:v") + Left err -> expectationFailure ("unexpected error: " <> T.unpack err) + + it "tolerates unknown fields inside the defaults object" $ do + let raw = BS8.pack + "{\"version\": 1, \"defaults\": \ + \{\"cookies\": {}, \"headers\": {}, \"bonus\": {}}}" + decodeDefaults raw `shouldSatisfy` isRight + + it "rejects unknown versions with structured message" $ do + let raw = BS8.pack "{\"version\": 2, \"defaults\": {}}" + decodeDefaults raw `shouldBe` Left "unsupported version: 2, expected 1" + + it "rejects version 0 with structured message" $ do + let raw = BS8.pack "{\"version\": 0}" + decodeDefaults raw `shouldBe` Left "unsupported version: 0, expected 1" + + it "decodes scopes even though v1 ignores them semantically" $ do + let raw = BS8.pack + "{\"version\": 1, \"scopes\": {\"cone\": {\"cookies\": {\"x\": \"literal:v\"}}}}" + case decodeDefaults raw of + Right sd -> do + case Map.lookup "cone" (sdScopes sd) of + Just scoped -> + Map.lookup "x" (sdsCookies scoped) `shouldBe` Just (CredentialRef "literal:v") + Nothing -> expectationFailure "expected cone scope" + Left err -> expectationFailure ("unexpected error: " <> T.unpack err) + + describe "ResolverRegistry" $ do + it "mempty returns ResolveUnknownScheme for any scheme" $ do + let reg = mempty :: ResolverRegistry + result <- resolveRef reg (CredentialRef "literal:foo") + result `shouldBe` Left (ResolveUnknownScheme "literal") + + it "mempty reports the correct scheme name on lookup failure" $ do + let reg = mempty :: ResolverRegistry + result <- resolveRef reg (CredentialRef "keychain://svc/account") + result `shouldBe` Left (ResolveUnknownScheme "keychain") + + it "surfaces parse errors via ResolveParseError" $ do + let reg = mempty :: ResolverRegistry + result <- resolveRef reg (CredentialRef "no-scheme-here") + case result of + Left (ResolveParseError _) -> pure () + other -> expectationFailure ("expected ResolveParseError, got " <> show other) + + it "dispatches to a registered resolver" $ do + let reg = registerResolver "literal" + (\p -> pure $ Right $ case puBody p of + OpaqueBody v -> v + _ -> "unexpected-body") + mempty + result <- resolveRef reg (CredentialRef "literal:hello") + result `shouldBe` Right "hello" + + it "later registrations override earlier ones" $ do + let reg = registerResolver "s" (\_ -> pure (Right "second")) + $ registerResolver "s" (\_ -> pure (Right "first")) + mempty + result <- resolveRef reg (CredentialRef "s://anything") + result `shouldBe` Right "second" + + -- ========================================================================== + -- SELF-7: core resolvers + -- ========================================================================== + + describe "literalResolver" $ do + let reg = registerResolver "literal" literalResolver mempty + + it "returns the body verbatim for literal:foo" $ do + result <- resolveRef reg (CredentialRef "literal:foo") + result `shouldBe` Right "foo" + + it "returns empty string for literal: (empty body)" $ do + result <- resolveRef reg (CredentialRef "literal:") + result `shouldBe` Right "" + + it "preserves leading/trailing spaces (literal: foo )" $ do + result <- resolveRef reg (CredentialRef "literal: foo ") + result `shouldBe` Right " foo " + + it "preserves interior colons (JWT-style)" $ do + result <- resolveRef reg (CredentialRef "literal:eyJhbGciOi.JJWT.sig") + result `shouldBe` Right "eyJhbGciOi.JJWT.sig" + + it "rejects hierarchical literal:// as backend error" $ do + result <- resolveRef reg (CredentialRef "literal://foo") + case result of + Left (ResolveBackendError _ _) -> pure () + other -> expectationFailure + ("expected ResolveBackendError, got " <> show other) + + describe "envResolver" $ do + let reg = registerResolver "env" envResolver mempty + testVar = "SYNAPSE_SELF_TEST_VAR_7F3A" + + it "returns the variable value when set" $ + withEnv testVar "hello-env" $ do + result <- resolveRef reg (CredentialRef ("env://" <> T.pack testVar)) + result `shouldBe` Right "hello-env" + + it "preserves whitespace inside variable values" $ + withEnv testVar " spaced " $ do + result <- resolveRef reg (CredentialRef ("env://" <> T.pack testVar)) + result `shouldBe` Right " spaced " + + it "reports ResolveNotFound when the variable is unset" $ + withoutEnv testVar $ do + result <- resolveRef reg (CredentialRef ("env://" <> T.pack testVar)) + result `shouldBe` Left + (ResolveNotFound (CredentialRef ("env://" <> T.pack testVar))) + + it "reports ResolveBackendError for env:// with no variable name" $ do + result <- resolveRef reg (CredentialRef "env://") + case result of + Left (ResolveBackendError _ _) -> pure () + other -> expectationFailure + ("expected ResolveBackendError, got " <> show other) + + it "reports ResolveBackendError for opaque env:VAR" $ do + result <- resolveRef reg (CredentialRef "env:FOO") + case result of + Left (ResolveBackendError _ _) -> pure () + other -> expectationFailure + ("expected ResolveBackendError, got " <> show other) + + describe "fileResolver" $ do + let reg = registerResolver "file" fileResolver mempty + + it "reads file contents and strips a single trailing newline" $ + withTempFileContents "hello\n" $ \path -> do + result <- resolveRef reg + (CredentialRef ("file://" <> T.pack path)) + result `shouldBe` Right "hello" + + it "preserves interior newlines and whitespace" $ + withTempFileContents "a\n b \nc\n" $ \path -> do + result <- resolveRef reg + (CredentialRef ("file://" <> T.pack path)) + result `shouldBe` Right "a\n b \nc" + + it "returns contents verbatim when there is no trailing newline" $ + withTempFileContents "no-newline" $ \path -> do + result <- resolveRef reg + (CredentialRef ("file://" <> T.pack path)) + result `shouldBe` Right "no-newline" + + it "strips only one trailing newline (leaves the rest)" $ + withTempFileContents "two\n\n" $ \path -> do + result <- resolveRef reg + (CredentialRef ("file://" <> T.pack path)) + result `shouldBe` Right "two\n" + + it "returns ResolveNotFound for a missing file" $ do + tmp <- getTemporaryDirectory + let path = tmp "synapse-self-does-not-exist-7f3a" + ref = CredentialRef ("file://" <> T.pack path) + result <- resolveRef reg ref + result `shouldBe` Left (ResolveNotFound ref) + + it "returns ResolveBackendError when the path is a directory" $ do + tmp <- getTemporaryDirectory + result <- resolveRef reg + (CredentialRef ("file://" <> T.pack tmp)) + case result of + Left (ResolveBackendError _ _) -> pure () + other -> expectationFailure + ("expected ResolveBackendError, got " <> show other) + + it "expands ~ to the user's home directory" $ do + home <- getHomeDirectory + -- Write a tmp file directly under $HOME so the ~ expansion test + -- doesn't depend on any specific subdir layout. + let name = ".synapse-self-test-7f3a" + path = home name + bracket_ + (TIO.writeFile path "tilde-ok\n") + (removePathForcibly path) + $ do + result <- resolveRef reg + (CredentialRef (T.pack ("file://~/" <> name))) + result `shouldBe` Right "tilde-ok" + + it "reports ResolveBackendError for opaque file:path" $ do + result <- resolveRef reg (CredentialRef "file:/tmp/x") + case result of + Left (ResolveBackendError _ _) -> pure () + other -> expectationFailure + ("expected ResolveBackendError, got " <> show other) + + describe "defaultRegistry" $ do + it "dispatches literal: via the default registry" $ do + result <- resolveRef defaultRegistry (CredentialRef "literal:abc") + result `shouldBe` Right "abc" + + it "dispatches env:// via the default registry" $ + withEnv "SYNAPSE_SELF_TEST_DEFAULT_REG" "reg-ok" $ do + result <- resolveRef defaultRegistry + (CredentialRef "env://SYNAPSE_SELF_TEST_DEFAULT_REG") + result `shouldBe` Right "reg-ok" + + it "dispatches file:// via the default registry" $ + withTempFileContents "file-ok\n" $ \path -> do + result <- resolveRef defaultRegistry + (CredentialRef ("file://" <> T.pack path)) + result `shouldBe` Right "file-ok" + + it "returns ResolveUnknownScheme for unregistered schemes" $ do + result <- resolveRef defaultRegistry + (CredentialRef "vault://svc/account") + result `shouldBe` Left (ResolveUnknownScheme "vault") + + it "end-to-end: resolves a StoredDefaults with one entry per scheme" $ + withEnv "SYNAPSE_SELF_TEST_E2E_ENV" "from-env" $ + withTempFileContents "from-file\n" $ \path -> do + let sd = StoredDefaults + { sdVersion = 1 + , sdCookies = Map.empty + , sdHeaders = Map.fromList + [ ("X-Literal", CredentialRef "literal:from-literal") + , ("X-Env", CredentialRef "env://SYNAPSE_SELF_TEST_E2E_ENV") + , ("X-File", CredentialRef ("file://" <> T.pack path)) + ] + , sdScopes = Map.empty + } + -- Resolve every header ref end-to-end via defaultRegistry. + resolved <- traverse (resolveRef defaultRegistry) (sdHeaders sd) + Map.lookup "X-Literal" resolved `shouldBe` Just (Right "from-literal") + Map.lookup "X-Env" resolved `shouldBe` Just (Right "from-env") + Map.lookup "X-File" resolved `shouldBe` Just (Right "from-file") + + -- ========================================================================== + -- SELF-2: loadDefaults / resolveAll / merge + -- ========================================================================== + + describe "loadDefaults" $ do + it "returns emptyStoredDefaults when the file is absent" $ + withBackendDefaults "synapse-self-test-missing" Nothing $ \_ -> do + sd <- loadDefaults "synapse-self-test-missing" + sd `shouldBe` emptyStoredDefaults + + it "reads and decodes a well-formed defaults.json" $ do + let sd = StoredDefaults + { sdVersion = 1 + , sdCookies = Map.fromList + [ ("access_token", CredentialRef "literal:jwt-abc") ] + , sdHeaders = Map.fromList + [ ("X-Trace-Id", CredentialRef "literal:trace-123") ] + , sdScopes = Map.empty + } + withBackendDefaults "synapse-self-test-ok" (Just (encodeDefaults sd)) + $ \_ -> do + loaded <- loadDefaults "synapse-self-test-ok" + loaded `shouldBe` sd + + it "raises an IOError naming the file path on malformed JSON" $ do + withBackendDefaults "synapse-self-test-bad" (Just "not json at all") + $ \path -> do + result <- try (loadDefaults "synapse-self-test-bad") + :: IO (Either IOError StoredDefaults) + case result of + Left ioErr -> do + let msg = show ioErr + msg `shouldSatisfy` containsSubstring path + -- A decoder message should appear somewhere — either the + -- aeson error text or our own "failed to parse" prefix. + msg `shouldSatisfy` containsSubstring "parse" + Right sd -> + expectationFailure + ("expected IOError, got successful parse: " <> show sd) + + it "raises an IOError on unknown version" $ do + let badVersion = BS8.pack "{\"version\": 99, \"defaults\": {}}" + withBackendDefaults "synapse-self-test-ver" (Just badVersion) $ \_ -> do + result <- try (loadDefaults "synapse-self-test-ver") + :: IO (Either IOError StoredDefaults) + case result of + Left ioErr -> + show ioErr `shouldSatisfy` containsSubstring "unsupported version" + Right sd -> + expectationFailure + ("expected IOError, got: " <> show sd) + + describe "resolveAll" $ do + let testMethod = ["foo", "bar"] :: MethodPath + + it "returns empty resolved defaults for empty stored defaults" $ do + r <- resolveAll defaultRegistry emptyStoredDefaults testMethod + r `shouldBe` Right emptyResolvedDefaults + + it "resolves literal-only cookies and headers end-to-end" $ do + let sd = StoredDefaults + { sdVersion = 1 + , sdCookies = Map.fromList + [ ("access_token", CredentialRef "literal:abc") + , ("session", CredentialRef "literal:xyz") + ] + , sdHeaders = Map.fromList + [ ("X-Trace", CredentialRef "literal:t-1") ] + , sdScopes = Map.empty + } + r <- resolveAll defaultRegistry sd testMethod + case r of + Right rd -> do + rdCookies rd `shouldBe` Map.fromList + [("access_token", "abc"), ("session", "xyz")] + rdHeaders rd `shouldBe` Map.fromList [("X-Trace", "t-1")] + Left err -> expectationFailure ("expected Right, got " <> show err) + + it "short-circuits on the first unknown scheme" $ do + -- Use 'vault' — not registered in defaultRegistry (reserved for + -- a future resolver). The test asserts that resolveAll bails on + -- the first unknown scheme and does not attempt subsequent refs. + let sd = StoredDefaults + { sdVersion = 1 + , sdCookies = Map.fromList + [ ("access_token", CredentialRef "vault://svc/token") + , ("session", CredentialRef "literal:should-not-leak") + ] + , sdHeaders = Map.empty + , sdScopes = Map.empty + } + r <- resolveAll defaultRegistry sd testMethod + r `shouldBe` Left (ResolveUnknownScheme "vault") + + it "reports ResolveNotFound for env:// with an unset variable" $ + withoutEnv "SYNAPSE_SELF_TEST_MISSING_VAR_2B" $ do + let ref = CredentialRef "env://SYNAPSE_SELF_TEST_MISSING_VAR_2B" + sd = StoredDefaults + { sdVersion = 1 + , sdCookies = Map.empty + , sdHeaders = Map.fromList [("X-K", ref)] + , sdScopes = Map.empty + } + r <- resolveAll defaultRegistry sd testMethod + case r of + Left (ResolveNotFound (CredentialRef uri)) -> + uri `shouldSatisfy` T.isInfixOf "SYNAPSE_SELF_TEST_MISSING_VAR_2B" + other -> + expectationFailure ("expected ResolveNotFound, got " <> show other) + + it "does not partial-resolve: failure in cookies discards header refs" $ + withoutEnv "SYNAPSE_SELF_TEST_MISSING_VAR_2C" $ do + let sd = StoredDefaults + { sdVersion = 1 + , sdCookies = Map.fromList + [ ("c", CredentialRef "env://SYNAPSE_SELF_TEST_MISSING_VAR_2C") ] + , sdHeaders = Map.fromList + [ ("H", CredentialRef "literal:header-value") ] + , sdScopes = Map.empty + } + r <- resolveAll defaultRegistry sd testMethod + case r of + Left _ -> pure () + Right v -> expectationFailure + ("expected Left, got Right " <> show v) + + it "threads MethodPath (v1 ignores it; any path resolves equivalently)" $ do + let sd = StoredDefaults + { sdVersion = 1 + , sdCookies = Map.fromList [("k", CredentialRef "literal:v")] + , sdHeaders = Map.empty + , sdScopes = Map.empty + } + r1 <- resolveAll defaultRegistry sd [] + r2 <- resolveAll defaultRegistry sd ["some", "method"] + r1 `shouldBe` r2 + + describe "merge" $ do + it "is identity when CLI maps are empty" $ do + let rd = ResolvedDefaults + { rdCookies = Map.fromList [("a", "1"), ("b", "2")] + , rdHeaders = Map.fromList [("X", "x")] + } + merge rd Map.empty Map.empty `shouldBe` + (rdCookies rd, rdHeaders rd) + + it "passes CLI values through when defaults are empty" $ do + let cliC = Map.fromList [("c", "v")] + cliH = Map.fromList [("H", "hv")] + merge emptyResolvedDefaults cliC cliH `shouldBe` (cliC, cliH) + + it "gives CLI priority over stored defaults on per-key conflict" $ do + let rd = ResolvedDefaults + { rdCookies = Map.fromList + [ ("access_token", "from-stored") + , ("other", "stored-only") + ] + , rdHeaders = Map.fromList [("X-Trace", "stored-trace")] + } + cliC = Map.fromList [("access_token", "from-cli")] + cliH = Map.fromList [("X-Trace", "cli-trace")] + (mergedC, mergedH) = merge rd cliC cliH + Map.lookup "access_token" mergedC `shouldBe` Just "from-cli" + Map.lookup "other" mergedC `shouldBe` Just "stored-only" + Map.lookup "X-Trace" mergedH `shouldBe` Just "cli-trace" + + it "unions disjoint key sets without loss" $ do + let rd = ResolvedDefaults + { rdCookies = Map.fromList [("a", "1")] + , rdHeaders = Map.fromList [("X", "x")] + } + cliC = Map.fromList [("b", "2")] + cliH = Map.fromList [("Y", "y")] + (mergedC, mergedH) = merge rd cliC cliH + mergedC `shouldBe` Map.fromList [("a", "1"), ("b", "2")] + mergedH `shouldBe` Map.fromList [("X", "x"), ("Y", "y")] + +-- | Set an env var for the duration of an action, restoring any prior +-- value (or unsetting if it was unset). +withEnv :: String -> String -> IO a -> IO a +withEnv name value action = do + prior <- lookupEnv name + bracket_ + (setEnv name value) + (case prior of + Just v -> setEnv name v + Nothing -> unsetEnv name) + action + +-- | Ensure an env var is unset for the duration of an action, restoring +-- it afterwards. +withoutEnv :: String -> IO a -> IO a +withoutEnv name action = do + prior <- lookupEnv name + bracket_ + (unsetEnv name) + (case prior of + Just v -> setEnv name v + Nothing -> pure ()) + action + +-- | Write @contents@ to a fresh temp file, pass its path to @action@, +-- and unlink the file on the way out. +withTempFileContents :: Text -> (FilePath -> IO a) -> IO a +withTempFileContents contents action = do + tmpDir <- getTemporaryDirectory + bracket + (openTempFile tmpDir "synapse-self-test.txt") + (\(path, h) -> hClose h `finally` removeFile path) + (\(path, h) -> do + IO.hSetEncoding h IO.utf8 + TIO.hPutStr h contents + hClose h + action path) + +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _ = False + +-- | True when the 'show'n error message contains the given substring. +containsSubstring :: String -> String -> Bool +containsSubstring needle = T.isInfixOf (T.pack needle) . T.pack + +-- | Stage @~\/.plexus\/\\/defaults.json@ with the given bytes +-- (or clear it) for the duration of the action, then restore. +-- +-- We write a unique-per-test backend subdir so parallel tests don't +-- collide and so we never perturb a real backend's defaults. The action +-- receives the absolute file path so it can assert against it. +withBackendDefaults :: String -> Maybe BS.ByteString -> (String -> IO a) -> IO a +withBackendDefaults backend mBytes action = do + home <- getHomeDirectory + let dir = home ".plexus" backend + path = dir "defaults.json" + createDirectoryIfMissing True dir + -- Snapshot prior state so we can restore it. + priorExists <- E.try (BS.readFile path) :: IO (Either E.IOException BS.ByteString) + -- Clear any existing file first, then install the test bytes (if any). + E.handle (\(_ :: E.IOException) -> pure ()) (removeFile path) + case mBytes of + Nothing -> pure () + Just bytes -> BS.writeFile path bytes + finally + (action path) + (do E.handle (\(_ :: E.IOException) -> pure ()) (removeFile path) + case priorExists of + Right bs -> BS.writeFile path bs + Left _ -> pure ()) diff --git a/test/SourceSpec.hs b/test/SourceSpec.hs new file mode 100644 --- /dev/null +++ b/test/SourceSpec.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | SYNAPSE-10: a parameter's value from a file or stdin. +module Main (main) where + +import Data.IORef (newIORef, readIORef, writeIORef) +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import System.Directory (getTemporaryDirectory, removeDirectoryRecursive, createDirectoryIfMissing) +import System.FilePath (()) +import Test.Hspec + +import Synapse.CLI.Source + +-- | An environment over a scratch directory, with stdin handed in and +-- counted, so a test can say what stdin holds and how often it was read. +withEnv :: BS.ByteString -> (SourceEnv -> FilePath -> IO Int -> IO a) -> IO a +withEnv stdinBytes body = do + tmp <- getTemporaryDirectory + let dir = tmp "synapse-source-spec" + createDirectoryIfMissing True dir + reads' <- newIORef (0 :: Int) + cache <- newIORef Nothing + let env = SourceEnv + { seCwd = dir + , seHome = Just (dir "home") + , seStdin = do n <- readIORef reads'; writeIORef reads' (n + 1); pure stdinBytes + , seCache = cache + } + createDirectoryIfMissing True (dir "home") + r <- body env dir (readIORef reads') + removeDirectoryRecursive dir + pure r + +main :: IO () +main = hspec $ describe "a value from a file or stdin (SYNAPSE-10)" $ do + it "reads @file as the file's contents, as they are" $ withEnv "" $ \env dir _ -> do + BS.writeFile (dir "body.md") "---\ntitle: x\n---\n\ncosts $HOME, keeps the final newline\n" + r <- expandSources env [("body", "@body.md"), ("title", "plain")] + r `shouldBe` Right [("body", "---\ntitle: x\n---\n\ncosts $HOME, keeps the final newline\n"), ("title", "plain")] + + it "round-trips a 1 MB body" $ withEnv "" $ \env dir _ -> do + let big = T.replicate (1024 * 1024 `div` 16) "0123456789abcdef" + BS.writeFile (dir "big.md") (TE.encodeUtf8 big) + r <- expandValue env "body" "@big.md" + fmap T.length r `shouldBe` Right (1024 * 1024) + r `shouldBe` Right big + + it "resolves ~/ against home and an absolute path as itself" $ withEnv "" $ \env dir _ -> do + BS.writeFile (dir "home" "h.txt") "from home" + BS.writeFile (dir "abs.txt") "absolute" + expandValue env "a" "@~/h.txt" >>= (`shouldBe` Right "from home") + expandValue env "b" (T.pack ("@" <> dir "abs.txt")) >>= (`shouldBe` Right "absolute") + + it "reads - from stdin, once, however many values ask" $ withEnv "piped in" $ \env _ reads' -> do + r <- expandSources env [("body", "-"), ("note", "-")] + r `shouldBe` Right [("body", "piped in"), ("note", "piped in")] + reads' >>= (`shouldBe` 1) + stdinWasRead env >>= (`shouldBe` True) + + it "has not read stdin when no value asked" $ withEnv "piped in" $ \env _ reads' -> do + _ <- expandSources env [("body", "text")] + reads' >>= (`shouldBe` 0) + stdinWasRead env >>= (`shouldBe` False) + + it "sends @@x as the literal @x" $ withEnv "" $ \env _ _ -> do + expandValue env "handle" "@@alice" >>= (`shouldBe` Right "@alice") + expandValue env "handle" "@@@" >>= (`shouldBe` Right "@@") + + it "leaves a lone @ and every other value alone" $ withEnv "" $ \env _ _ -> do + expandValue env "x" "@" >>= (`shouldBe` Right "@") + expandValue env "x" "a@b" >>= (`shouldBe` Right "a@b") + expandValue env "x" "--dashes" >>= (`shouldBe` Right "--dashes") + expandValue env "x" "" >>= (`shouldBe` Right "") + + it "refuses a file it cannot read, naming the flag, the path and the escape" $ withEnv "" $ \env _ _ -> do + r <- expandValue env "blocked_by" "@nope.md" + case r of + Left e -> do + seKey e `shouldBe` "blocked_by" + seSource e `shouldBe` "@nope.md" + let msg = renderSourceError e + msg `shouldSatisfy` T.isPrefixOf "--blocked-by @nope.md: cannot read nope.md" + msg `shouldSatisfy` T.isInfixOf "write @@nope.md" + Right v -> expectationFailure ("read " <> show v) + + it "names -p when the params object is the source" $ withEnv "" $ \env _ _ -> do + r <- expandValue env "" "@params.json" + fmap renderSourceError (either Just (const Nothing) r) `shouldSatisfy` maybe False (T.isPrefixOf "-p @params.json: cannot read params.json") + + it "stops at the first unreadable source" $ withEnv "" $ \env dir _ -> do + BS.writeFile (dir "ok.md") "ok" + r <- expandSources env [("a", "@ok.md"), ("b", "@missing"), ("c", "@missing2")] + either seSource (const "read everything") r `shouldBe` "@missing" diff --git a/test/TlsSpec.hs b/test/TlsSpec.hs new file mode 100644 --- /dev/null +++ b/test/TlsSpec.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} + +-- | 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 — +-- 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, +-- refused at the handshake before a byte of the request is sent. +module Main (main) where + +import Control.Concurrent (forkIO, killThread) +import Control.Exception (SomeException, bracket, finally, try) +import Control.Monad (forever, void) +import Data.Aeson (Value(..), decodeStrict, object) +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import Data.IORef +import qualified Data.Text as T +import qualified Network.Socket as N +import qualified Network.Socket.ByteString as NB +import qualified Network.TLS as TLS +import System.Directory (findExecutable) +import System.Exit (ExitCode(..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (readProcessWithExitCode) +import Test.Hspec + +import qualified Katip +import MockHub (todaysHub, withMockHub) +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.Transport (invoke, invokeStreamingWithBidir) +import Synapse.Reconnect (CallShape(..)) +import Plexus.Types (Response(..)) + +main :: IO () +main = do + openssl <- findExecutable "openssl" + hspec $ case openssl of + Nothing -> it "needs openssl to make a CA for the run" $ pendingWith "no openssl on PATH" + Just _ -> around withPki specs + +-- | The run's PKI: a CA, and a certificate for @localhost@ it signed. +data Pki = Pki { pkiCa :: FilePath, pkiCert :: FilePath, pkiKey :: FilePath, pkiOtherCa :: FilePath } + +withPki :: (Pki -> IO ()) -> IO () +withPki act = withSystemTempDirectory "synapse-tls" $ \dir -> do + let f = (dir ) + run args = do + (code, _, err) <- readProcessWithExitCode "openssl" args "" + case code of + ExitSuccess -> pure () + _ -> fail ("openssl " <> unwords args <> ": " <> err) + ca name = run ["req", "-x509", "-newkey", "rsa:2048", "-nodes", "-days", "1" + , "-keyout", f (name <> ".key"), "-out", f (name <> ".pem") + , "-subj", "/CN=" <> name + , "-addext", "basicConstraints=critical,CA:TRUE" + , "-addext", "keyUsage=critical,keyCertSign,cRLSign" ] + ca "synapse-test-ca" + ca "another-ca" + writeFile (f "ext.cnf") "subjectAltName=DNS:localhost\nbasicConstraints=CA:FALSE\nextendedKeyUsage=serverAuth\nkeyUsage=digitalSignature,keyEncipherment\n" + run ["req", "-newkey", "rsa:2048", "-nodes", "-keyout", f "srv.key", "-out", f "srv.csr", "-subj", "/CN=localhost"] + run ["x509", "-req", "-in", f "srv.csr", "-CA", f "synapse-test-ca.pem", "-CAkey", f "synapse-test-ca.key" + , "-CAcreateserial", "-days", "1", "-out", f "srv.pem", "-extfile", f "ext.cnf"] + act (Pki (f "synapse-test-ca.pem") (f "srv.pem") (f "srv.key") (f "another-ca.pem")) + +-- | What the terminator saw: each connection's request head (the bytes +-- before the first blank line), once its handshake completed. +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. +withTerminator :: Pki -> Int -> (Int -> Heads -> IO a) -> IO a +withTerminator pki backend act = do + cred <- TLS.credentialLoadX509 (pkiCert pki) (pkiKey pki) >>= either fail pure + heads <- newIORef [] + let params = TLS.defaultParamsServer + { TLS.serverShared = (TLS.serverShared TLS.defaultParamsServer) + { TLS.sharedCredentials = TLS.Credentials [cred] } } + 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 + tid <- forkIO (forever (N.accept sock >>= void . forkIO . serve params heads . fst)) + pure (sock, tid, port) + close (sock, tid, _) = killThread tid >> N.close sock + bracket open close (\(_, _, port) -> act port heads) + where + serve params heads conn = flip finally (N.close conn) $ void $ try @SomeException $ do + ctx <- TLS.contextNew conn params + TLS.handshake ctx + up <- N.socket N.AF_INET N.Stream N.defaultProtocol + flip finally (N.close up) $ do + N.connect up (N.SockAddrInet (fromIntegral backend) (N.tupleToHostAddress (127, 0, 0, 1))) + 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) + t <- forkIO (void (try @SomeException down) >> TLS.bye ctx) + flip finally (killThread t) $ forever $ do + b <- TLS.recvData ctx + if BS.null b then fail "client closed" else do + first <- atomicModifyIORef' seen (\s -> (True, not s)) + if first then modifyIORef' heads (++ [fst (BS.breakSubstring "\r\n\r\n" b)]) else pure () + NB.sendAll up b + +logger :: IO Log.Logger +logger = Log.makeLogger Katip.ErrorS + +specs :: SpecWith Pki +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 + let ep = Endpoint "localhost" port True "/ws" [pkiCa pki] + probeBackendAtEp [] ep `shouldReturn` Right "menger" + hs <- readIORef heads + h <- case hs of + (h : _) -> pure h + [] -> expectationFailure "the terminator saw no request" >> pure "" + BS8.unpack h `shouldStartWith` "GET /ws HTTP/1.1" + 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 + 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")] + `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 + lg <- logger + let ep = Endpoint "localhost" port True "/ws" [pkiCa pki] + seed = either (error . T.unpack) id (Proof.seedFromBytes (BS.pack [1 .. 32])) + r <- Session.loginWithKey lg ep "menger" seed "worker-1" [] Nothing + fmap Session.lrToken r `shouldBe` Right "mgs_agent_session" + hs <- readIORef heads + let proofs = [ p | h <- hs, l <- BS8.lines h + , Just rest <- [BS.stripPrefix "Authorization: Bearer plexus-key." l] + , Just p <- [decodeProof (BS8.takeWhile (/= '\r') rest)] ] + proofs `shouldSatisfy` (not . null) + 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 + lg <- logger + env <- initEnvAt (Endpoint "localhost" port True "/ws" [pkiCa pki]) "menger" lg Nothing + seen <- newIORef [] + asked <- newIORef [] + r <- runSynapseM env $ invokeStreamingWithBidir + (CallShape { csStream = False, csRead = False, csSince = False }) + (pure Nothing) (const (pure ())) ["tickets"] "ask" (object []) + (\i -> modifyIORef' seen (++ [i])) + (\rid _ -> modifyIORef' asked (++ [rid]) >> pure (Just (Confirmed True :: Response Value))) + 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")] + `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 + length (filter (BS.isPrefixOf "GET /ws HTTP/1.1") hs) `shouldSatisfy` (>= 2) + + 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 + 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 + 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 + r <- probeBackendAtEp [] (Endpoint "localhost" port True "/ws" [pkiKey pki]) + either T.unpack (const "") r `shouldContain` "holds no PEM certificate" + +-- | A key proof's JSON (@plexus-key.@ without its prefix). +decodeProof :: BS.ByteString -> Maybe (KM.KeyMap Value) +decodeProof b64 = case B64U.decodeUnpadded b64 of + Right json | Just (Object o) <- decodeStrict json -> Just o + _ -> Nothing