mirror of
https://github.com/urbit/shrub.git
synced 2024-12-22 02:11:38 +03:00
382 lines
11 KiB
Haskell
382 lines
11 KiB
Haskell
{-
|
|
# 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)
|
|
import Data.Acquire
|
|
import Data.Conduit
|
|
import Data.Conduit.List hiding (replicate)
|
|
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
|
|
removeFileIfExists (shipPath <> "/.urb/chk/north.bin")
|
|
removeFileIfExists (shipPath <> "/.urb/chk/south.bin")
|
|
print (shipPath <> "/.urb/chk/north.bin")
|
|
print (shipPath <> "/.urb/chk/south.bin")
|
|
|
|
tryBootFromPill :: FilePath -> FilePath -> Ship -> IO ()
|
|
tryBootFromPill pillPath shipPath ship = do
|
|
wipeSnapshot shipPath
|
|
with (Pier.booted pillPath shipPath serfFlags 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 serfFlags
|
|
putStrLn "SHIP RESUMED"
|
|
Pier.pier shipPath Nothing sls
|
|
|
|
tryResume :: FilePath -> IO ()
|
|
tryResume shipPath = do
|
|
with (Pier.resumed shipPath serfFlags) $ \(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
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
tryParseEvents :: FilePath -> EventId -> IO ()
|
|
tryParseEvents dir 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
|
|
showEvents :: IORef [Path] -> EventId -> EventId
|
|
-> ConduitT ByteString Void IO ()
|
|
showEvents vPax eId cycle = await >>= \case
|
|
Nothing -> print "Done!"
|
|
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)
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
serfFlags :: Serf.Flags
|
|
serfFlags = [Serf.Hashless, Serf.DryRun] -- [Serf.Verbose, Serf.Trace]
|
|
|
|
collectedFX :: FilePath -> Acquire ()
|
|
collectedFX top = do
|
|
log <- Log.existing (top <> "/.urb/log")
|
|
serf <- Serf.run (Serf.Config top serfFlags)
|
|
liftIO (Serf.collectFX serf log)
|
|
|
|
collectAllFx :: FilePath -> IO ()
|
|
collectAllFx top = do
|
|
wipeSnapshot top
|
|
with (collectedFX top) $ \() ->
|
|
putStrLn "[collectAllFx] Done collecting effects!"
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
tryDoStuff :: FilePath -> IO ()
|
|
tryDoStuff shipPath = runInBoundThread $ do
|
|
let pillPath = "/home/benjamin/r/urbit/bin/solid.pill"
|
|
ship = zod
|
|
|
|
-- collectAllFx "/home/benjamin/r/urbit/s/testnet-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
|
|
|
|
-- tryBootFromPill pillPath shipPath ship
|
|
-- tryResume shipPath
|
|
tryPlayShip shipPath
|
|
-- tryFullReplay shipPath
|
|
|
|
pure ()
|
|
|
|
newShip :: CLI.New -> CLI.Opts -> IO ()
|
|
newShip CLI.New{..} _ = do
|
|
tryBootFromPill nPillPath nPierPath (Ship 0)
|
|
|
|
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 r o -> pPrint (CLI.CmdNew r o)
|
|
CLI.CmdTry p -> tryDoStuff p
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
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"
|
|
-}
|