From c9e7bcdf0811c64fa2b88fa089f6823fc58ba906 Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Thu, 7 Mar 2019 14:36:55 +0100 Subject: [PATCH 1/5] Refactor into new CLI module To be shared between all executables (cardano-wallet-server and cardano-wallet-launcher), and by providing an @Encodable@ class, should make it easy for the launcher to forward arguments to the server. (launcher is introduced in a later commit) --- app/cli/CLI.hs | 73 ++++++++++++++++++++++++++++++++++++++++++++ app/server/Main.hs | 66 ++++++++------------------------------- cardano-wallet.cabal | 8 ++--- 3 files changed, 90 insertions(+), 57 deletions(-) create mode 100644 app/cli/CLI.hs diff --git a/app/cli/CLI.hs b/app/cli/CLI.hs new file mode 100644 index 00000000000..5f1c14cb2de --- /dev/null +++ b/app/cli/CLI.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +module CLI where + +import GHC.TypeLits + ( Symbol ) +import Prelude +import System.Console.Docopt + ( Arguments, Docopt, Option, exitWithUsage, getArgOrExitWith ) +import Text.Read + ( readMaybe ) + + +-- Shared types and helpers for CLI parsing + + +-- | Port number with a tag for describing what it is used for +newtype Port (tag :: Symbol) = Port + { getPort :: 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\"." diff --git a/app/server/Main.hs b/app/server/Main.hs index 412fa6a0023..07c5e573a11 100644 --- a/app/server/Main.hs +++ b/app/server/Main.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {- This module parses command line arguments and starts the wallet. @@ -15,25 +18,15 @@ import Cardano.NetworkLayer ( listen ) import Cardano.Wallet.Primitive ( Block ) +import CLI import Control.Monad ( when ) import Fmt ( build, fmt ) 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 @@ -44,7 +37,7 @@ 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] @@ -52,58 +45,25 @@ Usage: Options: --wallet-server-port port used for serving the wallet API [default: 8090] - --node-port port used for node-wallet communication [default: 8080] --network mainnet or testnet [default: mainnet] + --node-port port used for node-wallet communication [default: 8080] |] -data Network = Mainnet | Testnet - deriving (Show, Enum) main :: IO () main = do args <- parseArgsOrExit cli =<< getArgs when (args `isPresent` (longOption "help")) $ exitWithUsage cli + let getArg' = getArg args cli + + networkName <- getArg' (longOption "network") (decode @Network) + nodePort <- getArg' (longOption "node-port") decode - networkName <- getArg args (longOption "network") readNetwork - nodePort <- getArg args (longOption "node-port") readInt - _ <- getArg args (longOption "wallet-server-port") readInt + --_ <- getArg args (longOption "wallet-server-port") decode - network <- HttpBridge.newNetworkLayer (showNetwork networkName) nodePort + network <- HttpBridge.newNetworkLayer (T.pack . encode $ networkName) nodePort 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 diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index 81a88d24897..e2835f72cfa 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -82,9 +82,8 @@ executable cardano-wallet-server NoImplicitPrelude OverloadedStrings ghc-options: - -threaded -rtsopts + -rtsopts -Wall - -O2 build-depends: base , cardano-wallet @@ -93,10 +92,12 @@ executable cardano-wallet-server , fmt hs-source-dirs: app/server + app/cli + other-modules: + CLI main-is: Main.hs - executable cardano-generate-mnemonic default-language: Haskell2010 @@ -116,7 +117,6 @@ executable cardano-generate-mnemonic main-is: GenerateMnemonic.hs - test-suite unit default-language: Haskell2010 From f0d4d93c9e91263bc5ad39d267c22e2100ac9c06 Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Thu, 14 Mar 2019 23:07:54 +0100 Subject: [PATCH 2/5] Add Launcher --- app/launcher/Launcher.hs | 72 +++++++++++++++++++++++++++++++++ app/launcher/Main.hs | 86 ++++++++++++++++++++++++++++++++++++++++ cardano-wallet.cabal | 25 ++++++++++++ 3 files changed, 183 insertions(+) create mode 100644 app/launcher/Launcher.hs create mode 100644 app/launcher/Main.hs diff --git a/app/launcher/Launcher.hs b/app/launcher/Launcher.hs new file mode 100644 index 00000000000..47aeb918bfd --- /dev/null +++ b/app/launcher/Launcher.hs @@ -0,0 +1,72 @@ +module Launcher where + +import Control.Concurrent.Async + ( forConcurrently ) +import Control.Exception + ( Exception, throwIO, try ) +import GHC.IO.Handle + ( Handle ) +import Prelude +import System.Exit + ( ExitCode ) +import System.Process + ( ProcessHandle + , cleanupProcess + , createProcess + , interruptProcessGroupOf + , proc + , waitForProcess + ) + +-- | +-- 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) + +data Command = Command + { cmdName :: String + , cmdArgs :: [String] + } + +data RunningProcess = RunningProcess + { rpCommand :: Command + , rpHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) + } + +-- | ProcessHasExited is used by a monitoring thread to signal that the process +-- has exited. +data ProcessHasExited = ProcessHasExited String ExitCode + deriving Show + +instance Exception ProcessHasExited + +getProcessHandle :: RunningProcess -> ProcessHandle +getProcessHandle p = let (_,_,_,ph) = rpHandles p in ph + +launch :: [Command] -> IO [RunningProcess] +launch = mapM (\c -> RunningProcess c <$> run c) + where + run (Command name args) = createProcess $ proc name args + +-- |  +monitor :: [RunningProcess] -> IO ProcessHasExited +monitor running = do + r <- try $ forConcurrently running supervise + case r of + Left e -> return e + Right _ + -> error "Unreachable. Supervising threads should never finish.\ + \ They should stay running or throw @ProcessHasExited@." + +supervise :: RunningProcess -> IO () +supervise p@(RunningProcess (Command name _args) _) = do + code <- waitForProcess (getProcessHandle p) + throwIO $ ProcessHasExited name code + +kill :: RunningProcess -> IO () +kill p = do + interruptProcessGroupOf (getProcessHandle p) + cleanupProcess $ rpHandles p diff --git a/app/launcher/Main.hs b/app/launcher/Main.hs new file mode 100644 index 00000000000..48628ed8ee6 --- /dev/null +++ b/app/launcher/Main.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import CLI + ( Decodable (decode), Encodable (encode), Network, Port (..), getArg ) +import Control.Monad + ( forM_, when ) +import Launcher + ( Command (Command) + , ProcessHasExited (ProcessHasExited) + , kill + , launch + , monitor + ) +import Prelude +import System.Console.Docopt + ( Docopt, docopt, exitWithUsage, isPresent, longOption, parseArgsOrExit ) +import System.Environment + ( getArgs ) +import System.Exit + ( exitWith ) + +-- | 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: + --wallet-server-port port used for serving the wallet API [default: 8090] + --node-port port used for node-wallet communication [default: 8080] + --network mainnet or testnet [default: mainnet] +|] + + + +main :: IO () +main = do + args <- parseArgsOrExit cli =<< getArgs + when (args `isPresent` (longOption "help")) $ exitWithUsage cli + let getArg' = getArg args cli + + nodePort <- getArg' (longOption "node-port") decode + walletPort <- getArg' (longOption "wallet-server-port") decode + network <- getArg' (longOption "network") decode + + putStrLn $ + "Starting wallet on port " ++ (encode walletPort) ++ + ",\n connecting to node on port " ++ (encode nodePort) + + running <- launch + [ nodeHttpBridgeOn nodePort network + , walletOn walletPort nodePort network + , Command "./app/launcher/mock/node-exit-0.sh" [] + ] + + (ProcessHasExited name code) <- monitor running + putStrLn $ name <> " exited with code " <> show code  + forM_ running kill + exitWith code + +nodeHttpBridgeOn :: Port "Node" -> Network -> Command +nodeHttpBridgeOn port _network = Command + "cardano-http-bridge" + ["start", "--port", encode port] + + +walletOn :: Port "Wallet" -> Port "Node" -> Network -> Command +walletOn wp np net = Command + "cardano-wallet-server" + ["--wallet-server-port", encode wp, + "--node-port", encode np, + "--network", encode net] diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index e2835f72cfa..ef2bee70f4a 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -98,6 +98,31 @@ executable cardano-wallet-server main-is: Main.hs +executable cardano-wallet-launcher + default-language: + Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + ghc-options: + -threaded -rtsopts + -Wall + -O2 + build-depends: + async + , base + , docopt + , process + hs-source-dirs: + app/launcher + app/cli + other-modules: + CLI + Launcher + main-is: + Main.hs + + executable cardano-generate-mnemonic default-language: Haskell2010 From 82770bbff47dc279604346bf279dbaeae8176c39 Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Thu, 14 Mar 2019 23:08:07 +0100 Subject: [PATCH 3/5] Add launcher tests --- app/launcher/LauncherSpec.hs | 27 +++++++++++++++++++++++++++ app/launcher/mock/node-exit-0.sh | 4 ++++ app/launcher/mock/node-exit-1.sh | 4 ++++ app/launcher/mock/node.sh | 2 ++ app/launcher/mock/wallet-exit-0.sh | 4 ++++ app/launcher/mock/wallet-exit-1.sh | 4 ++++ app/launcher/mock/wallet.sh | 2 ++ cardano-wallet.cabal | 28 ++++++++++++++++++++++++++++ 8 files changed, 75 insertions(+) create mode 100644 app/launcher/LauncherSpec.hs create mode 100755 app/launcher/mock/node-exit-0.sh create mode 100755 app/launcher/mock/node-exit-1.sh create mode 100755 app/launcher/mock/node.sh create mode 100755 app/launcher/mock/wallet-exit-0.sh create mode 100755 app/launcher/mock/wallet-exit-1.sh create mode 100755 app/launcher/mock/wallet.sh diff --git a/app/launcher/LauncherSpec.hs b/app/launcher/LauncherSpec.hs new file mode 100644 index 00000000000..fad30133ff3 --- /dev/null +++ b/app/launcher/LauncherSpec.hs @@ -0,0 +1,27 @@ +import Control.Monad + ( forM_ ) +import Launcher +import Prelude +import System.Exit + ( ExitCode (..) ) +import Test.Hspec + +main :: IO () +main = hspec $ do + describe "Launcher.monitor" $ do + it "node + wallet" $ do + let commands = + [ Command "./app/launcher/mock/node-exit-0.sh" [] + , Command "./app/launcher/mock/wallet.sh" [] + ] + running <- launch commands + (ProcessHasExited name code) <- monitor running + putStrLn "killing" + forM_ running kill + putStrLn "has killed" + name `shouldBe` cmdName (commands !! 0) + code `shouldBe` ExitSuccess + -- Not quite working + + it "trivial" $ + True `shouldBe` True diff --git a/app/launcher/mock/node-exit-0.sh b/app/launcher/mock/node-exit-0.sh new file mode 100755 index 00000000000..f67dc9236f5 --- /dev/null +++ b/app/launcher/mock/node-exit-0.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +echo "I'm a node (will exit 0)"; +sleep $[ ( $RANDOM % 2 ) + 1 ]s; +exit 0; diff --git a/app/launcher/mock/node-exit-1.sh b/app/launcher/mock/node-exit-1.sh new file mode 100755 index 00000000000..116b5455aa0 --- /dev/null +++ b/app/launcher/mock/node-exit-1.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +echo "I'm a node (will exit 1)"; +sleep $[ ( $RANDOM % 2 ) + 1 ]s; +exit 1; diff --git a/app/launcher/mock/node.sh b/app/launcher/mock/node.sh new file mode 100755 index 00000000000..51a68010bfd --- /dev/null +++ b/app/launcher/mock/node.sh @@ -0,0 +1,2 @@ +#!/usr/bin/env bash +while true; do echo "I'm a node"; sleep $[ ( $RANDOM % 2 ) + 1 ]s; done diff --git a/app/launcher/mock/wallet-exit-0.sh b/app/launcher/mock/wallet-exit-0.sh new file mode 100755 index 00000000000..5f2acaf11ed --- /dev/null +++ b/app/launcher/mock/wallet-exit-0.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +echo "I'm a wallet (will exit 0)"; +sleep $[ ( $RANDOM % 2 ) + 1 ]s; +exit 0; diff --git a/app/launcher/mock/wallet-exit-1.sh b/app/launcher/mock/wallet-exit-1.sh new file mode 100755 index 00000000000..567faaa1497 --- /dev/null +++ b/app/launcher/mock/wallet-exit-1.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +echo "I'm a wallet (will exit 1)"; +sleep $[ ( $RANDOM % 2 ) + 1 ]s; +exit 1; diff --git a/app/launcher/mock/wallet.sh b/app/launcher/mock/wallet.sh new file mode 100755 index 00000000000..871e57dcf01 --- /dev/null +++ b/app/launcher/mock/wallet.sh @@ -0,0 +1,2 @@ +#!/usr/bin/env bash +while true; do echo "I'm a wallet"; sleep $[ ( $RANDOM % 2 ) + 1 ]s; done diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index ef2bee70f4a..7e1be2e01aa 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -142,6 +142,34 @@ executable cardano-generate-mnemonic main-is: GenerateMnemonic.hs + +test-suite launcher-tests + default-language: + Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + ghc-options: + -threaded -rtsopts + -Wall + -O2 + if (!flag(development)) + ghc-options: -Werror + build-depends: + base + , hspec + , process + , async + type: + exitcode-stdio-1.0 + hs-source-dirs: + app/launcher + app/cli + main-is: + LauncherSpec.hs + other-modules: + Launcher + test-suite unit default-language: Haskell2010 From 86d79c2137bfd0dbe3911e9cedf6196bf7397d18 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Fri, 15 Mar 2019 11:12:48 +1000 Subject: [PATCH 4/5] Example of using withCreateProcess and race It will ensure that: - the subprocess is killed if the main thread dies. - if the subprocess exits, the main thread will be cancelled. --- app/server/Main.hs | 32 +++++++++++++++++++++++++++----- cardano-wallet.cabal | 3 +++ 2 files changed, 30 insertions(+), 5 deletions(-) diff --git a/app/server/Main.hs b/app/server/Main.hs index 07c5e573a11..f86e3e5bffb 100644 --- a/app/server/Main.hs +++ b/app/server/Main.hs @@ -22,15 +22,19 @@ import CLI import Control.Monad ( when ) import Fmt - ( build, fmt ) + ( build, fmt, (+||), (||+), (+|), (|+) ) import System.Console.Docopt ( Docopt, docopt, exitWithUsage, isPresent, longOption, parseArgsOrExit ) import System.Environment ( getArgs ) +import System.Process (withCreateProcess, waitForProcess, proc, StdStream(..), CreateProcess(..)) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (race_) +import Say + ( say, sayErr, sayString ) 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 @@ -62,8 +66,26 @@ main = do --_ <- getArg args (longOption "wallet-server-port") decode - network <- HttpBridge.newNetworkLayer (T.pack . encode $ networkName) nodePort - listen network logBlock + let + httpBridgeExe = "cardano-http-bridge" + httpBridgeArgs = ["start", "--template", encode networkName + , "--port", show nodePort] + httpBridgeProc = + (proc httpBridgeExe httpBridgeArgs) + { std_in = NoStream, std_out = Inherit, std_err = Inherit } + + listenThread = do + threadDelay 1000000 -- wait 1sec for socket to appear + network <- HttpBridge.newNetworkLayer (T.pack . encode $ networkName) nodePort + listen network logBlock + + sayString $ "Starting " ++ httpBridgeExe ++ " " ++ unwords httpBridgeArgs + withCreateProcess httpBridgeProc $ \_ _ _ ph -> do + race_ listenThread $ do + status <- waitForProcess ph + sayErr . fmt $ ""+|httpBridgeExe|+" exited with "+||status||+"" + say "bye bye" + where logBlock :: Block -> IO () - logBlock = T.putStrLn . fmt . build + logBlock = say . fmt . build diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index 7e1be2e01aa..bf4296c1215 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -90,6 +90,9 @@ executable cardano-wallet-server , docopt , text , fmt + , process + , async + , say hs-source-dirs: app/server app/cli From 01108c568ba6f72b6bb8311cedf68015e36312b2 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Fri, 15 Mar 2019 10:59:36 +0100 Subject: [PATCH 5/5] Review launcher code, folder organization and API options - allow launcher's command to take a 'setup' action before they're ran This allows for the wallet backend to wait a bit before it starts. Or, any kind of startup action we may think of, like generating TLS certs, etc ... - review folder organization and tests scripts - add Buildable intance to 'Command' and use that to format the initial info - use --http-bridge-port instead of --node-port --- .weeder.yaml | 12 +++ app/{cli => Cardano}/CLI.hs | 26 +++-- app/Cardano/Launcher.hs | 78 ++++++++++++++ app/launcher/Launcher.hs | 72 ------------- app/launcher/LauncherSpec.hs | 27 ----- app/launcher/Main.hs | 84 +++++++-------- app/launcher/mock/node-exit-0.sh | 4 - app/launcher/mock/node-exit-1.sh | 4 - app/launcher/mock/node.sh | 2 - app/launcher/mock/wallet-exit-0.sh | 4 - app/launcher/mock/wallet-exit-1.sh | 4 - app/launcher/mock/wallet.sh | 2 - app/server/Main.hs | 62 ++++------- cardano-wallet.cabal | 160 +++++++++++++---------------- test/data/Launcher/forever.sh | 4 + test/data/Launcher/once.sh | 3 + test/unit/Cardano/LauncherSpec.hs | 48 +++++++++ 17 files changed, 294 insertions(+), 302 deletions(-) create mode 100644 .weeder.yaml rename app/{cli => Cardano}/CLI.hs (89%) create mode 100644 app/Cardano/Launcher.hs delete mode 100644 app/launcher/Launcher.hs delete mode 100644 app/launcher/LauncherSpec.hs delete mode 100755 app/launcher/mock/node-exit-0.sh delete mode 100755 app/launcher/mock/node-exit-1.sh delete mode 100755 app/launcher/mock/node.sh delete mode 100755 app/launcher/mock/wallet-exit-0.sh delete mode 100755 app/launcher/mock/wallet-exit-1.sh delete mode 100755 app/launcher/mock/wallet.sh create mode 100755 test/data/Launcher/forever.sh create mode 100755 test/data/Launcher/once.sh create mode 100644 test/unit/Cardano/LauncherSpec.hs diff --git a/.weeder.yaml b/.weeder.yaml new file mode 100644 index 00000000000..cfd796e6bec --- /dev/null +++ b/.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 diff --git a/app/cli/CLI.hs b/app/Cardano/CLI.hs similarity index 89% rename from app/cli/CLI.hs rename to app/Cardano/CLI.hs index 5f1c14cb2de..d47186c620e 100644 --- a/app/cli/CLI.hs +++ b/app/Cardano/CLI.hs @@ -1,6 +1,19 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} -module CLI where + +-- | +-- 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 ) @@ -10,20 +23,12 @@ import System.Console.Docopt import Text.Read ( readMaybe ) - --- Shared types and helpers for CLI parsing - - -- | Port number with a tag for describing what it is used for -newtype Port (tag :: Symbol) = Port - { getPort :: Int - } - +newtype Port (tag :: Symbol) = Port Int data Network = Mainnet | Testnet deriving (Show, Enum) - getArg :: Arguments -> Docopt @@ -43,7 +48,6 @@ getArg args cli opt decod = do class Encodable a where encode :: a -> String - -- | Decoding command line arguments class Decodable a where decode :: String -> Either String a diff --git a/app/Cardano/Launcher.hs b/app/Cardano/Launcher.hs new file mode 100644 index 00000000000..9aa446daa4a --- /dev/null +++ b/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@." diff --git a/app/launcher/Launcher.hs b/app/launcher/Launcher.hs deleted file mode 100644 index 47aeb918bfd..00000000000 --- a/app/launcher/Launcher.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Launcher where - -import Control.Concurrent.Async - ( forConcurrently ) -import Control.Exception - ( Exception, throwIO, try ) -import GHC.IO.Handle - ( Handle ) -import Prelude -import System.Exit - ( ExitCode ) -import System.Process - ( ProcessHandle - , cleanupProcess - , createProcess - , interruptProcessGroupOf - , proc - , waitForProcess - ) - --- | --- 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) - -data Command = Command - { cmdName :: String - , cmdArgs :: [String] - } - -data RunningProcess = RunningProcess - { rpCommand :: Command - , rpHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) - } - --- | ProcessHasExited is used by a monitoring thread to signal that the process --- has exited. -data ProcessHasExited = ProcessHasExited String ExitCode - deriving Show - -instance Exception ProcessHasExited - -getProcessHandle :: RunningProcess -> ProcessHandle -getProcessHandle p = let (_,_,_,ph) = rpHandles p in ph - -launch :: [Command] -> IO [RunningProcess] -launch = mapM (\c -> RunningProcess c <$> run c) - where - run (Command name args) = createProcess $ proc name args - --- |  -monitor :: [RunningProcess] -> IO ProcessHasExited -monitor running = do - r <- try $ forConcurrently running supervise - case r of - Left e -> return e - Right _ - -> error "Unreachable. Supervising threads should never finish.\ - \ They should stay running or throw @ProcessHasExited@." - -supervise :: RunningProcess -> IO () -supervise p@(RunningProcess (Command name _args) _) = do - code <- waitForProcess (getProcessHandle p) - throwIO $ ProcessHasExited name code - -kill :: RunningProcess -> IO () -kill p = do - interruptProcessGroupOf (getProcessHandle p) - cleanupProcess $ rpHandles p diff --git a/app/launcher/LauncherSpec.hs b/app/launcher/LauncherSpec.hs deleted file mode 100644 index fad30133ff3..00000000000 --- a/app/launcher/LauncherSpec.hs +++ /dev/null @@ -1,27 +0,0 @@ -import Control.Monad - ( forM_ ) -import Launcher -import Prelude -import System.Exit - ( ExitCode (..) ) -import Test.Hspec - -main :: IO () -main = hspec $ do - describe "Launcher.monitor" $ do - it "node + wallet" $ do - let commands = - [ Command "./app/launcher/mock/node-exit-0.sh" [] - , Command "./app/launcher/mock/wallet.sh" [] - ] - running <- launch commands - (ProcessHasExited name code) <- monitor running - putStrLn "killing" - forM_ running kill - putStrLn "has killed" - name `shouldBe` cmdName (commands !! 0) - code `shouldBe` ExitSuccess - -- Not quite working - - it "trivial" $ - True `shouldBe` True diff --git a/app/launcher/Main.hs b/app/launcher/Main.hs index 48628ed8ee6..a1a77c2f8ea 100644 --- a/app/launcher/Main.hs +++ b/app/launcher/Main.hs @@ -3,18 +3,20 @@ module Main where -import CLI - ( Decodable (decode), Encodable (encode), Network, Port (..), getArg ) -import Control.Monad - ( forM_, when ) -import Launcher - ( Command (Command) - , ProcessHasExited (ProcessHasExited) - , kill - , launch - , monitor - ) 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 @@ -22,6 +24,9 @@ import System.Environment import System.Exit ( exitWith ) +import qualified Data.Text as T + + -- | Command-Line Interface specification. See http://docopt.org/ cli :: Docopt cli = [docopt| @@ -34,53 +39,50 @@ 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: - --wallet-server-port port used for serving the wallet API [default: 8090] - --node-port port used for node-wallet communication [default: 8080] --network mainnet or testnet [default: mainnet] + --wallet-server-port port used for serving the wallet API [default: 8090] + --http-bridge-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 - let getArg' = getArg args cli - - nodePort <- getArg' (longOption "node-port") decode - walletPort <- getArg' (longOption "wallet-server-port") decode - network <- getArg' (longOption "network") decode - putStrLn $ - "Starting wallet on port " ++ (encode walletPort) ++ - ",\n connecting to node on port " ++ (encode nodePort) - - running <- launch - [ nodeHttpBridgeOn nodePort network - , walletOn walletPort nodePort network - , Command "./app/launcher/mock/node-exit-0.sh" [] - ] - - (ProcessHasExited name code) <- monitor running - putStrLn $ name <> " exited with code " <> show code  - forM_ running kill + 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" -> Network -> Command -nodeHttpBridgeOn port _network = Command +nodeHttpBridgeOn :: Port "Node" -> Command +nodeHttpBridgeOn port = Command "cardano-http-bridge" - ["start", "--port", encode port] - + [ "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, - "--node-port", encode np, - "--network", encode net] + [ "--wallet-server-port", encode wp + , "--http-bridge-port", encode np + , "--network", encode net + ] + (threadDelay oneSecond) + where + oneSecond = 1000000 diff --git a/app/launcher/mock/node-exit-0.sh b/app/launcher/mock/node-exit-0.sh deleted file mode 100755 index f67dc9236f5..00000000000 --- a/app/launcher/mock/node-exit-0.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash -echo "I'm a node (will exit 0)"; -sleep $[ ( $RANDOM % 2 ) + 1 ]s; -exit 0; diff --git a/app/launcher/mock/node-exit-1.sh b/app/launcher/mock/node-exit-1.sh deleted file mode 100755 index 116b5455aa0..00000000000 --- a/app/launcher/mock/node-exit-1.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash -echo "I'm a node (will exit 1)"; -sleep $[ ( $RANDOM % 2 ) + 1 ]s; -exit 1; diff --git a/app/launcher/mock/node.sh b/app/launcher/mock/node.sh deleted file mode 100755 index 51a68010bfd..00000000000 --- a/app/launcher/mock/node.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/usr/bin/env bash -while true; do echo "I'm a node"; sleep $[ ( $RANDOM % 2 ) + 1 ]s; done diff --git a/app/launcher/mock/wallet-exit-0.sh b/app/launcher/mock/wallet-exit-0.sh deleted file mode 100755 index 5f2acaf11ed..00000000000 --- a/app/launcher/mock/wallet-exit-0.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash -echo "I'm a wallet (will exit 0)"; -sleep $[ ( $RANDOM % 2 ) + 1 ]s; -exit 0; diff --git a/app/launcher/mock/wallet-exit-1.sh b/app/launcher/mock/wallet-exit-1.sh deleted file mode 100755 index 567faaa1497..00000000000 --- a/app/launcher/mock/wallet-exit-1.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash -echo "I'm a wallet (will exit 1)"; -sleep $[ ( $RANDOM % 2 ) + 1 ]s; -exit 1; diff --git a/app/launcher/mock/wallet.sh b/app/launcher/mock/wallet.sh deleted file mode 100755 index 871e57dcf01..00000000000 --- a/app/launcher/mock/wallet.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/usr/bin/env bash -while true; do echo "I'm a wallet"; sleep $[ ( $RANDOM % 2 ) + 1 ]s; done diff --git a/app/server/Main.hs b/app/server/Main.hs index f86e3e5bffb..a1a2d00df08 100644 --- a/app/server/Main.hs +++ b/app/server/Main.hs @@ -3,39 +3,37 @@ {-# 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 ( Block ) -import CLI import Control.Monad ( when ) import Fmt - ( build, fmt, (+||), (||+), (+|), (|+) ) + ( build, fmt ) +import Say + ( say ) import System.Console.Docopt ( Docopt, docopt, exitWithUsage, isPresent, longOption, parseArgsOrExit ) import System.Environment ( getArgs ) -import System.Process (withCreateProcess, waitForProcess, proc, StdStream(..), CreateProcess(..)) -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (race_) -import Say - ( say, sayErr, sayString ) import qualified Cardano.NetworkLayer.HttpBridge as HttpBridge import qualified Data.Text as T + -- | Command-Line Interface specification. See http://docopt.org/ cli :: Docopt cli = [docopt| @@ -48,44 +46,22 @@ Usage: cardano-wallet-server --help Options: - --wallet-server-port port used for serving the wallet API [default: 8090] --network mainnet or testnet [default: mainnet] - --node-port port used for node-wallet communication [default: 8080] + --wallet-server-port port used for serving the wallet API [default: 8090] + --http-bridge-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 - let getArg' = getArg args cli - - networkName <- getArg' (longOption "network") (decode @Network) - nodePort <- getArg' (longOption "node-port") decode - - --_ <- getArg args (longOption "wallet-server-port") decode - - let - httpBridgeExe = "cardano-http-bridge" - httpBridgeArgs = ["start", "--template", encode networkName - , "--port", show nodePort] - httpBridgeProc = - (proc httpBridgeExe httpBridgeArgs) - { std_in = NoStream, std_out = Inherit, std_err = Inherit } - - listenThread = do - threadDelay 1000000 -- wait 1sec for socket to appear - network <- HttpBridge.newNetworkLayer (T.pack . encode $ networkName) nodePort - listen network logBlock - sayString $ "Starting " ++ httpBridgeExe ++ " " ++ unwords httpBridgeArgs - withCreateProcess httpBridgeProc $ \_ _ _ ph -> do - race_ listenThread $ do - status <- waitForProcess ph - sayErr . fmt $ ""+|httpBridgeExe|+" exited with "+||status||+"" - say "bye bye" + 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 (T.pack . encode $ networkName) bridgePort + listen network logBlock where logBlock :: Block -> IO () logBlock = say . fmt . build diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index bf4296c1215..8f96943ee52 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -29,7 +29,8 @@ library -Wcompat -fwarn-redundant-constraints if (!flag(development)) - ghc-options: -Werror + ghc-options: + -Werror build-depends: base , base58-bytestring @@ -37,14 +38,13 @@ library , binary , bytestring , cardano-crypto - , cryptonite , cborg , containers , cryptonite , deepseq , digest - , fmt , exceptions + , fmt , http-api-data , http-client , http-media @@ -75,58 +75,64 @@ library other-modules: Paths_cardano_wallet -executable cardano-wallet-server + +test-suite unit default-language: Haskell2010 default-extensions: NoImplicitPrelude OverloadedStrings ghc-options: - -rtsopts + -threaded -rtsopts -Wall + -O2 + if (!flag(development)) + ghc-options: + -Werror build-depends: base + , async + , base58-bytestring + , bytestring + , cardano-crypto , cardano-wallet - , docopt - , text + , cborg + , containers + , deepseq + , exceptions , fmt + , hspec + , memory + , mtl , process - , async - , say + , QuickCheck + , text + , time-units + , transformers + type: + exitcode-stdio-1.0 hs-source-dirs: - app/server - app/cli - other-modules: - CLI + test/unit + app main-is: Main.hs - -executable cardano-wallet-launcher - default-language: - Haskell2010 - default-extensions: - NoImplicitPrelude - OverloadedStrings - ghc-options: - -threaded -rtsopts - -Wall - -O2 - build-depends: - async - , base - , docopt - , process - hs-source-dirs: - app/launcher - app/cli other-modules: - CLI - Launcher - main-is: - Main.hs + Cardano.DBLayerSpec + Cardano.Launcher + Cardano.LauncherSpec + Cardano.NetworkLayer.HttpBridge.ApiSpec + Cardano.NetworkLayer.HttpBridgeSpec + Cardano.NetworkLayerSpec + Cardano.Wallet.AddressDerivationSpec + Cardano.Wallet.AddressDiscoverySpec + Cardano.Wallet.Binary.PackfileSpec + Cardano.Wallet.BinarySpec + Cardano.Wallet.MnemonicSpec + Cardano.Wallet.PrimitiveSpec + Cardano.WalletSpec -executable cardano-generate-mnemonic +executable cardano-wallet-server default-language: Haskell2010 default-extensions: @@ -134,19 +140,25 @@ executable cardano-generate-mnemonic OverloadedStrings ghc-options: -threaded -rtsopts - -with-rtsopts=-N -Wall + -Werror + -O2 build-depends: base , cardano-wallet + , docopt + , fmt + , say , text hs-source-dirs: - app/mnemonic + app + app/server + other-modules: + Cardano.CLI main-is: - GenerateMnemonic.hs - + Main.hs -test-suite launcher-tests +executable cardano-wallet-launcher default-language: Haskell2010 default-extensions: @@ -155,69 +167,41 @@ test-suite launcher-tests ghc-options: -threaded -rtsopts -Wall + -Werror -O2 - if (!flag(development)) - ghc-options: -Werror build-depends: - base - , hspec - , process - , async - type: - exitcode-stdio-1.0 + async + , base + , docopt + , fmt + , process + , say + , text hs-source-dirs: + app app/launcher - app/cli - main-is: - LauncherSpec.hs other-modules: - Launcher + Cardano.CLI + Cardano.Launcher + main-is: + Main.hs -test-suite unit + +executable cardano-generate-mnemonic default-language: Haskell2010 default-extensions: NoImplicitPrelude OverloadedStrings ghc-options: - -threaded -rtsopts -Wall + -Werror -O2 - if (!flag(development)) - ghc-options: -Werror build-depends: base - , base58-bytestring - , bytestring - , cardano-crypto , cardano-wallet - , cborg - , containers - , deepseq - , exceptions - , fmt - , hspec - , memory - , mtl - , QuickCheck , text - , time-units - , transformers - type: - exitcode-stdio-1.0 hs-source-dirs: - test/unit + app/mnemonic main-is: - Main.hs - other-modules: - Cardano.DBLayerSpec - Cardano.Wallet.AddressDerivationSpec - Cardano.Wallet.AddressDiscoverySpec - Cardano.Wallet.Binary.PackfileSpec - Cardano.Wallet.BinarySpec - Cardano.Wallet.MnemonicSpec - Cardano.Wallet.PrimitiveSpec - Cardano.WalletSpec - Cardano.NetworkLayerSpec - Cardano.NetworkLayer.HttpBridgeSpec - Cardano.NetworkLayer.HttpBridge.ApiSpec + GenerateMnemonic.hs diff --git a/test/data/Launcher/forever.sh b/test/data/Launcher/forever.sh new file mode 100755 index 00000000000..b7d2bfcf8ee --- /dev/null +++ b/test/data/Launcher/forever.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +while true; do + sleep $[ ( $RANDOM % 2 ) + 1 ]s +done diff --git a/test/data/Launcher/once.sh b/test/data/Launcher/once.sh new file mode 100755 index 00000000000..76ab7809a32 --- /dev/null +++ b/test/data/Launcher/once.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +sleep $[ ( $RANDOM % 2 ) + 1 ]s; +exit $1; diff --git a/test/unit/Cardano/LauncherSpec.hs b/test/unit/Cardano/LauncherSpec.hs new file mode 100644 index 00000000000..37b833aa23e --- /dev/null +++ b/test/unit/Cardano/LauncherSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TypeApplications #-} + +module Cardano.LauncherSpec + ( spec + ) where + +import Prelude + +import Cardano.Launcher + ( Command (..), ProcessHasExited (..), launch ) +import Control.Concurrent.MVar + ( newEmptyMVar, putMVar, tryReadMVar ) +import System.Exit + ( ExitCode (..) ) +import Test.Hspec + ( Spec, it, shouldBe, shouldReturn ) + + +{-# ANN spec ("HLint: ignore Use head" :: String) #-} +spec :: Spec +spec = do + it "One process exits with 0, others are cancelled" $ do + let commands = + [ Command "./test/data/Launcher/once.sh" ["0"] (pure ()) + , Command "./test/data/Launcher/forever.sh" [] (pure ()) + ] + (ProcessHasExited name code) <- launch commands + name `shouldBe` cmdName (commands !! 0) + code `shouldBe` ExitSuccess + + it "One process exits with 14, others are cancelled" $ do + let commands = + [ Command "./test/data/Launcher/once.sh" ["14"] (pure ()) + , Command "./test/data/Launcher/forever.sh" [] (pure ()) + ] + (ProcessHasExited name code) <- launch commands + name `shouldBe` cmdName (commands !! 0) + code `shouldBe` (ExitFailure 14) + + it "Process executes a command before they start" $ do + mvar <- newEmptyMVar + let before = putMVar mvar "executed" + let commands = + [ Command "./test/data/Launcher/once.sh" ["0"] before + ] + (ProcessHasExited _ code) <- launch commands + code `shouldBe` ExitSuccess + tryReadMVar mvar `shouldReturn` (Just @String "executed")