ScpCommand.hs (28995B)
1 -- Host orchestration only. Compilation, configuration and publication remain 2 -- exports of consumers.command; each phase runs in a bounded child process. 3 module ScpCommand (ScpCommand, scpCommands, runScpCommand, loadBootstrapExport) where 4 5 import qualified Data.Aeson as A 6 import qualified Data.ByteString as BS 7 import qualified Data.ByteString.Lazy as BL 8 import qualified Data.ByteString.Builder as B 9 import qualified Data.Map.Strict as M 10 import qualified Data.Text as Text 11 import qualified Data.Text.Encoding as TE 12 import Data.Char (isAscii, isAlpha, isAlphaNum, isDigit) 13 import Data.List (sort) 14 import Data.Void (Void) 15 import Control.Monad (foldM, forM, forM_, unless, when, void) 16 import Control.Exception (IOException, catch, bracketOnError, bracket) 17 import System.Directory hiding (executable) 18 import System.Environment (getExecutablePath) 19 import System.Exit 20 import System.FilePath 21 import System.IO 22 import System.IO.Temp (withSystemTempDirectory) 23 import System.Posix.IO (openFd, closeFd, OpenMode(ReadOnly), defaultFileFlags) 24 import System.Posix.Unistd (fileSynchronise) 25 import System.Process (proc, readCreateProcessWithExitCode) 26 import Options.Applicative hiding (value, action) 27 import qualified Options.Applicative as Opt 28 import qualified Text.Megaparsec as P 29 import qualified Text.Megaparsec.Char as C 30 import ContentStore (StorePath(..), Domain(..), hashObject, decodeTreeTerm) 31 import ContentStore.Filesystem (getObject) 32 import ContentStore.Object (unDomain) 33 import ContentStore.Alias (ObjectRef(..)) 34 import ContentStore.Arboricx (treeTermDomain, decodeTreeTermShared) 35 import ContentStore.Bundle (indexedTreeDomain, decodeIndexedTree) 36 import Module.Manifest 37 import Wire 38 import qualified Data.Vector as V 39 import IODriver (IOPermissions(..), runIO) 40 import Research (T(..), apply, ofString) 41 42 -- File spelling chooses transport, not the runtime meaning of a tree. 43 data Input = LeafInput | ByteFile FilePath | TreeFile FilePath | TreePin String 44 deriving Show 45 data Display = ResultDisplay | DecodeDisplay | TreeDisplay deriving (Show, Eq) 46 data RuntimeInput = RuntimeFile FilePath | RuntimeTree Input deriving Show 47 data Common = Common 48 { store :: FilePath, seconds :: Int, executable :: Maybe FilePath, bootstrap :: FilePath } 49 deriving Show 50 data Phase 51 = Build String FilePath String 52 | Configure String String Input Input 53 | BindEntry String String String Input 54 | PublishFile String String String 55 | Select String String 56 | RunFile String FilePath 57 | RunTree String String Input Display 58 deriving Show 59 data ScpCommand 60 = PhaseCommand Common Phase Bool 61 | Prepare Common FilePath FilePath (Maybe String) 62 | RunPrepared FilePath RuntimeInput Display Int (Maybe FilePath) 63 deriving Show 64 65 pinValid :: String -> Bool 66 pinValid s = length s == 64 && all (`elem` ("0123456789abcdef" :: String)) s 67 nameValid :: String -> Bool 68 nameValid [] = False 69 nameValid (x:xs) = isAscii x && isAlpha x && all (\c -> isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))) xs 70 checked :: String -> (String -> Bool) -> ReadM String 71 checked message predicate = eitherReader $ \s -> if predicate s then Right s else Left message 72 pinReader, nameReader, workspaceReader :: ReadM String 73 pinReader = checked "expected a lowercase SHA-256 pin" pinValid 74 nameReader = checked "expected a simple name" nameValid 75 workspaceReader = checked "expected a workspace name or pin" (\s -> nameValid s || pinValid s) 76 positive :: ReadM Int 77 positive = eitherReader $ \s -> case (reads s :: [(Integer, String)]) of 78 [(n, "")] | n > 0 && n <= 1200 -> Right (fromInteger n) 79 _ -> Left "expected seconds in 1..1200" 80 commonParser :: Parser Common 81 commonParser = Common 82 <$> strOption (long "store" <> metavar "PATH") 83 <*> option positive (long "seconds" <> metavar "N") 84 <*> optional (strOption (long "tricu" <> metavar "EXECUTABLE" <> help "Explicit child runner (defaults to this executable)")) 85 <*> strOption (long "bootstrap" <> metavar "DIRECTORY" <> Opt.value "." <> help "Directory containing verified compiler-bootstrap.arboricx and scp-bootstrap.arboricx artifacts") 86 inputParser :: String -> Parser Input 87 inputParser field = 88 flag' LeafInput (long (field ++ "-leaf")) 89 <|> ByteFile <$> strOption (long (field ++ "-file") <> metavar "FILE") 90 <|> TreeFile <$> strOption (long (field ++ "-tree-file") <> metavar "FILE") 91 <|> TreePin <$> option pinReader (long (field ++ "-tree-pin") <> metavar "HASH") 92 treeInputParser :: Parser Input 93 treeInputParser = TreeFile <$> strOption (long "input-tree-file" <> metavar "FILE") 94 <|> TreePin <$> option pinReader (long "input-tree-pin" <> metavar "HASH") 95 displayParser :: Parser Display 96 displayParser = option (eitherReader $ \s -> case s of 97 "result" -> Right ResultDisplay 98 "decode" -> Right DecodeDisplay 99 "tree" -> Right TreeDisplay 100 _ -> Left "expected result, decode or tree") 101 (long "format" <> Opt.value ResultDisplay <> metavar "FORM") 102 pinOption, nameOption :: String -> Parser String 103 pinOption field = option pinReader (long field <> metavar "HASH") 104 nameOption field = option nameReader (long field <> metavar "NAME") 105 106 scpCommands :: (ScpCommand -> a) -> Mod CommandFields a 107 scpCommands wrap = mconcat 108 [ phase "build" (Build <$> option workspaceReader (long "workspace" <> metavar "MODULE") 109 <*> strOption (long "directory" <> metavar "PATH") <*> pinOption "compiler") 110 , phase "configure" (Configure <$> pinOption "code" <*> nameOption "entry" <*> inputParser "input" <*> inputParser "state") 111 , phase "configure-entry" (BindEntry <$> pinOption "code" <*> nameOption "entry" <*> nameOption "name" <*> inputParser "state") 112 , phase "file" (PublishFile <$> pinOption "invocations" <*> nameOption "entry" <*> nameOption "label") 113 , phase "select" (Select <$> pinOption "invocations" <*> nameOption "entry") 114 , phase "run-file" (RunFile <$> pinOption "manifest" <*> strOption (long "input-file" <> metavar "FILE")) 115 , phase "run-tree" (RunTree <$> pinOption "manifest" <*> nameOption "entry" <*> treeInputParser <*> displayParser) 116 , command "prepare" $ info (wrap <$> (Prepare <$> commonParser 117 <*> argument str (metavar "PROJECT") <*> strOption (long "output" <> metavar "RECORD") 118 <*> optional (pinOption "compiler")) <**> helper) (progDesc "Build, configure and pin a project") 119 , command "run" $ info (wrap <$> (RunPrepared <$> argument str (metavar "RECORD") 120 <*> (RuntimeFile <$> strOption (long "input-file" <> metavar "FILE") <|> RuntimeTree <$> treeInputParser) 121 <*> displayParser <*> option positive (long "seconds" <> metavar "N") 122 <*> optional (strOption (long "tricu" <> metavar "EXECUTABLE"))) <**> helper) 123 (progDesc "Invoke a prepared selection without source or rebuilding") 124 ] 125 where 126 phase label parser = command label $ info 127 (wrap <$> (PhaseCommand <$> commonParser <*> parser 128 <*> switch (long "worker" <> internal)) <**> helper) (progDesc $ "SCP " ++ label ++ " phase") 129 130 runScpCommand :: ScpCommand -> IO () 131 runScpCommand request = dispatch request `catch` (\(e :: IOException) -> die $ "scp: " ++ show e) 132 where 133 dispatch (PhaseCommand common phase True) = worker common phase 134 dispatch (PhaseCommand common phase False) = do 135 fields <- launch common phase 136 forM_ (M.toList fields) $ \(key, value) -> putStrLn $ key ++ "=" ++ value 137 dispatch (Prepare common path output compiler) = prepare common path output compiler 138 dispatch (RunPrepared path input display bound runner) = runPrepared path input display bound runner 139 140 runnerPath :: Maybe FilePath -> IO FilePath 141 runnerPath selected = canonicalizePath =<< maybe getExecutablePath pure selected 142 absoluteCommon :: Common -> IO Common 143 absoluteCommon common = do 144 root <- canonicalizePath (bootstrap common) 145 cas <- canonicalizePath (store common) 146 exe <- runnerPath (executable common) 147 pure common { store = cas, bootstrap = root, executable = Just exe } 148 149 bootstrapRoot :: FilePath -> IO FilePath 150 bootstrapRoot context = do 151 root <- canonicalizePath context 152 forM_ ["compiler-bootstrap.arboricx", "scp-bootstrap.arboricx"] $ \name -> do 153 exists <- doesFileExist (root </> name) 154 unless exists $ die "SCP preparation requires an artifact bootstrap directory; select --bootstrap DIRECTORY" 155 pure root 156 157 -- Full verified artifacts, not a source loader or a selected-function facade. 158 bootstrapExports :: FilePath -> IO (M.Map String T) 159 bootstrapExports root = do 160 rows <- fmap concat $ forM ["compiler-bootstrap.arboricx", "scp-bootstrap.arboricx"] $ \name -> do 161 bytes <- BS.readFile (root </> name) 162 bundle <- either die pure (decodeBundle bytes) 163 either die pure (verifyBundle bundle) 164 let terms = reconstructBundleTerms (bundleNodes bundle) 165 forM (manifestExports $ bundleManifest bundle) $ \exported -> do 166 unless (exportKind exported == "term" && exportAbi exported == "arboricx.abi.tree.v1") $ 167 die "SCP bootstrap exports require the tree ABI" 168 pure (Text.unpack $ exportName exported, terms V.! fromIntegral (exportRoot exported)) 169 let exports = M.fromList rows 170 unless (M.size exports == length rows) $ die "Duplicate SCP bootstrap export names" 171 pure exports 172 173 loadBootstrapExport :: FilePath -> String -> String -> IO T 174 loadBootstrapExport directory target name = do 175 root <- bootstrapRoot directory 176 exports <- bootstrapExports root 177 let flat c = if c == '.' || c == '-' then '_' else c 178 maybe (die $ "SCP bootstrap export not found: " ++ target ++ "." ++ name) pure 179 (M.lookup (map flat target ++ "." ++ name) exports) 180 181 -- Explicit pinned workspace selection uses verified transport, never source. 182 loadPinnedWorkspace :: FilePath -> String -> String -> IO T 183 loadPinnedWorkspace cas pin name = do 184 let require domain digest = do 185 payload <- getObject (StorePath cas) digest >>= maybe (die "Missing pinned SCP workspace object") pure 186 unless (hashObject domain payload == digest) $ die "Pinned SCP workspace digest mismatch" 187 pure payload 188 bytes <- require manifestDomain (Text.pack pin) 189 manifest <- either die pure (decodeManifest bytes) 190 exported <- case filter ((== Text.pack name) . moduleExportName) (moduleManifestExports manifest) of 191 [entry] -> pure entry 192 _ -> die "Pinned SCP workspace requires exactly one selected export" 193 unless (moduleExportAbi exported == "arboricx.abi.tree.v1") $ die "Pinned SCP workspace requires the tree ABI" 194 let ref = moduleExportObject exported 195 domain <- if objectRefKind ref == unDomain treeTermDomain then pure treeTermDomain 196 else if objectRefKind ref == unDomain indexedTreeDomain then pure indexedTreeDomain 197 else die "Unsupported pinned SCP workspace tree kind" 198 payload <- require domain (objectRefHash ref) 199 either die pure ((if domain == indexedTreeDomain then decodeIndexedTree else decodeTreeTermShared) payload) 200 201 phaseName :: Phase -> String 202 phaseName phase = case phase of 203 Build {} -> "build" 204 Configure {} -> "configure" 205 BindEntry {} -> "configure-entry" 206 PublishFile {} -> "file" 207 Select {} -> "select" 208 RunFile {} -> "run-file" 209 RunTree {} -> "run-tree" 210 inputArgs :: String -> Input -> [String] 211 inputArgs field input = case input of 212 LeafInput -> ["--" ++ field ++ "-leaf"] 213 ByteFile path -> ["--" ++ field ++ "-file", path] 214 TreeFile path -> ["--" ++ field ++ "-tree-file", path] 215 TreePin pin -> ["--" ++ field ++ "-tree-pin", pin] 216 phaseArgs :: Phase -> [String] 217 phaseArgs phase = case phase of 218 Build workspace directory compiler -> ["--workspace", workspace, "--directory", directory, "--compiler", compiler] 219 Configure code entry input state -> ["--code", code, "--entry", entry] ++ inputArgs "input" input ++ inputArgs "state" state 220 BindEntry code entry name state -> ["--code", code, "--entry", entry, "--name", name] ++ inputArgs "state" state 221 PublishFile manifest entry label -> ["--invocations", manifest, "--entry", entry, "--label", label] 222 Select manifest entry -> ["--invocations", manifest, "--entry", entry] 223 _ -> [] 224 -- File data is snapshotted before child execution. Paths travel as argv values. 225 snapshot :: FilePath -> String -> Input -> IO Input 226 snapshot scratch name input = case input of 227 ByteFile path -> copy ByteFile path 228 TreeFile path -> copy TreeFile path 229 _ -> pure input 230 where 231 copy constructor path = do 232 bytes <- BS.readFile path 233 let target = scratch </> name 234 BS.writeFile target bytes 235 pure $ constructor target 236 snapshotPhase :: FilePath -> Phase -> IO Phase 237 snapshotPhase scratch phase = case phase of 238 Build workspace directory compiler -> Build workspace <$> canonicalizePath directory <*> pure compiler 239 Configure code entry input state -> Configure code entry <$> snapshot scratch "input" input <*> snapshot scratch "state" state 240 BindEntry code entry name state -> BindEntry code entry name <$> snapshot scratch "state" state 241 _ -> pure phase 242 243 -- timeout owns the process deadline and the TERM/KILL escalation, as before. 244 bounded :: Int -> FilePath -> [String] -> IO (ExitCode, String) 245 bounded bound exe args = do 246 (status, out, err) <- readCreateProcessWithExitCode 247 (proc "timeout" (["--kill-after=5s", show bound, exe] ++ args ++ ["+RTS", "-N1", "-M48g", "-RTS"])) "" 248 unless (null err) $ hPutStr stderr err 249 pure (status, out) 250 expect :: String -> Int -> ExitCode -> String -> String -> [String] -> IO (M.Map String String) 251 expect phase bound status output marker keys = do 252 let failPhase message = do 253 hPutStr stderr output 254 hPutStrLn stderr $ phase ++ ": " ++ message ++ " (deadline " ++ show bound ++ "s)" 255 exitWith $ case status of ExitFailure n | n > 0 -> ExitFailure n; _ -> ExitFailure 1 256 unless (status == ExitSuccess && marker `elem` lines output) $ failPhase "failed or missing success marker" 257 fields <- forM keys $ \key -> case [drop (length key + 1) line | line <- lines output, (key ++ "=") `prefix` line] of 258 [value] | pinValid value -> pure (key, value) 259 _ -> failPhase ("missing, duplicate or invalid " ++ key ++ " output") >> pure (key, "") 260 pure $ M.fromList fields 261 where prefix a b = take (length a) b == a 262 launch :: Common -> Phase -> IO (M.Map String String) 263 launch original phase = do 264 common <- absoluteCommon original 265 exe <- runnerPath (executable common) 266 case phase of 267 RunFile manifest path -> do 268 target <- canonicalizePath path 269 runNative common exe ["--module", manifest, "--name", "processFile", "--arg", target, 270 "--io", "--allow-read", target, "--format", "decode"] 271 RunTree manifest entry input display -> do 272 arguments <- case input of 273 TreeFile path -> do target <- canonicalizePath path; pure ["--arg-tree-file", target] 274 TreePin pin -> pure ["--arg-tree-pin", pin] 275 _ -> die "run-tree requires an exact tree transport" 276 runNative common exe $ ["--module", manifest, "--name", entry] ++ arguments ++ case display of 277 ResultDisplay -> ["--result", "--format", "decode"] 278 DecodeDisplay -> ["--format", "decode"] 279 TreeDisplay -> ["--format", "tree"] 280 _ -> withSystemTempDirectory "scp-phase-" $ \scratch -> do 281 root <- bootstrapRoot (bootstrap common) 282 selected <- snapshotPhase scratch phase 283 let args = ["scp", phaseName selected, "--worker", "--store", store common, 284 "--bootstrap", root, "--seconds", show (seconds common)] ++ phaseArgs selected 285 (marker, keys) = case selected of 286 Build {} -> ("code-build-ok", ["code-manifest", "code-receipt"]) 287 Configure {} -> configured 288 BindEntry {} -> configured 289 PublishFile {} -> ("file-build-ok", ["file-manifest"]) 290 Select {} -> ("invocation-ready", ["invocations"]) 291 _ -> error "unreachable phase" 292 configured = ("configuration-ok", ["workers", "invocations", "configuration-receipt"]) 293 (status, output) <- bounded (seconds common) exe args 294 expect (phaseName phase) (seconds common) status output marker keys 295 where 296 runNative common exe args = do 297 (status, output) <- bounded (seconds common) exe (["arboricx", "run", "--store", store common] ++ args) 298 putStr output 299 unless (status == ExitSuccess) $ exitWith status 300 pure M.empty 301 302 -- These calls apply exported trees directly; no generated source/probe files. 303 worker :: Common -> Phase -> IO () 304 worker common phase = do 305 root <- canonicalizePath (bootstrap common) 306 cas <- canonicalizePath (store common) 307 createDirectoryIfMissing True cas 308 exports <- bootstrapExports root 309 let load target name | pinValid target = loadPinnedWorkspace cas target name 310 load target name = case M.lookup (map flat target ++ "." ++ name) exports of 311 Just term -> pure term 312 Nothing -> die $ "SCP bootstrap export not found: " ++ target ++ "." ++ name 313 flat c = if c == '.' || c == '-' then '_' else c 314 invoke name arguments = do 315 code <- load "consumers.command" name 316 outcome <- runIO (IOPermissions [] [] True True) (foldl apply code arguments) 317 either (die . ("scp phase IO error: " ++)) (const $ pure ()) outcome 318 text = ofString 319 action input = case input of 320 LeafInput -> pure $ pureOk Leaf 321 ByteFile path -> pureOk . ofString . Text.unpack . TE.decodeLatin1 <$> BS.readFile path 322 TreeFile path -> do 323 bytes <- BS.readFile path 324 value <- either (die . ("configuration-error: " ++)) pure (decodeTreeTerm bytes) 325 pure $ pureOk value 326 TreePin pin -> do 327 get <- load "source.object" "sourceObjectGetTree" 328 pure $ apply (apply get (text cas)) (text pin) 329 case phase of 330 Build workspace directory compiler -> do 331 request <- load workspace "request" 332 absolute <- canonicalizePath directory 333 invoke "build" [text cas, apply (apply request (text absolute)) (text compiler)] 334 Configure code entry input state -> do 335 inputAction <- action input 336 stateAction <- action state 337 invoke "configure" [text cas, text code, text entry, inputAction, stateAction] 338 BindEntry code entry name state -> do 339 stateAction <- action state 340 invoke "bindEntry" [text cas, text code, text entry, text name, stateAction] 341 PublishFile manifest entry label -> invoke "publishFile" [text cas, text manifest, text entry, text label] 342 Select manifest entry -> invoke "selectInvocation" [text cas, text manifest, text entry] 343 _ -> die "runtime phases use native CAS execution" 344 where 345 pureOk value = Fork Leaf (Fork (Stem Leaf) (Fork value Leaf)) 346 347 -- Strict JSON parsing retains duplicate-key rejection at every object depth. 348 -- Aeson handles the string escape/unicode grammar; our object parser owns keys. 349 data Json = Object (M.Map String Json) | String String | Boolean Bool 350 | Null | Array [Json] | Number String deriving Show 351 type JsonParser = P.Parsec Void String 352 jsonParser :: JsonParser Json 353 jsonParser = space *> value <* P.eof 354 where 355 space = P.skipMany (P.oneOf (" \t\r\n" :: String)) 356 token parser = parser <* space 357 string = do 358 (raw, _) <- P.match $ C.char '"' *> P.manyTill 359 (void (C.char '\\' *> P.anySingle) <|> void (P.satisfy (\c -> c /= '"' && c >= ' '))) (C.char '"') 360 case A.eitherDecodeStrict' (TE.encodeUtf8 $ Text.pack raw) of 361 Left problem -> fail problem 362 Right s -> pure s 363 value = token $ P.choice 364 [ Object <$> object, String <$> string, Boolean True <$ C.string "true" 365 , Boolean False <$ C.string "false", Null <$ C.string "null" 366 , Array <$> (C.char '[' *> space *> P.sepBy value (token $ C.char ',') <* C.char ']') 367 , do raw <- P.some (P.satisfy (\c -> isDigit c || c `elem` ("-.eE+" :: String))) 368 case (A.eitherDecodeStrict' (TE.encodeUtf8 $ Text.pack raw) :: Either String A.Value) of 369 Right (A.Number _) -> pure $ Number raw 370 _ -> fail "invalid JSON number" 371 ] 372 object = do 373 pairs <- C.char '{' *> space *> P.sepBy 374 ((,) <$> token string <* token (C.char ':') <*> value) (token $ C.char ',') <* C.char '}' 375 foldM (\seen (key, item) -> if M.member key seen 376 then fail $ "duplicate declaration key: " ++ key else pure $ M.insert key item seen) M.empty pairs 377 loadJson :: FilePath -> IO Json 378 loadJson path = do 379 bytes <- BS.readFile path 380 source <- either (die . show) pure $ TE.decodeUtf8' bytes 381 either (die . P.errorBundlePretty) pure $ P.parse jsonParser path (Text.unpack source) 382 objectFields :: String -> [String] -> Json -> IO (M.Map String Json) 383 objectFields label keys json = case json of 384 Object fields | sort keys == M.keys fields -> pure fields 385 _ -> die $ label ++ ": expected exactly " ++ unwords keys 386 getField :: M.Map String Json -> String -> Json 387 getField fields key = fields M.! key 388 stringValue :: String -> Json -> IO String 389 stringValue _ (String s) | not (null s) = pure s 390 stringValue label _ = die $ label ++ ": expected nonempty text" 391 validated :: String -> (String -> Bool) -> Json -> IO String 392 validated label predicate value = do 393 s <- stringValue label value 394 unless (predicate s) $ die $ "invalid " ++ label 395 pure s 396 version :: String -> Json -> IO () 397 version expected value = do 398 actual <- stringValue "version" value 399 unless (actual == expected) $ die "unsupported declaration version" 400 401 -- Snapshots are taken before starting any build and before publishing a record. 402 projectData :: FilePath -> FilePath -> String -> Json -> IO Input 403 projectData base scratch label value = case value of 404 Object fields -> case M.toList fields of 405 [("leaf", Boolean True)] -> pure LeafInput 406 [("text", String s)] -> bytes ByteFile $ TE.encodeUtf8 (Text.pack s) 407 [("file", path)] -> stringValue label path >>= BS.readFile . (base </>) >>= bytes ByteFile 408 [("tree-file", path)] -> stringValue label path >>= BS.readFile . (base </>) >>= bytes TreeFile 409 [("tree-pin", pin)] -> TreePin <$> validated "tree pin" pinValid pin 410 _ -> bad 411 _ -> bad 412 where 413 bad = die $ label ++ ": declare leaf, text, file, tree-file or tree-pin" 414 bytes constructor payload = do 415 let path = scratch </> label 416 BS.writeFile path payload 417 pure $ constructor path 418 -- The executable now contains the host launcher. Length-frame its bytes, 419 -- complete verified artifact bytes for a conservative identity. 420 compilerIdentity :: Common -> IO String 421 compilerIdentity common = do 422 exe <- runnerPath (executable common) 423 chunks <- mapM BS.readFile [exe, bootstrap common </> "compiler-bootstrap.arboricx", 424 bootstrap common </> "scp-bootstrap.arboricx"] 425 let framed = BL.toStrict $ B.toLazyByteString $ mconcat 426 [B.word64BE (fromIntegral $ BS.length bytes) <> B.byteString bytes | bytes <- chunks] 427 pure $ Text.unpack $ hashObject (Domain "scp-launcher-compiler.v3") framed 428 atomicRecord :: FilePath -> M.Map String String -> IO () 429 atomicRecord path fields = do 430 createDirectoryIfMissing True (takeDirectory path) 431 bracketOnError (openBinaryTempFile (takeDirectory path) ".scp-prepared-") 432 (\(temporary, handle) -> do 433 hClose handle `catch` (\(_ :: IOException) -> pure ()) 434 removeFile temporary `catch` (\(_ :: IOException) -> pure ())) 435 (\(temporary, handle) -> do 436 BL.hPut handle (A.encode fields) 437 hPutStrLn handle "" 438 hFlush handle 439 hClose handle 440 bracket (openFd temporary ReadOnly defaultFileFlags) closeFd fileSynchronise 441 renameFile temporary path) 442 443 -- Unlike filepath's makeRelative, this also represents sibling stores with .. . 444 relativeStore :: FilePath -> FilePath -> FilePath 445 relativeStore base target = case strip (splitDirectories base) (splitDirectories target) of 446 ([], []) -> "." 447 (left, right) -> joinPath (replicate (length left) ".." ++ right) 448 where 449 strip (a:as) (b:bs) | a == b = strip as bs 450 strip as bs = (as, bs) 451 452 prepare :: Common -> FilePath -> FilePath -> Maybe String -> IO () 453 prepare original projectPath outputPath override = withSystemTempDirectory "scp-project-" $ \scratch -> do 454 baseCommon <- absoluteCommon original 455 root <- bootstrapRoot (bootstrap baseCommon) 456 let common = baseCommon { bootstrap = root } 457 path <- canonicalizePath projectPath 458 output <- canonicalizePath outputPath 459 when (path == output) $ die "deployment output must not overwrite the project declaration" 460 project <- loadJson path >>= objectFields "project" ["version", "name", "workspace", "directory", "configuration", "presentation"] 461 version "scp-project.v1" (getField project "version") 462 program <- validated "program name" nameValid (getField project "name") 463 workspace <- validated "workspace" (\s -> nameValid s || pinValid s) (getField project "workspace") 464 directory <- stringValue "directory" (getField project "directory") >>= canonicalizePath . (takeDirectory path </>) 465 let configuration = getField project "configuration" 466 binding = case configuration of Object fields -> M.member "bind" fields; _ -> False 467 config <- objectFields "configuration" (if binding then ["bind", "state"] else ["entry", "input", "state"]) configuration 468 entry <- validated "configuration entry" nameValid (getField config $ if binding then "bind" else "entry") 469 let presentation = getField project "presentation" 470 profile <- case presentation of 471 Object fields -> maybe (die "missing presentation profile") (stringValue "profile") (M.lookup "profile" fields) 472 _ -> die "invalid presentation" 473 unless (profile == fileProfile || profile == treeProfile) $ die "unsupported presentation profile" 474 selected <- objectFields "presentation" (if profile == fileProfile then ["profile", "entry", "label"] else ["profile", "entry"]) presentation 475 name <- validated "invocation entry" nameValid (getField selected "entry") 476 label <- if profile == fileProfile then validated "presentation label" nameValid (getField selected "label") else pure "" 477 input <- if binding then pure LeafInput else projectData (takeDirectory path) scratch "input" (getField config "input") 478 state <- projectData (takeDirectory path) scratch "state" (getField config "state") 479 compiler <- maybe (compilerIdentity common) pure override 480 let phase operation = do 481 hPutStrLn stderr $ program ++ ": " ++ phaseName operation 482 launch common operation `catch` (\(code :: ExitCode) -> do 483 hPutStrLn stderr $ program ++ ": preparation stopped at " ++ phaseName operation ++ "; deployment record unchanged." 484 exitWith code) 485 built <- phase $ Build workspace directory compiler 486 configured <- phase $ if binding 487 then BindEntry (built M.! "code-manifest") entry name state 488 else Configure (built M.! "code-manifest") entry input state 489 published <- phase $ if profile == fileProfile 490 then PublishFile (configured M.! "invocations") name label else Select (configured M.! "invocations") name 491 let selection = M.fromList $ [("version", "scp-prepared.v1"), ("name", program), ("profile", profile), 492 ("store", relativeStore (takeDirectory output) (store common)), ("compiler", compiler)] ++ 493 [("entry", name) | profile == treeProfile] 494 atomicRecord output $ M.unions [selection, built, configured, published] 495 putStrLn $ "prepared=" ++ output 496 497 fileProfile, treeProfile :: String 498 fileProfile = "scp.file-lines.result.v1" 499 treeProfile = "scp-invocation.result.v1" 500 pins :: [String] 501 pins = ["code-manifest", "code-receipt", "workers", "invocations", "configuration-receipt"] 502 runPrepared :: FilePath -> RuntimeInput -> Display -> Int -> Maybe FilePath -> IO () 503 runPrepared recordPath input display bound runner = do 504 path <- canonicalizePath recordPath 505 json <- loadJson path 506 profile <- case json of 507 Object fields -> maybe (die "missing prepared profile") (stringValue "profile") (M.lookup "profile" fields) 508 _ -> die "invalid prepared record" 509 unless (profile == fileProfile || profile == treeProfile) $ die "unsupported prepared version/profile" 510 fields <- objectFields "prepared record" 511 (["version", "name", "profile", "store", "compiler"] ++ pins ++ if profile == fileProfile then ["file-manifest"] else ["entry"]) json 512 version "scp-prepared.v1" (getField fields "version") 513 program <- validated "program name" nameValid (getField fields "name") 514 forM_ ("compiler" : pins ++ ["file-manifest" | profile == fileProfile]) $ \key -> 515 void $ validated key pinValid (getField fields key) 516 cas <- stringValue "store" (getField fields "store") >>= canonicalizePath . (takeDirectory path </>) 517 operation <- case (profile == treeProfile, input) of 518 (True, RuntimeTree value) -> RunTree <$> stringValue "invocations" (getField fields "invocations") 519 <*> validated "invocation entry" nameValid (getField fields "entry") <*> pure value <*> pure display 520 (False, RuntimeFile file) | display /= TreeDisplay -> RunFile <$> stringValue "file-manifest" (getField fields "file-manifest") <*> pure file 521 (True, _) -> die "direct invocation requires --input-tree-file or --input-tree-pin" 522 _ -> die "file presentation requires --input-file and owns its display" 523 hPutStrLn stderr $ program ++ ": run" 524 void $ launch (Common cas bound runner ".") operation