shrub/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs

597 lines
16 KiB
Haskell
Raw Normal View History

2019-08-13 07:57:30 +03:00
{-# OPTIONS_GHC -Werror -Wall #-}
{-# LANGUAGE CPP #-}
2020-01-23 07:16:09 +03:00
{-|
Command line parsing.
-}
module Urbit.King.CLI where
2019-08-13 07:57:30 +03:00
2020-08-15 05:25:07 +03:00
import ClassyPrelude hiding (log)
2019-08-13 07:57:30 +03:00
import Options.Applicative
import Options.Applicative.Help.Pretty
import Data.Word (Word16)
2020-08-15 05:25:07 +03:00
import RIO (LogLevel(..))
2019-08-13 07:57:30 +03:00
import System.Environment (getProgName)
--------------------------------------------------------------------------------
2020-08-15 05:25:07 +03:00
data Host = Host
{ hSharedHttpPort :: Maybe Word16
, hSharedHttpsPort :: Maybe Word16
2020-08-18 22:43:31 +03:00
, hUseNatPmp :: Nat
, hSerfExe :: Maybe Text
}
deriving (Show)
2020-08-15 05:25:07 +03:00
-- | Options for each running pier.
2019-08-13 07:57:30 +03:00
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
, oInjectEvents :: [Injection]
2019-08-13 07:57:30 +03:00
}
deriving (Show)
2020-08-15 05:25:07 +03:00
-- | Options for the logging subsystem.
data Log = Log
{ lTarget :: Maybe (LogTarget FilePath)
, lLevel :: LogLevel
2020-08-15 05:25:07 +03:00
}
deriving (Show)
data LogTarget a
= LogOff
| LogStderr
| LogFile a
deriving (Show)
2019-10-01 21:23:34 +03:00
data BootType
= BootComet
| BootFake Text
| BootFromKeyfile FilePath
deriving (Show)
data PillSource
= PillSourceFile FilePath
| PillSourceURL String
deriving (Show)
2020-08-18 22:43:31 +03:00
data Nat
= NatAlways
| NatWhenPrivateNetwork
| NatNever
deriving (Show)
data Injection
= InjectOneEvent FilePath
| InjectManyEvents FilePath
deriving (Show)
2019-08-13 07:57:30 +03:00
data New = New
{ nPillSource :: PillSource
, nPierPath :: Maybe FilePath -- Derived from ship name if not specified.
, nArvoDir :: Maybe FilePath
, nBootType :: BootType
, nLite :: Bool
, nEthNode :: String
, nSerfExe :: Maybe Text
2019-08-13 07:57:30 +03:00
}
deriving (Show)
data Run = Run
2019-08-13 08:56:31 +03:00
{ rPierPath :: FilePath
2019-08-13 07:57:30 +03:00
}
deriving (Show)
data Bug
2019-08-22 02:49:08 +03:00
= ValidatePill
{ bPillPath :: FilePath
, bPrintPil :: Bool
, bPrintSeq :: Bool
}
| CollectAllFX
{ bPierPath :: FilePath
}
| EventBrowser
{ bPierPath :: FilePath
}
2019-08-22 03:29:39 +03:00
| ValidateEvents
{ bPierPath :: FilePath
, bFirstEvt :: Word64
2019-08-22 03:54:00 +03:00
, bFinalEvt :: Word64
2019-08-22 03:29:39 +03:00
}
| ValidateFX
{ bPierPath :: FilePath
2019-08-22 03:54:00 +03:00
, bFirstEvt :: Word64
, bFinalEvt :: Word64
2019-08-22 03:29:39 +03:00
}
| ReplayEvents
{ bPierPath :: FilePath
, bFinalEvt :: Word64
}
| CheckDawn
{ bEthNode :: String
, bKeyfilePath :: FilePath
2019-09-24 02:42:12 +03:00
}
| CheckComet
deriving (Show)
2019-08-13 07:57:30 +03:00
data Cmd
2020-08-15 05:25:07 +03:00
= CmdNew New Opts
| CmdRun Host [(Run, Opts, Bool)]
| CmdBug Bug
| CmdCon FilePath
2019-08-13 07:57:30 +03:00
deriving (Show)
--------------------------------------------------------------------------------
headNote :: String -> Doc
headNote _version = string $ intercalate "\n"
[ "Urbit: a personal server operating function"
, "https://urbit.org"
, "Version " <> VERSION_urbit_king
2019-08-13 07:57:30 +03:00
]
2020-01-23 07:16:09 +03:00
-- | TODO This needs to be updated.
2019-08-13 07:57:30 +03:00
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"
]
--------------------------------------------------------------------------------
2020-08-15 05:25:07 +03:00
parseArgs :: IO (Cmd, Log)
2019-08-13 07:57:30 +03:00
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
2020-01-23 07:16:09 +03:00
defaultPillURL = "https://bootstrap.urbit.org/urbit-v" <> ver <> ".pill"
where
ver = VERSION_urbit_king
--------------------------------------------------------------------------------
2019-10-01 21:23:34 +03:00
newComet :: Parser BootType
newComet = flag' BootComet
2020-01-23 07:16:09 +03:00
( long "comet"
<> help "Boot a new comet"
)
2019-10-01 21:23:34 +03:00
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")
injectEvents :: Parser [Injection]
2020-10-22 17:53:28 +03:00
injectEvents = many $ InjectOneEvent <$> strOption
( short 'I'
<> long "inject-event"
<> metavar "JAM"
<> help "Path to a jammed event"
<> hidden)
<|> InjectManyEvents <$> strOption
( long "inject-event-list"
<> metavar "JAM_LIST"
<> help "Path to a jammed list of events"
<> hidden)
serfExe :: Parser (Maybe Text)
serfExe = optional
$ strOption
$ metavar "PATH"
<> long "serf"
<> help "Path to serf binary to run ships in"
<> hidden
ethNode :: Parser String
ethNode = strOption
$ short 'e'
<> long "eth-node"
<> value "http://eth-mainnet.urbit.org:8545"
<> help "Ethereum gateway URL"
<> hidden
2019-08-13 07:57:30 +03:00
new :: Parser New
new = do
nPierPath <- optional pierPath
2019-08-15 05:42:48 +03:00
2019-10-01 21:23:34 +03:00
nBootType <- newComet <|> newFakeship <|> newFromKeyfile
nPillSource <- pillFromPath <|> pillFromURL
2019-08-15 05:42:48 +03:00
2019-10-03 21:31:15 +03:00
nLite <- switch
$ short 'l'
<> long "lite"
<> help "Boots ship in lite mode"
2019-08-15 05:42:48 +03:00
nArvoDir <- option auto
$ metavar "PATH"
<> short 'A'
<> long "arvo"
<> value Nothing
<> help "Replace initial clay filesys with contents of PATH"
2019-08-13 07:57:30 +03:00
nEthNode <- ethNode
nSerfExe <- serfExe
2019-08-13 07:57:30 +03:00
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
2019-08-15 05:42:48 +03:00
oInjectEvents <- injectEvents
oHashless <- switch $ short 'S'
<> long "hashless"
<> help "Disable battery hashing (Ignored for now)"
<> hidden
2019-08-15 05:42:48 +03:00
oQuiet <- switch $ short 'q'
<> long "quiet"
<> help "Quiet"
<> hidden
oVerbose <- switch $ short 'v'
<> long "verbose"
2020-08-15 05:25:07 +03:00
<> help "Puts the serf and king into verbose mode"
2019-08-15 05:42:48 +03:00
<> hidden
oExit <- switch $ short 'x'
<> long "exit"
2020-02-04 04:27:16 +03:00
<> help "Exit immediately"
2019-08-15 05:42:48 +03:00
<> hidden
2019-10-22 01:32:12 +03:00
oDryRun <- switch $ long "dry-run"
<> help "Persist no events and turn off Ames networking"
2019-08-15 05:42:48 +03:00
<> 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
2019-08-15 05:42:48 +03:00
oLocalhost <- switch $ short 'L'
<> long "local"
<> help "Localhost-only networking"
<> hidden
oCollectFx <- switch $ short 'f'
<> long "collect-fx"
2019-08-15 01:35:36 +03:00
<> help "Write effects to disk for debugging"
2019-08-15 05:42:48 +03:00
<> hidden
2019-10-18 03:02:33 +03:00
oOffline <- switch $ short 'O'
<> long "offline"
<> help "Run without any networking"
<> hidden
2019-10-22 01:26:51 +03:00
oFullReplay <- switch
$ long "full-log-replay"
2020-08-15 05:25:07 +03:00
<> help "Ignores snapshot and recomputes state from event log"
2019-10-22 23:05:58 +03:00
<> hidden
2019-10-22 01:26:51 +03:00
2019-08-13 07:57:30 +03:00
pure (Opts{..})
2020-08-15 05:25:07 +03:00
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 <-
( flag' LevelDebug
2020-08-15 05:25:07 +03:00
$ long "log-debug"
<> help "Log errors, warnings, info, and debug messages"
<> hidden
)
<|> ( flag' LevelInfo
$ long "log-info"
<> help "Log errors, warnings, and info"
2020-08-15 05:25:07 +03:00
<> hidden
)
<|> ( flag' LevelWarn
$ long "log-warn"
<> help "Log errors and warnings (default)"
2020-08-15 05:25:07 +03:00
<> hidden
)
<|> ( flag' LevelError
$ long "log-error"
<> help "Log errors only"
<> hidden
)
<|> pure LevelWarn
2020-08-15 05:25:07 +03:00
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)
2020-08-15 05:25:07 +03:00
host :: Parser Host
host = do
hSharedHttpPort <-
optional
$ option auto
$ metavar "PORT"
<> long "shared-http-port"
<> help "HTTP port"
<> hidden
2020-08-15 05:25:07 +03:00
hSharedHttpsPort <-
optional
$ option auto
$ metavar "PORT"
<> long "shared-https-port"
<> help "HTTPS port"
<> hidden
hUseNatPmp <-
2020-08-18 22:43:31 +03:00
( flag' NatAlways
$ long "port-forwarding"
<> help "Always try to search for a router to forward ames ports"
<> hidden
) <|>
2020-08-18 22:43:31 +03:00
( flag' NatNever
$ long "no-port-forwarding"
<> help "Disable trying to ask the router to forward ames ports"
<> hidden
) <|>
2020-08-18 22:43:31 +03:00
( flag' NatWhenPrivateNetwork
$ long "port-forwarding-when-internal"
<> help ("Try asking the router to forward when ip is 192.168.0.0/16, " <>
"172.16.0.0/12 or 10.0.0.0/8 (default).")
2020-08-18 22:43:31 +03:00
<> hidden
) <|>
(pure $ NatWhenPrivateNetwork)
hSerfExe <- serfExe
2020-08-15 05:25:07 +03:00
pure (Host{..})
2020-08-15 05:25:07 +03:00
runShip :: Parser (Cmd, Log)
runShip = (,) <$> (CmdRun <$> host <*> some runOneShip) <*> log
2019-08-15 05:42:48 +03:00
valPill :: Parser Bug
2019-08-15 05:42:48 +03:00
valPill = do
2019-08-22 02:49:08 +03:00
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{..}
2019-09-24 02:42:12 +03:00
keyfilePath :: Parser FilePath
keyfilePath = strArgument (metavar "KEYFILE" <> help "Path to key file")
2019-08-22 03:54:00 +03:00
firstEv :: Parser Word64
firstEv = option auto $ long "first"
<> metavar "FST"
<> help "starting from event FST"
<> value 1
2019-08-22 03:29:39 +03:00
2019-08-22 03:54:00 +03:00
lastEv :: Parser Word64
lastEv = option auto $ long "last"
<> metavar "LAS"
<> help "ending with event LAS"
2019-08-22 03:54:00 +03:00
<> value maxBound
checkEvs :: Parser Bug
checkEvs = ValidateEvents <$> pierPath <*> firstEv <*> lastEv
checkFx :: Parser Bug
checkFx = ValidateFX <$> pierPath <*> firstEv <*> lastEv
2019-08-22 03:29:39 +03:00
replayEvs :: Parser Bug
replayEvs = ReplayEvents <$> pierPath <*> lastEv
browseEvs :: Parser Bug
browseEvs = EventBrowser <$> pierPath
checkDawn :: Parser Bug
checkDawn = CheckDawn <$> ethNode <*> keyfilePath
2020-08-15 05:25:07 +03:00
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"
)
2019-08-22 03:29:39 +03:00
<> 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"
)
2019-08-22 03:54:00 +03:00
<> 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"
)
2020-08-15 05:25:07 +03:00
conCmd :: Parser (Cmd, Log)
conCmd = (,) <$> (CmdCon <$> pierPath) <*> log
allFx :: Parser Bug
allFx = do
2019-08-22 02:49:08 +03:00
bPierPath <- strArgument (metavar "PIER" <> help "Path to pier")
pure CollectAllFX{..}
2019-08-15 05:42:48 +03:00
2020-08-15 05:25:07 +03:00
cmd :: Parser (Cmd, Log)
2019-08-13 07:57:30 +03:00
cmd = subparser
2019-08-15 05:42:48 +03:00
$ 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."
2019-08-15 05:42:48 +03:00
)
<> command "con" ( info (conCmd <**> helper)
$ progDesc "Connect a terminal to a running urbit."
)