Skip to content

Commit

Permalink
Example of using withCreateProcess and race
Browse files Browse the repository at this point in the history
It will ensure that:
- the subprocess is killed if the main thread dies.
- if the subprocess exits, the main thread will be cancelled.
  • Loading branch information
rvl authored and Anviking committed Mar 15, 2019
1 parent 46320ad commit 6f98643
Show file tree
Hide file tree
Showing 2 changed files with 30 additions and 5 deletions.
32 changes: 27 additions & 5 deletions app/server/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
3 changes: 3 additions & 0 deletions cardano-wallet.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -91,6 +91,9 @@ executable cardano-wallet-server
, docopt
, text
, fmt
, process
, async
, say
hs-source-dirs:
app/server
app/cli
Expand Down

0 comments on commit 6f98643

Please sign in to comment.