Merge pull request #38 from input-output-hk/anviking/8/launcher

Launch http bridge and wallet together

.weeder.yaml

@@ -0,0 +1,12 @@
+- package:
+  - name: cardano-wallet
+  - section:
+    - name: exe:cardano-wallet-launcher exe:cardano-wallet-server
+    - message:
+      - name: Module reused between components
+      - module: Cardano.CLI
+  - section:
+    - name: exe:cardano-wallet-launcher test:unit
+    - message:
+      - name: Module reused between components
+      - module: Cardano.Launcher

app/Cardano/CLI.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+
+-- |
+-- Copyright: © 2018-2019 IOHK
+-- License: MIT
+--
+-- Shared types and helpers for CLI parsing
+
+module Cardano.CLI
+    ( getArg
+    , Port
+    , Network
+    , encode
+    , decode
+    ) where
+
+import GHC.TypeLits
+    ( Symbol )
+import Prelude
+import System.Console.Docopt
+    ( Arguments, Docopt, Option, exitWithUsage, getArgOrExitWith )
+import Text.Read
+    ( readMaybe )
+
+-- | Port number with a tag for describing what it is used for
+newtype Port (tag :: Symbol) = Port Int
+
+data Network = Mainnet | Testnet
+    deriving (Show, Enum)
+
+getArg
+    :: Arguments
+    -> Docopt
+    -> Option
+    -> (String -> Either String a)
+    -> IO a
+getArg args cli opt decod = do
+    str <- getArgOrExitWith cli args opt
+    case decod str of
+        Right a -> return a
+        Left err -> do
+            putStrLn $ "Invalid " <> show opt <> ". " <> err
+            putStrLn ""
+            exitWithUsage cli
+
+-- | Encoding things into command line arguments
+class Encodable a where
+    encode :: a -> String
+
+-- | Decoding command line arguments
+class Decodable a where
+    decode :: String -> Either String a
+
+instance Encodable Int where
+    encode = show
+
+instance Decodable Int where
+    decode str =
+        maybe (Left err) Right (readMaybe str)
+      where
+        err = "Not an integer: " ++ show str ++ "."
+
+instance Encodable (Port (tag :: Symbol)) where
+    encode (Port p) = encode p
+
+instance Decodable (Port (tag :: Symbol))where
+    decode str = Port <$> decode str
+
+instance Encodable Network where
+    encode Mainnet = "mainnet"
+    encode Testnet = "testnet"
+
+instance Decodable Network where
+    decode "mainnet" = Right Mainnet
+    decode "testnet" = Right Testnet
+    decode s = Left $ show s ++ " is neither \"mainnet\" nor \"testnet\"."

app/Cardano/Launcher.hs

