diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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` + + + diff --git a/build4docker.sh b/build4docker.sh new file mode 100644 --- /dev/null +++ b/build4docker.sh @@ -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 + diff --git a/docker-compose.yml b/docker-compose.yml new file mode 100644 --- /dev/null +++ b/docker-compose.yml @@ -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" diff --git a/network.config b/network.config new file mode 100644 --- /dev/null +++ b/network.config @@ -0,0 +1,5 @@ +net +{ + host = "127.0.0.1" + port = "5000" +} diff --git a/rundock.sh b/rundock.sh new file mode 100644 --- /dev/null +++ b/rundock.sh @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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) diff --git a/src/Network/Distributed.hs b/src/Network/Distributed.hs new file mode 100644 --- /dev/null +++ b/src/Network/Distributed.hs @@ -0,0 +1,16 @@ +-- | +-- Module: Network.Distributed +-- Copyright: (c) 2018 Sean McGroarty +-- License: BSD3 +-- Maintainer: Sean McGroarty +-- 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 diff --git a/src/Network/Distributed/Process.hs b/src/Network/Distributed/Process.hs new file mode 100644 --- /dev/null +++ b/src/Network/Distributed/Process.hs @@ -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 +-- 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 () diff --git a/src/Network/Distributed/Transfer.hs b/src/Network/Distributed/Transfer.hs new file mode 100644 --- /dev/null +++ b/src/Network/Distributed/Transfer.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Network.Distributed.Transfer +-- Copyright: (c) 2018 Sean McGroarty +-- License: BSD3 +-- Maintainer: Sean McGroarty +-- 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 +-------------------------------------------------------------------------------------------- diff --git a/src/Network/Distributed/Types.hs b/src/Network/Distributed/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Distributed/Types.hs @@ -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 +-- 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..." +--------------------------------------------------------------------------------- diff --git a/src/Network/Distributed/Utils.hs b/src/Network/Distributed/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/Distributed/Utils.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Network.Distributed.Transfer +-- Copyright: (c) 2018 Sean McGroarty +-- License: BSD3 +-- Maintainer: Sean McGroarty +-- 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 diff --git a/stack-network.cabal b/stack-network.cabal new file mode 100644 --- /dev/null +++ b/stack-network.cabal @@ -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 +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 +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 diff --git a/test/DockerCompose.hs b/test/DockerCompose.hs new file mode 100644 --- /dev/null +++ b/test/DockerCompose.hs @@ -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" +|] diff --git a/test/DockerSpec.hs b/test/DockerSpec.hs new file mode 100644 --- /dev/null +++ b/test/DockerSpec.hs @@ -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 () diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}