{- # Booting a Ship - TODO Correctly setup the Pier directory. - TODO Hook up CLI command. - TODO Don't just boot, also run the ship (unless `-x` is set). - TODO Figure out why ships booted by us don't work. # Event Pruning - `king discard-events NUM_EVENTS`: Delete the last `n` events from the event log. - `king discard-events-interactive`: Iterate through the events in the event log, from last to first, pretty-print each event, and ask if it should be pruned. # `-L` -- Local-Only Networking Localhost-only networking, even on real ships. # `-O` -- Networking Disabled Run networking drivers, but configure them to never send any packages and to never open any ports. # `-N` -- Dry Run Disable all persistence and use no-op networking. # `-x` -- Exit Immediately When creating a new ship, or booting an existing one, simply get to a good state, snapshot, and then exit. Don't do anything that has any effect on the outside world, just boot or catch the snapshot up to the event log. # Proper Logging - TODO Consider using RIO's logging infrastructure. - TODO If that's too heavy, figure out what the best way to do logging is now. - TODO Convert all existing logging to the chosen logging system. - TODO Add more logging to all the places. Logging is super useful. # Implement subcommands to test event and effect parsing. - `king * --collect-fx`: All effects that come from the serf get written into the `effects` LMDB database. - `king parse-events PIER`: Run through the event log, and parse all events, print failures. - `king parse-effects PIER`: Run through the event log, and parse all effects, print any failures. - `king clear-fx PIER`: Deletes all collected effects. - `king full-replay PIER`: Replays the whole event log events, print any failures. On success, replace the snapshot. # Validate Pill Files - `king validate-pill PILL`: Parse a pill file. Print an error on exit, and print a description of the pill on success. # Full Replay -- An Integration Test - Copy the event log: - Create a new event log at the destination. - Stream events from the first event log. - Parse each event. - Re-Serialize each event. - Verify that the round-trip was successful. - Write the event into the new database. - Replay the event log at the destination. - If `--collect-fx` is set, then record effects as well. - Snapshot. - Verify that the final mug is the same as it was before. # Implement Remaining Serf Flags - `DebugRam`: Memory debugging. - `DebugCpu`: Profiling - `CheckCorrupt`: Heap Corruption Tests - `CheckFatal`: TODO What is this? - `Verbose`: TODO Just the `-v` flag? - `DryRun`: TODO Just the `-N` flag? - `Quiet`: TODO Just the `-q` flag? - `Hashless`: Don't use hashboard for jets. - `Trace`: TODO What does this do? -} module Main where import ClassyPrelude import Options.Applicative import Options.Applicative.Help.Pretty import Arvo import Control.Exception hiding (evaluate, throwIO) import Data.Acquire import Data.Conduit import Data.Conduit.List hiding (replicate, take) import Noun hiding (Parser) import Vere.Pier import Vere.Pier.Types import Vere.Serf import Control.Concurrent (runInBoundThread, threadDelay) import Control.Lens ((&)) import System.Directory (doesFileExist, removeFile) import System.Environment (getProgName) import Text.Show.Pretty (pPrint) import Urbit.Time (Wen) import qualified CLI import qualified Data.Set as Set import qualified Vere.Log as Log import qualified Vere.Pier as Pier import qualified Vere.Serf as Serf -------------------------------------------------------------------------------- zod :: Ship zod = 0 -------------------------------------------------------------------------------- removeFileIfExists :: FilePath -> IO () removeFileIfExists pax = do exists <- doesFileExist pax when exists $ do removeFile pax catchAny :: IO a -> (SomeException -> IO a) -> IO a catchAny = Control.Exception.catch -------------------------------------------------------------------------------- wipeSnapshot :: FilePath -> IO () wipeSnapshot shipPath = do putStrLn "wipeSnapshot" removeFileIfExists (shipPath <> "/.urb/chk/north.bin") removeFileIfExists (shipPath <> "/.urb/chk/south.bin") print (shipPath <> "/.urb/chk/north.bin") print (shipPath <> "/.urb/chk/south.bin") putStrLn "SNAPSHOT WIPED" tryBootFromPill :: FilePath -> FilePath -> Ship -> IO () tryBootFromPill pillPath shipPath ship = do wipeSnapshot shipPath with (Pier.booted pillPath shipPath [] ship) $ \(serf, log, ss) -> do print "lul" print ss threadDelay 500000 shutdown serf 0 >>= print putStrLn "[tryBootFromPill] Booted!" runAcquire act = with act pure tryPlayShip :: FilePath -> IO () tryPlayShip shipPath = do runAcquire $ do putStrLn "RESUMING SHIP" sls <- Pier.resumed shipPath [] putStrLn "SHIP RESUMED" Pier.pier shipPath Nothing sls tryResume :: FilePath -> IO () tryResume shipPath = do with (Pier.resumed shipPath []) $ \(serf, log, ss) -> do print ss threadDelay 500000 shutdown serf 0 >>= print putStrLn "[tryResume] Resumed!" tryFullReplay :: FilePath -> IO () tryFullReplay shipPath = do wipeSnapshot shipPath tryResume shipPath -------------------------------------------------------------------------------- checkEvs :: FilePath -> Word64 -> IO () checkEvs pier first = do vPax <- newIORef [] with (Log.existing dir) $ \log -> do let ident = Log.identity log print ident runConduit $ Log.streamEvents log first .| showEvents vPax first (fromIntegral $ lifecycleLen ident) paths <- sort . ordNub <$> readIORef vPax for_ paths print where dir :: FilePath dir = pier <> "/.urb/log" showEvents :: IORef [Path] -> EventId -> EventId -> ConduitT ByteString Void IO () showEvents vPax eId cycle = await >>= \case Nothing -> print "Everything checks out." Just bs -> do -- print ("got event", eId) n <- liftIO $ cueBSExn bs -- print ("done cue", eId) when (eId <= cycle) $ do -- putStrLn ("[tryParseEvents] lifecycle nock: " <> tshow eId) pure () when (eId > cycle) $ liftIO $ do (mug, wen, evNoun) <- unpackJob n case fromNounErr evNoun of Left err -> liftIO $ do -- pPrint err -- pPrint evNoun print err Right (ev :: Ev) -> do -- print ev pure () -- pPrint ev -- paths <- readIORef vPax -- let pax = case ev of Ovum pax _ -> pax -- writeIORef vPax (pax:paths) -- print ("done from noun", eId) -- print (Job eId mug $ DateOvum date ev) -- unless (eId - first > 1000) $ showEvents vPax (succ eId) cycle unpackJob :: Noun -> IO (Mug, Wen, Noun) unpackJob n = fromNounExn n -------------------------------------------------------------------------------- {- This runs the serf at `$top/.tmpdir`, but we disable snapshots, so this should never actually be created. We just do this to avoid letting the serf use an existing snapshot. -} collectAllFx :: FilePath -> IO () collectAllFx top = do putStrLn (pack top) with collectedFX $ \() -> putStrLn "[collectAllFx] Done collecting effects!" where tmpDir :: FilePath tmpDir = top <> "/.tmpdir" collectedFX :: Acquire () collectedFX = do log <- Log.existing (top <> "/.urb/log") serf <- Serf.run (Serf.Config tmpDir serfFlags) liftIO (Serf.collectFX serf log) serfFlags :: Serf.Flags serfFlags = [Serf.Hashless, Serf.DryRun] -------------------------------------------------------------------------------- tryDoStuff :: FilePath -> IO () tryDoStuff shipPath = runInBoundThread $ do let pillPath = "/home/benjamin/r/urbit/bin/solid.pill" ship = zod -- tryParseEvents "/home/benjamin/r/urbit/s/zod/.urb/log" 1 -- tryParseEvents "/home/benjamin/r/urbit/s/testnet-zod/.urb/log" 1 -- tryParseFX "/home/benjamin/zod-fx" 1 100000000 -- tryParseFX "/home/benjamin/testnet-zod-fx" 1 100000000 -- tryResume shipPath tryPlayShip shipPath -- tryFullReplay shipPath pure () -------------------------------------------------------------------------------- {- Interesting -} testPill :: FilePath -> Bool -> Bool -> IO () testPill pax showPil showSeq = do putStrLn "Reading pill file." pillBytes <- readFile pax putStrLn "Cueing pill file." pillNoun <- cueBS pillBytes & either throwIO pure putStrLn "Parsing pill file." pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure putStrLn "Using pill to generate boot sequence." bootSeq <- generateBootSeq zod pill putStrLn "Validate jam/cue and toNoun/fromNoun on pill value" reJam <- validateNounVal pill putStrLn "Checking if round-trip matches input file:" unless (reJam == pillBytes) $ do putStrLn " Our jam does not match the file...\n" putStrLn " This is surprising, but it is probably okay." when showPil $ do putStrLn "\n\n== Pill ==\n" pPrint pill when showSeq $ do putStrLn "\n\n== Boot Sequence ==\n" pPrint bootSeq validateNounVal :: (Eq a, ToNoun a, FromNoun a) => a -> IO ByteString validateNounVal inpVal = do putStrLn " jam" inpByt <- evaluate $ jamBS $ toNoun inpVal putStrLn " cue" outNon <- cueBS inpByt & either throwIO pure putStrLn " fromNoun" outVal <- fromNounErr outNon & either (throwIO . uncurry ParseErr) pure putStrLn " toNoun" outNon <- evaluate (toNoun outVal) putStrLn " jam" outByt <- evaluate $ jamBS outNon putStrLn "Checking if: x == cue (jam x)" unless (inpVal == outVal) $ error "Value fails test: x == cue (jam x)" putStrLn "Checking if: jam x == jam (cue (jam x))" unless (inpByt == outByt) $ error "Value fails test: jam x == jam (cue (jam x))" pure outByt -------------------------------------------------------------------------------- newShip :: CLI.New -> CLI.Opts -> IO () newShip CLI.New{..} _ = do tryBootFromPill nPillPath pierPath (Ship 0) where pierPath = fromMaybe ("./" <> unpack nShipAddr) nPierPath runShip :: CLI.Run -> CLI.Opts -> IO () runShip (CLI.Run pierPath) _ = tryPlayShip pierPath main :: IO () main = CLI.parseArgs >>= \case CLI.CmdRun r o -> runShip r o CLI.CmdNew n o -> newShip n o CLI.CmdBug (CLI.CollectAllFX pax) -> collectAllFx pax CLI.CmdBug (CLI.ValidatePill pax pil seq) -> testPill pax pil seq CLI.CmdBug (CLI.ValidateFX pax) -> print "validate-fx" CLI.CmdBug (CLI.ValidateEvents pax start) -> checkEvs pax start validatePill :: FilePath -> IO () validatePill = const (pure ()) -------------------------------------------------------------------------------- tryParseFX :: FilePath -> Word -> Word -> IO () tryParseFX pax first last = runConduit $ streamFX pax first last .| tryParseFXStream streamFX :: FilePath -> Word -> Word -> ConduitT () ByteString IO () streamFX dir first last = loop first where loop n = do -- when (n `mod` 1000 == 0) $ do -- print n let fil = dir <> "/" <> show n exists <- liftIO (doesFileExist fil) when (exists && n <= last) $ do liftIO (readFile fil) >>= yield loop (n+1) tryParseFXStream :: ConduitT ByteString Void IO () tryParseFXStream = loop 0 (mempty :: Set (Text, Noun)) where loop 1 pax = for_ (setToList pax) print loop errors pax = await >>= \case Nothing -> for_ (setToList pax) $ \(t,n) -> putStrLn (t <> ": " <> tshow n) Just bs -> do n <- liftIO (cueBSExn bs) fromNounErr n & \case Left err -> print err >> loop (errors + 1) pax Right [] -> loop errors pax Right (fx :: FX) -> do -- pax <- pure $ Set.union pax -- $ setFromList -- $ fx <&> \(Effect p v) -> (getTag v, toNoun p) loop errors pax -- getTag :: Effect -> Text -- getTag fx = -- let n = toNoun fx -- in case n of -- A _ -> maybe "ERR" unCord (fromNoun n) -- C h _ -> maybe "ERR" unCord (fromNoun h) {- tryCopyLog :: IO () tryCopyLog = do let logPath = "/Users/erg/src/urbit/zod/.urb/falselog/" falselogPath = "/Users/erg/src/urbit/zod/.urb/falselog2/" persistQ <- newTQueueIO releaseQ <- newTQueueIO (ident, nextEv, events) <- with (do { log <- Log.existing logPath ; Pier.runPersist log persistQ (writeTQueue releaseQ) ; pure log }) \log -> do ident <- pure $ Log.identity log events <- runConduit (Log.streamEvents log 1 .| consume) nextEv <- Log.nextEv log pure (ident, nextEv, events) print ident print nextEv print (length events) persistQ2 <- newTQueueIO releaseQ2 <- newTQueueIO with (do { log <- Log.new falselogPath ident ; Pier.runPersist log persistQ2 (writeTQueue releaseQ2) ; pure log }) $ \log2 -> do let writs = zip [1..] events <&> \(id, a) -> (Writ id Nothing a, []) print "About to write" for_ writs $ \w -> atomically (writeTQueue persistQ2 w) print "About to wait" replicateM_ 100 $ do atomically $ readTQueue releaseQ2 print "Done" -}