ConsoleExe.hs (24674B)
1 -- Copyright 2023 The Plunder Authors 2 -- Use of this source code is governed by a BSD-style license that can be 3 -- found in the LICENSE file. 4 5 {-# OPTIONS_GHC -Wall #-} 6 {-# OPTIONS_GHC -Werror #-} 7 {-# LANGUAGE NoFieldSelectors #-} 8 {-# LANGUAGE Strict #-} 9 10 module Server.ConsoleExe (main) where 11 12 import Data.Acquire 13 import Fan.Convert 14 import GHC.IO.Encoding 15 import Options.Applicative 16 import PlunderPrelude hiding (Handler, handle) 17 import Server.Debug 18 import Server.Evaluator 19 import Server.Machine 20 import Server.Types.Logging 21 import System.Environment 22 import System.Posix.Signals hiding (Handler) 23 import System.Process 24 25 import Server.Hardware.Http (createHardwareHttp) 26 import Server.Hardware.Port (createHardwarePort) 27 import Server.Hardware.Rand (createHardwareRand) 28 import Server.Hardware.Types (DeviceTable(..)) 29 import System.Random (randomIO) 30 -- ort Server.Hardware.Sock (createHardwareSock) 31 import Server.Hardware.Time (createHardwareTime) 32 -- ort Server.Hardware.Wock (createHardwareWock) 33 import Server.Hardware.Poke (createHardwarePoke) 34 35 import Control.Concurrent (threadDelay) 36 import Control.Monad.State (State, execState, modify') 37 import Data.Time.Format.ISO8601 (iso8601Show) 38 import Fan.Hash (fanHash) 39 import Hash256 (hashToBTC) 40 import Loot.ReplExe (showFan, trkFan, trkRex) 41 import Sire.Types (trkRexM) 42 import System.Directory (createDirectoryIfMissing, doesFileExist, 43 getHomeDirectory, removeFile) 44 import System.Exit (ExitCode(..), exitWith) 45 import System.IO.Error (catchIOError) 46 import System.Posix.Types (CPid(CPid)) 47 48 import qualified Loot.ReplExe 49 import qualified Rex 50 import qualified Sire 51 52 import qualified Data.ByteString as BS 53 import qualified Data.Char as C 54 import qualified Data.Map as M 55 import qualified Fan as F 56 import qualified Fan.Prof as Prof 57 import qualified Fan.Seed as F 58 import qualified Fan.Types as F 59 import qualified Server.LmdbStore as DB 60 import qualified Server.AgentMachine as AMach 61 62 -------------------------------------------------------------------------------- 63 64 safeDeleteFile :: FilePath -> IO () 65 safeDeleteFile pax = catchIOError (removeFile pax) (const $ pure ()) 66 67 getPidFile :: Debug => FilePath -> Acquire FilePath 68 getPidFile storeDir = 69 mkAcquire start safeDeleteFile 70 where 71 start = do 72 createDirectoryIfMissing True storeDir 73 pid <- getCurrentPid 74 let pax = (storeDir </> "pid") 75 debugVal "pidfile" (pack pax :: Text) 76 exists <- doesFileExist pax 77 when exists $ do 78 debugFan "pidfile_exists" 79 pidTxt <- readFileUtf8 pax 80 case readMay pidTxt of 81 Nothing -> do 82 debug (["malformed_pidfile","overwriting"] :: [Text]) 83 pure () 84 Just alien -> do 85 debug [ "found_existing_daemon" 86 , "killing_id" :: Text 87 ] 88 89 let killIt = do 90 signalProcess sigTERM alien 91 debugText "waiting_for_alien_shut_down" 92 loop 0 93 loop (1000::Int) = do 94 debugText "failed_to_kill_daemon" 95 exitWith (ExitFailure 1) 96 loop i = doesFileExist pax >>= \case 97 True -> threadDelay 10_000 >> loop (i+1) 98 False -> pure () 99 100 catchIOError killIt \exn -> 101 if isDoesNotExistError exn then 102 debugText "daemon_not_actually_running" 103 else 104 throwIO exn 105 debugFan "old_daemon_killed" 106 107 debugFan "write_pidfile" 108 writeFileUtf8 pax (tshow (coerce pid :: Int32)) 109 pure pax 110 111 withDirectoryWriteLock :: Debug => FilePath -> IO a -> IO a 112 withDirectoryWriteLock storeDir a = 113 with (getPidFile storeDir) $ \_ -> a 114 115 -------------------------------------------------------------------------------- 116 117 type Prof = Maybe FilePath 118 119 data ProfilingOpts = ProfilingOpts Prof Bool 120 121 data InterpreterOpts 122 = InterpreterOpts Bool -- Warn on jet deopt 123 Bool -- Crash on jet deopt 124 Bool -- Crash on jet mistmatch 125 126 data MachineOpts 127 = MachineOpts Bool -- snapshots enabled? 128 Int -- Number of EVAL workers 129 130 data RunType 131 = RTSire FilePath 132 ProfilingOpts 133 InterpreterOpts 134 [FilePath] -- SireFile 135 | RTSave ProfilingOpts 136 InterpreterOpts 137 FilePath -- Seed file 138 FilePath -- SireFile 139 | RTShow FilePath 140 | RTRepl FilePath FilePath InterpreterOpts 141 | RTLoot FilePath ProfilingOpts [FilePath] 142 | RTBoot ProfilingOpts InterpreterOpts MachineOpts Bool FilePath Text 143 | RTUses FilePath Int 144 | RTOpen FilePath CogId 145 | RTTerm FilePath CogId 146 -- TODO: Rename 'run' or 'spin' or 'crank' or something. 147 | RTStart FilePath 148 ProfilingOpts 149 InterpreterOpts 150 MachineOpts 151 ReplayFrom 152 -- | RTPoke FilePath Text FilePath 153 154 cogIdArg :: Parser CogId 155 cogIdArg = COG_ID <$> argument auto (metavar "COG" <> help helpTxt) 156 where 157 helpTxt = "The cog id number" 158 159 replayFromOption :: Parser ReplayFrom 160 replayFromOption = 161 flag LatestSnapshot EarliestSnapshot 162 ( long "replay-all" 163 <> help "Replay log from beginning." 164 ) 165 166 bootHashArg :: Parser Text 167 bootHashArg = strArgument 168 ( metavar "HASH" 169 <> help "Boot using this sire file (or pin hash)" 170 ) 171 172 sireFile :: Parser FilePath 173 sireFile = 174 strArgument (metavar "SIRE" <> help helpTxt) 175 where 176 helpTxt = "A sire file to load before launching the REPL" 177 178 seedFile :: Parser FilePath 179 seedFile = 180 strArgument (metavar "SEED" <> help helpTxt) 181 where 182 helpTxt = "The seed file to write the result to" 183 184 lootFile :: Parser FilePath 185 lootFile = 186 strArgument (metavar "LOOT" <> help helpTxt) 187 where 188 helpTxt = "A loot file to load before starting the REPL" 189 190 plunderCmd :: String -> String -> Parser a -> Mod CommandFields a 191 plunderCmd cmd desc parser = 192 command cmd (info (parser <**> helper) (progDesc desc)) 193 194 runType :: FilePath -> Parser RunType 195 runType defaultDir = subparser 196 ( plunderCmd "term" "Connect to the terminal of a cog." 197 (RTTerm <$> storeOpt 198 <*> cogIdArg) 199 200 <> plunderCmd "open" "Open a terminal's GUI interface." 201 (RTOpen <$> storeOpt 202 <*> cogIdArg) 203 204 <> plunderCmd "sire" "Run a standalone Sire repl." 205 (RTSire <$> storeOpt 206 <*> profilingOpts 207 <*> interpreterOpts 208 <*> many sireFile) 209 210 <> plunderCmd "save" "Load a sire file and save a seed." 211 (RTSave <$> profilingOpts 212 <*> interpreterOpts 213 <*> seedFile 214 <*> sireFile) 215 216 <> plunderCmd "show" "Print a seed file." 217 (RTShow <$> seedFile) 218 219 <> plunderCmd "repl" "Interact with a seed file." 220 (RTRepl <$> seedFile 221 <*> replWriteOpt 222 <*> interpreterOpts) 223 224 <> plunderCmd "start" "Resume an idle machine." 225 (RTStart <$> storeArg 226 <*> profilingOpts 227 <*> interpreterOpts 228 <*> machineOpts 229 <*> replayFromOption) 230 231 <> plunderCmd "loot" "Run a standalone sire repl." 232 (RTLoot <$> storeOpt <*> profilingOpts <*> many lootFile) 233 234 <> plunderCmd "boot" "Boot a machine." 235 (RTBoot <$> profilingOpts 236 <*> interpreterOpts 237 <*> machineOpts 238 <*> startAtBoot 239 <*> storeArg 240 <*> bootHashArg) 241 242 <> plunderCmd "du" "du -ab compatible output for pin state." 243 (RTUses <$> storeArg <*> numWorkers) 244 245 -- <> plunderCmd "poke" "Pokes a started cog with a value." 246 -- -- TODO: should pokePath parse the '/' instead? 247 -- (RTPoke <$> storeOpt <*> pokePath 248 -- <*> pokeSire) 249 ) 250 where 251 -- pokePathHelp = help "Path to send data on" 252 -- pokeSireHelp = help "Sire file to parse and send" 253 storeHlp = help "Location of plunder data" 254 profHelp = help "Where to output profile traces (JSON)" 255 storeArg = strArgument (metavar "STORE" <> storeHlp) 256 257 profilingOpts = ProfilingOpts <$> profOutput <*> profLaw 258 interpreterOpts = InterpreterOpts <$> doptWarn <*> doptCrash <*> matchCrash 259 machineOpts = MachineOpts <$> doSnap <*> numWorkers 260 261 storeOpt = 262 strOption ( long "store" 263 <> value defaultDir 264 <> short 'd' 265 <> metavar "STORE" 266 <> storeHlp 267 ) 268 269 -- pokePath = strArgument (metavar "PATH" <> pokePathHelp) 270 -- pokeSire = strArgument (metavar "SIRE" <> pokeSireHelp) 271 272 profLaw :: Parser Bool 273 profLaw = switch ( short 'P' 274 <> long "profile-laws" 275 <> help "Include law-execution in profile traces." 276 ) 277 278 startAtBoot :: Parser Bool 279 startAtBoot = switch ( long "start" 280 <> help "Immediate start the machine after boot" ) 281 282 doptWarn :: Parser Bool 283 doptWarn = switch ( short 'f' 284 <> long "law-fallback-warn" 285 <> help ( "Print a warning when a jet falls back to raw" 286 <> "fan execution." 287 ) 288 ) 289 290 doptCrash :: Parser Bool 291 doptCrash = switch ( short 'F' 292 <> long "law-fallback-crash" 293 <> help "Crash when a jet falls back to raw fan execution." 294 ) 295 296 matchCrash :: Parser Bool 297 matchCrash = switch ( short 'M' 298 <> long "jet-mismatch-crash" 299 <> help "Crash if a jet-match fails" 300 ) 301 302 doSnap :: Parser Bool 303 doSnap = fmap not 304 $ switch ( short 'S' 305 <> long "disable-snapshots" 306 <> help "Disable snapshots" 307 ) 308 309 310 profOutput = 311 fmap (\x -> if null x then Nothing else Just x) $ 312 strOption ( long "profile-output" 313 <> value "" 314 <> short 'p' 315 <> metavar "PROF_FILE" 316 <> profHelp 317 ) 318 319 replWriteOpt = 320 strOption ( long "save" 321 <> value "/dev/null" 322 <> metavar "OUTPUT_FILE" 323 <> help "Where to write the formal output" 324 ) 325 326 numWorkers = 327 option auto ( long "eval-workers" 328 <> value 8 329 <> short 'w' 330 <> metavar "NUM_WORKERS" 331 <> help "Number of EVAL workers to use" 332 ) 333 334 runInfo :: FilePath -> ParserInfo RunType 335 runInfo defaultDir = 336 info (runType defaultDir <**> helper) 337 ( fullDesc 338 <> progDesc "Let's run plunder." 339 <> header "new-network - a test for running plunder machines" 340 ) 341 342 data BadPortsFile = BAD_PORTS_FILE Text FilePath Text 343 deriving (Eq, Ord, Show) 344 deriving anyclass Exception 345 346 -- | Initial test here. We create a store, create one machine in it, and then 347 -- write one artificial logbatch, and then read it back. 348 main :: IO () 349 main = do 350 -- some systems require the following, even if their locale is already UTF-8 351 setLocaleEncoding utf8 352 353 Rex.colorsOnlyInTerminal do 354 hSetBuffering stdout LineBuffering 355 hSetBuffering stderr LineBuffering 356 357 home <- getHomeDirectory 358 ddir <- lookupEnv "PLUNDER_DIR" <&> maybe (home </> ".plunder") id 359 args <- customExecParser 360 (prefs (showHelpOnError <> showHelpOnEmpty <> noBacktrack)) 361 (runInfo ddir) 362 363 withProfileOutput args $ 364 withInterpreterOpts args $ 365 withDebugOutput $ 366 case args of 367 RTBoot _ _ mo start d y -> do 368 bootMachine d y 369 when start $ do 370 runMachine d EarliestSnapshot mo 371 372 RTUses d w -> duMachine d w 373 RTShow fp -> showSeed fp 374 RTRepl fp o _ -> replSeed fp o 375 RTOpen d cog -> void (openBrowser d cog) 376 RTTerm d cog -> void (openTerminal d cog) 377 378 RTLoot _ _ fz -> do 379 liftIO $ Loot.ReplExe.replMain fz 380 381 RTSire _ _ _ fz -> do 382 code <- liftIO (Sire.main fz) 383 exitWith code 384 385 RTSave _ _ sd sr -> do 386 saveSeed sd sr 387 388 RTStart d _ _ mo r -> do 389 runMachine d r mo 390 391 withProfileOutput :: RunType -> IO () -> IO () 392 withProfileOutput args act = do 393 case argsProf args of 394 Just (ProfilingOpts (Just fil) laws) -> do 395 putStrLn ("Profiling Output: " <> pack fil) 396 Prof.withProfileOutput fil laws act 397 _ -> act 398 where 399 argsProf = \case 400 RTSire _ po _ _ -> Just po 401 RTSave po _ _ _ -> Just po 402 RTLoot _ po _ -> Just po 403 RTShow _ -> Nothing 404 RTRepl{} -> Nothing 405 RTOpen{} -> Nothing 406 RTTerm{} -> Nothing 407 RTStart _ po _ _ _ -> Just po 408 RTUses{} -> Nothing 409 RTBoot po _ _ _ _ _ -> Just po 410 -- RTPoke _ _ _ _ -> Nothing 411 412 withInterpreterOpts :: RunType -> IO () -> IO () 413 withInterpreterOpts args act = do 414 case argsInterpreter args of 415 Just (InterpreterOpts j c m) -> do 416 let onJetMismatch = if m then F.CRASH else F.WARN 417 let onJetFallback = case (j, c) of (_, True) -> F.CRASH 418 (True, _) -> F.WARN 419 _ -> F.IGNORE 420 writeIORef F.vRtsConfig $ F.RTS_CONFIG {..} 421 act 422 _ -> act 423 where 424 argsInterpreter = \case 425 RTSire _ _ io _ -> Just io 426 RTSave _ io _ _ -> Just io 427 RTShow _ -> Nothing 428 RTRepl _ _ io -> Just io 429 RTLoot _ _ _ -> Nothing 430 RTBoot _ io _ _ _ _ -> Just io 431 RTUses _ _ -> Nothing 432 RTOpen _ _ -> Nothing 433 RTTerm _ _ -> Nothing 434 RTStart _ _ io _ _ -> Just io 435 436 bootMachine :: (Debug, Rex.RexColor) => FilePath -> Text -> IO () 437 bootMachine storeDir pash = do 438 withDirectoryWriteLock storeDir $ do 439 let fil = unpack pash 440 e <- liftIO (doesFileExist fil) 441 unless e (error $ unpack ("File does not exist: " <> pash)) 442 val <- liftIO (Sire.loadFile fil) 443 444 with (DB.openDatastore storeDir) $ \lmdb -> do 445 DB.hasSnapshot lmdb >>= \case 446 False -> do 447 firstCogId <- COG_ID <$> randomIO 448 DB.writeMachineSnapshot lmdb (BatchNum 0) 449 (singletonMap firstCogId 450 (CG_SPINNING val)) 451 True -> do 452 error "Trying to overwrite existing machine" 453 454 -- TODO: Output the result of an expression? Not just "main"? 455 saveSeed :: (Debug, Rex.RexColor) => FilePath -> FilePath -> IO () 456 saveSeed outFile inputFile = do 457 val <- liftIO (Sire.loadFile inputFile) 458 byt <- F.saveSeed val 459 writeFile outFile byt 460 461 showSeed :: (Debug, Rex.RexColor) => FilePath -> IO () 462 showSeed seedFileToShow = do 463 writeIORef F.vShowFan showFan 464 writeIORef F.vTrkFan trkFan 465 writeIORef F.vTrkRex trkRex 466 byt <- readFile seedFileToShow 467 pin <- F.loadSeed byt >>= either throwIO pure 468 print pin 469 fullPrint pin 470 where 471 fullPrint x = trkRexM $ Sire.planRexFull $ toNoun x 472 473 -- TODO: If given something like $path.sire:main, load that instead of 474 -- just using a seed. 475 replSeed :: (Debug, Rex.RexColor) => FilePath -> FilePath -> IO () 476 replSeed seedFileToShow outputFile = do 477 let onJetFallback = F.WARN 478 let onJetMismatch = F.WARN 479 writeIORef F.vJetMatch $! F.jetMatch 480 writeIORef F.vShowFan $! showFan 481 writeIORef F.vTrkFan $! trkFan 482 writeIORef F.vTrkRex $! trkRex 483 writeIORef F.vRtsConfig $! F.RTS_CONFIG{..} 484 byt <- readFile seedFileToShow 485 pin <- F.loadSeed byt >>= either throwIO pure 486 withFile outputFile WriteMode \h -> 487 interactive h pin 488 where 489 fullPrint x = trkRexM $ Sire.planRexFull $ toNoun x 490 491 interactive h st0 = do 492 input <- (try $ BS.hGetSome stdin 80) >>= \case 493 Left (e :: IOError) | isEOFError e -> pure mempty 494 Left (e :: IOError) -> throwIO e 495 Right ln -> pure ln 496 let result = (st0 F.%% F.BAR input) 497 case fromNoun result of 498 Nothing -> do 499 fullPrint result 500 error ("bad noun") 501 Just (output, st1) -> do 502 BS.hPutStr h output 503 unless (null input) do 504 interactive h st1 505 506 -- pokeCog :: (Debug, Rex.RexColor) => FilePath -> Text -> FilePath 507 -- -> IO () 508 -- pokeCog d c p pash = do 509 -- withDaemon d $ do 510 -- let fil = unpack pash 511 -- e <- liftIO (doesFileExist fil) 512 -- unless e (error $ unpack ("File does not exist: " <> pash)) 513 -- mVl <- liftIO (Sire.ReplExe.loadFile fil) 514 -- val <- case mVl of 515 -- Nothing -> (error . unpack) $ 516 -- ("No value at end of file : " <> pash) 517 -- Just vl -> pure vl 518 -- reqPoke c (splitOn "/" p) (JELLY_PACK val) 519 520 shellFg :: String -> [String] -> IO ExitCode 521 shellFg c a = do 522 let p = (proc c a) { std_in = Inherit 523 , std_out = Inherit 524 , std_err = Inherit 525 , close_fds = True 526 , delegate_ctlc = True 527 } 528 (_, _, _, ph) <- createProcess p 529 waitForProcess ph 530 531 openBrowser :: FilePath -> CogId -> IO ExitCode 532 openBrowser dir cogId = do 533 let cogNm = tshow cogId.int 534 let pax = (dir </> unpack (cogNm <> ".http.port")) 535 exists <- doesFileExist pax 536 unless exists (error "Cog does not serve HTTP") 537 port <- do cont <- readFileUtf8 pax 538 case readMay @Text @Word cont of 539 Nothing -> throwIO (BAD_PORTS_FILE "http" pax cont) 540 Just pt -> pure pt 541 let url = "http://localhost:" <> show port 542 shellFg "xdg-open" [url] 543 544 openTerminal :: FilePath -> CogId -> IO ExitCode 545 openTerminal dir cogId = do 546 let cogNm = tshow cogId.int 547 let pax = (dir </> unpack (cogNm <> ".telnet.port")) 548 exists <- doesFileExist pax 549 unless exists (error "Cog does not serve Telnet") 550 port <- do cont <- readFileUtf8 pax 551 case readMay @Text @Word cont of 552 Nothing -> throwIO (BAD_PORTS_FILE "telnet" pax cont) 553 Just pt -> pure pt 554 shellFg "nc" ["localhost", show port] 555 556 -- {- 557 -- Deliver a noun from the outside to a given cog. 558 -- -} 559 -- doPoke :: Debug => ServerState -> [Text] -> JellyPack -> IO () 560 -- doPoke st path pak = do 561 -- debug ["poke_cog"] 562 -- st.poke (fromList path) pak.fan 563 564 withMachineIn :: Debug 565 => FilePath 566 -> Int 567 -> Bool 568 -> (MachineContext -> IO a) 569 -> IO a 570 withMachineIn storeDir numWorkers enableSnaps machineAction = do 571 withDirectoryWriteLock storeDir do 572 -- Setup plunder interpreter state. 573 writeIORef F.vTrkFan $! \x -> do 574 now <- getCurrentTime 575 debug (["trk"::Text, pack (iso8601Show now)], x) 576 577 writeIORef F.vShowFan $! Loot.ReplExe.showFan 578 writeIORef F.vJetMatch $! F.jetMatch 579 580 -- TODO: Thing about all the shutdown signal behaviour. Right now, we're 581 -- ignoring it, but there's a bunch of things the old system did to catch 582 -- Ctrl-C. 583 584 agentQueue <- newTBQueueIO 100 585 586 let devTable db hw_poke = do 587 hw1_rand <- createHardwareRand 588 --(hw4_wock, wsApp) <- createHardwareWock 589 let wsApp _cogId _ws = pure () 590 hw2_http <- createHardwareHttp storeDir db wsApp 591 --hw3_sock <- createHardwareSock storeDir 592 hw5_time <- createHardwareTime 593 hw6_port <- createHardwarePort agentQueue 594 (pure . DEVICE_TABLE . mapFromList) $ 595 [ ( "rand", hw1_rand ) 596 , ( "http", hw2_http ) 597 --( "sock", hw3_sock ) 598 --( "wock", hw4_wock ) 599 , ( "time", hw5_time ) 600 , ( "port", hw6_port ) 601 , ( "poke", hw_poke ) 602 ] 603 604 605 let machineState = do 606 lmdb <- DB.openDatastore storeDir 607 (pokeHW, _submitPoke) <- createHardwarePoke 608 hw <- devTable lmdb pokeHW 609 eval <- evaluator numWorkers 610 -- 611 let filterFun k _ = k `elem` ["rand", "time", "port"] 612 let am_hw = DEVICE_TABLE (M.filterWithKey filterFun hw.table) 613 let agentMachCtx = 614 AMach.MACHINE_CONTEXT{eval,hw=am_hw,aQ=agentQueue} 615 agentMach <- liftIO (AMach.bootMachine agentMachCtx) 616 -- 617 pure MACHINE_CONTEXT{lmdb,hw,eval,enableSnaps,agentMach} 618 with machineState machineAction 619 620 runMachine :: Debug => FilePath -> ReplayFrom -> MachineOpts -> IO () 621 runMachine storeDir replayFrom (MachineOpts enableSnaps numWorkers) = do 622 cache <- DB.CUSHION <$> newIORef mempty 623 withMachineIn storeDir numWorkers enableSnaps $ \ctx -> do 624 machine <- withCogDebugging $ replayAndCrankMachine cache ctx replayFrom 625 626 -- Listen for Ctrl-C and external shutdown signals. 627 termSignal <- newEmptyTMVarIO 628 for_ [sigTERM, sigINT] $ \sig -> do 629 installHandler sig 630 (Catch (atomically $ putTMVar termSignal ())) 631 Nothing 632 633 c <- atomically $ (Left <$> readTMVar termSignal <|> 634 Right <$> readTMVar machine.shutdownComplete) 635 case c of 636 Left () -> do 637 -- We got an external shutdown signal, so shut down the machine 638 -- and wait for things to sync to disk. 639 shutdownMachine machine 640 Right () -> do 641 -- The machine exited on its own and we don't have to wait for 642 -- its 643 -- 644 -- TODO: Print a report here about the state of why the machine 645 -- shutdown on its own. 646 pure () 647 648 649 duMachine :: Debug => FilePath -> Int -> IO () 650 duMachine storeDir numWorkers = do 651 withMachineIn storeDir numWorkers False $ \ctx -> do 652 retLines <- walkNoun ctx 653 forM_ retLines $ putStrLn 654 where 655 walkNoun :: MachineContext -> IO [Text] 656 walkNoun ctx = do 657 cache <- DB.CUSHION <$> newIORef mempty 658 659 -- Replay the machine to get the current noun. 660 (_, MOMENT noun _) <- performReplay cache ctx LatestSnapshot 661 662 pin <- F.mkPin' (toNoun noun) 663 (pins, _hed, blob) <- F.savePin pin 664 665 pure $ execState (fanDu pins blob) [] 666 667 fanDu :: Vector F.Pin -> ByteString -> State [Text] () 668 fanDu refs blob = do 669 refSize <- sum <$> mapM (pinDu []) refs 670 _ <- calcEntry [] refSize blob 671 pure () 672 673 pinDu :: [Text] -> F.Pin -> State [Text] Int 674 pinDu path p = do 675 error "TODO: This is more complex now" path 676 error "We should probably store sizes and edge-lists in the database" p 677 error "And this should be a read transaction" binName ok ugul 678 -- let pinName = binName p.item 679 -- refSize <- sum <$> mapM (pinDu (pinName : path)) p.refs 680 -- calcEntry (pinName : path) refSize p.blob 681 682 calcEntry :: [Text] -> Int -> ByteString -> State [Text] Int 683 calcEntry path refSize blob = do 684 let blobSize = BS.length blob 685 totalSize = refSize + blobSize 686 let displayPath :: Text = concat $ intersperse "/" $ reverse path 687 modify' ((tshow totalSize <> " " <> displayPath):) 688 pure totalSize 689 690 -- TODO: Better way to identify grains that don't have law names? 691 binName :: F.Fan -> Text 692 binName = \case 693 F.FUN law -> ugul law.name.nat 694 F.PIN pin -> binName pin.item 695 f -> hashToBTC (fanHash f) 696 697 ok '_' = True 698 ok c = C.isAlphaNum c 699 700 ugul :: Nat -> Text 701 ugul 0 = "anon" 702 ugul nat = case natUtf8 nat of 703 Right t | all ok t -> t 704 _ -> tshow nat