summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Main.hs18
-rw-r--r--src/Network.hs13
-rw-r--r--src/Network.hs-boot4
-rw-r--r--src/Parser.hs43
-rw-r--r--src/Test.hs14
5 files changed, 64 insertions, 28 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 02d690f..b6c952f 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -165,27 +165,29 @@ createNode nname@(NodeName tnname) inner = do
net <- asks $ tsNetwork . snd
let name = T.unpack tnname
dir = netDir net </> ("erebos_" ++ name)
- node = Node { nodeName = nname
- , nodeNetwork = net
- , nodeDir = dir
- }
- ip <- liftIO $ do
+ node <- liftIO $ do
exists <- doesPathExist dir
when exists $ ioError $ userError $ dir ++ " exists"
createDirectoryIfMissing True dir
modifyMVar (netNodes net) $ \nodes -> do
let ip = "192.168.0." ++ show (11 + length nodes)
+ node = Node { nodeName = nname
+ , nodeIp = T.pack ip
+ , nodeNetwork = net
+ , nodeDir = dir
+ }
+
callCommand $ "ip netns add \""++ name ++ "\""
callCommand $ "ip link add \"veth_" ++ name ++ ".0\" group 1 type veth peer name \"veth_" ++ name ++ ".1\" netns \"" ++ name ++ "\""
callCommand $ "ip link set dev \"veth_" ++ name ++ ".0\" master br0 up"
callOn node $ "ip addr add " ++ ip ++ "/24 broadcast 192.168.0.255 dev \"veth_" ++ name ++ ".1\""
callOn node $ "ip link set dev \"veth_" ++ name++ ".1\" up"
callOn node $ "ip link set dev lo up"
- return $ (node : nodes, ip)
+ return $ (node : nodes, node)
- local (fmap $ \s -> s { tsVars = (VarName [tnname, T.pack "ip"], SomeVarValue (T.pack ip)) : tsVars s }) $ do
+ local (fmap $ \s -> s { tsVars = (VarName tnname, SomeVarValue node) : tsVars s }) $ do
inner node
callOn :: Node -> String -> IO ()
@@ -315,7 +317,7 @@ evalSteps = mapM_ $ \case
evalSteps inner
Spawn pname nname inner -> do
- getNode nname $ \node -> do
+ either getNode ((>>=) . eval) nname $ \node -> do
opts <- asks $ teOptions . fst
p <- spawnOn (Right node) pname Nothing $
fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts)
diff --git a/src/Network.hs b/src/Network.hs
index 633db16..5872d13 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -4,12 +4,14 @@ module Network (
NodeName(..), textNodeName, unpackNodeName,
) where
+import Control.Arrow
import Control.Concurrent
import Data.Text (Text)
import Data.Text qualified as T
import Process
+import Test
data Network = Network
{ netNodes :: MVar [Node]
@@ -19,6 +21,7 @@ data Network = Network
data Node = Node
{ nodeName :: NodeName
+ , nodeIp :: Text
, nodeNetwork :: Network
, nodeDir :: FilePath
}
@@ -31,3 +34,13 @@ textNodeName (NodeName name) = name
unpackNodeName :: NodeName -> String
unpackNodeName (NodeName tname) = T.unpack tname
+
+
+instance ExprType Node where
+ textExprType _ = T.pack "node"
+ textExprValue n = T.pack "n:" <> textNodeName (nodeName n)
+ emptyVarValue = Node (NodeName T.empty) T.empty undefined undefined
+
+ recordMembers = map (first T.pack)
+ [ ("ip", RecordSelector $ nodeIp)
+ ]
diff --git a/src/Network.hs-boot b/src/Network.hs-boot
new file mode 100644
index 0000000..820fdaf
--- /dev/null
+++ b/src/Network.hs-boot
@@ -0,0 +1,4 @@
+module Network where
+
+data Node
+data NodeName
diff --git a/src/Parser.hs b/src/Parser.hs
index 7534eaa..0f3747d 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -27,7 +27,7 @@ import qualified Text.Megaparsec.Char.Lexer as L
import System.Exit
-import Network (NodeName(..))
+import Network (Node, NodeName(..))
import Process (ProcName(..))
import Test
@@ -46,7 +46,6 @@ someEmptyVar :: SomeExprType -> SomeVarValue
someEmptyVar (SomeExprType (Proxy :: Proxy a)) = SomeVarValue $ emptyVarValue @a
instance MonadEval TestParser where
- lookupVar (VarName [_, ip]) | ip == T.pack "ip" = return $ SomeVarValue T.empty
lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") (return . someEmptyVar) =<< gets (lookup name . testVars)
skipLineComment :: TestParser ()
@@ -90,12 +89,6 @@ listOf item = do
x <- item
(x:) <$> choice [ symbol "," >> listOf item, return [] ]
-nodeName :: TestParser NodeName
-nodeName = label "network node name" $ lexeme $ do
- c <- lowerChar
- cs <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_' || x == '-')
- return $ NodeName $ TL.toStrict (c `TL.cons` cs)
-
procName :: TestParser ProcName
procName = label "process name" $ lexeme $ do
c <- lowerChar
@@ -107,13 +100,11 @@ identifier = do
lexeme $ TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
varName :: TestParser VarName
-varName = lexeme $ do
- VarName . T.splitOn (T.singleton '.') . TL.toStrict <$>
- takeWhile1P Nothing (\x -> isAlphaNum x || x == '_' || x == '.')
+varName = VarName <$> identifier
newVarName :: forall a proxy. ExprType a => proxy a -> TestParser VarName
newVarName proxy = do
- name <- VarName . (:[]) <$> identifier
+ name <- varName
addVarName proxy name
return name
@@ -128,7 +119,7 @@ someExpansion :: TestParser SomeExpr
someExpansion = do
void $ char '$'
choice
- [do name <- VarName . (:[]) . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
+ [do name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_')
SomeVarValue (_ :: a) <- lookupVar name
return $ SomeExpr $ Variable @a name
, between (char '{') (char '}') someExpr
@@ -219,7 +210,9 @@ someExpr = join inner <?> "expression"
term = parens inner <|> literal <|> variable <?> "term"
- table = [ [ prefix "-" $ [ SomeUnOp (negate @Integer) ]
+ table = [ [ recordSelector
+ ]
+ , [ prefix "-" $ [ SomeUnOp (negate @Integer) ]
]
, [ binary "*" $ [ SomeBinOp ((*) @Integer) ]
, binary "/" $ [ SomeBinOp (div @Integer) ]
@@ -257,6 +250,20 @@ someExpr = join inner <?> "expression"
[T.pack "operator '", T.pack name, T.pack "' not defined for '", textExprType e, T.pack "' and '", textExprType f, T.pack "'"]
maybe err return $ listToMaybe $ catMaybes $ map (\(SomeBinOp op) -> SomeExpr <$> applyBinOp op e f) ops
+ recordSelector :: Operator TestParser (TestParser SomeExpr)
+ recordSelector = Postfix $ do
+ void $ osymbol "."
+ off <- stateOffset <$> getParserState
+ VarName m <- varName
+ return $ \p -> do
+ SomeExpr e <- p
+ let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
+ [ T.pack "value of type ", textExprType e, T.pack " does not have member '", m, T.pack "'" ]
+ maybe err return $ applyRecordSelector e <$> lookup m recordMembers
+
+ applyRecordSelector :: ExprType a => Expr a -> RecordSelector a -> SomeExpr
+ applyRecordSelector e (RecordSelector f) = SomeExpr $ UnOp f e
+
literal = label "literal" $ choice
[ return . SomeExpr <$> integerLiteral
, return . SomeExpr <$> quotedString
@@ -292,7 +299,7 @@ letStatement = do
line <- getSourceLine
indent <- L.indentLevel
wsymbol "let"
- name <- VarName . (:[]) <$> identifier
+ name <- varName
osymbol "="
SomeExpr (e :: Expr a) <- someExpr
void $ eol
@@ -316,7 +323,7 @@ instance ParamType SourceLine where
showParamType _ = "<source line>"
instance ParamType NodeName where
- parseParam = nodeName
+ parseParam = NodeName . textVarName <$> newVarName @Node Proxy
showParamType _ = "<node>"
instance ParamType ProcName where
@@ -336,6 +343,10 @@ instance ParamType a => ParamType [a] where
showParamType _ = showParamType @a Proxy ++ " [, " ++ showParamType @a Proxy ++ " ...]"
paramDefault = return []
+instance (ParamType a, ParamType b) => ParamType (Either a b) where
+ parseParam = try (Left <$> parseParam) <|> (Right <$> parseParam)
+ showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy
+
data SomeParam f = forall a. ParamType a => SomeParam (f a)
data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> a)
diff --git a/src/Test.hs b/src/Test.hs
index 41649ef..a90035b 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -7,6 +7,7 @@ module Test (
VarName(..), textVarName, unpackVarName,
ExprType(..),
SomeVarValue(..), fromSomeVarValue, textSomeVarValue,
+ RecordSelector(..),
Expr(..), eval, gatherVars,
Regex,
) where
@@ -22,7 +23,7 @@ import Data.Typeable
import Text.Regex.TDFA
import Text.Regex.TDFA.Text
-import Network
+import {-# SOURCE #-} Network
import Process
import Util
@@ -32,7 +33,7 @@ data Test = Test
}
data TestStep = forall a. ExprType a => Let SourceLine VarName (Expr a) [TestStep]
- | Spawn ProcName NodeName [TestStep]
+ | Spawn ProcName (Either NodeName (Expr Node)) [TestStep]
| Send ProcName (Expr Text)
| Expect SourceLine ProcName (Expr Regex) [VarName] [TestStep]
| Guard SourceLine (Expr Bool)
@@ -45,11 +46,11 @@ class MonadFail m => MonadEval m where
lookupVar :: VarName -> m SomeVarValue
-data VarName = VarName [Text]
+newtype VarName = VarName Text
deriving (Eq, Ord)
textVarName :: VarName -> Text
-textVarName (VarName name) = T.concat $ intersperse (T.singleton '.') name
+textVarName (VarName name ) = name
unpackVarName :: VarName -> String
unpackVarName = T.unpack . textVarName
@@ -60,6 +61,9 @@ class Typeable a => ExprType a where
textExprValue :: a -> Text
emptyVarValue :: a
+ recordMembers :: [(Text, RecordSelector a)]
+ recordMembers = []
+
instance ExprType Integer where
textExprType _ = T.pack "integer"
textExprValue x = T.pack (show x)
@@ -83,6 +87,8 @@ instance ExprType Regex where
data SomeVarValue = forall a. ExprType a => SomeVarValue a
+data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)
+
fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m a
fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast value
where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", textExprType (Just value) ]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 23:36:11 +0000