packages feed

stack-network (empty) → 0.1.0.0

raw patch · 16 files changed

+982/−0 lines, 16 filesdep +Cabaldep +ansi-terminaldep +async

Dependencies added: Cabal, ansi-terminal, async, base, binary, bytestring, clock, configurator, directory, dirstream, distributed-process-lifted, distributed-process-simplelocalnet, exceptions, filepath, hspec, lifted-base, mtl, optparse-applicative, pipes, pipes-safe, process, raw-strings-qq, stack-network, system-fileio, system-filepath, temporary, text, transformers, yaml

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Sean McGroarty (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,49 @@+# stack-network++## About+This is a program I built as part of my Final Year Project in College. The project is titled __An Exploration into the Distribution of Stack__ in which I designed and tested a few approaches for distributing Stack. stack-network uses [Cloud Haskell](https://hackage.haskell.org/package/cloud-haskell) and [pipes](https://hackage.haskell.org/package/pipes) to efficiently transmit files between nodes on a network and thus minimise build times.++## Testing+ +__Prerequisites__++[Stack](https://docs.haskellstack.org/en/stable/README/)++[Docker](https://www.docker.com/) (installed and running)++`docker pull mcgizzle/stack-network`++`stack test`++This will run a number of scenarios created from `docker-compose` files embedded into the program using [Quasi-Quotes](https://wiki.haskell.org/Quasiquotation).++## Building & Running+ +`stack build`++Ensure you have a `network.config` file++```+net +{+	host = "127.0.0.1"+	port = "5000"+}+```++Update the port and host as appropriate.++`stack exec stack-network --help` will list the options++To see the program in action it is suggested running it with Docker. I have provided an image that wil work with the tests and the docker-compose located in the project root.++Pull the image from Docker++`docker pull mcgizzle/stack-network`++Run this from the root of the project++`docker-compose up`+++
+ build4docker.sh view
@@ -0,0 +1,21 @@+#!/bin/bash++function myReplace {+if [ "$1" = "Text" ]+then+  other="ByteString"+else+  other="Text"+fi++sed -i '' "s/($1,/($other,/" src/Network/Distributed/Types.hs++echo "Swapped $1 for $other"+}++myReplace "Text" && +stack --docker build && +stack --docker image container && +myReplace "ByteString" &&+stack test+
+ docker-compose.yml view
@@ -0,0 +1,24 @@+slave2:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|6002|' network.config && sed -i -e 's|mwc-random|mtl|' testbuild1.cabal && stack-network join"+  tty: true+  stdin_open: true+  net: "host"+  ports: +    - "6002:6002"+slave1:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|6001|' network.config && stack-network join"+  tty: true+  stdin_open: true+  net: "host"+  ports: +    - "6001:6001"+master:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|6000|' network.config && stack-network build -n 2"+  tty: true+  stdin_open: true+  net: "host"+  ports:+    - "6000:6000"
+ network.config view
@@ -0,0 +1,5 @@+net +{+  host = "127.0.0.1"+  port = "5000"+}
+ rundock.sh view
@@ -0,0 +1,9 @@+#!/bin/bash+echo "Building image.."+docker build -t $1 -f Dockerfile.base . &&+echo "Building Stack..."+stack --docker build &&+echo "Creating image container..."+stack --docker image container &&+echo "Done diddly done :) Running docker-compose..."+docker-compose up
+ src/Main.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE LambdaCase #-}++module Main where++import           Control.Monad       (join)+import           Data.Semigroup      ((<>))+import           Network.Distributed+import           Options.Applicative++data Opts = Opts+  { waitNodes :: Int+  }++optParser :: Parser Opts+optParser =+  Opts <$>+  option+    auto+    (long "nodes" <> short 'n' <>+     help "How many nodes the Master should wait for before beginning build" <>+     showDefault <>+     value 1 <>+     metavar "INT")++description :: InfoMod a+description =+  fullDesc <>+  progDesc "stack-network interfaces with Stack to create a distributed version" <>+  header "stack-network"++commands :: Parser (IO ())+commands = subparser $ buildCmd <> joinCmd++buildCmd :: Mod CommandFields (IO ())+buildCmd = command "build" (info (runBuild <$> optParser) description)++joinCmd :: Mod CommandFields (IO ())+joinCmd = command "join" (info (pure runJoin) description)++runJoin :: IO ()+runJoin = runStackBuildT >> parseNetConfig >>= joinNetwork++runBuild :: Opts -> IO ()+runBuild opts = runRequestNode (waitNodes opts) =<< parseNetConfig++main :: IO ()+main = join $ execParser (info (commands <**> helper) description)
+ src/Network/Distributed.hs view
@@ -0,0 +1,16 @@+-- |+-- Module:      Network.Distributed+-- Copyright:   (c) 2018 Sean McGroarty+-- License:     BSD3+-- Maintainer:  Sean McGroarty <mcgroas@tcd.ie.com>+-- Stability:   experimental+--+module Network.Distributed+  ( module Network.Distributed.Process+  , module Network.Distributed.Types+  , module Network.Distributed.Utils+  ) where++import           Network.Distributed.Process+import           Network.Distributed.Types+import           Network.Distributed.Utils
+ src/Network/Distributed/Process.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}++-- |+-- Module:      Network.Distributed.Process+-- Copyright:   (c) 2018 Sean McGroarty+-- License:     BSD3+-- Maintainer:  Sean McGroarty <mcgroas@tcd.ie.com>+-- Stability:   experimental+--+module Network.Distributed.Process+  ( runRequestNode+  , runRequestNode'+  , joinNetwork+  , joinNetwork'+  , findPids+  , gatherDeps+  , receiveF+  , withTransfer+  ) where++import           Network.Distributed.Transfer+import           Network.Distributed.Types+import           Network.Distributed.Utils++import           Control.Applicative+import           Control.Monad+import           Control.Monad.Catch+import           Prelude                                            hiding+                                                                     (FilePath,+                                                                     log)++import           Control.Distributed.Process.Backend.SimpleLocalnet+import           Control.Distributed.Process.Lifted                 hiding+                                                                     (bracket,+                                                                     catch)+import           Control.Distributed.Process.Lifted.Class+import qualified Control.Distributed.Process.Node.Lifted            as PN++import           Data.Maybe                                         (catMaybes)++import           Filesystem+import           Filesystem.Path                                    (directory)+import           Filesystem.Path.CurrentOS                          (decode)++import           Control.Monad.Reader++----------------------------------------------------------------------------+-- | Logs that the Node is joining the network and returns a Backend+mkBackend :: NetworkConfig -> IO Backend+mkBackend nc@NetworkConfig {..} = do+  log ("Node joining network on: " ++ show nc)+  initializeBackend hostNetworkConfig portNetworkConfig PN.initRemoteTable++-- | Runs a Process that is a master node+runRequestNode ::+     Int+  -- ^ Number of slave nodes the master should wait for+  -> NetworkConfig+  -> IO ()+runRequestNode waitN nc = do+  backend <- mkBackend nc+  let cfg = AppConfig waitN backend+  flip PN.runProcess (runApp cfg runRequestNode') =<< newLocalNode backend+  runStackBuildT++-- | Internal for master node+runRequestNode' :: App ()+runRequestNode' = do+  log "Searching the Network..."+  pids <- findPids+  logSucc ("Found Nodes: " ++ show pids)+  pDeps <- gatherDeps pids+  log "Finding most compatable node..."+  myDeps <- listDeps+  withTransfer pDeps myDeps retryReq $ \pid (sPort, rPort) -> do+    log $ "Node: " ++ show pid ++ " Is the best match."+    send pid (TransferReq sPort)+    log "Working..."+    receiveF rPort+    logSucc "Transmission complete. All files received. Ready to build."+  mapM_ (`send` Terminate) pids+  where+    retryReq :: SomeException -> App ()+    retryReq _ = logWarn "Slave died. Retrying..." >> runRequestNode'++-- | Creates the Backend and runs a Process that is a Slave node+joinNetwork :: NetworkConfig -> IO ()+joinNetwork = mkBackend >=> newLocalNode >=> flip PN.runProcess joinNetwork'++-- | Internal for slave node+joinNetwork' :: Process ()+joinNetwork' = do+  me <- getSelfPid+  register "slaveNodeS" me+  loop me+  where+    loop me = receiveWait [match $ \req -> receiveReq me req]+    receiveReq :: ProcessId -> Request -> Process ()+    receiveReq me (Ping pid) = do+      log "Received a Ping!"+      deps <- listDeps+      send pid (PD (deps, me))+      loop me+    receiveReq me (TransferReq sPort) = do+      log "Received request to transmit files... Beginning transmission"+      pipeFiles (sendChan sPort) *> sendChan sPort TransferDone+      logSucc "Transmission complete"+      loop me+    receiveReq _ Terminate = log "Received a request to terminate. Bye."++-- | Faciliaties a safe Transfer bewteen nodes+withTransfer ::+     (Exception e, MonadProcess m, MonadCatch m)+  => [ProcessDeps]+  -- ^ Slaves process dependencies+  -> Deps+  -- ^ Masters dependencies+  -> (e -> m ())+  -- ^ Recovery function+  -> (ProcessId -> (SendPort Transfer, ReceivePort Transfer) -> m ())+  -- ^ Action to execute with the linked process and typed-channel+  -> m ()+withTransfer pDeps myDeps retry action =+  case getBestPid pDeps myDeps (Nothing, 0) of+    Just n  -> runAction n `catch` retry+    Nothing -> logWarn "No Nodes share dependencies, aborting."+  where+    runAction n = do+      link n+      chan <- newChan+      linkPort (fst chan)+      action n chan+      unlinkPort (fst chan)+      unlink n++-- | Internal function used to gather ProcessId's+findPids ::+     (MonadMask m, MonadProcess m, MonadReader AppConfig m) => m [ProcessId]+findPids = loop =<< asks nodes+  where+    loop nc = do+      backend <- asks backend+      nids <- liftIO $ findPeers backend 1000000+      pids <-+        bracket (mapM monitorNode nids) (mapM unmonitor) $ \_ -> do+          mapM_ (`whereisRemoteAsync` "slaveNodeS") nids+          catMaybes <$>+            replicateM+              (length nids)+              (receiveWait+                 [ match (\(WhereIsReply "slaveNodeS" mPid) -> pure mPid)+                 , match (\NodeMonitorNotification {} -> pure Nothing)+                 ])+      if length pids == nc+        then pure pids+        else loop nc++-- | Internal function used to get all slaves dependencies+gatherDeps :: (MonadProcess m, MonadMask m) => Network -> m [ProcessDeps]+gatherDeps pids = do+  ping <- Ping <$> getSelfPid+  mapM_ (`send` ping) pids+  bracket (mapM monitor pids) (mapM unmonitor) $ \_ ->+    catMaybes <$>+    replicateM+      (length pids)+      (receiveWait+         [ match $ \(PD pd) -> pure $ Just pd+         , match $ \NodeMonitorNotification {} -> pure Nothing+         ])++-- | Internal function used to reveive the Transfer+receiveF :: MonadProcess m => ReceivePort Transfer -> m ()+receiveF rPort = work =<< receiveChan rPort+  where+    work (TransferInProg (path, file)) = do+      liftIO $ do+        let path' = decode path+        createTree (directory path')+        Filesystem.writeFile path' file+      receiveF rPort+    work TransferDone = pure ()
+ src/Network/Distributed/Transfer.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module:      Network.Distributed.Transfer+-- Copyright:   (c) 2018 Sean McGroarty+-- License:     BSD3+-- Maintainer:  Sean McGroarty <mcgroas@tcd.ie.com>+-- Stability:   experimental+--+module Network.Distributed.Transfer where++import           Network.Distributed.Types+import           Network.Distributed.Utils++import           Control.Applicative+import           Data.DirStream+import           Filesystem+import           Filesystem.Path           (FilePath)+import           Filesystem.Path.CurrentOS (encode)+import           Pipes+import qualified Pipes.Prelude             as P+import           Pipes.Safe                (MonadMask, MonadSafe, runSafeT)+import           Prelude                   hiding (FilePath, log)++--------------------------------------------------------------------------------------------+-- | Internal function that executes a pipeline of effects+pipeFiles ::+     (MonadMask m, MonadIO m)+  => (Transfer -> m ())+  -- ^ Function that accepts a Transfer and has IO at its base+  -> m ()+pipeFiles action =+  runSafeT $+  runEffect $+  for+    (producers >-> P.filterM (liftIO . isFile) >-> P.chain (log . show) >->+     P.mapM packageFile)+    (lift . lift . action)++-- | Produces output for the pipeline+producers :: MonadSafe m => Pipes.Proxy x' x () FilePath m ()+producers =+  every+    (descendentOf "root/snapshots" <|> descendentOf "root/loaded-snapshot-cache")++-- | Packages a file by reading in its bytes+packageFile :: MonadIO m => FilePath -> m Transfer+packageFile file =+  liftIO $ TransferInProg . (,) (encode file) <$> Filesystem.readFile file+--------------------------------------------------------------------------------------------
+ src/Network/Distributed/Types.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-}++-- |+-- Module:      Network.Distributed.Types+-- Copyright:   (c) 2018 Sean McGroarty+-- License:     BSD3+-- Maintainer:  Sean McGroarty <mcgroas@tcd.ie.com>+-- Stability:   experimental+--+module Network.Distributed.Types where++import           Control.Distributed.Process.Backend.SimpleLocalnet (Backend)+import           Control.Distributed.Process.Lifted                 (Process,+                                                                     ProcessId,+                                                                     SendPort)+import           Control.Monad.Reader+import           Data.Binary                                        (Binary)+import           Data.ByteString                                    (ByteString)+import           Data.Text                                          (Text)+import           Data.Typeable                                      (Typeable)+import           Filesystem.Path.CurrentOS                          (decode)+import           GHC.Generics                                       (Generic)++---------------------------------------------------------------------------------+-- | Configuration for the master node+data AppConfig = AppConfig+  { nodes   :: Int+  -- ^ Number of slave nodes the master should wait for before attempting a build+  , backend :: Backend+  }++-- | A Monad which wraps Process with ReaderT+type App a = ReaderT AppConfig Process a++-- | Runs App+runApp :: AppConfig -> App a -> Process a+runApp = flip runReaderT++---------------------------------------------------------------------------------+-- | Host and Port of a Node+data NetworkConfig = NetworkConfig+  { hostNetworkConfig :: String+  , portNetworkConfig :: String+  }++instance Show NetworkConfig where+  show NetworkConfig {..} =+    "//" ++ hostNetworkConfig ++ ":" ++ portNetworkConfig++---------------------------------------------------------------------------------+-- | A Node is used for communication+type Node = ProcessId++-- | A collection of Nodes+type Network = [Node]++-- | The dependecies a Node has, represented as a list of Strings+type Deps = [String]++-- | A Node and its dependencies+type ProcessDeps = (Deps, ProcessId)++-- | Tuple of file name and bytes+type FileInfo = (Text, ByteString)++---------------------------------------------------------------------------------+-- | All Types used messaging are derived from a Message+data Message+  = Request+  | Response++-- | Only masters can make a Request+data Request+  = Ping ProcessId+  -- ^ Used to transmit masters ProcessId to a slabe+  | TransferReq (SendPort Transfer)+  -- ^ FacilitateS a Transfer+  | Terminate+  -- ^ Terminates a slaves connection to the network+  deriving (Generic, Typeable)++instance Binary Request++-- | Only slaves can issue a Reponse in reply to a Request+data Response+  = PD ProcessDeps+  -- ^ Response to a Ping+  | Transfer+  -- ^ Reponse to a TransferReq+  deriving (Generic, Typeable)++instance Binary Response++-- | Data-Type used in a Transfer+data Transfer+  = TransferInProg FileInfo+  -- ^ Transfer In Progress+  | TransferDone+  -- ^ Informs master the Transfer is complete+  deriving (Generic, Typeable)++instance Binary Transfer++instance Show Transfer where+  show (TransferInProg (s, _)) = show $ decode s+  show _                       = "Transfer Complete"++---------------------------------------------------------------------------------+data ProcessError =+  SlaveError++instance Show ProcessError where+  show SlaveError = "Slave died during transfer. Aborting to retry..."+---------------------------------------------------------------------------------
+ src/Network/Distributed/Utils.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module:      Network.Distributed.Transfer+-- Copyright:   (c) 2018 Sean McGroarty+-- License:     BSD3+-- Maintainer:  Sean McGroarty <mcgroas@tcd.ie.com>+-- Stability:   experimental+--+module Network.Distributed.Utils+  ( parseNetConfig+  , log+  , logSucc+  , logWarn+  , listDeps+  , getBestPid+  , timeIt+  , runStackBuild+  , runStackBuildT+  ) where++import           Control.Monad.IO.Class    (MonadIO, liftIO)+import qualified Data.Configurator         as C+import           Data.List                 (intersect)+import           Network.Distributed.Types+import           Prelude                   hiding (log)+import           System.Clock+import           System.Console.ANSI+import           System.Directory          (getCurrentDirectory)+import           System.Exit               (ExitCode (..))+import           System.IO                 (BufferMode (..), hGetContents,+                                            hSetBuffering)+import           System.Process++-------------------------------------------------------------------------------------+-- | Parsers configuration from provided file+parseNetConfig :: IO NetworkConfig+parseNetConfig = do+  cfg <- C.load [C.Required "network.config"]+  NetworkConfig <$> C.require cfg "net.host" <*> C.require cfg "net.port"++-------------------------------------------------------------------------------------+-- | Logs to stdout in grey+log :: MonadIO m => String -> m ()+log = log' [[SetColor Foreground Vivid Black]]++-- | Logs to stdout in green+logSucc :: MonadIO m => String -> m ()+logSucc = log' [[SetColor Foreground Vivid Green]]++-- | Logs to stdout in red+logWarn :: MonadIO m => String -> m ()+logWarn = log' [[SetColor Foreground Dull Red]]++-- | Internal log function+log' :: MonadIO m => [[SGR]] -> String -> m ()+log' styles msg =+  liftIO $ do+    mapM_ setSGR styles+    putStrLn msg+    setSGR [Reset]++---------------------------------------------------------------------------------------+-- | Determines a nodes dependencies+listDeps :: MonadIO m => m [String]+listDeps =+  liftIO $ do+    path <- getCurrentDirectory+    (_, Just hStdout, _, p) <-+      System.Process.createProcess+        (proc "stack" ["list-dependencies", "--stack-root", path ++ "/root"])+        {std_out = CreatePipe, std_err = Inherit}+    hSetBuffering hStdout NoBuffering+    exit_code <- waitForProcess p+    case exit_code of+      ExitSuccess   -> lines <$> hGetContents hStdout+      ExitFailure _ -> logWarn "Error calculating dependencies" >> pure []++-- | Finds the ProcessId with the most overlapp, returning Nothing if there is no overlapp+getBestPid ::+     [(Deps, Node)]+  -- ^ a list of pairs of Nodes and their dependencies+  -> Deps+  -- ^ Master nodes dependencies+  -> (Maybe Node, Int)+  -- ^ Current best. Initially set to (Nothing,0)+  -> Maybe Node+getBestPid [] _ best = fst best+getBestPid ((curDeps, curPid):xs) cmpDeps curBest+  | curLen > snd curBest = recurse (Just curPid, curLen)+  | otherwise = recurse curBest+  where+    curLen = length (curDeps `intersect` cmpDeps)+    recurse = getBestPid xs cmpDeps++-------------------------------------------------------------------------------------+runStackBuildT :: IO ()+runStackBuildT = timeIt runStackBuild++runStackBuild :: IO ()+runStackBuild = do+  log "Build invoked..."+  path <- getCurrentDirectory+  callProcess "stack" ["build", "--stack-root", path ++ "/root"]+  logSucc "Build Succesfully Completed."++-------------------------------------------------------------------------------------+-- | Times an action+timeIt ::+     MonadIO m+  => m a+  -- ^ Action to time+  -> m a+timeIt action = do+  start <- liftIO $ getTime Monotonic+  res <- action+  end <- liftIO $ getTime Monotonic+  logSucc $ "Time: " ++ show (sec $ diffTimeSpec start end) ++ " seconds"+  pure res
+ stack-network.cabal view
@@ -0,0 +1,155 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 12a687ca0943e077ae9a6701e456dcb05c158b2d5231a99dab1235832cb71e44++name:           stack-network+version:        0.1.0.0+synopsis:       A program for extending Stack to add distributed capabilities+description:    See README at <https://github.com/McGizzle/stack-network#readme>+category:       Web+homepage:       https://github.com/McGizzle/stack-network#readme+bug-reports:    https://github.com/McGizzle/stack-network/issues+author:         Sean McGroarty+maintainer:     Sean McGroarty <mcgroas@tcd.ie>+copyright:      2018 Sean McGroarty+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    build4docker.sh+    docker-compose.yml+    network.config+    README.md+    rundock.sh++source-repository head+  type: git+  location: https://github.com/McGizzle/stack-network++library+  hs-source-dirs:+      src+  ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+  build-depends:+      Cabal+    , ansi-terminal+    , async+    , base >=4.7 && <5+    , binary+    , bytestring+    , clock+    , configurator+    , directory+    , dirstream+    , distributed-process-lifted+    , distributed-process-simplelocalnet+    , exceptions+    , filepath+    , lifted-base+    , mtl+    , optparse-applicative+    , pipes+    , pipes-safe+    , process+    , system-fileio+    , system-filepath+    , temporary+    , text+    , transformers+  exposed-modules:+      Network.Distributed+      Network.Distributed.Types+      Network.Distributed.Utils+      Network.Distributed.Process+      Network.Distributed.Transfer+  other-modules:+      Main+      Paths_stack_network+  default-language: Haskell2010++executable stack-network+  main-is: Main.hs+  hs-source-dirs:+      src+  ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+  build-depends:+      Cabal+    , ansi-terminal+    , async+    , base >=4.7 && <5+    , binary+    , bytestring+    , clock+    , configurator+    , directory+    , dirstream+    , distributed-process-lifted+    , distributed-process-simplelocalnet+    , exceptions+    , filepath+    , lifted-base+    , mtl+    , optparse-applicative+    , pipes+    , pipes-safe+    , process+    , stack-network+    , system-fileio+    , system-filepath+    , temporary+    , text+    , transformers+  other-modules:+      Network.Distributed+      Network.Distributed.Process+      Network.Distributed.Transfer+      Network.Distributed.Types+      Network.Distributed.Utils+      Paths_stack_network+  default-language: Haskell2010++test-suite distributed-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      Cabal+    , ansi-terminal+    , async+    , base >=4.7 && <5+    , binary+    , bytestring+    , clock+    , configurator+    , directory+    , dirstream+    , distributed-process-lifted+    , distributed-process-simplelocalnet+    , exceptions+    , filepath+    , hspec+    , lifted-base+    , mtl+    , optparse-applicative+    , pipes+    , pipes-safe+    , process+    , raw-strings-qq+    , stack-network+    , system-fileio+    , system-filepath+    , temporary+    , text+    , transformers+    , yaml+  other-modules:+      DockerCompose+      DockerSpec+      Paths_stack_network+  default-language: Haskell2010
+ test/DockerCompose.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module DockerCompose where++import           Data.ByteString   (ByteString)+import           Text.RawString.QQ++fourNYaml :: ByteString+fourNYaml =+  [r|+slave3:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|7003|' network.config && sed -i -e 's|mwc-random|mtl,transformers|' testbuild1.cabal && stack-network join"+  tty: true+  stdin_open: true+  net: "host"+  ports:+    - "7003:7003"+slave2:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|7002|' network.config && sed -i -e 's|mwc-random|transformers|' testbuild1.cabal && stack-network join"+  tty: true+  stdin_open: true+  net: "host"+  ports:+    - "7002:7002"+slave1:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|7001|' network.config && sed -i -e 's|mwc-random|mtl,mwc-random|' testbuild1.cabal && stack-network join"+  tty: true+  stdin_open: true+  net: "host"+  ports:+    - "7001:7001"+master:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|7000|' network.config && sed -i -e 's|mwc-random|mtl,mwc-random|' testbuild1.cabal && stack-network build -n 3"+  tty: true+  stdin_open: true+  net: "host"+  ports:+    - "7000:7000"+|]++threeNYaml :: ByteString+threeNYaml =+  [r|+slave2:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|7002|' network.config && sed -i -e 's|mwc-random|primitive|' testbuild1.cabal && stack-network join"+  tty: true+  stdin_open: true+  net: "host"+  ports:+    - "7002:7002"+slave1:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|7001|' network.config && sed -i -e 's|mwc-random|vector|' testbuild1.cabal && stack-network join"+  tty: true+  stdin_open: true+  net: "host"+  ports:+    - "7001:7001"+master:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|7000|' network.config && sed -i -e 's|mwc-random|primitive|' testbuild1.cabal && stack-network build -n 2"+  tty: true+  stdin_open: true+  net: "host"+  ports:+    - "7000:7000"+|]++simpleYaml :: ByteString+simpleYaml =+  [r|+slave:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|7001|' network.config && sed -i -e 's|mwc-random|array|' testbuild1.cabal && stack-network join"+  tty: true+  stdin_open: true+  net: "host"+  ports:+    - "7001:7001"+master:+  image: mcgizzle/stack-network+  command: bash -c "cd testbuild && sed -i -e 's|&port|7000|' network.config && sed -i -e 's|mwc-random|array|' testbuild1.cabal && stack-network build"+  tty: true+  stdin_open: true+  net: "host"+  ports:+    - "7000:7000"+|]
+ test/DockerSpec.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE OverloadedStrings #-}++module DockerSpec where++import           DockerCompose++import           Data.ByteString  (ByteString)+import qualified Data.ByteString  as BS+import           GHC.IO.Handle+import           System.Directory (getCurrentDirectory)+import           System.Exit      (ExitCode (..))+import           System.IO.Temp   (withTempFile)+import           System.Process+import           Test.Hspec++type Test = (ByteString, String)++tests :: [Test]+tests =+  [ (simpleYaml, "Runs two containers with one dependency")+  , (threeNYaml, "Runs three containers with one dependency each")+  , (fourNYaml, "Runs four containers with multiple dependencies")+  ]++spec :: Spec+spec = describe "Test using docker-compose" $ mapM_ (uncurry runSpec) tests++runSpec :: ByteString -> String -> SpecWith ()+runSpec file info =+  it info $ do+    dir <- getCurrentDirectory+    withTempFile dir "temp.yml" $ \fp h -> do+      hSetBuffering h NoBuffering+      BS.hPut h file+      res <- execDocker fp+      res `shouldBe` True++execDocker :: FilePath -> IO Bool+execDocker dc = runDocker dc <* clearDocker dc++runDocker :: FilePath -> IO Bool+runDocker file = do+  (_, _, _, ph) <-+    createProcess (proc "docker-compose" ["-f", file, "up", "--force-recreate"])+  exit_code <- waitForProcess ph+  case exit_code of+    ExitSuccess   -> pure True+    ExitFailure e -> print e >> pure False++clearDocker :: FilePath -> IO ()+clearDocker file = do+  (_, _, _, ph) <-+    createProcess+      (proc "docker-compose" ["-f", file, "down"])+      {std_out = NoStream, std_err = NoStream}+  _ <- waitForProcess ph+  pure ()
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}