CLI parsing.

pkg/king/app/CLI.hs

@@ -0,0 +1,133 @@
+{-# OPTIONS_GHC -Werror -Wall #-}
+{-# LANGUAGE CPP #-}
+
+module CLI (parseArgs, Cmd(..), New(..), Run(..), Opts(..)) where
+
+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
+    , oVerbose  :: Bool
+    , oAmesPort :: Maybe Word16
+    , oProf     :: Bool
+    }
+  deriving (Show)
+
+data New = New
+    { naPillPath :: FilePath
+    , naShipAddr :: Text
+    , naPierPath :: FilePath
+    , naArvoDir  :: Maybe FilePath
+    }
+  deriving (Show)
+
+data Run = Run
+    { raPierPath :: FilePath
+    }
+  deriving (Show)
+
+data Cmd
+    = CmdNew New Opts
+    | CmdRun Run Opts
+  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
+
+--------------------------------------------------------------------------------
+
+run :: Parser Run
+run = do
+    raPierPath <- strArgument (metavar "PIER" <> help "Path to pier")
+    pure Run{..}
+
+new :: Parser New
+new = do
+    naPierPath <- strArgument (metavar "PIER" <> help "Path to pier")
+
+    naPillPath <- strArgument $ metavar "PILL"
+                             <> help "Path to pill file"
+
+    naShipAddr <- strArgument $ metavar "SHIP"
+                             <> help "Ship address"
+
+    naArvoDir <- option auto $ metavar "ARVO"
+                            <> short 'A'
+                            <> value Nothing
+                            <> help "Initial Arvo filesystem"
+
+    pure New{..}
+
+opts :: Parser Opts
+opts = do
+    oAmesPort <- option auto $ metavar "PORT"
+                            <> short 'p'
+                            <> help "Ames port number"
+                            <> value Nothing
+
+    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")
+    oProf     <- switch (short 'p' <> help "Enable profiling")
+
+    pure (Opts{..})
+
+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")
+        )
+  where
+    runShip = CmdRun <$> run <*> opts
+    newShip = CmdNew <$> new <*> opts

pkg/king/app/Main.hs

@@ -2,12 +2,15 @@ module Main where
 
 import ClassyPrelude
 
+import Options.Applicative
+import Options.Applicative.Help.Pretty
+
 import Arvo
 import Control.Exception hiding (evaluate)
 import Data.Acquire
 import Data.Conduit
-import Data.Conduit.List
-import Noun
+import Data.Conduit.List hiding (replicate)
+import Noun hiding (Parser)
 import Vere.Pier
 import Vere.Pier.Types
 import Vere.Serf
@@ -15,9 +18,11 @@ import Vere.Serf
 import Control.Concurrent (runInBoundThread, threadDelay)
 import Control.Lens       ((&))
 import System.Directory   (doesFileExist, removeFile)
+import System.Environment (getProgName)
 import Text.Show.Pretty   (pPrint)
 import Urbit.Time         (Wen)
 
+import qualified CLI
 import qualified Data.Set  as Set
 import qualified Vere.Log  as Log
 import qualified Vere.Pier as Pier
@@ -153,8 +158,8 @@ collectAllFx top = do
 
 --------------------------------------------------------------------------------
 
-main :: IO ()
-main = runInBoundThread $ do
+tryDoStuff :: IO ()
+tryDoStuff = runInBoundThread $ do
     let pillPath = "/home/benjamin/r/urbit/bin/solid.pill"
         shipPath = "/home/benjamin/r/urbit/s/dev/"
         ship     = zod
@@ -174,6 +179,9 @@ main = runInBoundThread $ do
 
     pure ()
 
+main :: IO ()
+main = CLI.parseArgs >>= print
+
 --------------------------------------------------------------------------------
 
 tryParseFX :: FilePath -> Word -> Word -> IO ()

pkg/king/app/TryJamPill.hs

@@ -1,4 +1,4 @@
-module Main where
+module TryJamPill where
 
 import ClassyPrelude
 import Control.Lens

pkg/king/app/TryTimers.hs

@@ -1,5 +1,6 @@
-module Main where
+module TryTimers where
 
+{-
 import Prelude
 import Control.Lens
 
@@ -47,3 +48,4 @@ main = do
   putStrLn "<bench>"
   replicateM_ 10 (bench behn)
   putStrLn "</bench>"
+-}

pkg/king/package.yaml

@@ -1,4 +1,4 @@
-name: urbit
+name: king
 version: 0.1.0
 license: AGPL-3.0-only
 
@@ -12,10 +12,10 @@ library:
     - -O2
 
 tests:
-  urbit-tests:
+  king-tests:
     source-dirs: test
     main: Main.hs
-    dependencies: urbit
+    dependencies: king
     ghc-options:
       - -threaded
       - -rtsopts
@@ -82,6 +82,7 @@ dependencies:
   - wai-conduit
   - warp
   - warp-tls
+  - optparse-applicative
 
 default-extensions:
   - ApplicativeDo
@@ -127,3 +128,15 @@ default-extensions:
   - UnboxedTuples
   - UnicodeSyntax
   - ViewPatterns
+
+executables:
+  king:
+    main: Main.hs
+    source-dirs: app
+    dependencies: ["king"]
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - "-with-rtsopts=-N"
+      - -fwarn-incomplete-patterns
+      - -O0

stack.yaml

@@ -1,8 +1,7 @@
 resolver: lts-13.10
 
 packages:
-  - pkg/hs-urbit
-  - pkg/hs-vere
+  - pkg/king
 
 extra-deps:
   - para-1.1@sha256:a90eebb063ad70271e6e2a7f00a93e8e8f8b77273f100f39852fbf8301926f81
@@ -17,7 +16,7 @@ nix:
     - zlib
 
 ghc-options:
-  urbit: -fobject-code
+  king: -fobject-code
 
 # build:
 #   executable-profiling: true