mirror of
https://github.com/urbit/shrub.git
synced 2024-12-24 20:47:27 +03:00
CLI Parsing cleanup.
This commit is contained in:
Benjamin Summers
parent
7c6709de9b
commit
e02dd2342c
@ -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")
|
||||
|
||||
@ -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 ())
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user