@@ -0,0 +1,78 @@
+-- |
+-- Copyright: © 2018-2019 IOHK
+-- License: MIT
+--
+-- This module contains a mechanism for launching external processes together,
+-- and provides the functionality needed to kill them all if one goes down.
+-- (would be achieved using @monitor@ and @kill@ in combination)
+
+module Cardano.Launcher
+    ( Command (..)
+    , ProcessHasExited(..)
+    , launch
+    ) where
+
+import Prelude
+
+import Control.Concurrent.Async
+    ( forConcurrently )
+import Control.Exception
+    ( Exception, throwIO, try )
+import Data.List
+    ( isPrefixOf )
+import Fmt
+    ( Buildable (..), blockListF', indentF )
+import System.Exit
+    ( ExitCode )
+import System.Process
+    ( proc, waitForProcess, withCreateProcess )
+
+
+data Command = Command
+    { cmdName :: String
+    , cmdArgs :: [String]
+    , cmdSetup :: IO ()
+        -- ^ An extra action to run _before_ the command
+    }
+
+-- Format a command nicely with one argument / option per line.
+--
+-- e.g.
+--
+-- >>> fmt $ build $ Command "cardano-wallet-server" ["--port", "8080", "--network", "mainnet"] (return ())
+-- cardano-wallet-server
+--     --port 8080
+--     --network mainnet
+instance Buildable Command where
+    build (Command name args _) = build name
+        <> "\n"
+        <> indentF 4 (blockListF' "" build $ snd $ foldl buildOptions ("", []) args)
+      where
+        buildOptions :: (String, [String]) -> String -> (String, [String])
+        buildOptions ("", grp) arg =
+            (arg, grp)
+        buildOptions (partial, grp) arg =
+            if ("--" `isPrefixOf` partial) && not ("--" `isPrefixOf` arg) then
+                ("", grp ++ [partial <> " " <> arg])
+            else
+                (arg, grp ++ [partial])
+
+-- | ProcessHasExited is used by a monitoring thread to signal that the process
+-- has exited.
+data ProcessHasExited = ProcessHasExited String ExitCode
+    deriving Show
+
+instance Exception ProcessHasExited
+
+launch :: [Command] -> IO ProcessHasExited
+launch cmds = do
+    res <- try $ forConcurrently cmds $ \(Command name args before) -> do
+        before
+        withCreateProcess (proc name args) $ \_ _ _ h -> do
+            code <- waitForProcess h
+            throwIO $ ProcessHasExited name code
+    case res of
+        Left e -> return e
+        Right _ -> error
+            "Unreachable. Supervising threads should never finish. \
+            \They should stay running or throw @ProcessHasExited@."

app/launcher/Main.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Main where
+
+import Prelude
+
+import Cardano.CLI
+    ( Network, Port, decode, encode, getArg )
+import Cardano.Launcher
+    ( Command (Command), ProcessHasExited (ProcessHasExited), launch )
+import Control.Concurrent
+    ( threadDelay )
+import Control.Monad
+    ( when )
+import Fmt
+    ( blockListF, fmt )
+import Say
+    ( sayErr )
+import System.Console.Docopt
+    ( Docopt, docopt, exitWithUsage, isPresent, longOption, parseArgsOrExit )
+import System.Environment
+    ( getArgs )
+import System.Exit
+    ( exitWith )
+
+import qualified Data.Text as T
+
+
+-- | Command-Line Interface specification. See http://docopt.org/
+cli :: Docopt
+cli = [docopt|
+cardano-wallet-launcher
+
+Start the cardano wallet along with its API and underlying node.
+
+Requires cardano-http-bridge. To install, follow instructions at
+https://github.com/input-output-hk/cardano-http-bridge, and run
+  cargo install --path .
+in the directory.
+
+Usage:
+  cardano-wallet-launcher [options]
+  cardano-wallet-launcher --help
+
+Options:
+  --network <NETWORK>          mainnet or testnet [default: mainnet]
+  --wallet-server-port <PORT>  port used for serving the wallet API [default: 8090]
+  --http-bridge-port <PORT>    port used for communicating with the http-bridge [default: 8080]
+|]
+
+main :: IO ()
+main = do
+    args <- parseArgsOrExit cli =<< getArgs
+    when (args `isPresent` (longOption "help")) $ exitWithUsage cli
+
+    bridgePort <- getArg args cli (longOption "http-bridge-port") decode
+    walletPort <- getArg args cli (longOption "wallet-server-port") decode
+    network <- getArg args cli (longOption "network") decode
+
+    sayErr "Starting..."
+    let commands =
+            [ nodeHttpBridgeOn bridgePort
+            , walletOn walletPort bridgePort network
+            ]
+    sayErr $ fmt $ blockListF commands
+    (ProcessHasExited name code) <- launch commands
+    sayErr $ T.pack name <> " exited with code " <> T.pack (show code) 
+    exitWith code
+
+nodeHttpBridgeOn :: Port "Node" -> Command
+nodeHttpBridgeOn port = Command
+    "cardano-http-bridge"
+    [ "start"
+    , "--port", encode port
+    ]
+    (return ())
+
+walletOn :: Port "Wallet" -> Port "Node" -> Network -> Command
+walletOn wp np net = Command
+    "cardano-wallet-server"
+    [ "--wallet-server-port", encode wp
+    , "--http-bridge-port", encode np
+    , "--network", encode net
+    ]
+    (threadDelay oneSecond)
+  where
+    oneSecond = 1000000

app/server/Main.hs

@@ -1,16 +1,20 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
-{-
-   This module parses command line arguments and starts the wallet.
-
-   This should be the only module that has a notion of command line arguments.
-   Although, for development purposes, we may extend the docopt specification
-   here and call `getArgs` where it is needed.
--}
+-- |
+-- This module parses command line arguments and starts the wallet.
+--
+-- This should be the only module that has a notion of command line arguments.
+-- Although, for development purposes, we may extend the docopt specification
+-- here and call `getArgs` where it is needed.
 module Main where
 
 import Prelude
 
+import Cardano.CLI
+    ( Network, Port, decode, encode, getArg )
 import Cardano.NetworkLayer
     ( listen )
 import Cardano.Wallet.Primitive
@@ -19,91 +23,45 @@ import Control.Monad
     ( when )
 import Fmt
     ( build, fmt )
+import Say
+    ( say )
 import System.Console.Docopt
-    ( Arguments
-    , Docopt
-    , Option
-    , docopt
-    , exitWithUsage
-    , getArgOrExitWith
-    , isPresent
-    , longOption
-    , parseArgsOrExit
-    )
+    ( Docopt, docopt, exitWithUsage, isPresent, longOption, parseArgsOrExit )
 import System.Environment
     ( getArgs )
-import Text.Read
-    ( readMaybe )
 
 import qualified Cardano.NetworkLayer.HttpBridge as HttpBridge
 import qualified Data.Text as T
-import qualified Data.Text.IO as T
+
 
 -- | Command-Line Interface specification. See http://docopt.org/
 cli :: Docopt
 cli = [docopt|
 cardano-wallet-server
 
-Start the cardano wallet along with its API and underlying node.
+Start the cardano wallet server.
 
 Usage:
   cardano-wallet-server [options]
   cardano-wallet-server --help
 
 Options:
-  --wallet-server-port <PORT>  port used for serving the wallet API [default: 8090]
-  --node-port <PORT>           port used for node-wallet communication [default: 8080]
   --network <NETWORK>          mainnet or testnet [default: mainnet]
+  --wallet-server-port <PORT>  port used for serving the wallet API [default: 8090]
+  --http-bridge-port <PORT>    port used for communicating with the http-bridge [default: 8080]
 |]
 
-
-data Network = Mainnet | Testnet
-    deriving (Show, Enum)
-
 main :: IO ()
 main = do
     args <- parseArgsOrExit cli =<< getArgs
     when (args `isPresent` (longOption "help")) $ exitWithUsage cli
 
-    networkName <- getArg args (longOption "network") readNetwork
-    nodePort <- getArg args (longOption "node-port") readInt
-    _ <- getArg args (longOption "wallet-server-port") readInt
+    networkName <- getArg args cli (longOption "network") (decode @Network)
+    bridgePort <- getArg args cli (longOption "http-bridge-port") decode
+    _ <- getArg args cli (longOption "wallet-server-port") (decode @(Port "wallet"))
 
-    network <- HttpBridge.newNetworkLayer (showNetwork networkName) nodePort
+    network <- HttpBridge.newNetworkLayer (T.pack . encode $ networkName) bridgePort
     listen network logBlock
   where
     logBlock :: Block -> IO ()
-    logBlock = T.putStrLn . fmt . build
-
--- Functions for parsing the values of command line options
---
--- As the Left cases will just be used for printing in this module, we use
--- @String@ for now.
-
-readInt :: String -> Either String Int
-readInt str =
-    maybe (Left err) Right (readMaybe str)
-  where
-    err = "Not an integer: " ++ show str ++ "."
-
-readNetwork :: String -> Either String Network
-readNetwork "mainnet" = Right Mainnet
-readNetwork "testnet" = Right Testnet
-readNetwork s = Left $ show s ++ " is neither \"mainnet\" nor \"testnet\"."
-
-showNetwork :: Network -> T.Text
-showNetwork = T.toLower . T.pack . show
-
-getArg
-    :: Arguments
-    -> Option
-    -> (String -> Either String a)
-    -> IO a
-getArg args opt decode = do
-    str <- getArgOrExitWith cli args opt
-    case decode str of
-        Right a -> return a
-        Left err -> do
-            putStrLn $ "Invalid " <> show opt <> ". " <> err
-            putStrLn ""
-            exitWithUsage cli
+    logBlock = say . fmt . build