summaryrefslogtreecommitdiff
path: root/src/Main.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2021-08-03 22:07:44 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2021-08-04 21:41:28 +0200
commitbb9d723d3336e2f64beb04ac777a0ea45873f818 (patch)
tree987907de82c08f03ef872750c04d9328894da206 /src/Main.hs
parent640096d8f2735701d804abd599fa93e6a8f73316 (diff)
Network and process init with unsharing wrapper
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs94
1 files changed, 93 insertions, 1 deletions
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)