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