{-# LANGUAGE ApplicativeDo #-}
-- | Synapse CLI - Algebraic Implementation
--
-- This executable uses the categorical machinery:
-- - Effect stack (SynapseM) with caching and cycle detection
-- - Reified algebras for navigation, rendering, completion
-- - Proper error handling
--
-- Compare with Main.hs which takes pragmatic shortcuts.
module Main where
import Control.Monad.IO.Class (liftIO)
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.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 System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStrLn, stderr, hFlush, stdout)
import Plexus (PlexusStreamItem(..))
import Synapse.Schema.Types
import Synapse.Monad
import Synapse.Algebra.Navigate
import Synapse.Algebra.Render (renderSchema, renderMethodFull)
import Synapse.Algebra.TemplateGen (GeneratedTemplate(..), generateAllTemplatesWithCallback)
import Synapse.Transport
import Synapse.Renderer (RendererConfig, defaultRendererConfig, renderItem, prettyValue)
import System.Directory (createDirectoryIfMissing)
-- ============================================================================
-- Types
-- ============================================================================
data Args = Args
{ argHost :: Text
, argPort :: Int
, argJson :: Bool -- ^ Output raw JSON stream items
, argRaw :: Bool -- ^ Output raw content (no templates)
, argDryRun :: Bool
, argSchema :: Bool -- ^ Show raw schema JSON
, argGenerate :: Bool -- ^ Generate templates from schemas
, argParams :: Maybe Text -- ^ JSON params via -p
, argRpc :: Maybe Text -- ^ Raw JSON-RPC passthrough
, argPath :: [Text] -- ^ Path segments and --key value params
}
deriving Show
-- ============================================================================
-- Main
-- ============================================================================
main :: IO ()
main = do
args <- execParser argsInfo
env <- initEnv (argHost args) (argPort args)
rendererCfg <- defaultRendererConfig
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{..} rendererCfg = do
-- Mode 1: Raw JSON-RPC passthrough
case argRpc 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 argJson argRaw rendererCfg) items
return ()
Nothing -> do
-- Parse path and inline params (--key value pairs)
let (pathSegs, inlineParams) = parsePathAndParams argPath
-- Mode 2: Schema request
if argSchema
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
else if argGenerate
then do
let baseDir = ".substrate/templates"
writeAndLog gt = do
writeGeneratedTemplate baseDir gt
TIO.putStrLn $ " " <> T.pack (gtPath gt)
liftIO $ TIO.putStrLn $ "Generating templates in " <> T.pack baseDir <> "..."
count <- generateAllTemplatesWithCallback writeAndLog pathSegs
liftIO $ TIO.putStrLn $ "Generated " <> T.pack (show count) <> " templates"
else do
-- Mode 4: 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
-- Build params: start with schema defaults, then merge user params
-- Schema defaults are extracted from methodParams JSON Schema
let schemaDefaults = extractSchemaDefaults method
userParams <- case argParams of
Just jsonStr ->
case eitherDecode (LBS.fromStrict $ TE.encodeUtf8 jsonStr) of
Left err -> throwParse $ T.pack err
Right p -> pure p
Nothing
| not (null inlineParams) -> pure $ buildParamsObject inlineParams
| otherwise -> pure $ object []
-- Merge: user params override schema defaults
let params = mergeParams schemaDefaults userParams
if argDryRun
then liftIO $ LBS.putStrLn $ encodeDryRun (init path) (last path) params
else if hasRequiredParams method && params == object [] && null inlineParams
then liftIO $ TIO.putStrLn $ renderMethodFull method
else invokeMethod path params
where
invokeMethod path params = do
let namespacePath = init path -- path without method name
let methodName' = last path
invokeStreaming namespacePath methodName' params (printResult argJson argRaw rendererCfg)
-- 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 [PlexusStreamItem]
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)
-- Example: ["echo", "once", "--message", "hello", "--count", "3"]
-- -> (["echo", "once"], [("message", "hello"), ("count", "3")])
parsePathAndParams :: [Text] -> ([Text], [(Text, Text)])
parsePathAndParams = go [] []
where
go path params [] = (reverse path, reverse params)
go path params (x:xs)
-- --key value pair
| Just key <- T.stripPrefix "--" x
, not (T.null key)
, (val:rest) <- xs =
go path ((key, val) : params) rest
-- --key with no value (skip malformed)
| T.isPrefixOf "--" x =
go path params xs
-- Regular path segment
| otherwise =
go (x : path) params 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")
where
failure = parserFailure defaultPrefs argsInfo (ShowHelpText Nothing) mempty
-- | Render an error for display
renderError :: SynapseError -> String
renderError = \case
NavError (NotFound seg path) ->
"Not found: '" <> T.unpack seg <> "' at " <> showPath path
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
ParseError msg ->
"Parse error: " <> T.unpack msg
ValidationError msg ->
"Validation error: " <> T.unpack msg
where
showPath [] = "root"
showPath p = T.unpack $ T.intercalate "." p
-- | Write a generated template to disk (no logging)
writeGeneratedTemplate :: FilePath -> GeneratedTemplate -> IO ()
writeGeneratedTemplate baseDir gt = do
let fullPath = baseDir </> gtPath gt
createDirectoryIfMissing True (baseDir </> T.unpack (gtNamespace gt))
TIO.writeFile fullPath (gtTemplate gt)
where
(</>) = \a b -> a ++ "/" ++ b
-- | Encode a dry-run request
encodeDryRun :: [Text] -> Text -> Value -> LBS.ByteString
encodeDryRun namespacePath method params =
let fullPath = if null namespacePath then ["plexus"] else namespacePath
dotPath = T.intercalate "." (fullPath ++ [method])
in encode $ object
[ "jsonrpc" .= ("2.0" :: Text)
, "id" .= (1 :: Int)
, "method" .= ("plexus_call" :: Text)
, "params" .= object
[ "method" .= dotPath
, "params" .= params
]
]
-- | Print a stream result
-- argJson: output raw JSON stream items
-- argRaw: skip template rendering, just output content JSON
-- otherwise: try template rendering, fall back to content JSON
printResult :: Bool -> Bool -> RendererConfig -> PlexusStreamItem -> IO ()
printResult True _ _ item = LBS.putStrLn $ encode item
printResult _ True _ item = case item of
-- Raw mode: just output the content
StreamData _ _ _ dat -> do
LBS.putStrLn $ encode dat
hFlush stdout
StreamProgress _ _ msg _ -> do
TIO.putStr msg
TIO.putStr "\r"
hFlush stdout
StreamError _ _ 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 -> do
TIO.putStrLn text
hFlush stdout
Nothing -> case item of
-- Fallback to pretty-printed content
StreamData _ _ _ dat -> do
TIO.putStrLn $ prettyValue dat
hFlush stdout
StreamProgress _ _ msg _ -> do
TIO.putStr msg
TIO.putStr "\r"
hFlush stdout
StreamError _ _ err _ ->
hPutStrLn stderr $ "Error: " <> T.unpack err
_ -> pure ()
-- ============================================================================
-- Argument Parsing
-- ============================================================================
argsInfo :: ParserInfo Args
argsInfo = info (argsParser <**> helper)
( fullDesc
<> header "synapse - Algebraic CLI for Plexus"
<> progDesc "Navigate and invoke methods via coalgebraic schema traversal"
<> forwardOptions -- Pass unrecognized --flags to positional args
)
argsParser :: Parser Args
argsParser = do
argHost <- T.pack <$> strOption
( long "host" <> short 'H' <> metavar "HOST"
<> value "127.0.0.1" <> showDefault
<> help "Plexus server host" )
argPort <- option auto
( long "port" <> short 'P' <> metavar "PORT"
<> value 4444 <> showDefault
<> help "Plexus server port" )
argJson <- switch
( long "json" <> short 'j'
<> help "Output raw JSON stream items" )
argRaw <- switch
( long "raw"
<> help "Output raw content JSON (skip templates)" )
argDryRun <- switch
( long "dry-run" <> short 'n'
<> help "Show JSON-RPC request without sending" )
argSchema <- switch
( long "schema" <> short 's'
<> help "Fetch raw schema JSON for path" )
argGenerate <- switch
( long "generate-templates" <> short 'g'
<> help "Generate mustache templates from schemas" )
argParams <- optional $ T.pack <$> strOption
( long "params" <> short 'p' <> metavar "JSON"
<> help "Method parameters as JSON object" )
argRpc <- optional $ T.pack <$> strOption
( long "rpc" <> short 'r' <> metavar "JSON"
<> help "Raw JSON-RPC request (bypass navigation)" )
argPath <- many $ T.pack <$> argument str
( metavar "PATH... [--key value ...]"
<> help "Path to plugin/method, with optional --key value params" )
pure Args{..}