mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-22 22:31:30 +03:00
533 lines
14 KiB
Haskell
533 lines
14 KiB
Haskell
{-# OPTIONS_GHC -Werror -Wall #-}
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
{-|
|
|
Command line parsing.
|
|
-}
|
|
module Urbit.King.CLI where
|
|
|
|
import ClassyPrelude hiding (log)
|
|
import Options.Applicative
|
|
import Options.Applicative.Help.Pretty
|
|
|
|
import Data.Word (Word16)
|
|
import RIO (LogLevel(..))
|
|
import System.Environment (getProgName)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
data Host = Host
|
|
{ hSharedHttpPort :: Maybe Word16
|
|
, hSharedHttpsPort :: Maybe Word16
|
|
}
|
|
deriving (Show)
|
|
|
|
-- | Options for each running pier.
|
|
data Opts = Opts
|
|
{ oQuiet :: Bool
|
|
, oHashless :: Bool
|
|
, oExit :: Bool
|
|
, oDryRun :: Bool
|
|
, oDryFrom :: Maybe Word64
|
|
, oVerbose :: Bool
|
|
, oAmesPort :: Maybe Word16
|
|
, oNoAmes :: Bool
|
|
, oNoHttp :: Bool
|
|
, oNoHttps :: Bool
|
|
, oTrace :: Bool
|
|
, oCollectFx :: Bool
|
|
, oLocalhost :: Bool
|
|
, oOffline :: Bool
|
|
, oFullReplay :: Bool
|
|
, oHttpPort :: Maybe Word16
|
|
, oHttpsPort :: Maybe Word16
|
|
, oLoopbackPort :: Maybe Word16
|
|
, oSerfExe :: Maybe Text
|
|
}
|
|
deriving (Show)
|
|
|
|
-- | Options for the logging subsystem.
|
|
data Log = Log
|
|
{ lTarget :: Maybe (LogTarget FilePath)
|
|
, lLevel :: Maybe LogLevel
|
|
}
|
|
deriving (Show)
|
|
|
|
data LogTarget a
|
|
= LogOff
|
|
| LogStderr
|
|
| LogFile a
|
|
deriving (Show)
|
|
|
|
data BootType
|
|
= BootComet
|
|
| BootFake Text
|
|
| BootFromKeyfile FilePath
|
|
deriving (Show)
|
|
|
|
data PillSource
|
|
= PillSourceFile FilePath
|
|
| PillSourceURL String
|
|
deriving (Show)
|
|
|
|
data New = New
|
|
{ nPillSource :: PillSource
|
|
, nPierPath :: Maybe FilePath -- Derived from ship name if not specified.
|
|
, nArvoDir :: Maybe FilePath
|
|
, nBootType :: BootType
|
|
, nLite :: Bool
|
|
}
|
|
deriving (Show)
|
|
|
|
data Run = Run
|
|
{ rPierPath :: FilePath
|
|
}
|
|
deriving (Show)
|
|
|
|
data Bug
|
|
= ValidatePill
|
|
{ bPillPath :: FilePath
|
|
, bPrintPil :: Bool
|
|
, bPrintSeq :: Bool
|
|
}
|
|
| CollectAllFX
|
|
{ bPierPath :: FilePath
|
|
}
|
|
| EventBrowser
|
|
{ bPierPath :: FilePath
|
|
}
|
|
| ValidateEvents
|
|
{ bPierPath :: FilePath
|
|
, bFirstEvt :: Word64
|
|
, bFinalEvt :: Word64
|
|
}
|
|
| ValidateFX
|
|
{ bPierPath :: FilePath
|
|
, bFirstEvt :: Word64
|
|
, bFinalEvt :: Word64
|
|
}
|
|
| ReplayEvents
|
|
{ bPierPath :: FilePath
|
|
, bFinalEvt :: Word64
|
|
}
|
|
| CheckDawn
|
|
{ bKeyfilePath :: FilePath
|
|
}
|
|
| CheckComet
|
|
deriving (Show)
|
|
|
|
data Cmd
|
|
= CmdNew New Opts
|
|
| CmdRun Host [(Run, Opts, Bool)]
|
|
| CmdBug Bug
|
|
| CmdCon FilePath
|
|
deriving (Show)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
headNote :: String -> Doc
|
|
headNote _version = string $ intercalate "\n"
|
|
[ "Urbit: a personal server operating function"
|
|
, "https://urbit.org"
|
|
, "Version " <> VERSION_urbit_king
|
|
]
|
|
|
|
-- | TODO This needs to be updated.
|
|
footNote :: String -> Doc
|
|
footNote exe = string $ intercalate "\n"
|
|
[ "Development Usage:"
|
|
, " To create a development ship, use a fakezod:"
|
|
, " $ " <>exe<> " new zod /path/to/pill -F zod -A arvo/folder"
|
|
, ""
|
|
, "Simple Usage: "
|
|
, " $ " <>exe<> " new pier <my-comet> to create a comet (anonymous urbit)"
|
|
, " $ " <>exe<> " new pier <my-planet> -k <my-key-file> if you own a planet"
|
|
, " $ " <>exe<> " run <myplanet or mycomet> to restart an existing urbit"
|
|
, ""
|
|
, "For more information about developing on urbit, see:"
|
|
, " https://github.com/urbit/urbit/blob/master/CONTRIBUTING.md"
|
|
]
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
parseArgs :: IO (Cmd, Log)
|
|
parseArgs = do
|
|
nm <- getProgName
|
|
|
|
let p = prefs $ showHelpOnError
|
|
<> showHelpOnEmpty
|
|
<> columns 80
|
|
|
|
let o = info (cmd <**> helper)
|
|
$ progDesc "Start an existing Urbit or boot a new one."
|
|
<> headerDoc (Just $ headNote "0.9001.0")
|
|
<> footerDoc (Just $ footNote nm)
|
|
<> fullDesc
|
|
|
|
customExecParser p o
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
defaultPillURL :: String
|
|
defaultPillURL = "https://bootstrap.urbit.org/urbit-v" <> ver <> ".pill"
|
|
where
|
|
ver = VERSION_urbit_king
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
newComet :: Parser BootType
|
|
newComet = flag' BootComet
|
|
( long "comet"
|
|
<> help "Boot a new comet"
|
|
)
|
|
|
|
newFakeship :: Parser BootType
|
|
newFakeship = BootFake <$> strOption
|
|
(short 'F'
|
|
<> long "fake"
|
|
<> metavar "SHIP"
|
|
<> help "Boot a fakeship")
|
|
|
|
newFromKeyfile :: Parser BootType
|
|
newFromKeyfile = BootFromKeyfile <$> strOption
|
|
(short 'k'
|
|
<> long "keyfile"
|
|
<> metavar "KEYFILE"
|
|
<> help "Boot from a keyfile")
|
|
|
|
pillFromPath :: Parser PillSource
|
|
pillFromPath = PillSourceFile <$> strOption
|
|
( short 'B'
|
|
<> long "pill"
|
|
<> metavar "PILL"
|
|
<> help "Path to pill file")
|
|
|
|
pillFromURL :: Parser PillSource
|
|
pillFromURL = PillSourceURL <$> strOption
|
|
( short 'u'
|
|
<> long "pill-url"
|
|
<> metavar "URL"
|
|
<> value defaultPillURL
|
|
<> help "URL to pill file")
|
|
|
|
pierPath :: Parser FilePath
|
|
pierPath = strArgument (metavar "PIER" <> help "Path to pier")
|
|
|
|
new :: Parser New
|
|
new = do
|
|
nPierPath <- optional pierPath
|
|
|
|
nBootType <- newComet <|> newFakeship <|> newFromKeyfile
|
|
|
|
nPillSource <- pillFromPath <|> pillFromURL
|
|
|
|
nLite <- switch
|
|
$ short 'l'
|
|
<> long "lite"
|
|
<> help "Boots ship in lite mode"
|
|
|
|
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 <-
|
|
optional
|
|
$ option auto
|
|
$ metavar "PORT"
|
|
<> short 'p'
|
|
<> long "ames"
|
|
<> help "Ames port"
|
|
<> hidden
|
|
|
|
oNoAmes <-
|
|
switch
|
|
$ long "no-ames"
|
|
<> help "Run with Ames disabled."
|
|
<> hidden
|
|
|
|
oNoHttp <-
|
|
switch
|
|
$ long "no-http"
|
|
<> help "Run with HTTP disabled."
|
|
<> hidden
|
|
|
|
oNoHttps <-
|
|
switch
|
|
$ long "no-https"
|
|
<> help "Run with HTTPS disabled."
|
|
<> hidden
|
|
|
|
oHttpPort <-
|
|
optional
|
|
$ option auto
|
|
$ metavar "PORT"
|
|
<> long "http-port"
|
|
<> help "HTTP port"
|
|
<> hidden
|
|
|
|
oHttpsPort <-
|
|
optional
|
|
$ option auto
|
|
$ metavar "PORT"
|
|
<> long "https-port"
|
|
<> help "HTTPS port"
|
|
<> hidden
|
|
|
|
oLoopbackPort <-
|
|
optional
|
|
$ option auto
|
|
$ metavar "PORT"
|
|
<> long "loopback-port"
|
|
<> help "Localhost-only HTTP port"
|
|
<> hidden
|
|
|
|
oSerfExe <-
|
|
optional
|
|
$ strOption
|
|
$ metavar "PATH"
|
|
<> long "serf"
|
|
<> help "Path to Serf"
|
|
<> hidden
|
|
|
|
oHashless <- switch $ short 'S'
|
|
<> long "hashless"
|
|
<> help "Disable battery hashing (Ignored for now)"
|
|
<> hidden
|
|
|
|
oQuiet <- switch $ short 'q'
|
|
<> long "quiet"
|
|
<> help "Quiet"
|
|
<> hidden
|
|
|
|
oVerbose <- switch $ short 'v'
|
|
<> long "verbose"
|
|
<> help "Puts the serf and king into verbose mode"
|
|
<> hidden
|
|
|
|
oExit <- switch $ short 'x'
|
|
<> long "exit"
|
|
<> help "Exit immediately"
|
|
<> hidden
|
|
|
|
oDryRun <- switch $ long "dry-run"
|
|
<> help "Persist no events and turn off Ames networking"
|
|
<> hidden
|
|
|
|
oDryFrom <- optional $ option auto $ metavar "EVENT"
|
|
<> long "dry-from"
|
|
<> help "Dry run from event number"
|
|
<> hidden
|
|
|
|
oTrace <- switch $ short 't'
|
|
<> long "trace"
|
|
<> help "Enable tracing"
|
|
<> hidden
|
|
|
|
oLocalhost <- switch $ short 'L'
|
|
<> long "local"
|
|
<> help "Localhost-only networking"
|
|
<> hidden
|
|
|
|
oCollectFx <- switch $ short 'f'
|
|
<> long "collect-fx"
|
|
<> help "Write effects to disk for debugging"
|
|
<> hidden
|
|
|
|
oOffline <- switch $ short 'O'
|
|
<> long "offline"
|
|
<> help "Run without any networking"
|
|
<> hidden
|
|
|
|
oFullReplay <- switch
|
|
$ long "full-log-replay"
|
|
<> help "Ignores snapshot and recomputes state from event log"
|
|
<> hidden
|
|
|
|
pure (Opts{..})
|
|
|
|
log :: Parser Log
|
|
log = do
|
|
lTarget <-
|
|
optional
|
|
$ ( flag' LogStderr
|
|
$ long "log-to-stderr"
|
|
<> long "stderr"
|
|
<> help "Display logs on stderr"
|
|
<> hidden
|
|
)
|
|
<|> ( fmap LogFile . strOption
|
|
$ long "log-to"
|
|
<> metavar "LOG_FILE"
|
|
<> help "Append logs to the given file"
|
|
<> hidden
|
|
)
|
|
<|> ( flag' LogOff
|
|
$ long "no-logging"
|
|
<> help "Disable logging entirely"
|
|
<> hidden
|
|
)
|
|
|
|
lLevel <-
|
|
optional
|
|
$ ( flag' LevelDebug
|
|
$ long "log-debug"
|
|
<> help "Log errors, warnings, info, and debug messages"
|
|
<> hidden
|
|
)
|
|
<|> ( flag' LevelInfo
|
|
$ long "log-info"
|
|
<> help "Log errors, warnings, and info (default)"
|
|
<> hidden
|
|
)
|
|
<|> ( flag' LevelWarn
|
|
$ long "log-warn"
|
|
<> help "Log errors and warnings"
|
|
<> hidden
|
|
)
|
|
<|> ( flag' LevelError
|
|
$ long "log-error"
|
|
<> help "Log errors only"
|
|
<> hidden
|
|
)
|
|
|
|
pure (Log{..})
|
|
|
|
newShip :: Parser (Cmd, Log)
|
|
newShip = (,) <$> (CmdNew <$> new <*> opts) <*> log
|
|
|
|
runOneShip :: Parser (Run, Opts, Bool)
|
|
runOneShip = (,,) <$> fmap Run pierPath <*> opts <*> df
|
|
where
|
|
df = switch (short 'd' <> long "daemon" <> help "Daemon mode" <> hidden)
|
|
|
|
host :: Parser Host
|
|
host = do
|
|
hSharedHttpPort <-
|
|
optional
|
|
$ option auto
|
|
$ metavar "PORT"
|
|
<> long "shared-http-port"
|
|
<> help "HTTP port"
|
|
<> hidden
|
|
|
|
hSharedHttpsPort <-
|
|
optional
|
|
$ option auto
|
|
$ metavar "PORT"
|
|
<> long "shared-https-port"
|
|
<> help "HTTPS port"
|
|
<> hidden
|
|
|
|
pure (Host{..})
|
|
|
|
runShip :: Parser (Cmd, Log)
|
|
runShip = (,) <$> (CmdRun <$> host <*> some runOneShip) <*> log
|
|
|
|
valPill :: Parser Bug
|
|
valPill = do
|
|
bPillPath <- strArgument (metavar "PILL" <> help "Path to pill")
|
|
|
|
bPrintPil <- switch $ long "print-pill"
|
|
<> help "Print pill"
|
|
|
|
bPrintSeq <- switch $ long "print-boot"
|
|
<> help "Print boot sequence"
|
|
|
|
pure ValidatePill{..}
|
|
|
|
keyfilePath :: Parser FilePath
|
|
keyfilePath = strArgument (metavar "KEYFILE" <> help "Path to key file")
|
|
|
|
firstEv :: Parser Word64
|
|
firstEv = option auto $ long "first"
|
|
<> metavar "FST"
|
|
<> help "starting from event FST"
|
|
<> value 1
|
|
|
|
lastEv :: Parser Word64
|
|
lastEv = option auto $ long "last"
|
|
<> metavar "LAS"
|
|
<> help "ending with event LAS"
|
|
<> value maxBound
|
|
|
|
checkEvs :: Parser Bug
|
|
checkEvs = ValidateEvents <$> pierPath <*> firstEv <*> lastEv
|
|
|
|
checkFx :: Parser Bug
|
|
checkFx = ValidateFX <$> pierPath <*> firstEv <*> lastEv
|
|
|
|
replayEvs :: Parser Bug
|
|
replayEvs = ReplayEvents <$> pierPath <*> lastEv
|
|
|
|
browseEvs :: Parser Bug
|
|
browseEvs = EventBrowser <$> pierPath
|
|
|
|
checkDawn :: Parser Bug
|
|
checkDawn = CheckDawn <$> keyfilePath
|
|
|
|
bugCmd :: Parser (Cmd, Log)
|
|
bugCmd = (flip (,) <$> log <*>) $ fmap CmdBug
|
|
$ subparser
|
|
$ command "validate-pill"
|
|
( info (valPill <**> helper)
|
|
$ progDesc "Validate a pill file."
|
|
)
|
|
<> command "collect-all-fx"
|
|
( info (allFx <**> helper)
|
|
$ progDesc "Replay entire event log, collecting all effects"
|
|
)
|
|
<> command "validate-events"
|
|
( info (checkEvs <**> helper)
|
|
$ progDesc "Parse all data in event log"
|
|
)
|
|
<> command "event-browser"
|
|
( info (browseEvs <**> helper)
|
|
$ progDesc "Interactively view (and prune) event log"
|
|
)
|
|
<> command "validate-effects"
|
|
( info (checkFx <**> helper)
|
|
$ progDesc "Parse all data in event log"
|
|
)
|
|
<> command "partial-replay"
|
|
( info (replayEvs <**> helper)
|
|
$ progDesc "Replay up to N events"
|
|
)
|
|
<> command "dawn"
|
|
( info (checkDawn <**> helper)
|
|
$ progDesc "Test run dawn"
|
|
)
|
|
<> command "comet"
|
|
( info (pure CheckComet)
|
|
$ progDesc "Shows the list of stars accepting comets"
|
|
)
|
|
|
|
conCmd :: Parser (Cmd, Log)
|
|
conCmd = (,) <$> (CmdCon <$> pierPath) <*> log
|
|
|
|
allFx :: Parser Bug
|
|
allFx = do
|
|
bPierPath <- strArgument (metavar "PIER" <> help "Path to pier")
|
|
pure CollectAllFX{..}
|
|
|
|
cmd :: Parser (Cmd, Log)
|
|
cmd = subparser
|
|
$ command "new" ( info (newShip <**> helper)
|
|
$ progDesc "Boot a new ship."
|
|
)
|
|
<> command "run" ( info (runShip <**> helper)
|
|
$ progDesc "Run an existing ship."
|
|
)
|
|
<> command "bug" ( info (bugCmd <**> helper)
|
|
$ progDesc "Run a debugging sub-command."
|
|
)
|
|
<> command "con" ( info (conCmd <**> helper)
|
|
$ progDesc "Connect a terminal to a running urbit."
|
|
)
|