summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2021-08-04 22:05:05 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2021-08-04 22:55:53 +0200
commit55a699fcbb6d222e08f6fc7739ed1d3d9d98d09f (patch)
tree8ad62cdef22560547b1790aeef152d6b8b08a86a
parent56854a666ed7bf2bd923c6be55cf4f753de2673f (diff)
Create EREBOS_DIR and pass it via environment
-rw-r--r--.gitignore1
-rw-r--r--erebos-tester.cabal2
-rw-r--r--src/Main.hs24
3 files changed, 25 insertions, 2 deletions
diff --git a/.gitignore b/.gitignore
index c33954f..edc0c50 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1 +1,2 @@
dist-newstyle/
+.test
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index d9e25c7..ab52ab4 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -37,6 +37,8 @@ executable erebos-tester-core
-- other-extensions:
default-extensions: LambdaCase
build-depends: base ^>=4.13.0.0,
+ directory ^>=1.3.6.0,
+ filepath ^>=1.4.2.1,
process ^>=1.6.9,
regex-tdfa ^>=1.3.1.0,
stm ^>=2.5.0.1,
diff --git a/src/Main.hs b/src/Main.hs
index 169cec4..e1d4c41 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -7,18 +7,22 @@ import Control.Monad
import Text.Regex.TDFA
import Text.Regex.TDFA.String
+import System.Directory
import System.Environment
+import System.FilePath
import System.IO
import System.IO.Error
import System.Process
data Network = Network
{ netNodes :: MVar [(Int, Node)]
+ , netDir :: FilePath
}
data Node = Node
{ nodeNetwork :: Network
, nodeName :: String
+ , nodeDir :: FilePath
}
data Process = Process
@@ -28,22 +32,36 @@ data Process = Process
, procOutput :: TVar [String]
}
+testDir :: FilePath
+testDir = "./.test"
+
initNetwork :: IO Network
initNetwork = do
+ exists <- doesPathExist testDir
+ when exists $ ioError $ userError $ testDir ++ " exists"
+ createDirectoryIfMissing True testDir
+
callCommand "ip link add name br0 type bridge"
callCommand "ip addr add 192.168.0.1/24 broadcast 192.168.0.255 dev br0"
callCommand "ip link set dev br0 up"
callCommand "ip link set dev lo up"
- Network <$> newMVar []
+ Network <$> newMVar [] <*> pure testDir
getNode :: Network -> Int -> IO Node
getNode net idx = (lookup idx <$> readMVar (netNodes net)) >>= \case
Just node -> return node
_ -> do
let name = "node" ++ show idx
+ dir = netDir net </> ("erebos" ++ show idx)
node = Node { nodeNetwork = net
, nodeName = name
+ , nodeDir = dir
}
+
+ exists <- doesPathExist dir
+ when exists $ ioError $ userError $ dir ++ " exists"
+ createDirectoryIfMissing True dir
+
callCommand $ "ip netns add \""++ name ++ "\""
callCommand $ "ip link add \"veth" ++ show idx ++ ".0\" type veth peer name \"veth" ++ show idx ++ ".1\" netns \"" ++ name ++ "\""
callCommand $ "ip link set dev \"veth" ++ show idx ++ ".0\" master br0 up"
@@ -59,7 +77,9 @@ callOn node cmd = callCommand $ "ip netns exec \"" ++ nodeName node ++ "\" " ++
spawnOn :: Node -> String -> IO Process
spawnOn node cmd = do
(Just hin, Just hout, Just herr, handle) <- createProcess (shell $ "ip netns exec \"" ++ nodeName node ++ "\" " ++ cmd)
- { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
+ { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
+ , env = Just [("EREBOS_DIR", nodeDir node)]
+ }
out <- newTVarIO []
let readingLoop :: Handle -> (String -> IO ()) -> IO ()