diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # stack-network +[![Hackage](https://img.shields.io/hackage/v/lens.svg)](https://hackage.haskell.org/package/stack-network-0.1.0.0) + ## 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. diff --git a/build4docker.sh b/build4docker.sh deleted file mode 100644 --- a/build4docker.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/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/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,13 +1,23 @@ -{-# LANGUAGE LambdaCase #-} +-- | +-- Module: Main +-- Copyright: (c) 2018 Sean McGroarty +-- License: BSD3 +-- Maintainer: Sean McGroarty +-- Stability: experimental +-- +module Main + ( main + ) where -module Main where +------------------------------------------------------------------------------------------- +import Network.Distributed +------------------------------------------------------------------------------------------- import Control.Monad (join) import Data.Semigroup ((<>)) -import Network.Distributed import Options.Applicative -data Opts = Opts +newtype Opts = Opts { waitNodes :: Int } @@ -29,19 +39,14 @@ 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 +commands = + subparser $ + command "build" (info (runBuild <$> optParser) description) <> + command "join" (info (pure runJoin) description) + where + runJoin = runStackBuildT >> parseNetConfig >>= joinNetwork + runBuild opts = runRequestNode (waitNodes opts) =<< parseNetConfig +-- | Main main :: IO () main = join $ execParser (info (commands <**> helper) description) diff --git a/src/Network/Distributed/Process.hs b/src/Network/Distributed/Process.hs --- a/src/Network/Distributed/Process.hs +++ b/src/Network/Distributed/Process.hs @@ -23,40 +23,46 @@ , 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.Backend.SimpleLocalnet (Backend, + findPeers, + initializeBackend, + newLocalNode) import Control.Distributed.Process.Lifted hiding (bracket, catch) -import Control.Distributed.Process.Lifted.Class +import Control.Distributed.Process.Lifted.Class (MonadProcess) import qualified Control.Distributed.Process.Node.Lifted as PN - +import Control.Monad (replicateM, + (>=>)) +import Control.Monad.Catch (MonadCatch, + MonadMask, + SomeException, + bracket, + catch) +import Control.Monad.Reader (MonadReader, + asks) import Data.Maybe (catMaybes) - -import Filesystem +import Filesystem (createTree, + writeFile) import Filesystem.Path (directory) -import Filesystem.Path.CurrentOS (decode) - -import Control.Monad.Reader +import Prelude hiding + (FilePath, + log) ---------------------------------------------------------------------------- --- | Logs that the Node is joining the network and returns a Backend +-- | 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 +-- | Runs a 'Process' that is a master 'Node' runRequestNode :: Int -- ^ Number of slave nodes the master should wait for @@ -65,11 +71,11 @@ runRequestNode waitN nc = do backend <- mkBackend nc let cfg = AppConfig waitN backend - flip PN.runProcess (runApp cfg runRequestNode') =<< newLocalNode backend + flip PN.runProcess (runNetProc cfg runRequestNode') =<< newLocalNode backend runStackBuildT --- | Internal for master node -runRequestNode' :: App () +-- | Internal for master 'Node' +runRequestNode' :: NetProc () runRequestNode' = do log "Searching the Network..." pids <- findPids @@ -85,14 +91,14 @@ logSucc "Transmission complete. All files received. Ready to build." mapM_ (`send` Terminate) pids where - retryReq :: SomeException -> App () + retryReq :: SomeException -> NetProc () retryReq _ = logWarn "Slave died. Retrying..." >> runRequestNode' --- | Creates the Backend and runs a Process that is a Slave node +-- | 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 +-- | Internal for slave 'Node' joinNetwork' :: Process () joinNetwork' = do me <- getSelfPid @@ -180,7 +186,7 @@ where work (TransferInProg (path, file)) = do liftIO $ do - let path' = decode path + let path' = decodePath path createTree (directory path') Filesystem.writeFile path' file receiveF rPort diff --git a/src/Network/Distributed/Transfer.hs b/src/Network/Distributed/Transfer.hs --- a/src/Network/Distributed/Transfer.hs +++ b/src/Network/Distributed/Transfer.hs @@ -7,22 +7,27 @@ -- Maintainer: Sean McGroarty -- Stability: experimental -- -module Network.Distributed.Transfer where +module Network.Distributed.Transfer + ( pipeFiles + , packageFile + , producers + ) where +-------------------------------------------------------------------------------------- import Network.Distributed.Types import Network.Distributed.Utils -import Control.Applicative -import Data.DirStream -import Filesystem +-------------------------------------------------------------------------------------- +import Control.Applicative ((<|>)) +import Data.DirStream (descendentOf) +import Filesystem (isFile, readFile) 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) @@ -45,6 +50,6 @@ -- | Packages a file by reading in its bytes packageFile :: MonadIO m => FilePath -> m Transfer -packageFile file = - liftIO $ TransferInProg . (,) (encode file) <$> Filesystem.readFile file --------------------------------------------------------------------------------------------- +packageFile path = + liftIO $ TransferInProg . (,) (encodePath path) <$> Filesystem.readFile path +-------------------------------------------------------------------------------------- diff --git a/src/Network/Distributed/Types.hs b/src/Network/Distributed/Types.hs --- a/src/Network/Distributed/Types.hs +++ b/src/Network/Distributed/Types.hs @@ -16,12 +16,11 @@ import Control.Distributed.Process.Lifted (Process, ProcessId, SendPort) -import Control.Monad.Reader +import Control.Monad.Reader (ReaderT, + runReaderT) 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) --------------------------------------------------------------------------------- @@ -32,15 +31,17 @@ , backend :: Backend } --- | A Monad which wraps Process with ReaderT -type App a = ReaderT AppConfig Process a +-- | NetProc Monad +-- +-- Wraps Process with ReaderT +type NetProc a = ReaderT AppConfig Process a --- | Runs App -runApp :: AppConfig -> App a -> Process a -runApp = flip runReaderT +-- | Run the 'NetProc' Monad +runNetProc :: AppConfig -> NetProc a -> Process a +runNetProc = flip runReaderT --------------------------------------------------------------------------------- --- | Host and Port of a Node +-- | Host and Port of a 'Node' data NetworkConfig = NetworkConfig { hostNetworkConfig :: String , portNetworkConfig :: String @@ -51,20 +52,20 @@ "//" ++ hostNetworkConfig ++ ":" ++ portNetworkConfig --------------------------------------------------------------------------------- --- | A Node is used for communication +-- | A 'Node' is used for communication type Node = ProcessId --- | A collection of Nodes +-- | A collection of 'Node's type Network = [Node] --- | The dependecies a Node has, represented as a list of Strings +-- | 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) +type FileInfo = (ByteString, ByteString) --------------------------------------------------------------------------------- -- | All Types used messaging are derived from a Message @@ -75,16 +76,16 @@ -- | Only masters can make a Request data Request = Ping ProcessId - -- ^ Used to transmit masters ProcessId to a slabe + -- ^ Used to transmit masters 'ProcessId' to a slave | TransferReq (SendPort Transfer) - -- ^ FacilitateS a 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 +-- | Only slaves can issue a Reponse in reply to a 'Request' data Response = PD ProcessDeps -- ^ Response to a Ping @@ -104,11 +105,8 @@ instance Binary Transfer -instance Show Transfer where - show (TransferInProg (s, _)) = show $ decode s - show _ = "Transfer Complete" - --------------------------------------------------------------------------------- +-- | Errors covering a 'Process' failing data ProcessError = SlaveError diff --git a/src/Network/Distributed/Utils.hs b/src/Network/Distributed/Utils.hs --- a/src/Network/Distributed/Utils.hs +++ b/src/Network/Distributed/Utils.hs @@ -15,16 +15,25 @@ , logWarn , listDeps , getBestPid + , encodePath + , decodePath , timeIt , runStackBuild , runStackBuildT ) where +------------------------------------------------------------------------------------- +import Network.Distributed.Types + +------------------------------------------------------------------------------------- import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.ByteString (ByteString) import qualified Data.Configurator as C import Data.List (intersect) -import Network.Distributed.Types -import Prelude hiding (log) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Filesystem.Path (FilePath) +import Filesystem.Path.CurrentOS (fromText, toText) +import Prelude hiding (FilePath, log) import System.Clock import System.Console.ANSI import System.Directory (getCurrentDirectory) @@ -34,7 +43,7 @@ import System.Process ------------------------------------------------------------------------------------- --- | Parsers configuration from provided file +-- | Parsers configuration from provided @network.config@ file parseNetConfig :: IO NetworkConfig parseNetConfig = do cfg <- C.load [C.Required "network.config"] @@ -84,7 +93,7 @@ -> Deps -- ^ Master nodes dependencies -> (Maybe Node, Int) - -- ^ Current best. Initially set to (Nothing,0) + -- ^ Current best. Initially set to @(Nothing,0)@ -> Maybe Node getBestPid [] _ best = fst best getBestPid ((curDeps, curPid):xs) cmpDeps curBest @@ -95,9 +104,24 @@ recurse = getBestPid xs cmpDeps ------------------------------------------------------------------------------------- +fromEither :: Either a a -> a +fromEither (Right a) = a +fromEither (Left a) = a + +-- | Cross-platform encoding of 'FilePath' +encodePath :: FilePath -> ByteString +encodePath = encodeUtf8 . fromEither . toText + +-- | Cross-platform decoding of 'FilePath' +decodePath :: ByteString -> FilePath +decodePath = fromText . decodeUtf8 + +------------------------------------------------------------------------------------- +-- | Runs a timed build runStackBuildT :: IO () runStackBuildT = timeIt runStackBuild +-- | Runs a build runStackBuild :: IO () runStackBuild = do log "Build invoked..." @@ -107,6 +131,8 @@ ------------------------------------------------------------------------------------- -- | Times an action +-- +--Logs out the amount of seconds the action took timeIt :: MonadIO m => m a diff --git a/stack-network.cabal b/stack-network.cabal --- a/stack-network.cabal +++ b/stack-network.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 12a687ca0943e077ae9a6701e456dcb05c158b2d5231a99dab1235832cb71e44 +-- hash: 74f29ade797e135996fc0afdf72f45c180f58a0544a9c6692fea4265203cd39c name: stack-network -version: 0.1.0.0 +version: 0.1.0.1 synopsis: A program for extending Stack to add distributed capabilities description: See README at category: Web @@ -20,7 +20,6 @@ cabal-version: >= 1.10 extra-source-files: - build4docker.sh docker-compose.yml network.config README.md @@ -97,7 +96,6 @@ , pipes , pipes-safe , process - , stack-network , system-fileio , system-filepath , temporary diff --git a/test/DockerCompose.hs b/test/DockerCompose.hs --- a/test/DockerCompose.hs +++ b/test/DockerCompose.hs @@ -6,6 +6,48 @@ import Data.ByteString (ByteString) import Text.RawString.QQ +sevenDeps :: ByteString +sevenDeps = + [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|text|' 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|text|' testbuild1.cabal && stack-network build" + tty: true + stdin_open: true + net: "host" + ports: + - "7000:7000" +|] + +fiveDeps :: ByteString +fiveDeps = + [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|attoparsec|' 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|attoparsec|' testbuild1.cabal && stack-network build" + tty: true + stdin_open: true + net: "host" + ports: + - "7000:7000" +|] + fourNYaml :: ByteString fourNYaml = [r| @@ -27,7 +69,7 @@ - "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" + command: bash -c "cd testbuild && sed -i -e 's|&port|7001|' network.config && sed -i -e 's|mwc-random|mwc-random|' testbuild1.cabal && stack-network join" tty: true stdin_open: true net: "host" @@ -35,7 +77,7 @@ - "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" + command: bash -c "cd testbuild && sed -i -e 's|&port|7000|' network.config && sed -i -e 's|mwc-random|mwc-random|' testbuild1.cabal && stack-network build -n 3" tty: true stdin_open: true net: "host" diff --git a/test/DockerSpec.hs b/test/DockerSpec.hs --- a/test/DockerSpec.hs +++ b/test/DockerSpec.hs @@ -6,6 +6,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import Data.Monoid ((<>)) import GHC.IO.Handle import System.Directory (getCurrentDirectory) import System.Exit (ExitCode (..)) @@ -22,8 +23,13 @@ , (fourNYaml, "Runs four containers with multiple dependencies") ] +timeTests :: [Test] +timeTests = [(fiveDeps, "5 Deps"), (sevenDeps, "7 Deps")] + spec :: Spec -spec = describe "Test using docker-compose" $ mapM_ (uncurry runSpec) tests +spec = + describe "Test using docker-compose" $ + mapM_ (uncurry runSpec) $ tests <> timeTests runSpec :: ByteString -> String -> SpecWith () runSpec file info =