shrub/pkg/king/app/CLI.hs

348 lines
9.9 KiB
Haskell
Raw Normal View History

2019-08-13 07:57:30 +03:00
{-# OPTIONS_GHC -Werror -Wall #-}
{-# LANGUAGE CPP #-}
2019-10-01 21:23:34 +03:00
module CLI (parseArgs, Cmd(..), BootType(..), New(..), Run(..), Bug(..),
Opts(..)) where
2019-08-13 07:57:30 +03:00
import ClassyPrelude
import Options.Applicative
import Options.Applicative.Help.Pretty
import Data.Word (Word16)
import System.Environment (getProgName)
--------------------------------------------------------------------------------
data Opts = Opts
{ oQuiet :: Bool
, oHashless :: Bool
, oExit :: Bool
, oDryRun :: Bool
, oVerbose :: Bool
, oAmesPort :: Maybe Word16
, oTrace :: Bool
2019-08-15 01:35:36 +03:00
, oCollectFx :: Bool
2019-08-15 05:42:48 +03:00
, oLocalhost :: Bool
, oOffline :: Bool
2019-08-13 07:57:30 +03:00
}
deriving (Show)
2019-10-01 21:23:34 +03:00
data BootType
= BootComet
| BootFake Text
| BootFromKeyfile FilePath
deriving (Show)
2019-08-13 07:57:30 +03:00
data New = New
2019-10-01 21:23:34 +03:00
-- TODO: Pill path needs to become optional; need to default to either the
-- git hash version or the release version per current vere.
{ nPillPath :: FilePath
, nPierPath :: Maybe FilePath -- Derived from ship name if not specified.
, nArvoDir :: Maybe FilePath
2019-10-01 21:23:34 +03:00
, nBootType :: BootType
2019-10-03 21:31:15 +03:00
, nLite :: Bool
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
}
| CheckDawn
2019-09-24 02:42:12 +03:00
{ bKeyfilePath :: FilePath
}
| CheckComet
deriving (Show)
2019-08-13 07:57:30 +03:00
data Cmd
= CmdNew New Opts
| CmdRun Run Opts
| CmdBug Bug
| CmdCon Word16
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_king
]
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
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
--------------------------------------------------------------------------------
2019-10-01 21:23:34 +03:00
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")
2019-08-13 07:57:30 +03:00
new :: Parser New
new = do
2019-10-01 21:23:34 +03:00
-- nShipAddr <- strArgument
-- $ metavar "SHIP"
-- <> help "Ship address"
2019-08-15 05:42:48 +03:00
nPierPath <- optional
$ strArgument
2019-08-15 05:42:48 +03:00
$ metavar "PIER"
<> help "Path to pier"
2019-10-01 21:23:34 +03:00
nBootType <- newComet <|> newFakeship <|> newFromKeyfile
2019-08-15 05:42:48 +03:00
nPillPath <- strOption
$ short 'B'
<> long "pill"
<> metavar "PILL"
<> help "Path to pill file"
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
pure New{..}
opts :: Parser Opts
opts = do
2019-08-15 05:42:48 +03:00
oAmesPort <- option auto $ metavar "PORT"
<> short 'p'
<> long "ames"
<> help "Ames port number"
<> value Nothing
<> hidden
oHashless <- switch $ short 'S'
<> long "hashless"
<> help "Disable battery hashing"
<> hidden
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
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
oOffline <- switch $ short 'O'
<> long "offline"
<> help "Run without any 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-08-13 07:57:30 +03:00
pure (Opts{..})
newShip :: Parser Cmd
newShip = CmdNew <$> new <*> opts
2019-08-15 05:42:48 +03:00
runShip :: Parser Cmd
runShip = do
rPierPath <- strArgument (metavar "PIER" <> help "Path to pier")
o <- opts
pure (CmdRun (Run{..}) o)
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-08-22 03:54:00 +03:00
pierPath :: Parser FilePath
pierPath = strArgument (metavar "PIER" <> help "Path to pier")
2019-08-22 03:29:39 +03:00
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 "anding with event LAS"
<> 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
browseEvs :: Parser Bug
browseEvs = EventBrowser <$> pierPath
checkDawn :: Parser Bug
2019-09-24 02:42:12 +03:00
checkDawn = CheckDawn <$> keyfilePath
bugCmd :: Parser Cmd
bugCmd = 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 "dawn"
( info (checkDawn <**> helper)
$ progDesc "Test run dawn"
)
<> command "comet"
( info (pure CheckComet)
$ progDesc "Shows the list of stars accepting comets"
)
conCmd :: Parser Cmd
conCmd = do
port <- argument auto ( metavar "PORT"
<> help "Port of terminal server"
)
pure (CmdCon port)
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
2019-08-13 07:57:30 +03:00
cmd :: Parser Cmd
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."
)