diff options
| -rw-r--r-- | erebos-tester.cabal | 19 | ||||
| -rw-r--r-- | src/Main.hs | 94 | ||||
| -rw-r--r-- | src/Wrapper.hs | 25 |
3 files changed, 136 insertions, 2 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal index ea0add7..0808f86 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -18,9 +18,26 @@ category: Testing extra-source-files: CHANGELOG.md executable erebos-tester + ghc-options: -Wall + main-is: Wrapper.hs + -- other-modules: + -- other-extensions: + build-depends: base ^>=4.13.0.0, + filepath ^>=1.4.2.1, + linux-namespaces ^>=0.1.3, + process ^>=1.6.9, + unix ^>=2.7.2.2, + hs-source-dirs: src + default-language: Haskell2010 + +executable erebos-tester-core + ghc-options: -Wall -threaded main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base ^>=4.13.0.0 + default-extensions: LambdaCase + build-depends: base ^>=4.13.0.0, + process ^>=1.6.9, + stm ^>=2.5.0.1, hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs index 65ae4a0..4c9b1fc 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,96 @@ module Main where +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad + +import System.Environment +import System.IO +import System.IO.Error +import System.Process + +data Network = Network + { netNodes :: MVar [(Int, Node)] + } + +data Node = Node + { nodeNetwork :: Network + , nodeName :: String + } + +data Process = Process + { procHandle :: ProcessHandle + , procNode :: Node + , procStdin :: Handle + , procOutput :: TVar [String] + } + +initNetwork :: IO Network +initNetwork = do + 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 [] + +getNode :: Network -> Int -> IO Node +getNode net idx = (lookup idx <$> readMVar (netNodes net)) >>= \case + Just node -> return node + _ -> do + let name = "node" ++ show idx + node = Node { nodeNetwork = net + , nodeName = name + } + 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" + callOn node $ "ip addr add 192.168.0." ++ show (10 + idx) ++ "/24 broadcast 192.168.0.255 dev \"veth" ++ show idx ++ ".1\"" + callOn node $ "ip link set dev \"veth" ++ show idx ++ ".1\" up" + callOn node $ "ip link set dev lo up" + modifyMVar_ (netNodes net) $ return . ((idx, node):) + return node + +callOn :: Node -> String -> IO () +callOn node cmd = callCommand $ "ip netns exec \"" ++ nodeName node ++ "\" " ++ cmd + +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 } + out <- newTVarIO [] + + let readingLoop :: Handle -> (String -> IO ()) -> IO () + readingLoop h act = + tryIOError (hGetLine h) >>= \case + Left err + | isEOFError err -> return () + | otherwise -> putStrLn $ "\ESC[31m" ++ nodeName node ++ "!!> IO error: " ++ show err ++ "\ESC[0m" + Right line -> do + act line + readingLoop h act + + void $ forkIO $ readingLoop hout $ \line -> do + putStrLn $ nodeName node ++ "> " ++ line + atomically $ modifyTVar out (++[line]) + void $ forkIO $ readingLoop herr $ \line -> do + putStrLn $ "\ESC[31m" ++ nodeName node ++ "!> " ++ line ++ "\ESC[0m" + + return Process + { procHandle = handle + , procNode = node + , procStdin = hin + , procOutput = out + } + main :: IO () -main = putStrLn "Hello, Haskell!" +main = do + [tool] <- getArgs + + net <- initNetwork + node1 <- getNode net 1 + node2 <- getNode net 2 + + p1 <- spawnOn node1 tool + p2 <- spawnOn node2 tool + + void $ return (p1, p2) diff --git a/src/Wrapper.hs b/src/Wrapper.hs new file mode 100644 index 0000000..c97d242 --- /dev/null +++ b/src/Wrapper.hs @@ -0,0 +1,25 @@ +module Main where + +import System.Environment +import System.FilePath +import System.Linux.Namespaces +import System.Posix.Process +import System.Posix.User +import System.Process + +main :: IO () +main = do + -- we must get uid/gid before unshare + uid <- getEffectiveUserID + gid <- getEffectiveGroupID + + unshare [User, Network, Mount] + writeUserMappings Nothing [UserMapping 0 uid 1] + writeGroupMappings Nothing [GroupMapping 0 gid 1] True + + -- needed for creating /run/netns + callCommand "mount -t tmpfs tmpfs /run" + + path <- getExecutablePath + args <- getArgs + executeFile (takeDirectory path </> "../../../erebos-tester-core/build/erebos-tester-core/erebos-tester-core") False args Nothing |