stack-network 0.1.0.0 → 0.1.0.1
raw patch · 10 files changed
+169/−102 lines, 10 files
Files
- README.md +2/−0
- build4docker.sh +0/−21
- src/Main.hs +22/−17
- src/Network/Distributed/Process.hs +30/−24
- src/Network/Distributed/Transfer.hs +14/−9
- src/Network/Distributed/Types.hs +18/−20
- src/Network/Distributed/Utils.hs +30/−4
- stack-network.cabal +2/−4
- test/DockerCompose.hs +44/−2
- test/DockerSpec.hs +7/−1
README.md view
@@ -1,5 +1,7 @@ # stack-network +[](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.
− build4docker.sh
@@ -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-
src/Main.hs view
@@ -1,13 +1,23 @@-{-# LANGUAGE LambdaCase #-}+-- |+-- Module: Main+-- Copyright: (c) 2018 Sean McGroarty+-- License: BSD3+-- Maintainer: Sean McGroarty <mcgroas@tcd.ie.com>+-- 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)
src/Network/Distributed/Process.hs view
@@ -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
src/Network/Distributed/Transfer.hs view
@@ -7,22 +7,27 @@ -- Maintainer: Sean McGroarty <mcgroas@tcd.ie.com> -- 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+--------------------------------------------------------------------------------------
src/Network/Distributed/Types.hs view
@@ -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
src/Network/Distributed/Utils.hs view
@@ -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
stack-network.cabal view
@@ -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 <https://github.com/McGizzle/stack-network#readme> 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
test/DockerCompose.hs view
@@ -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"
test/DockerSpec.hs view
@@ -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 =