diff --git a/pkg/king/app/CLI.hs b/pkg/king/app/CLI.hs index d09345dfdd..da94e6a6ef 100644 --- a/pkg/king/app/CLI.hs +++ b/pkg/king/app/CLI.hs @@ -21,16 +21,17 @@ data Opts = Opts , oAmesPort :: Maybe Word16 , oProf :: Bool , oCollectFx :: Bool + , oLocalhost :: Bool + , oOffline :: Bool } deriving (Show) data New = New { nPillPath :: FilePath , nShipAddr :: Text - , nPierPath :: FilePath + , nPierPath :: Maybe FilePath -- Derived from ship name if not specified. , nArvoDir :: Maybe FilePath , nBootFake :: Bool - , nLocalhost :: Bool } deriving (Show) @@ -42,7 +43,7 @@ data Run = Run data Cmd = CmdNew New Opts | CmdRun Run Opts - | CmdTry FilePath + | CmdVal FilePath -- Validate Pill deriving (Show) -------------------------------------------------------------------------------- @@ -89,61 +90,114 @@ parseArgs = do -------------------------------------------------------------------------------- -run :: Parser Run -run = do - rPierPath <- strArgument (metavar "PIER" <> help "Path to pier") - pure Run{..} - new :: Parser New new = do - nPierPath <- strArgument (metavar "PIER" <> help "Path to pier") - nPillPath <- strArgument (metavar "PILL" <> help "Path to pill file") - nShipAddr <- strArgument (metavar "SHIP" <> help "Ship address") + nShipAddr <- strArgument + $ metavar "SHIP" + <> help "Ship address" - nLocalhost <- switch $ short 'L' - <> long "local" - <> help "Localhost-only networking" + nPierPath <- argument auto + $ metavar "PIER" + <> help "Path to pier" + <> value Nothing - nBootFake <- switch $ short 'F' - <> long "fake" - <> help "Create a fake ship" + nPillPath <- strOption + $ short 'B' + <> long "pill" + <> metavar "PILL" + <> help "Path to pill file" - nArvoDir <- option auto $ metavar "ARVO" - <> short 'A' - <> value Nothing - <> help "Initial Arvo filesystem" + nBootFake <- switch + $ short 'F' + <> long "fake" + <> help "Create a fake ship" + + nArvoDir <- option auto + $ metavar "PATH" + <> short 'A' + <> long "arvo" + <> value Nothing + <> help "Replace initial clay filesys with contents of PATH" pure New{..} opts :: Parser Opts opts = do - oAmesPort <- option auto $ metavar "PORT" - <> short 'p' - <> help "Ames port number" - <> value Nothing + oAmesPort <- option auto $ metavar "PORT" + <> short 'p' + <> long "ames" + <> help "Ames port number" + <> value Nothing + <> hidden - oHashless <- switch (short 'S' <> help "Disable battery hashing") - oQuiet <- switch (short 'q' <> help "Quiet") - oVerbose <- switch (short 'v' <> help "Verbose") - oExit <- switch (short 'x' <> help "Exit immediatly") - oDryRun <- switch (short 'N' <> help "Dry run -- Don't persist") - oProf <- switch (short 'p' <> help "Enable profiling") + oHashless <- switch $ short 'S' + <> long "hashless" + <> help "Disable battery hashing" + <> hidden - oCollectFx <- switch $ long "collect-fx" + oQuiet <- switch $ short 'q' + <> long "quiet" + <> help "Quiet" + <> hidden + + oVerbose <- switch $ short 'v' + <> long "verbose" + <> help "Verbose" + <> hidden + + oExit <- switch $ short 'x' + <> long "exit" + <> help "Exit immediatly" + <> hidden + + oDryRun <- switch $ short 'N' + <> long "dry-run" + <> help "Dry run -- Don't persist" + <> hidden + + oProf <- switch $ short 'p' + <> long "profile" + <> help "Enable profiling" + <> hidden + + oLocalhost <- switch $ short 'L' + <> long "local" + <> help "Localhost-only networking" + <> hidden + + oOffline <- switch $ short 'O' + <> long "offline" + <> help "Run without any networking" + <> hidden + + oCollectFx <- switch $ short 'f' + <> long "collect-fx" <> help "Write effects to disk for debugging" + <> hidden pure (Opts{..}) +runShip :: Parser Cmd +runShip = do + rPierPath <- strArgument (metavar "PIER" <> help "Path to pier") + o <- opts + pure (CmdRun (Run{..}) o) + +valPill :: Parser Cmd +valPill = do + pillPath <- strArgument (metavar "PILL" <> help "Path to pill") + pure (CmdVal pillPath) + cmd :: Parser Cmd cmd = subparser - ( (command "new" $ info (newShip <**> helper) - $ progDesc "Boot a new ship") - <> (command "run" $ info (runShip <**> helper) - $ progDesc "Run an existing ship") - <> (command "try" $ info (tryShip <**> helper) - $ progDesc "Run development test flow") - ) + $ command "new" ( info (newShip <**> helper) + $ progDesc "Boot a new ship." + ) + <> command "run" ( info (runShip <**> helper) + $ progDesc "Run an existing ship." + ) + <> command "val" ( info (valPill <**> helper) + $ progDesc "Validate a pill file." + ) where - runShip = CmdRun <$> run <*> opts newShip = CmdNew <$> new <*> opts - tryShip = CmdTry <$> strArgument (metavar "PIER" <> help "Path to pier") diff --git a/pkg/king/app/Main.hs b/pkg/king/app/Main.hs index 2f3908f6e1..662bebfc05 100644 --- a/pkg/king/app/Main.hs +++ b/pkg/king/app/Main.hs @@ -153,10 +153,12 @@ 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 @@ -277,7 +279,9 @@ tryDoStuff shipPath = runInBoundThread $ do newShip :: CLI.New -> CLI.Opts -> IO () newShip CLI.New{..} _ = do - tryBootFromPill nPillPath nPierPath (Ship 0) + tryBootFromPill nPillPath pierPath (Ship 0) + where + pierPath = fromMaybe ("./" <> unpack nShipAddr) nPierPath runShip :: CLI.Run -> CLI.Opts -> IO () runShip (CLI.Run pierPath) _ = tryPlayShip pierPath @@ -285,8 +289,11 @@ 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 + CLI.CmdNew n o -> newShip n o + CLI.CmdVal pil -> validatePill pil + +validatePill :: FilePath -> IO () +validatePill = const (pure ()) -------------------------------------------------------------------------------- diff --git a/pkg/king/lib/Vere/Pier.hs b/pkg/king/lib/Vere/Pier.hs index 2661f0f03d..cc693e7745 100644 --- a/pkg/king/lib/Vere/Pier.hs +++ b/pkg/king/lib/Vere/Pier.hs @@ -26,8 +26,8 @@ import qualified Vere.Serf as Serf _ioDrivers = [] :: [IODriver] -_setupPierDirectory :: FilePath -> IO () -_setupPierDirectory shipPath = do +setupPierDirectory :: FilePath -> IO () +setupPierDirectory shipPath = do for_ ["put", "get", "log", "chk"] $ \seg -> do let pax = shipPath <> "/.urb/" <> seg createDirectoryIfMissing True pax @@ -75,19 +75,37 @@ writeJobs log !jobs = do booted :: FilePath -> FilePath -> Serf.Flags -> Ship -> Acquire (Serf, EventLog, SerfState) booted pillPath pierPath flags ship = do + putStrLn "LOADING PILL" + pill <- liftIO $ loadFile @Pill pillPath >>= \case Left l -> error (show l) -- TODO Throw a real exception. Right p -> pure p + putStrLn "PILL LOADED" + seq@(BootSeq ident x y) <- liftIO $ generateBootSeq ship pill + putStrLn "BootSeq Computed" + + liftIO (setupPierDirectory pierPath) + + putStrLn "Directory Setup" + log <- Log.new (pierPath <> "/.urb/log") ident + + putStrLn "Event Log Initialized" + serf <- Serf.run (Serf.Config pierPath flags) + putStrLn "Serf Started" + liftIO $ do (events, serfSt) <- Serf.bootFromSeq serf seq + putStrLn "Boot Sequence completed" Serf.snapshot serf serfSt + putStrLn "Snapshot taken" writeJobs log (fromList events) + putStrLn "Events written" pure (serf, log, serfSt) diff --git a/pkg/king/lib/Vere/Serf.hs b/pkg/king/lib/Vere/Serf.hs index 979a01ca3f..fd1b0d22ce 100644 --- a/pkg/king/lib/Vere/Serf.hs +++ b/pkg/king/lib/Vere/Serf.hs @@ -74,6 +74,9 @@ data SerfState = SerfState } deriving (Eq, Ord, Show) +ssLastEv :: SerfState -> EventId +ssLastEv = pred . ssNextEv + data Serf = Serf { sendHandle :: Handle , recvHandle :: Handle @@ -283,7 +286,7 @@ cordText = T.strip . unCord -------------------------------------------------------------------------------- snapshot :: Serf -> SerfState -> IO () -snapshot serf SerfState{..} = sendOrder serf (OSave $ ssNextEv - 1) +snapshot serf ss = sendOrder serf $ OSave $ ssLastEv ss shutdown :: Serf -> Word8 -> IO () shutdown serf code = sendOrder serf (OExit code)