Main.hs (55165B)
1 module Main where 2 3 import ContentStore 4 import ContentStore.Executable hiding (loadExecutableObject) 5 import qualified Package 6 import qualified Module.Provenance as Provenance 7 import qualified Module.Inspection as Inspection 8 import qualified InteractionInspection as Interaction 9 import qualified Project 10 import ContentStore.Bundle 11 import Module.Manifest 12 import System.IO.Error (ioeGetErrorString) 13 import System.Exit (die, exitFailure) 14 import IODriver (runIO) 15 import REPL (portableRepl) 16 import PortableCompiler 17 import Runtime (T(..), EvaluatedForm(..), formatT, exportDag, apply, ofString, toString) 18 import qualified Wire 19 import Wire (encodeBundle, buildBundleShared, defaultExportNames, Bundle(..)) 20 import TreeObservation (forceTreeShared) 21 22 import Control.Monad (forM, forM_, unless, when) 23 import Control.Exception (IOException, bracketOnError, catch, evaluate) 24 import Data.Char (isAlphaNum) 25 import Data.List (sortOn) 26 import qualified Data.Text as T 27 import qualified Data.Text.Encoding as TE 28 import Data.Version (showVersion) 29 import Paths_tricu (version) 30 import Crypto.Hash (hash, Digest, SHA256) 31 import System.IO.Temp (withSystemTempDirectory, withTempFile) 32 import Options.Applicative 33 34 import qualified Data.ByteString as BS 35 import qualified Data.ByteString.Lazy as BL 36 import qualified Data.Sequence as Seq 37 import qualified Data.Map as Map 38 import System.Directory (createDirectoryIfMissing, getCurrentDirectory, 39 renameFile, removeFile, pathIsSymbolicLink, doesPathExist, doesFileExist, canonicalizePath) 40 import System.FilePath (takeBaseName, takeDirectory, (</>)) 41 import System.Timeout (timeout) 42 import System.IO (openBinaryTempFile, hClose, hFlush, hPutStrLn, stdout, stderr, withBinaryFile, IOMode(ReadMode)) 43 import qualified Data.Aeson as JSON 44 import GHC.Clock (getMonotonicTimeNSec) 45 import GHC.Stats 46 import System.Mem (performGC) 47 import System.Posix.Files (fileMode, getFileStatus, setFileMode, isRegularFile) 48 49 -- --------------------------------------------------------------------------- 50 -- CLI argument types 51 -- --------------------------------------------------------------------------- 52 53 data AppArgs = AppArgs 54 { globalStore :: Maybe FilePath 55 , appCommand :: TricuArgs 56 } deriving (Show) 57 58 -- Argument spelling chooses transport only; every decoded value is a T. 59 data StoredArgument 60 = StringArgument String 61 | TreeFileArgument FilePath 62 | TreePinArgument String 63 | ExportArgument String 64 deriving (Show) 65 66 data TricuArgs 67 = PackageCommand PackageArgs 68 | ProjectCommand ProjectArgs 69 | ProvenanceCommand ProvenanceArgs 70 | Repl CompilerOptions 71 | Eval 72 { evalFiles :: [FilePath] 73 , evalStore :: Maybe FilePath 74 , evalFormat :: EvaluatedForm 75 , evalOutput :: FilePath 76 , evalIo :: Bool 77 , evalAllowRead :: [FilePath] 78 , evalAllowWrite :: [FilePath] 79 , evalAllowReadAll :: Bool 80 , evalAllowWriteAll :: Bool 81 , evalUnsafeIo :: Bool 82 , evalCompiler :: CompilerOptions 83 } 84 | TreeWrite 85 { treeInput :: FilePath 86 , treeName :: String 87 , treeOutput :: FilePath 88 , treeStore :: Maybe FilePath 89 } 90 | TriFormat 91 { triFormatInput :: FilePath 92 , triFormatStore :: Maybe FilePath 93 , triFormatTools :: Maybe FilePath 94 , triFormatManifest :: String 95 , triFormatWrite :: Bool 96 , triFormatCheck :: Bool 97 , triFormatSeconds :: Int 98 } 99 | ArboricxCompile 100 { compileInput :: FilePath 101 , compileStore :: Maybe FilePath 102 , compileOutput :: FilePath 103 , compileNames :: [String] 104 , compileCompiler :: CompilerOptions 105 } 106 | ArboricxInspect FilePath String Bool Int Int Int Int 107 | ArboricxImport 108 { importFile :: FilePath 109 , importStore :: Maybe FilePath 110 , importModule :: Maybe String 111 , importIndexed :: Bool 112 , importFlatLimit :: Integer 113 } 114 | ArboricxRun 115 { storedModule :: String 116 , storedName :: String 117 , storedArgs :: [StoredArgument] 118 , storedRepeat :: Int 119 , storedStore :: Maybe FilePath 120 , storedFormat :: EvaluatedForm 121 , storedResult :: Bool 122 , storedNoResult :: Bool 123 , storedIo :: Bool 124 , storedAllowRead :: [FilePath] 125 , storedAllowWrite :: [FilePath] 126 , storedUnsafeIo :: Bool 127 , storedProfile :: Bool 128 , storedProfileFullResult :: Bool 129 } 130 | ArboricxExport 131 { exportTargets :: [String] 132 , exportModules :: [String] 133 , exportOutput :: FilePath 134 , exportNames :: [String] 135 , exportStore :: Maybe FilePath 136 , exportAll :: Bool 137 , exportSplit :: Bool 138 , dag :: Bool 139 } 140 | StoreAliasList 141 { storeAliasKind :: AliasKind 142 , storePathOpt :: Maybe FilePath 143 } 144 | StoreAliasGet 145 { storeAliasKind :: AliasKind 146 , storeAliasName :: String 147 , storePathOpt :: Maybe FilePath 148 } 149 deriving (Show) 150 151 data PackageArgs 152 = PackagePublish FilePath String String FilePath 153 | PackageResolve FilePath String String String FilePath Bool 154 | PackageFetch FilePath FilePath (Maybe FilePath) 155 | PackageBind FilePath FilePath (Maybe FilePath) 156 deriving (Show) 157 158 packageParser :: Parser TricuArgs 159 packageParser = PackageCommand <$> subparser (mconcat 160 [ command "publish" (info (publish <**> helper) (progDesc "Publish an immutable exact release into a trusted server directory")) 161 , command "resolve" (info (resolve <**> helper) (progDesc "Resolve an exact version from an explicitly trusted registry into a lock")) 162 , command "fetch" (info (fetch <**> helper) (progDesc "Fetch a locked module; never consult the package index")) 163 , command "bind" (info (binding <**> helper) (progDesc "Write a pinned workspace re-export module, offline")) 164 ]) 165 where 166 opt name label = strOption (long name <> metavar label) 167 config = opt "registries" "CONFIG" 168 lock = opt "lock" "LOCK" 169 name = opt "name" "PACKAGE" 170 version = opt "version" "VERSION" 171 publish = PackagePublish <$> opt "root" "SERVER_STORE" <*> name <*> version <*> opt "file" "BUNDLE" 172 resolve = PackageResolve <$> config <*> opt "registry" "REGISTRY" <*> name <*> version <*> lock 173 <*> switch (long "update" <> help "Permit changing the locked selection, never an existing version's identity") 174 fetch = PackageFetch <$> config <*> lock <*> storePathParser 175 binding = PackageBind <$> lock <*> opt "output" "MODULE.tri" <*> storePathParser 176 177 runPackage :: PackageArgs -> IO () 178 runPackage args = (case args of 179 PackagePublish root name version file -> Package.publishRelease root (T.pack name) (T.pack version) file >>= BS.putStr . Package.encodeRelease 180 PackageResolve config registry name version lock update -> 181 Package.resolveRelease config (T.pack registry) (T.pack name) (T.pack version) lock update >>= BS.putStr . Package.encodeLock 182 PackageFetch config lock store -> do 183 resolved <- resolveStorePath store 184 selected <- Package.fetchLocked config lock resolved 185 putStrLn (T.unpack (Package.releaseManifest (Package.lockRelease selected))) 186 PackageBind lock output store -> resolveStorePath store >>= \resolved -> Package.bindLocked lock resolved output 187 ) `catch` (\(e :: IOException) -> die (show e)) 188 189 -- A single declaration/lock covers the whole dependency set. Source compilation 190 -- remains independent; these commands only prepare local immutable imports. 191 data ProjectArgs 192 = ProjectResolve FilePath (Maybe FilePath) FilePath Project.Update 193 | ProjectExplain FilePath (Maybe FilePath) (Maybe FilePath) (Maybe FilePath) 194 | ProjectDiff FilePath FilePath (Maybe FilePath) 195 | ProjectFetch FilePath (Maybe FilePath) FilePath (Maybe FilePath) 196 | ProjectBind FilePath (Maybe FilePath) (Maybe FilePath) (Maybe FilePath) Bool 197 deriving (Show) 198 199 projectParser :: Parser TricuArgs 200 projectParser = ProjectCommand <$> subparser (mconcat 201 [ command "resolve" (info (resolve Project.Frozen <**> helper) (progDesc "Create a project lock; preserve existing selections without network")) 202 , command "update" (info (update <**> helper) (progDesc "Explicitly update selected dependencies and report identity changes")) 203 , command "fetch" (info (fetch <**> helper) (progDesc "Fetch the locked project into the CAS; never consult the index")) 204 , command "bind" (info (binding False <**> helper) (progDesc "Verify and generate owned workspace bindings offline")) 205 , command "explain" (info (explain <**> helper) (progDesc "Explain locked selections and local evidence offline, without writes")) 206 , command "diff" (info (diff <**> helper) (progDesc "Compare locks, interfaces and tree structure offline, without execution")) 207 , command "check" (info (binding True <**> helper) (progDesc "Check declaration, lock, generated bindings and local CAS offline")) 208 ]) 209 where 210 opt name label description = strOption (long name <> metavar label <> help description) 211 project = strOption (long "project" <> metavar "FILE" <> value "tricu.project" <> showDefault <> help "Dependency declaration") 212 lock = optional (opt "lock" "FILE" "Consolidated lock; default tricu.lock beside the declaration") 213 config = opt "registries" "CONFIG" "Explicit trusted registry configuration" 214 resolve mode = ProjectResolve <$> project <*> lock <*> config <*> pure mode 215 update = ProjectResolve <$> project <*> lock <*> config <*> 216 ((flag' Project.All (long "all" <> help "Re-resolve all selections")) <|> 217 (Project.Selected . map T.pack <$> some (opt "dependency" "BINDING" "Local binding to update; repeat to select several"))) 218 fetch = ProjectFetch <$> project <*> lock <*> config <*> storePathParser 219 explain = ProjectExplain <$> project <*> lock <*> optional (opt "directory" "WORKSPACE" "Binding directory; default beside declaration") <*> storePathParser 220 diff = ProjectDiff <$> opt "before" "LOCK" "Previous project lock" <*> opt "after" "LOCK" "Next project lock" <*> storePathParser 221 binding check = ProjectBind <$> project <*> lock <*> optional (opt "directory" "WORKSPACE" "Flat workspace; default beside the declaration") <*> storePathParser <*> pure check 222 223 runProject :: ProjectArgs -> IO () 224 runProject args = (case args of 225 ProjectResolve file lock config mode -> Project.resolveProject file (lockPath file lock) config mode >>= putStr . T.unpack 226 ProjectExplain file lock directory store -> do 227 resolved <- resolveStorePath store 228 emitReport =<< Project.explainProject file (lockPath file lock) (maybe (takeDirectory file) id directory) resolved 229 ProjectDiff before after store -> do 230 resolved <- resolveStorePath store 231 emitReport =<< Project.diffProject before after resolved 232 ProjectFetch file lock config store -> do 233 resolved <- resolveStorePath store 234 Project.fetchProject file (lockPath file lock) config resolved 235 putStrLn "Project modules verified locally." 236 ProjectBind file lock directory store check -> do 237 resolved <- resolveStorePath store 238 let workspace = maybe (takeDirectory file) id directory 239 (if check then Project.checkProject else Project.bindProject) file (lockPath file lock) workspace resolved 240 putStrLn (if check then "Project bindings and modules verified." else "Project bindings ready; compilation remains offline.") 241 ) `catch` (\(e :: IOException) -> die (show e)) 242 where 243 lockPath file = maybe (takeDirectory file </> "tricu.lock") id 244 emitReport (report, complete) = do 245 putStr (T.unpack report) 246 unless complete exitFailure 247 248 data ProvenanceArgs 249 = CaptureInputs FilePath (Maybe FilePath) FilePath String Int (Maybe String) (Maybe (FilePath,Maybe FilePath)) FilePath 250 | VerifyInputs FilePath String 251 | RebuildInputs FilePath String String FilePath Int Int 252 deriving (Show) 253 254 provenanceParser :: Parser TricuArgs 255 provenanceParser = ProvenanceCommand <$> subparser (mconcat 256 [ command "capture" (info (capture <**> helper) (progDesc "Retain native receipts, exact sources and executable inputs in a new pack")) 257 , command "verify" (info (verify <**> helper) (progDesc "Authenticate a retained input closure without executing its compiler")) 258 , command "rebuild" (info (rebuild <**> helper) (progDesc "Rebuild in a new directory with an explicitly trusted retained compiler")) 259 ]) 260 where 261 opt name label = strOption (long name <> metavar label <> help label) 262 pack = opt "pack" "DIRECTORY" 263 pin = opt "pin" "INPUTS_HASH" 264 capture = CaptureInputs <$> opt "file" "ENTRY.tri" <*> storePathParser 265 <*> opt "tool-store" "TOOL_STORE" <*> opt "toolchain" "COMPILER_MANIFEST" 266 <*> ioVersion "toolchain-io-version" 267 <*> optional (opt "receipt" "NATIVE_RECEIPT_HASH") 268 <*> optional ((,) <$> opt "project" "DECLARATION" <*> optional (opt "lock" "PROJECT_LOCK")) 269 <*> opt "output" "NEW_PACK_DIRECTORY" 270 ioVersion name = option (eitherReader (\raw -> case raw of 271 "1" -> Right 1 272 "2" -> Right 2 273 _ -> Left "IO version must be 1 or 2")) 274 (long name <> metavar "VERSION" <> value 1 275 <> help "Explicit compiler IO protocol: 1 (default) or 2 (OS process authority)") 276 verify = VerifyInputs <$> pack <*> pin 277 rebuild = RebuildInputs <$> pack <*> pin <*> strOption (long "trust-compiler" <> metavar "COMPILER_MANIFEST" 278 <> help "Explicitly authorize this compiler; a matching hash is not publisher trust") 279 <*> opt "output" "NEW_REBUILD_DIRECTORY" 280 <*> option auto (long "compile-timeout" <> value 120 <> showDefault <> help "Compiler deadline in seconds") 281 <*> ioVersion "trust-io-version" 282 283 runProvenance :: ProvenanceArgs -> IO () 284 runProvenance args = (case args of 285 CaptureInputs file store tools compiler ioVersion receipt project output -> do 286 app <- resolveStorePath store 287 let context = fmap (\(p,l) -> (p, maybe (takeDirectory p </> "tricu.lock") id l)) project 288 pin <- Provenance.capture file app (StorePath tools) (T.pack compiler) ioVersion (T.pack <$> receipt) context output 289 putStrLn ("Retained build inputs: " ++ T.unpack pin ++ "\nProducer claims; use verify, then an explicitly trusted rebuild.") 290 VerifyInputs pack pin -> Provenance.verifyPack pack (T.pack pin) >>= putStr . T.unpack 291 RebuildInputs pack pin trusted output seconds trustedIO -> do 292 let tools = output </> "tools" 293 app = output </> "application" 294 options = CompilerOptions (Just trusted) (Just tools) seconds False trustedIO 295 validateCompilerOptions options 296 recipe <- Provenance.prepareRebuild pack (T.pack pin) (T.pack trusted) trustedIO output 297 (_,actual,receipt) <- buildPortableResult options (Just app) 298 (output </> "workspace" </> T.unpack (Provenance.recipeEntry recipe) ++ ".tri") 299 (report,exact) <- Provenance.finishRebuild pack (T.pack pin) output recipe actual receipt 300 putStr (T.unpack report) 301 unless exact exitFailure 302 ) `catch` (\(e :: IOException) -> die (T.unpack (Inspection.safeText (T.pack (show e))))) 303 304 -- --------------------------------------------------------------------------- 305 -- optparse-applicative parsers 306 -- --------------------------------------------------------------------------- 307 308 readEvaluatedForm :: ReadM EvaluatedForm 309 readEvaluatedForm = eitherReader $ \s -> case s of 310 "tree" -> Right Tree 311 "fsl" -> Right FSL 312 "ast" -> Right AST 313 "ternary" -> Right Ternary 314 "ascii" -> Right Ascii 315 "decode" -> Right Decode 316 "number" -> Right Number 317 "string" -> Right StringLit 318 _ -> Left $ "Unknown format: " ++ s ++ ". Expected: tree, fsl, ast, ternary, ascii, decode, number, string" 319 320 compilerOptionsParser :: Parser CompilerOptions 321 compilerOptionsParser = CompilerOptions 322 <$> optional (strOption (long "toolchain" <> metavar "MANIFEST" 323 <> help "Override the packaged stable compiler with a pinned sourceBuildGraph manifest")) 324 <*> optional (strOption (long "tool-store" <> metavar "PATH" 325 <> help "Verified compiler artifact store (defaults to the application store)")) 326 <*> option auto (long "compile-timeout" <> metavar "SECONDS" <> value 120 327 <> help "Portable compiler load/build deadline (default 120 seconds)") 328 <*> switch (long "compile-profile" 329 <> help "Report portable load/build stages and RTS counters to stderr (requires +RTS -T)") 330 <*> option (eitherReader (\version -> case version of 331 "1" -> Right 1 332 "2" -> Right 2 333 _ -> Left "--toolchain-io-version must be 1 or 2")) 334 (long "toolchain-io-version" <> metavar "VERSION" <> value 2 335 <> help "Selected compiler IO protocol: 2 (OS process authority, default) or 1 (explicit retained bridge); no fallback") 336 337 evalParser :: Parser TricuArgs 338 evalParser = Eval 339 <$> many (argument str (metavar "FILE...")) 340 <*> optional (option str 341 ( long "store" 342 <> short 's' 343 <> metavar "PATH" 344 <> help "Content-addressed store path for module import resolution" 345 )) 346 <*> option readEvaluatedForm 347 ( long "format" 348 <> short 'f' 349 <> metavar "FORM" 350 <> value Tree 351 <> help "Output format: tree, fsl, ast, ternary, ascii, decode, number, string" 352 ) 353 <*> option str 354 ( long "output" 355 <> short 'o' 356 <> metavar "FILE" 357 <> value "" 358 <> help "Write output to file instead of stdout" 359 ) 360 <*> switch 361 ( long "io" 362 <> help "Interpret the result as an IO action tree and execute it" 363 ) 364 <*> many (option str 365 ( long "allow-read" 366 <> metavar "PATH" 367 <> help "Allow reading from PATH prefix (repeatable)" 368 )) 369 <*> many (option str 370 ( long "allow-write" 371 <> metavar "PATH" 372 <> help "Allow writing to PATH prefix (repeatable)" 373 )) 374 <*> switch 375 ( long "allow-read-all" 376 <> help "Allow reading from any path" 377 ) 378 <*> switch 379 ( long "allow-write-all" 380 <> help "Allow writing to any path" 381 ) 382 <*> switch 383 ( long "unsafe-io" 384 <> help "Allow unrestricted read and write access" 385 ) 386 <*> compilerOptionsParser 387 388 compileParser :: Parser TricuArgs 389 compileParser = ArboricxCompile 390 <$> option str 391 ( long "file" 392 <> short 'f' 393 <> metavar "FILE" 394 <> value "" 395 <> help "Input .tri source file" 396 ) 397 <*> optional (option str 398 ( long "store" 399 <> short 's' 400 <> metavar "PATH" 401 <> help "Content-addressed store path for module import resolution" 402 )) 403 <*> option str 404 ( long "output" 405 <> short 'o' 406 <> metavar "FILE" 407 <> value "" 408 <> help "Output bundle file path (required)" 409 ) 410 <*> many (option str 411 ( long "name" 412 <> short 'n' 413 <> metavar "NAME" 414 <> help "Definition name(s) to export as bundle roots (repeatable)" 415 )) 416 <*> compilerOptionsParser 417 418 inspectParser :: Parser TricuArgs 419 inspectParser = ArboricxInspect 420 <$> strOption (long "file" <> short 'f' <> metavar "FILE.arboricx" <> help "Indexed bundle to read (no store import)") 421 <*> strOption (long "name" <> short 'n' <> metavar "EXPORT" <> value "main" <> showDefault <> help "Already-materialized IO export to inspect") 422 <*> switch (long "json" <> help "Emit versioned JSON instead of a terminal outline") 423 <*> option auto (long "max-depth" <> value 24 <> showDefault <> help "Maximum occurrence depth (0..256)") 424 <*> option auto (long "max-nodes" <> value 500 <> showDefault <> help "Maximum displayed occurrences (1..100000); not a stored-node limit") 425 <*> option auto (long "preview-items" <> value 80 <> showDefault <> help "Maximum characters/bytes or aliases per occurrence (1..4096)") 426 <*> option auto (long "max-bytes" <> value (64 * 1024 * 1024) <> showDefault <> help "Input bundle byte limit (1..67108864); not a heap limit") 427 <* option (eitherReader (\s -> if s == "io" then Right () else Left "only --as io is supported")) 428 (long "as" <> metavar "io" <> help "Explicitly select the host IO protocol (required)") 429 430 importParser :: Parser TricuArgs 431 importParser = ArboricxImport 432 <$> option str 433 ( long "file" 434 <> short 'f' 435 <> metavar "FILE" 436 <> value "" 437 <> help "Bundle file to import" 438 ) 439 <*> optional (option str 440 ( long "store" 441 <> short 's' 442 <> metavar "PATH" 443 <> help "Content-addressed store path" 444 )) 445 <*> optional (option str 446 ( long "module" 447 <> short 'm' 448 <> metavar "NAME" 449 <> help "Module alias to create for the imported bundle (defaults to bundle file basename)" 450 )) 451 <*> (flag' False (long "flat" <> help "Expand exports into tree-term objects (size-bounded)") 452 <|> flag' True (long "indexed" <> help "Preserve DAG sharing (default)") 453 <|> pure True) 454 <*> option auto (long "max-flat-bytes" <> metavar "BYTES" 455 <> value defaultFlatImportLimit <> showDefault 456 <> help "Positive aggregate expanded byte limit for --flat; not a heap or input-size limit") 457 458 storedRunParser :: Parser TricuArgs 459 storedRunParser = ArboricxRun 460 <$> strOption (long "module" <> short 'm' <> metavar "MANIFEST" 461 <> help "Pinned executable module manifest hash (not a mutable alias)") 462 <*> strOption (long "name" <> short 'n' <> metavar "EXPORT" 463 <> help "Name of the executable export") 464 <*> many (StringArgument <$> strOption (long "arg" <> metavar "TEXT" 465 <> help "Apply a tricu string argument (repeatable)") 466 <|> TreeFileArgument <$> strOption (long "arg-tree-file" <> metavar "FILE" 467 <> help "Apply an exact tree-term payload from FILE (no source evaluation)") 468 <|> TreePinArgument <$> strOption (long "arg-tree-pin" <> metavar "HASH" 469 <> help "Apply a verified tree-term object from this CAS (shared decoding)") 470 <|> ExportArgument <$> strOption (long "arg-export" <> metavar "MANIFEST:EXPORT" 471 <> help "Apply a verified flat or indexed executable export from this CAS")) 472 <*> option auto (long "repeat" <> metavar "N" <> value 1 473 <> help "Repeat invocation in one host process after loading once") 474 <*> storePathParser 475 <*> option readEvaluatedForm (long "format" <> short 'f' 476 <> metavar "FORM" <> value Tree <> help "Output format") 477 <*> switch (long "result" <> help "Display a canonical Result with ok/error labels") 478 <*> switch (long "no-result" <> help "Suppress final value display for --io; keep program output and errors") 479 <*> switch (long "io" <> help "Run a stored IO program") 480 <*> many (strOption (long "allow-read" <> metavar "PATH" 481 <> help "Allow reading from PATH prefix (repeatable)")) 482 <*> many (strOption (long "allow-write" <> metavar "PATH" 483 <> help "Allow writing to PATH prefix (repeatable)")) 484 <*> switch (long "unsafe-io" <> help "Allow unrestricted IO") 485 <*> switch (long "profile" <> help "Emit load/invocation/observation/yield samples without extra result forcing (requires +RTS -T)") 486 <*> switch (long "profile-full-result" <> help "Also force the complete result with sharing-aware traversal (requires --profile; changes demand)") 487 488 exportParser :: Parser TricuArgs 489 exportParser = ArboricxExport 490 <$> many (option str 491 ( long "target" 492 <> short 't' 493 <> metavar "TARGET" 494 <> help "Target hash or name (repeatable)" 495 )) 496 <*> many (option str 497 ( long "module" 498 <> short 'm' 499 <> metavar "MODULE" 500 <> help "Module alias or manifest hash to export (repeatable; bundle export only)" 501 )) 502 <*> option str 503 ( long "output" 504 <> short 'o' 505 <> metavar "FILE" 506 <> value "" 507 <> help "Output file path (required for bundle export)" 508 ) 509 <*> many (option str 510 ( long "name" 511 <> short 'n' 512 <> metavar "NAME" 513 <> help "Export name(s) for the bundle manifest (repeatable)" 514 )) 515 <*> optional (option str 516 ( long "store" 517 <> short 's' 518 <> metavar "PATH" 519 <> help "Content-addressed store path" 520 )) 521 <*> switch 522 ( long "all" 523 <> help "Export all name aliases that point at tree-term objects" 524 ) 525 <*> switch 526 ( long "split" 527 <> help "Write one single-export bundle per export; --output is treated as a directory" 528 ) 529 <*> switch 530 ( long "dag" 531 <> help "Export as a topologically-sorted DAG node table instead of a bundle" 532 ) 533 534 aliasKindReader :: ReadM AliasKind 535 aliasKindReader = eitherReader $ \s -> case s of 536 "names" -> Right NameAlias 537 "name" -> Right NameAlias 538 "modules" -> Right ModuleAlias 539 "module" -> Right ModuleAlias 540 "packages" -> Right PackageAlias 541 "package" -> Right PackageAlias 542 _ -> Left "alias kind must be one of: names, modules, packages" 543 544 storePathParser :: Parser (Maybe FilePath) 545 storePathParser = optional (option str 546 ( long "store" 547 <> short 's' 548 <> metavar "PATH" 549 <> help "Content-addressed store path" 550 )) 551 552 aliasKindParser :: Parser AliasKind 553 aliasKindParser = option aliasKindReader 554 ( long "kind" 555 <> short 'k' 556 <> metavar "KIND" 557 <> value NameAlias 558 <> help "Alias kind: names, modules, packages (default: names)" 559 ) 560 561 storeAliasListParser :: Parser TricuArgs 562 storeAliasListParser = StoreAliasList 563 <$> aliasKindParser 564 <*> storePathParser 565 566 storeAliasGetParser :: Parser TricuArgs 567 storeAliasGetParser = StoreAliasGet 568 <$> aliasKindParser 569 <*> argument str (metavar "NAME") 570 <*> storePathParser 571 572 versionStr :: String 573 versionStr = "tricu " ++ showVersion version 574 575 tricuParser :: Parser AppArgs 576 tricuParser = AppArgs 577 <$> optional (option str 578 ( long "store" 579 <> metavar "PATH" 580 <> help "Global content-addressed store path used by commands and the REPL unless a subcommand overrides it" 581 )) 582 <*> ((subparser topCommands <|> (Repl <$> compilerOptionsParser)) 583 <**> infoOption versionStr (long "version" <> help "Show version")) 584 where 585 topCommands = mconcat 586 [ command "provenance" (info (provenanceParser <**> helper) (progDesc "Retained build inputs and offline reproduction")) 587 , command "project" (info (projectParser <**> helper) (progDesc "Project dependency preparation and offline inspection")) 588 , command "package" (info (packageParser <**> helper) (progDesc "Exact-version trusted registry operations")) 589 , command "repl" (info ((Repl <$> compilerOptionsParser) <**> helper) 590 (progDesc "Interactive portable source session")) 591 , command "eval" (info (evalParser <**> helper) 592 (progDesc "Compile a native module and print its exported main")) 593 , command "format" (info (triFormatParser <**> helper) 594 (progDesc "Align .tri equation heads using a pinned portable formatter")) 595 , command "tree" (info (treeParser <**> helper) 596 (progDesc "Author exact tree data")) 597 , command "arboricx" (info (arboricxParser <**> helper) 598 (progDesc "Arboricx bundle operations")) 599 , command "store" (info (storeParser <**> helper) 600 (progDesc "Inspect and manage the content-addressed store")) 601 ] 602 603 treeParser :: Parser TricuArgs 604 treeParser = subparser $ command "write" (info (treeWriteParser <**> helper) 605 (progDesc "Evaluate a selected source definition and serialize its exact tree")) 606 607 treeWriteParser :: Parser TricuArgs 608 treeWriteParser = TreeWrite 609 <$> argument str (metavar "FILE.tri") 610 <*> strOption (long "name" <> metavar "DEFINITION") 611 <*> strOption (long "output" <> short 'o' <> metavar "FILE.tree") 612 <*> storePathParser 613 614 triFormatParser :: Parser TricuArgs 615 triFormatParser = TriFormat 616 <$> argument str (metavar "FILE.tri") 617 <*> storePathParser 618 <*> optional (strOption (long "tool-store" <> metavar "PATH" 619 <> help "Formatter artifact store (defaults to --store)")) 620 <*> strOption (long "formatter" <> metavar "MANIFEST" 621 <> help "Pinned manifest exporting formatTri; no source-loading fallback") 622 <*> switch (long "write" <> help "Atomically replace the source file") 623 <*> switch (long "check" <> help "Fail if formatting would change the source") 624 <*> option auto (long "seconds" <> metavar "SECONDS" <> value 60 625 <> help "Formatter load/execution deadline (default 60 seconds)") 626 627 arboricxParser :: Parser TricuArgs 628 arboricxParser = subparser $ mconcat 629 [ command "compile" (info (compileParser <**> helper) 630 (progDesc "Compile a .tri file into a standalone Arboricx bundle")) 631 , command "inspect" (info (inspectParser <**> helper) 632 (progDesc "Inspect an exported IO tree without evaluation, effects, or store writes")) 633 , command "import" (info (importParser <**> helper) 634 (progDesc "Import an Arboricx bundle into the content store")) 635 , command "export" (info (exportParser <**> helper) 636 (progDesc "Export one or more terms from the content store")) 637 , command "run" (info (storedRunParser <**> helper) 638 (progDesc "Load a compiled tree from the CAS and run it in the Haskell host")) 639 ] 640 641 storeParser :: Parser TricuArgs 642 storeParser = subparser $ mconcat 643 [ command "alias" (info (storeAliasParser <**> helper) 644 (progDesc "Inspect workspace aliases")) 645 ] 646 647 storeAliasParser :: Parser TricuArgs 648 storeAliasParser = subparser $ mconcat 649 [ command "list" (info (storeAliasListParser <**> helper) 650 (progDesc "List aliases by kind")) 651 , command "get" (info (storeAliasGetParser <**> helper) 652 (progDesc "Resolve an alias by kind and name")) 653 ] 654 655 -- --------------------------------------------------------------------------- 656 -- Entry point 657 -- --------------------------------------------------------------------------- 658 659 main :: IO () 660 main = runMain `catch` (\(err :: IOException) -> die (ioeGetErrorString err)) 661 662 runMain :: IO () 663 runMain = do 664 appArgs <- execParser $ info (tricuParser <**> helper) 665 ( fullDesc 666 <> progDesc "Exploring Tree Calculus" 667 <> header versionStr 668 ) 669 let mGlobalStore = globalStore appArgs 670 args = applyGlobalStore mGlobalStore (appCommand appArgs) 671 case args of 672 PackageCommand commandArgs -> runPackage commandArgs 673 ProjectCommand commandArgs -> runProject commandArgs 674 ProvenanceCommand commandArgs -> runProvenance commandArgs 675 Repl options -> runReplWithOptions mGlobalStore options 676 Eval {} -> runEval args 677 TreeWrite {} -> runTreeWrite args 678 TriFormat {} -> runTriFormat args 679 ArboricxCompile {} -> runCompile args 680 ArboricxInspect {} -> runInspect args 681 ArboricxImport {} -> runImport args 682 ArboricxExport {} -> runExport args 683 ArboricxRun {} -> runStored args 684 StoreAliasList {} -> runStoreAliasList args 685 StoreAliasGet {} -> runStoreAliasGet args 686 687 688 -- --------------------------------------------------------------------------- 689 -- Command runners 690 -- --------------------------------------------------------------------------- 691 692 applyGlobalStore :: Maybe FilePath -> TricuArgs -> TricuArgs 693 applyGlobalStore mGlobal args = case args of 694 PackageCommand (PackageFetch config lock store) -> PackageCommand (PackageFetch config lock (preferLocal store)) 695 PackageCommand (PackageBind lock output store) -> PackageCommand (PackageBind lock output (preferLocal store)) 696 PackageCommand _ -> args 697 ProjectCommand (ProjectFetch file lock config store) -> ProjectCommand (ProjectFetch file lock config (preferLocal store)) 698 ProjectCommand (ProjectBind file lock directory store check) -> ProjectCommand (ProjectBind file lock directory (preferLocal store) check) 699 ProjectCommand (ProjectExplain file lock directory store) -> ProjectCommand (ProjectExplain file lock directory (preferLocal store)) 700 ProjectCommand (ProjectDiff before after store) -> ProjectCommand (ProjectDiff before after (preferLocal store)) 701 ProjectCommand _ -> args 702 ProvenanceCommand (CaptureInputs file store tools compiler ioVersion receipt project output) -> ProvenanceCommand (CaptureInputs file (preferLocal store) tools compiler ioVersion receipt project output) 703 ProvenanceCommand _ -> args 704 Repl options -> Repl options 705 Eval {} -> args { evalStore = preferLocal (evalStore args) } 706 TreeWrite {} -> args { treeStore = preferLocal (treeStore args) } 707 TriFormat {} -> args { triFormatStore = preferLocal (triFormatStore args) } 708 ArboricxCompile {} -> args { compileStore = preferLocal (compileStore args) } 709 ArboricxInspect {} -> args 710 ArboricxImport {} -> args { importStore = preferLocal (importStore args) } 711 ArboricxExport {} -> args { exportStore = preferLocal (exportStore args) } 712 ArboricxRun {} -> args { storedStore = preferLocal (storedStore args) } 713 StoreAliasList {} -> args { storePathOpt = preferLocal (storePathOpt args) } 714 StoreAliasGet {} -> args { storePathOpt = preferLocal (storePathOpt args) } 715 where 716 preferLocal local = case local of 717 Just _ -> local 718 Nothing -> mGlobal 719 720 runRepl :: IO () 721 runRepl = runReplWithStore Nothing 722 723 runReplWithStore :: Maybe FilePath -> IO () 724 runReplWithStore mStore = runReplWithOptions mStore (CompilerOptions Nothing Nothing 120 False 2) 725 726 runReplWithOptions :: Maybe FilePath -> CompilerOptions -> IO () 727 runReplWithOptions mStore options = do 728 validateCompilerOptions options 729 putStrLn "Welcome to the tricu REPL" 730 putStrLn "You may exit with `CTRL+D` or the `!exit` command." 731 -- Fail at startup, even for an empty session, if the installation is broken. 732 store <- resolveStorePath mStore 733 checkPortableCompiler options store 734 portableRepl store (\active source -> do 735 directory <- getCurrentDirectory 736 withTempFile directory "tricu_repl.tri" $ \path handle -> do 737 hClose handle 738 BS.writeFile path (TE.encodeUtf8 $ T.pack source) 739 portableExports options (Just $ unStorePath active) path) 740 (\active path -> snd <$> buildPortableModule options (Just $ unStorePath active) path) 741 742 runEval :: TricuArgs -> IO () 743 runEval opts = do 744 when (evalUnsafeIo opts || evalAllowReadAll opts || evalAllowWriteAll opts 745 || not (null (evalAllowRead opts)) || not (null (evalAllowWrite opts))) $ 746 die "IO v1 permission grants are not accepted; IO uses OS process authority" 747 let files = evalFiles opts 748 form = evalFormat opts 749 out = evalOutput opts 750 validateCompilerOptions (evalCompiler opts) 751 resultT <- case files of 752 [file] -> evaluateModule file 753 [] -> do 754 bytes <- BS.getContents 755 withSystemTempDirectory "tricu-stdin" $ \directory -> do 756 let file = directory </> "stdin.tri" 757 BS.writeFile file bytes 758 evaluateModule file 759 _ -> die "Portable eval requires one native module file exporting main (or stdin)" 760 finalT <- if evalIo opts 761 then do 762 result <- runIO resultT 763 case result of 764 Left err -> die $ "IO error: " ++ err 765 Right val -> pure val 766 else return resultT 767 writeOutput out (formatT form finalT) 768 769 where 770 evaluateModule file = do 771 (store, manifest) <- buildPortableModule (evalCompiler opts) (evalStore opts) file 772 snd <$> loadVerifiedExport store manifest "main" 773 774 -- Explicit source authoring boundary. Runtime arguments use only the payload. 775 runTreeWrite :: TricuArgs -> IO () 776 runTreeWrite opts = do 777 let path = treeOutput opts 778 source <- canonicalizePath (treeInput opts) 779 target <- canonicalizePath path 780 when (source == target) $ die "Tree output must not replace its source" 781 symbolic <- pathIsSymbolicLink path `catch` (\(_ :: IOException) -> pure False) 782 when symbolic $ die "Tree output refuses symbolic links" 783 exists <- doesPathExist path 784 permissions <- if exists then Just . fileMode <$> getFileStatus path else pure Nothing 785 (store, manifest) <- buildPortableModule (CompilerOptions Nothing Nothing 120 False 2) 786 (treeStore opts) (treeInput opts) 787 (_, value) <- loadVerifiedExport store manifest (T.pack $ treeName opts) 788 let payload = encodeTreeTerm value 789 _ <- evaluate (BS.length payload) 790 bracketOnError (openBinaryTempFile (takeDirectory path) ".tree-write-") 791 (\(temporary, handle) -> do 792 hClose handle `catch` (\(_ :: IOException) -> pure ()) 793 removeFile temporary `catch` (\(_ :: IOException) -> pure ())) 794 (\(temporary, handle) -> do 795 BS.hPut handle payload 796 hClose handle 797 forM_ permissions (setFileMode temporary) 798 renameFile temporary path) 799 800 -- No source frontend or workspace loading at the .tri formatting boundary. 801 runTriFormat :: TricuArgs -> IO () 802 runTriFormat opts = do 803 when (triFormatWrite opts && triFormatCheck opts) $ 804 die "tricu format: --write and --check are mutually exclusive" 805 unless (triFormatSeconds opts >= 1 && triFormatSeconds opts <= 86400) $ 806 die "tricu format: --seconds must be between 1 and 86400" 807 let path = triFormatInput opts 808 when (triFormatWrite opts) $ do 809 symbolic <- pathIsSymbolicLink path 810 when symbolic $ die "tricu format: --write refuses symbolic links" 811 bytes <- BS.readFile path 812 when (BS.pack [0xef, 0xbb, 0xbf] `BS.isPrefixOf` bytes) $ 813 die "Invalid source text: initial UTF-8 BOM is not supported" 814 source <- either (die . ("Invalid UTF-8: " ++) . show) pure (TE.decodeUtf8' bytes) 815 defaultStore <- resolveStorePath (triFormatStore opts) 816 let tools = maybe defaultStore StorePath (triFormatTools opts) 817 outcome <- timeout (triFormatSeconds opts * 1000000) $ do 818 (_, formatter) <- loadVerifiedExport tools (T.pack $ triFormatManifest opts) "formatTri" 819 formatted <- case apply formatter (ofString $ T.unpack source) of 820 Fork (Stem Leaf) (Fork text Leaf) -> 821 either (die . ("Invalid formatter output: " ++)) pure (toString text) 822 Fork Leaf (Fork problem _) -> die $ "Formatter error: " ++ formatT Decode problem 823 _ -> die "Invalid formatter Result" 824 let output = TE.encodeUtf8 (T.pack formatted) 825 _ <- evaluate (BS.length output) 826 pure output 827 output <- maybe (die "Formatter load/execution deadline exceeded") pure outcome 828 if triFormatCheck opts 829 then unless (output == bytes) $ die $ path ++ ": needs formatting" 830 else if triFormatWrite opts 831 then when (output /= bytes) $ do 832 permissions <- fileMode <$> getFileStatus path 833 bracketOnError (openBinaryTempFile (takeDirectory path) ".tri-format-") 834 (\(temporary, handle) -> do 835 hClose handle `catch` (\(_ :: IOException) -> pure ()) 836 removeFile temporary `catch` (\(_ :: IOException) -> pure ())) 837 (\(temporary, handle) -> do 838 BS.hPut handle output 839 hClose handle 840 setFileMode temporary permissions 841 renameFile temporary path) 842 else BS.putStr output 843 844 runCompile :: TricuArgs -> IO () 845 runCompile opts = do 846 let input = compileInput opts 847 out = compileOutput opts 848 names = compileNames opts 849 when (null out) $ die "tricu arboricx compile: --output is required" 850 when (null input) $ die "tricu arboricx compile: input file is required" 851 let nameTexts = if null names then [] else map T.pack names 852 validateCompilerOptions (compileCompiler opts) 853 source <- canonicalizePath input 854 target <- canonicalizePath out 855 when (source == target) $ die "Bundle output must not replace its source" 856 (store, manifestHash) <- buildPortableModule (compileCompiler opts) (compileStore opts) input 857 when (length nameTexts /= Map.size (Map.fromList [(name, ()) | name <- nameTexts])) $ 858 die "Duplicate --name selection" 859 terms <- loadVerifiedExportSelection store manifestHash 860 (if null names then Nothing else Just nameTexts) 861 when (null terms) $ die "Portable module has no exports" 862 bundle <- buildBundleShared terms 863 BS.writeFile out (encodeBundle bundle) 864 865 runImport :: TricuArgs -> IO () 866 runImport opts = do 867 let file = importFile opts 868 unless (importFlatLimit opts > 0) $ die "flat import byte limit must be positive" 869 when (null file) $ die "tricu arboricx import: input file is required" 870 let moduleName = T.pack $ maybe (takeBaseName file) id (importModule opts) 871 either die pure (validateAliasName moduleName) 872 store <- resolveStorePath (importStore opts) 873 bundleData <- BL.readFile file 874 roots <- (if importIndexed opts then unpackIndexedBundleToStore else unpackBundleToStoreWithLimit (importFlatLimit opts)) 875 store (BL.toStrict bundleData) 876 let executableRef root = if importIndexed opts 877 then ObjectRef (unDomain indexedTreeDomain) root 878 else treeTermRef root 879 -- Validate the entire publication set before changing any mutable aliases. 880 -- Invalid names may leave immutable CAS objects, but publish no aliases. 881 -- Subsequent filesystem IO failures are not a transactional publication. 882 mapM_ (either die pure . validateAliasName . fst) roots 883 mapM_ (\(name, root) -> 884 writeAlias store NameAlias name (executableRef root)) roots 885 let manifest = ModuleManifest [] 886 [ ModuleExport 887 name 888 (executableRef root) 889 "arboricx.abi.tree.v1" 890 | (name, root) <- roots 891 ] 892 manifestHash <- putManifest store manifest 893 writeAlias store ModuleAlias moduleName (ObjectRef (unDomain manifestDomain) manifestHash) 894 putStrLn $ "Imported " ++ show (length roots) ++ " root(s):" 895 mapM_ (\(name, root) -> putStrLn $ " " ++ T.unpack name ++ " -> " ++ T.unpack root) roots 896 putStrLn $ "Created module alias " ++ T.unpack moduleName ++ " -> " ++ T.unpack manifestHash 897 898 -- Execute a previously compiled tree directly from a verified CAS manifest. 899 -- No .tri frontend or source compilation occurs here. 900 runStored :: TricuArgs -> IO () 901 runStored opts = do 902 when (storedUnsafeIo opts || not (null (storedAllowRead opts)) 903 || not (null (storedAllowWrite opts))) $ 904 die "IO v1 permission grants are not accepted; IO uses OS process authority" 905 when (storedNoResult opts && (not (storedIo opts) || storedResult opts)) $ 906 die "--no-result requires --io and cannot be combined with --result" 907 unless (storedRepeat opts >= 1 && storedRepeat opts <= 1000) $ 908 die "--repeat must be between 1 and 1000" 909 when (storedProfileFullResult opts && not (storedProfile opts)) $ 910 die "--profile-full-result requires --profile" 911 when (storedProfile opts) $ do 912 enabled <- getRTSStatsEnabled 913 unless enabled $ die "--profile requires +RTS -T" 914 let sample label = when (storedProfile opts) (profileSample label) 915 sample "load-begin" 916 store <- resolveStorePath (storedStore opts) 917 (_, term) <- loadVerifiedExport store (T.pack (storedModule opts)) (T.pack (storedName opts)) 918 arguments <- mapM (storedArgument store) (storedArgs opts) 919 let applied = foldl apply term arguments 920 _ <- evaluate term 921 sample "load-end" 922 when (storedRepeat opts > 1) $ putStrLn "READY" 923 forM_ [1..storedRepeat opts] $ \iteration -> do 924 let label phase = phase ++ "-" ++ show iteration 925 sample (label "invoke-begin") 926 finalT <- if storedIo opts 927 then runIO applied >>= either (die . ("IO error: " ++)) pure 928 else pure applied 929 sample (label "invoke-end") 930 when (storedProfileFullResult opts) $ do 931 sample (label "force-begin") 932 forceTreeShared finalT 933 sample (label "force-end") 934 sample (label "observe-begin") 935 unless (storedNoResult opts) $ do 936 displayed <- if storedResult opts 937 then either die pure (renderInvocationResult (storedFormat opts) finalT) 938 else pure (formatT (storedFormat opts) finalT) 939 writeOutput "" displayed 940 -- Keep the following JSON on its own line even when stdout/stderr are merged. 941 when (storedProfile opts) $ hFlush stdout >> hPutStrLn stderr "" 942 sample (label "observe-end") 943 when (storedRepeat opts > 1) $ do 944 putStrLn "" 945 putStrLn "RUN_DONE" 946 947 -- One digest/kind/ABI-verified boundary for runtime execution and tooling. 948 -- Each sample forces a major collection. Deltas include sampling overhead; 949 -- yielded samples retain the scheduler's pending work. Rendering follows timing. 950 profileSample :: String -> IO () 951 profileSample label = do 952 performGC 953 stats <- getRTSStats 954 wall <- getMonotonicTimeNSec 955 BL.hPutStr stderr (JSON.encode (JSON.object 956 [ "profile" JSON..= label 957 , "wall_ns" JSON..= wall 958 , "allocated_bytes" JSON..= allocated_bytes stats 959 , "live_bytes" JSON..= gcdetails_live_bytes (gc stats) 960 , "gc_elapsed_ns" JSON..= gc_elapsed_ns stats 961 ])) 962 BL.hPutStr stderr "\n" 963 964 -- Presentation of the canonical Result envelope; the underlying tree survives. 965 renderInvocationResult :: EvaluatedForm -> Runtime.T -> Either String String 966 renderInvocationResult form (Fork (Stem Leaf) (Fork value _)) = 967 Right $ "ok: " ++ case (form, value) of 968 (Decode, Leaf) -> "[]" 969 _ -> formatT form value 970 renderInvocationResult form (Fork Leaf (Fork problem _)) = 971 Right $ "error: " ++ case (form, toString problem) of 972 (Decode, Right message) -> message 973 _ -> formatT form problem 974 renderInvocationResult _ _ = Left "Invalid Result envelope; use the tree view to inspect it" 975 976 storedArgument :: StorePath -> StoredArgument -> IO Runtime.T 977 storedArgument _ (StringArgument value) = pure (ofString value) 978 storedArgument _ (TreeFileArgument path) = do 979 payload <- BS.readFile path 980 either (die . (("Invalid argument tree " ++ path ++ ": ") ++)) pure 981 (decodeTreeTerm payload) 982 storedArgument store (TreePinArgument pin) = do 983 let hash = T.pack pin 984 either (die . ("Invalid argument tree pin: " ++)) pure (textToHashBytes hash) 985 payload <- getObject store hash >>= maybe 986 (die $ "Argument tree not found: " ++ pin) pure 987 unless (hashObject treeTermDomain payload == hash) $ 988 die "Argument tree digest/domain mismatch" 989 either (die . ("Invalid argument tree: " ++)) pure (decodeTreeTermShared payload) 990 storedArgument store (ExportArgument selection) = 991 case break (== ':') selection of 992 (manifest, ':' : name) | not (null name) && ':' `notElem` name -> 993 snd <$> loadVerifiedExport store (T.pack manifest) (T.pack name) 994 _ -> die "Invalid executable argument: expected MANIFEST:EXPORT" 995 996 runExport :: TricuArgs -> IO () 997 runExport opts = 998 if dag opts 999 then runExportDag opts 1000 else runExportBundle opts 1001 1002 runExportBundle :: TricuArgs -> IO () 1003 runExportBundle opts = do 1004 let targets = exportTargets opts 1005 modules = exportModules opts 1006 out = exportOutput opts 1007 names = exportNames opts 1008 allFlag = exportAll opts 1009 splitFlag = exportSplit opts 1010 when (null out) $ die "tricu arboricx export: --output is required" 1011 when (null targets && null modules && not allFlag) $ 1012 die "tricu arboricx export: at least one --target, --module, or --all is required" 1013 when (splitFlag && not (null names)) $ 1014 die "tricu arboricx export --split: --name is not supported; split bundles use their export names" 1015 store <- resolveStorePath (exportStore opts) 1016 allEntries <- if allFlag then resolveAllNameExports store else pure [] 1017 targetRoots <- mapM (resolveStoreTarget store) targets 1018 moduleRoots <- concat <$> mapM (resolveModuleExports store) modules 1019 let targetEntries = zip (defaultExportNames (length targetRoots)) targetRoots 1020 entries = allEntries ++ targetEntries ++ moduleRoots 1021 expNames = if null names then map fst entries else map T.pack names 1022 when (null entries) $ 1023 die "tricu arboricx export: no tree-term exports found" 1024 when (length expNames /= length entries) $ 1025 die "tricu arboricx export: number of --name values must match number of exported roots" 1026 unless splitFlag $ do 1027 when (any T.null expNames) $ die "manifest export has empty name" 1028 when (Map.size (Map.fromList [(name, ()) | name <- expNames]) /= length expNames) $ 1029 die "duplicate export name" 1030 if splitFlag 1031 then runExportBundleSplit store out (zip expNames (map snd entries)) 1032 else do 1033 bundle <- packExecutableBundleFromStore store (zip expNames (map snd entries)) 1034 let bundleData = encodeBundle bundle 1035 BL.writeFile out (BL.fromStrict bundleData) 1036 putStrLn $ "Exported bundle with " ++ show (length entries) ++ " export(s) to " ++ out 1037 putStrLn $ " nodes: " ++ show (Seq.length (bundleNodes bundle)) 1038 putStrLn $ " size: " ++ show (BS.length bundleData) ++ " bytes" 1039 1040 runExportBundleSplit :: StorePath -> FilePath -> [(T.Text, ObjectRef)] -> IO () 1041 runExportBundleSplit store outDir entries = do 1042 createDirectoryIfMissing True outDir 1043 written <- forM (zip [0 :: Int ..] entries) $ \(i, (name, root)) -> do 1044 bundle <- packExecutableBundleFromStore store [(name, root)] 1045 let bundleData = encodeBundle bundle 1046 path = outDir </> splitBundleFileName i name 1047 BL.writeFile path (BL.fromStrict bundleData) 1048 pure (path, Seq.length (bundleNodes bundle), BS.length bundleData) 1049 putStrLn $ "Exported " ++ show (length written) ++ " split bundle(s) to " ++ outDir 1050 mapM_ (\(path, nodeCount, byteCount) -> 1051 putStrLn $ " " ++ path ++ " (nodes: " ++ show nodeCount ++ ", size: " ++ show byteCount ++ " bytes)") written 1052 1053 runStoreAliasList :: TricuArgs -> IO () 1054 runStoreAliasList opts = do 1055 store <- resolveStorePath (storePathOpt opts) 1056 aliases <- listAliases store (storeAliasKind opts) 1057 mapM_ (\(name, ref) -> putStrLn $ T.unpack name ++ " -> " ++ formatObjectRef ref) aliases 1058 1059 runStoreAliasGet :: TricuArgs -> IO () 1060 runStoreAliasGet opts = do 1061 store <- resolveStorePath (storePathOpt opts) 1062 mRef <- readAlias store (storeAliasKind opts) (T.pack $ storeAliasName opts) 1063 case mRef of 1064 Nothing -> die $ "alias not found: " ++ storeAliasName opts 1065 Just ref -> putStrLn $ storeAliasName opts ++ " -> " ++ formatObjectRef ref 1066 1067 runExportDag :: TricuArgs -> IO () 1068 runExportDag opts = do 1069 let targets = exportTargets opts 1070 modules = exportModules opts 1071 out = exportOutput opts 1072 unless (null modules) $ 1073 die "tricu arboricx export --dag: --module is only supported for bundle export" 1074 case targets of 1075 [target] -> do 1076 store <- resolveStorePath (exportStore opts) 1077 root <- resolveStoreTarget store target 1078 term <- loadExecutableObject store root 1079 let (rootIdx, nodes) = Runtime.exportDag term 1080 output = unlines $ 1081 show rootIdx : 1082 map (\(tag, refs) -> unwords (tag : map show refs)) nodes 1083 writeOutput out output 1084 [] -> die "tricu arboricx export --dag: exactly one --target is required" 1085 _ -> die "tricu arboricx export --dag: exactly one --target is required" 1086 1087 -- --------------------------------------------------------------------------- 1088 -- Helpers 1089 -- --------------------------------------------------------------------------- 1090 1091 treeTermRef :: ObjectHash -> ObjectRef 1092 treeTermRef = ObjectRef (unDomain treeTermDomain) 1093 1094 resolveStoreTarget :: StorePath -> String -> IO ObjectRef 1095 resolveStoreTarget store target = do 1096 mAlias <- readAlias store NameAlias (T.pack target) 1097 let root = maybe (T.pack target) objectRefHash mAlias 1098 present <- exportTreeTermPresent store root 1099 unless present $ die $ "Term not found in store: " ++ target 1100 case mAlias of 1101 Just ref -> pure ref -- The declared domain is binding; never guess on failure. 1102 Nothing -> do 1103 -- A bare digest has no declared kind. Sniff only the wire magic here; 1104 -- packing authenticates all bytes under the selected domain before decode. 1105 prefix <- withBinaryFile (objectPath store root) ReadMode (\h -> BS.hGet h 8) 1106 pure $ ObjectRef (unDomain $ if prefix == "ARBORICX" then indexedTreeDomain else treeTermDomain) root 1107 1108 resolveAllNameExports :: StorePath -> IO [(T.Text, ObjectRef)] 1109 resolveAllNameExports store = do 1110 aliases <- sortOn fst <$> listAliases store NameAlias 1111 fmap concat $ mapM exportAlias aliases 1112 where 1113 exportAlias (name, ref) 1114 | objectRefKind ref `notElem` map unDomain [treeTermDomain, indexedTreeDomain] = pure [] 1115 | otherwise = do 1116 present <- exportTreeTermPresent store (objectRefHash ref) 1117 if present then pure [(name, ref)] 1118 else die $ "Name alias tree term not found: " ++ T.unpack name 1119 1120 resolveModuleExports :: StorePath -> String -> IO [(T.Text, ObjectRef)] 1121 resolveModuleExports store moduleTarget = do 1122 manifestHash <- resolveModuleManifestHash store moduleTarget 1123 mManifest <- getManifest store manifestHash 1124 manifest <- case mManifest of 1125 Nothing -> die $ "Module manifest not found in store: " ++ moduleTarget 1126 Just value -> return value 1127 mapM exportEntry (moduleManifestExports manifest) 1128 where 1129 exportEntry ex = do 1130 let ref = moduleExportObject ex 1131 unless (objectRefKind ref `elem` map unDomain [treeTermDomain, indexedTreeDomain]) $ 1132 die $ "Unsupported module export object kind for " ++ T.unpack (moduleExportName ex) ++ ": " ++ T.unpack (objectRefKind ref) 1133 unless (moduleExportAbi ex == "arboricx.abi.tree.v1") $ die "Unsupported module export ABI" 1134 present <- exportTreeTermPresent store (objectRefHash ref) 1135 if present then return (moduleExportName ex, ref) 1136 else die $ "Module export tree term not found: " ++ T.unpack (moduleExportName ex) 1137 1138 exportTreeTermPresent :: StorePath -> ObjectHash -> IO Bool 1139 exportTreeTermPresent store root = do 1140 either (die . ("Invalid tree term hash: " ++)) (const (pure ())) (textToHashBytes root) 1141 doesFileExist (objectPath store root) 1142 1143 resolveModuleManifestHash :: StorePath -> String -> IO ObjectHash 1144 resolveModuleManifestHash store moduleTarget = do 1145 mAlias <- readAlias store ModuleAlias (T.pack moduleTarget) 1146 case mAlias of 1147 Just ref -> do 1148 unless (objectRefKind ref == unDomain manifestDomain) $ 1149 die $ "Module alias does not point at a module manifest: " ++ moduleTarget 1150 return (objectRefHash ref) 1151 Nothing -> return (T.pack moduleTarget) 1152 1153 formatObjectRef :: ObjectRef -> String 1154 formatObjectRef ref = T.unpack (objectRefKind ref) ++ " " ++ T.unpack (objectRefHash ref) 1155 1156 splitBundleFileName :: Int -> T.Text -> FilePath 1157 splitBundleFileName i name = show i ++ "-" ++ sanitize (T.unpack name) ++ ".arboricx" 1158 where 1159 sanitize [] = "export" 1160 sanitize xs = case map safeChar xs of 1161 [] -> "export" 1162 ys -> ys 1163 safeChar c 1164 | isAlphaNum c || c == '-' || c == '_' || c == '.' = c 1165 | otherwise = '_' 1166 1167 writeOutput :: FilePath -> String -> IO () 1168 writeOutput path content 1169 | null path = putStr content 1170 | otherwise = writeFile path content 1171 1172 -- Inspection reads only the selected artifact. The byte cap is enforced before 1173 -- decoding; output traversal limits do not pretend to bound validation heap. 1174 runInspect :: TricuArgs -> IO () 1175 runInspect (ArboricxInspect file name json depth count preview byteLimit) = 1176 (do 1177 when (byteLimit < 1 || byteLimit > 64 * 1024 * 1024) $ 1178 die "max-bytes must be between 1 and 67108864" 1179 status <- getFileStatus file 1180 unless (isRegularFile status) $ die "inspection requires a regular file" 1181 bytes <- withBinaryFile file ReadMode $ \h -> BS.hGet h (byteLimit + 1) 1182 when (BS.length bytes > byteLimit) $ die "bundle exceeds max-bytes" 1183 bundle <- either (die . T.unpack . Inspection.safeText . T.pack) pure (Wire.decodeBundle bytes) 1184 report <- either (die . T.unpack . Inspection.safeText . T.pack) pure $ 1185 Interaction.inspectBundle (Interaction.Limits depth count preview) (T.pack name) bundle 1186 let fingerprint = T.pack (show (hash bytes :: Digest SHA256)) 1187 if json then BL.putStr (JSON.encode (Interaction.reportJSON fingerprint report) <> "\n") 1188 else putStrLn ("bundle sha256 " ++ T.unpack fingerprint) >> 1189 putStr (T.unpack (Interaction.renderOutline report)) 1190 when (any (\o -> Interaction.occurrenceStatus o `elem` ["invalid", "unknown"]) (Interaction.occurrences report)) exitFailure 1191 ) `catch` (\(e :: IOException) -> die (T.unpack (Inspection.safeText (T.pack (show e))))) 1192 runInspect _ = die "invalid inspection invocation"