diff options
Diffstat (limited to 'src')
35 files changed, 4351 insertions, 992 deletions
diff --git a/src/Asset.hs b/src/Asset.hs new file mode 100644 index 0000000..2b14dcf --- /dev/null +++ b/src/Asset.hs @@ -0,0 +1,33 @@ +module Asset ( + Asset(..), + AssetPath(..), textAssetPath, +) where + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable + +import Script.Expr.Class + +data Asset = Asset + { assetPath :: AssetPath + } + +newtype AssetPath = AssetPath FilePath + +textAssetPath :: AssetPath -> Text +textAssetPath (AssetPath path) = T.pack path + +instance ExprType Asset where + textExprType _ = "Asset" + textExprValue asset = "asset:" <> textAssetPath (assetPath asset) + + recordMembers = + [ ( "path", RecordSelector $ assetPath ) + ] + +instance ExprType AssetPath where + textExprType _ = "Filepath" + textExprValue = ("filepath:" <>) . textAssetPath + + exprExpansionConvTo = cast textAssetPath diff --git a/src/Config.hs b/src/Config.hs index 7f5895c..af2161a 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -2,11 +2,14 @@ module Config ( Config(..), findConfig, parseConfig, + getConfigTestFiles, ) where import Control.Monad.Combinators import Data.ByteString.Lazy qualified as BS +import Data.Scientific +import Data.Text (Text) import Data.Text qualified as T import Data.YAML @@ -16,31 +19,41 @@ import System.FilePath import System.FilePath.Glob data Config = Config - { configTool :: Maybe FilePath - , configTests :: [Pattern] + { configDir :: FilePath + , configTool :: Maybe FilePath + , configTests :: [ Pattern ] + , configSelect :: Maybe [ Text ] + , configExclude :: [ Text ] + , configTimeout :: Maybe Scientific } deriving (Show) -instance Semigroup Config where - a <> b = Config - { configTool = maybe (configTool b) Just (configTool a) - , configTests = configTests a ++ configTests b - } - -instance Monoid Config where - mempty = Config - { configTool = Nothing - , configTests = [] - } - -instance FromYAML Config where - parseYAML = withMap "Config" $ \m -> Config - <$> (fmap T.unpack <$> m .:? "tool") - <*> (map (compile . T.unpack) <$> foldr1 (<|>) +instance FromYAML (FilePath -> Config) where + parseYAML = withMap "Config" $ \m -> do + configTool <- (fmap T.unpack <$> m .:? "tool") + configTests <- (map (compile . T.unpack) <$> foldr1 (<|>) [ fmap (:[]) (m .: "tests") -- single pattern , m .:? "tests" .!= [] -- list of patterns ] ) + configSelect <- foldr1 (<|>) + [ fmap (Just . (: [])) (m .: "select") -- single item + , m .:? "select" -- list of items + ] + configExclude <- foldr1 (<|>) + [ fmap (: []) (m .: "exclude") -- single item + , m .:? "exclude" .!= [] -- list of items + ] + configTimeout <- fmap fromNumber <$> m .:! "timeout" + return $ \configDir -> Config {..} + +newtype Number = Number { fromNumber :: Scientific } + +instance FromYAML Number where + parseYAML = \case + Scalar _ (SFloat x) -> return $ Number $ realToFrac x + Scalar _ (SInt x) -> return $ Number $ fromIntegral x + node -> typeMismatch "int or float" node findConfig :: IO (Maybe FilePath) findConfig = go "." @@ -63,4 +76,7 @@ parseConfig path = do Left (pos, err) -> do putStr $ prettyPosWithSource pos contents err exitFailure - Right conf -> return conf + Right conf -> return $ conf $ takeDirectory path + +getConfigTestFiles :: Config -> IO [ FilePath ] +getConfigTestFiles config = concat <$> mapM (flip globDir1 $ configDir config) (configTests config) @@ -72,14 +72,19 @@ gdbStart onCrash = do { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } pout <- liftIO $ newTVarIO [] + ignore <- liftIO $ newTVarIO ( 0, [] ) + pid <- liftIO $ getPid handle let process = Process - { procName = ProcNameGDB - , procHandle = handle + { procId = ProcessId (-2) + , procName = ProcNameGDB + , procHandle = Left handle , procStdin = hin , procOutput = pout + , procIgnore = ignore , procKillWith = Nothing , procNode = undefined + , procPid = pid } gdb <- GDB <$> pure process @@ -144,7 +149,7 @@ gdbLine gdb rline = either (outProc OutputError (gdbProcess gdb) . T.pack . erro addInferior :: MonadOutput m => GDB -> Process -> m () addInferior gdb process = do - liftIO (getPid $ procHandle process) >>= \case + liftIO (either getPid (\_ -> return Nothing) $ procHandle process) >>= \case Nothing -> outProc OutputError process $ "failed to get PID" Just pid -> do tgid <- liftIO (atomically $ tryReadTChan $ gdbThreadGroups gdb) >>= \case diff --git a/src/JUnit.hs b/src/JUnit.hs new file mode 100644 index 0000000..03e07ec --- /dev/null +++ b/src/JUnit.hs @@ -0,0 +1,60 @@ +module JUnit ( + writeJUnitReport, +) where + +import Control.Monad + +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as BC +import Data.Function +import Data.List.NonEmpty qualified as NE +import Data.Scientific +import Data.Text qualified as T +import Data.Text.Encoding + +import System.Directory +import System.FilePath +import System.IO + +import Run +import Script.Var + + +showTime :: Scientific -> B.ByteString +showTime = BC.pack . formatScientific Fixed Nothing + +writeJUnitReport :: FilePath -> Report -> IO () +writeJUnitReport path Report {..} = do + createDirectoryIfMissing True $ takeDirectory path + withFile path WriteMode $ \h -> do + B.hPutStr h $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" + B.hPutStr h $ "<testsuites time=\"" <> showTime reportTotalTime <> "\">\n" + forM_ (NE.groupBy ((==) `on` (testNameModule . reportTestName)) reportTests) $ \grp -> do + B.hPutStr h $ "<testsuite name=\"" <> encodeUtf8 (textModuleName $ testNameModule $ reportTestName $ NE.head grp) <> "\" time=\"" <> showTime (sum $ map reportTime $ NE.toList grp) <> "\">" + forM_ grp $ \SingleTestReport {..} -> do + B.hPutStr h $ B.concat + [ "<testcase name=\"", encodeUtf8 (testNameBase reportTestName), "\"" + , " classname=\"", encodeUtf8 (textModuleName $ testNameModule reportTestName), "\"" + , " time=\"", showTime reportTime, "\">" + , "<system-out>" + , encodeUtf8 $ escape reportOutput + , "</system-out>" + , case reportTestFailed of + Nothing -> do + "" + Just Failed -> do + "<failure message=\"Test failed\">" <> encodeUtf8 (escape reportOutputError) <> "</failure>" + Just (ProcessCrashed _) -> do + "<error message=\"Process crashed\">" <> encodeUtf8 (escape reportOutputError) <> "</error>" + , "</testcase>" + ] + + B.hPutStr h $ "</testsuite>" + B.hPutStr h $ "</testsuites>\n" + + where + escape = T.concatMap $ \case + '&' -> "&" + '<' -> "<" + '>' -> ">" + c -> T.singleton c diff --git a/src/Main.hs b/src/Main.hs index 61afbd8..3bc9e22 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,10 +1,14 @@ module Main (main) where import Control.Monad +import Control.Monad.Reader +import Data.Char import Data.Maybe -import qualified Data.Text as T +import Data.Text (Text) +import Data.Text qualified as T +import Text.Printf import Text.Read (readMaybe) import System.Console.GetOpt @@ -12,40 +16,54 @@ import System.Directory import System.Environment import System.Exit import System.FilePath -import System.FilePath.Glob import System.IO import System.Posix.Terminal import System.Posix.Types import Config +import JUnit import Output -import Parser +import Parser.Core import Process -import Run -import Test -import Util +import Run.Builtins +import TestMode +import TextFormat import Version data CmdlineOptions = CmdlineOptions { optTest :: TestOptions - , optRepeat :: Int + , optExclude :: [ Text ] , optVerbose :: Bool + , optReport :: Bool + , optJUnitReport :: Maybe FilePath , optColor :: Maybe Bool , optShowHelp :: Bool , optShowVersion :: Bool + , optTestMode :: Bool + , optCmdlineTcpdump :: TcpdumpOption } defaultCmdlineOptions :: CmdlineOptions defaultCmdlineOptions = CmdlineOptions { optTest = defaultTestOptions - , optRepeat = 1 + , optExclude = [] , optVerbose = False + , optReport = False + , optJUnitReport = Nothing , optColor = Nothing , optShowHelp = False , optShowVersion = False + , optTestMode = False + , optCmdlineTcpdump = TcpdumpAuto } -options :: [OptDescr (CmdlineOptions -> CmdlineOptions)] +data TcpdumpOption + = TcpdumpAuto + | TcpdumpManual FilePath + | TcpdumpOff + + +options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] options = [ Option ['T'] ["tool"] (ReqArg (\str -> to $ \opts -> case break (==':') str of @@ -77,11 +95,29 @@ options = (NoArg $ to $ \opts -> opts { optKeep = True }) "keep test directory even if all tests succeed" , Option ['r'] ["repeat"] - (ReqArg (\str opts -> opts { optRepeat = read str }) "<count>") + (ReqArg (\str -> to $ \opts -> opts { optRepeat = read str }) "<count>") "number of times to repeat the test(s)" + , Option [ 'e' ] [ "exclude" ] + (ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test|tag>") + "exclude given test or test tag from execution" + , Option [] [ "keep-going" ] + (NoArg $ to $ \opts -> opts { optKeepGoing = True }) + "keep going after a failed test" + , Option [] [ "report" ] + (NoArg $ \opts -> opts { optReport = True, optTest = (optTest opts) { optKeepGoing = True } }) + "print summary of passing and failing tests (implies --keep-going)" + , Option [] [ "junit-report" ] + (ReqArg (\str opts -> opts { optJUnitReport = Just str, optTest = (optTest opts) { optKeepGoing = True } }) "<path>") + "write test report in JUnit XML format to <path> (implies --keep-going)" , Option [] ["wait"] (NoArg $ to $ \opts -> opts { optWait = True }) "wait at the end of each test" + , Option [] [ "no-tcpdump" ] + (NoArg (\opts -> opts { optCmdlineTcpdump = TcpdumpOff })) + "do not run tcpdump to capture network traffic" + , Option [] [ "tcpdump" ] + (OptArg (\str opts -> opts { optCmdlineTcpdump = maybe TcpdumpAuto TcpdumpManual str }) "<path>") + "use tcpdump to capture network traffic, at given <path> or found in PATH" , Option ['h'] ["help"] (NoArg $ \opts -> opts { optShowHelp = True }) "show this help and exit" @@ -92,11 +128,17 @@ options = where to f opts = opts { optTest = f (optTest opts) } +hiddenOptions :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ] +hiddenOptions = + [ Option [] [ "test-mode" ] + (NoArg (\opts -> opts { optTestMode = True })) + "test mode" + ] + main :: IO () main = do - configPath <- findConfig - config <- mapM parseConfig configPath - let baseDir = maybe "." dropFileName configPath + config <- mapM parseConfig =<< findConfig + let baseDir = maybe "." configDir config envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool -> return $ fromMaybe (error "No test tool defined") $ mbtool `mplus` (return . (baseDir </>) =<< configTool =<< config) @@ -105,19 +147,26 @@ main = do { optTest = defaultTestOptions { optDefaultTool = envtool , optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions + , optTimeout = fromMaybe (optTimeout defaultTestOptions) $ configTimeout =<< config } } args <- getArgs - (opts, ofiles) <- case getOpt Permute options args of + (opts, oselection) <- case getOpt Permute (options ++ hiddenOptions) args of (o, files, []) -> return (foldl (flip id) initOpts o, files) (_, _, errs) -> do hPutStrLn stderr $ concat errs <> "Try `erebos-tester --help' for more information." exitFailure + let ( ofiles, otests ) + | any (any isPathSeparator) oselection = ( oselection, [] ) + | otherwise = ( [], map T.pack oselection ) + when (optShowHelp opts) $ do let header = unlines - [ "Usage: erebos-tester [<option>...] [<script>[:<test>]...]" + [ "Usage: erebos-tester [<option>...] [<test-name>...]" + , " or: erebos-tester [<option>...] <script>[:<test>]..." + , " <test-name> name of a test from project configuration" , " <script> path to test script file" , " <test> name of the test to run" , "" @@ -130,30 +179,88 @@ main = do putStrLn versionLine exitSuccess - getPermissions (head $ words $ optDefaultTool $ optTest opts) >>= \perms -> do - when (not $ executable perms) $ do - fail $ optDefaultTool (optTest opts) <> " is not executable" + when (optTestMode opts) $ do + testMode config + exitSuccess + + case words $ optDefaultTool $ optTest opts of + (path : _) -> getPermissions path >>= \perms -> do + when (not $ executable perms) $ do + fail $ "‘" <> path <> "’ is not executable" + _ -> fail $ "invalid tool argument: ‘" <> optDefaultTool (optTest opts) <> "’" files <- if not (null ofiles) then return $ flip map ofiles $ \ofile -> case span (/= ':') ofile of (path, ':':test) -> (path, Just $ T.pack test) (path, _) -> (path, Nothing) - else map (, Nothing) . concat <$> mapM (flip globDir1 baseDir) (maybe [] configTests config) + else map (, Nothing) <$> maybe (return []) (getConfigTestFiles) config when (null files) $ fail $ "No test files" useColor <- case optColor opts of Just use -> return use Nothing -> queryTerminal (Fd 1) - out <- startOutput (optVerbose opts) useColor + let outputStyle + | optVerbose opts = OutputStyleVerbose + | otherwise = OutputStyleQuiet + out <- startOutput outputStyle useColor + + lm@LoadedModules {..} <- exitOnError =<< loadModules files + + let tfSelect = if null otests then Nothing else Just otests + tfExclude = optExclude opts + tfilter = maybe mempty testFilterFromConfig config <> TestFilter {..} + tests <- exitOnError $ filterTests tfilter lm - tests <- forM files $ \(path, mbTestName) -> do - Module { .. } <- parseTestFile path - return $ case mbTestName of - Nothing -> moduleTests - Just name -> filter ((==name) . testName) moduleTests + tcpdump <- case optCmdlineTcpdump opts of + TcpdumpAuto -> findExecutable "tcpdump" + TcpdumpManual path -> return (Just path) + TcpdumpOff -> return Nothing + + let topts = (optTest opts) + { optTcpdump = tcpdump + } + + report@Report {..} <- runTests out topts lmGlobalDefs tests + + when (optReport opts) $ flip runReaderT out $ do + outLineF OutputGlobalSummary Nothing $ "Total tests: " <> plainText (T.pack (show reportTotalCount)) + let ( mins, secs ) = (floor reportTotalTime :: Integer) `quotRem` 60 + csecs = floor (reportTotalTime * 100) `rem` 100 :: Integer + outLineF OutputGlobalSummary Nothing $ "Total time: " <> plainText (T.pack $ printf "%d:%02d.%02d" mins secs csecs) + outLineF OutputGlobalSummary Nothing $ mconcat + [ "Passed tests: " + , withStyle (if (reportPassedCount > 0) then setForegroundColor Green noStyle else noStyle) $ + plainText $ T.pack $ show reportPassedCount + ] + outLineF OutputGlobalSummary Nothing $ mconcat + [ "Failed tests: " + , withStyle (if (reportFailedCount > 0) then setForegroundColor Red noStyle else noStyle) $ + plainText (T.pack (show reportFailedCount)) + ] + when (reportFailedCount > 0) $ do + outLine OutputGlobalSummary Nothing "" + outLineF OutputGlobalSummary Nothing $ withStyle (setForegroundColor BrightRed noStyle) $ "Failed tests:" + forM_ reportFailedList $ \tname -> do + outLineF OutputGlobalSummary Nothing $ + withStyle (setForegroundColor Red noStyle) $ + plainText $ textTestName tname + + forM_ (optJUnitReport opts) $ \path -> writeJUnitReport path report + + when (reportFailedCount > 0) exitFailure + +exitOnError :: Either CustomTestError a -> IO a +exitOnError (Left err) = do + hPutStrLn stderr $ capitalize $ showCustomTestError err + exitFailure + where + capitalize (c : cs) = toUpper c : cs + capitalize [] = [] +exitOnError (Right x) = do + return x - ok <- allM (runTest out $ optTest opts) $ - concat $ replicate (optRepeat opts) $ concat tests - when (not ok) exitFailure +foreign export ccall testerMain :: IO () +testerMain :: IO () +testerMain = main diff --git a/src/Network.hs b/src/Network.hs index aa06952..b48a233 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -5,6 +5,7 @@ module Network ( NodeName(..), textNodeName, unpackNodeName, nextNodeName, + rootNetworkVar, newInternet, delInternet, newSubnet, newNode, @@ -25,7 +26,8 @@ import System.FilePath import System.Process import Network.Ip -import Test +import Script.Expr +import Script.Expr.Class {- NETWORK STRUCTURE @@ -99,28 +101,33 @@ instance HasNetns Network where getNetns = netNetns instance HasNetns Node where getNetns = nodeNetns instance ExprType Network where - textExprType _ = T.pack "network" - textExprValue n = "s:" <> textNetworkName (netPrefix n) + textExprType _ = T.pack "Network" + textExprValue n = "<network:" <> textNetworkName (netPrefix n) <> ">" instance ExprType Node where - textExprType _ = T.pack "node" - textExprValue n = T.pack "n:" <> textNodeName (nodeName n) + textExprType _ = T.pack "Node" + textExprValue n = T.pack "<node:" <> textNodeName (nodeName n) <> ">" recordMembers = map (first T.pack) - [ ("ip", RecordSelector $ textIpAddress . nodeIp) - , ("network", RecordSelector $ nodeNetwork) + [ ( "ifname", RecordSelector $ const ("veth0" :: Text) ) + , ( "ip", RecordSelector $ textIpAddress . nodeIp ) + , ( "network", RecordSelector $ nodeNetwork ) ] +rootNetworkVar :: TypedVarName Network +rootNetworkVar = TypedVarName (VarName "$ROOT_NET") + nextPrefix :: IpPrefix -> [Word8] -> Word8 nextPrefix _ used = maximum (0 : used) + 1 newInternet :: MonadIO m => FilePath -> m Internet newInternet dir = do + adir <- liftIO $ makeAbsolute dir atomicallyWithIO $ do Internet - <$> pure dir - <*> newNetwork (IpPrefix [1]) dir + <$> pure adir + <*> newNetwork (IpPrefix [1]) adir delInternet :: MonadIO m => Internet -> m () delInternet _ = liftIO $ do diff --git a/src/Network.hs-boot b/src/Network.hs-boot deleted file mode 100644 index 1b5e9c4..0000000 --- a/src/Network.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Network where - -data Network -data Node -data NodeName diff --git a/src/Network/Ip.hs b/src/Network/Ip.hs index 8f0887a..69a6b43 100644 --- a/src/Network/Ip.hs +++ b/src/Network/Ip.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Network.Ip ( IpPrefix(..), textIpNetwork, @@ -17,7 +19,9 @@ module Network.Ip ( NetworkNamespace, HasNetns(..), addNetworkNamespace, + setNetworkNamespace, textNetnsName, + runInNetworkNamespace, callOn, Link(..), @@ -32,7 +36,9 @@ module Network.Ip ( addRoute, ) where +import Control.Concurrent import Control.Concurrent.STM +import Control.Exception import Control.Monad import Control.Monad.Writer @@ -42,6 +48,11 @@ import Data.Text qualified as T import Data.Typeable import Data.Word +import Foreign.C.Error +import Foreign.C.Types + +import System.Posix.IO +import System.Posix.Types import System.Process newtype IpPrefix = IpPrefix [Word8] @@ -122,12 +133,37 @@ addNetworkNamespace netnsName = do netnsRoutesActive <- liftSTM $ newTVar [] return $ NetworkNamespace {..} +setNetworkNamespace :: MonadIO m => NetworkNamespace -> m () +setNetworkNamespace netns = liftIO $ do + let path = "/var/run/netns/" <> T.unpack (textNetnsName netns) +#if MIN_VERSION_unix(2,8,0) + open = openFd path ReadOnly defaultFileFlags { cloexec = True } +#else + open = openFd path ReadOnly Nothing defaultFileFlags +#endif + res <- bracket open closeFd $ \(Fd fd) -> do + c_setns fd c_CLONE_NEWNET + when (res /= 0) $ do + throwErrno "setns failed" + +foreign import ccall unsafe "sched.h setns" c_setns :: CInt -> CInt -> IO CInt +c_CLONE_NEWNET :: CInt +c_CLONE_NEWNET = 0x40000000 + +runInNetworkNamespace :: NetworkNamespace -> IO a -> IO a +runInNetworkNamespace netns act = do + mvar <- newEmptyMVar + void $ forkOS $ do + setNetworkNamespace netns + putMVar mvar =<< act + takeMVar mvar + + textNetnsName :: NetworkNamespace -> Text textNetnsName = netnsName callOn :: HasNetns a => a -> Text -> IO () -callOn n cmd = callCommand $ T.unpack $ "ip netns exec \"" <> ns <> "\" " <> cmd - where ns = textNetnsName $ getNetns n +callOn n cmd = runInNetworkNamespace (getNetns n) $ callCommand $ T.unpack cmd data Link a = Link diff --git a/src/Output.hs b/src/Output.hs index 135e6e0..b0744d4 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -1,10 +1,15 @@ module Output ( - Output, OutputType(..), + Output, OutputStyle(..), OutputType(..), MonadOutput(..), startOutput, + resetOutputTime, + getElapsedTime, outLine, + outLineF, outPromptGetLine, outPromptGetLineCompletion, + collectOutput, + collectErrorOutput, ) where import Control.Concurrent.MVar @@ -12,38 +17,65 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader +import Data.Scientific import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.IO qualified as TL +import System.Clock import System.Console.Haskeline import System.Console.Haskeline.History +import System.IO + +import Text.Printf + +import Script.Expr + +import TextFormat +import TextFormat.Ansi + data Output = Output { outState :: MVar OutputState , outConfig :: OutputConfig + , outStartedAt :: MVar TimeSpec } data OutputConfig = OutputConfig - { outVerbose :: Bool + { outStyle :: OutputStyle , outUseColor :: Bool } data OutputState = OutputState { outPrint :: TL.Text -> IO () , outHistory :: History + , outLines :: [ Text ] + , outErrLines :: [ Text ] } -data OutputType = OutputChildStdout - | OutputChildStderr - | OutputChildStdin - | OutputChildInfo - | OutputChildFail - | OutputMatch - | OutputMatchFail - | OutputError - | OutputAlways +data OutputStyle + = OutputStyleQuiet + | OutputStyleVerbose + | OutputStyleTest + deriving (Eq) + +data OutputType + = OutputGlobalInfo + | OutputGlobalError + | OutputGlobalSummary + | OutputChildStdout + | OutputChildStderr + | OutputChildStdin + | OutputChildExec + | OutputChildInfo + | OutputChildFail + | OutputMatch + | OutputMatchFail CallStack + | OutputIgnored + | OutputError + | OutputAlways + | OutputTestRaw class MonadIO m => MonadOutput m where getOutput :: m Output @@ -51,64 +83,201 @@ class MonadIO m => MonadOutput m where instance MonadIO m => MonadOutput (ReaderT Output m) where getOutput = ask -startOutput :: Bool -> Bool -> IO Output -startOutput outVerbose outUseColor = Output - <$> newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory } - <*> pure OutputConfig { .. } +startOutput :: OutputStyle -> Bool -> IO Output +startOutput outStyle outUseColor = do + outState <- newMVar OutputState + { outPrint = TL.putStrLn + , outHistory = emptyHistory + , outLines = [] + , outErrLines = [] + } + outConfig <- pure OutputConfig {..} + outStartedAt <- newMVar =<< getTime Monotonic + hSetBuffering stdout LineBuffering + return Output {..} + +resetOutputTime :: Output -> IO () +resetOutputTime Output {..} = do + modifyMVar_ outStartedAt . const $ getTime Monotonic + +getElapsedTime :: Output -> IO Scientific +getElapsedTime Output {..} = do + stime <- readMVar outStartedAt + (/ 1000000000) . fromIntegral . toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic + outColor :: OutputType -> Text -outColor OutputChildStdout = T.pack "0" -outColor OutputChildStderr = T.pack "31" -outColor OutputChildStdin = T.pack "0" -outColor OutputChildInfo = T.pack "0" -outColor OutputChildFail = T.pack "31" -outColor OutputMatch = T.pack "32" -outColor OutputMatchFail = T.pack "31" -outColor OutputError = T.pack "31" -outColor OutputAlways = "0" +outColor = \case + OutputGlobalInfo -> "0" + OutputGlobalError -> "31" + OutputGlobalSummary -> "0" + OutputChildStdout -> "0" + OutputChildStderr -> "31" + OutputChildStdin -> "0" + OutputChildExec -> "33" + OutputChildInfo -> "0" + OutputChildFail -> "31" + OutputMatch -> "32" + OutputMatchFail {} -> "31" + OutputIgnored -> "90" + OutputError -> "31" + OutputAlways -> "0" + OutputTestRaw -> "0" outSign :: OutputType -> Text -outSign OutputChildStdout = T.empty -outSign OutputChildStderr = T.pack "!" -outSign OutputChildStdin = T.empty -outSign OutputChildInfo = T.pack "." -outSign OutputChildFail = T.pack "!!" -outSign OutputMatch = T.pack "+" -outSign OutputMatchFail = T.pack "/" -outSign OutputError = T.pack "!!" -outSign OutputAlways = T.empty +outSign = \case + OutputGlobalInfo -> "" + OutputGlobalError -> "" + OutputGlobalSummary -> "" + OutputChildStdout -> " " + OutputChildStderr -> "!" + OutputChildStdin -> T.empty + OutputChildExec -> "*" + OutputChildInfo -> "." + OutputChildFail -> "!!" + OutputMatch -> "+" + OutputMatchFail {} -> "/" + OutputIgnored -> "-" + OutputError -> "!!" + OutputAlways -> T.empty + OutputTestRaw -> T.empty outArr :: OutputType -> Text -outArr OutputChildStdin = "<" -outArr _ = ">" +outArr = \case + OutputGlobalInfo -> "" + OutputGlobalError -> "" + OutputGlobalSummary -> "" + OutputChildStdin -> "<" + _ -> ">" + +outTestLabel :: OutputType -> Text +outTestLabel = \case + OutputGlobalInfo -> "global-info" + OutputGlobalError -> "global-error" + OutputGlobalSummary -> "global-summary" + OutputChildStdout -> "child-stdout" + OutputChildStderr -> "child-stderr" + OutputChildStdin -> "child-stdin" + OutputChildExec -> "child-exec" + OutputChildInfo -> "child-info" + OutputChildFail -> "child-fail" + OutputMatch -> "match" + OutputMatchFail {} -> "match-fail" + OutputIgnored -> "ignored" + OutputError -> "error" + OutputAlways -> "other" + OutputTestRaw -> "" printWhenQuiet :: OutputType -> Bool printWhenQuiet = \case + OutputGlobalSummary -> True + OutputAlways -> True + t -> printIsError t + +printIsError :: OutputType -> Bool +printIsError = \case + OutputGlobalError -> True OutputChildStderr -> True OutputChildFail -> True - OutputMatchFail -> True + OutputMatchFail {} -> True OutputError -> True - OutputAlways -> True _ -> False +includeTestTime :: OutputType -> Bool +includeTestTime = \case + OutputGlobalInfo -> False + OutputGlobalError -> False + OutputGlobalSummary -> False + _ -> True + ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a ioWithOutput act = liftIO . act =<< getOutput outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m () -outLine otype prompt line = ioWithOutput $ \out -> - when (outVerbose (outConfig out) || printWhenQuiet otype) $ do - withMVar (outState out) $ \st -> do - outPrint st $ TL.fromChunks $ concat - [ if outUseColor (outConfig out) +outLine otype prompt line = outLineF otype prompt (plainText line) + +outLineF :: MonadOutput m => OutputType -> Maybe Text -> FormattedText -> m () +outLineF otype prompt line = ioWithOutput $ \out -> + case outStyle (outConfig out) of + OutputStyleQuiet -> normalOutput (printWhenQuiet otype) out + OutputStyleVerbose -> normalOutput True out + OutputStyleTest -> testOutput out + where + normalOutput normal out = do + secs <- getElapsedTime out + + let formatLine color line' = T.concat $ concat + [ if includeTestTime otype + then [ T.pack $ printf "[% 2d.%03d] " (floor secs :: Integer) (floor (secs * 1000) `rem` 1000 :: Integer) ] + else [] + , if color then [ T.pack "\ESC[", outColor otype, T.pack "m" ] else [] , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ] - , [ line ] - , if outUseColor (outConfig out) + , [ line' ] + , if color then [ T.pack "\ESC[0m" ] else [] ] + modifyMVar_ (outState out) $ \ost -> do + (\f -> foldM f ost (normalOutputLines otype $ renderLine out line)) $ \st line' -> do + when normal $ do + outPrint st $ TL.fromStrict $ formatLine (outUseColor (outConfig out)) line' + return st + { outLines = formatLine False line' : outLines st + , outErrLines = (if printIsError otype + then (formatLine False line' :) + else id) $ outErrLines st + } + + renderLine out + | outUseColor (outConfig out) = fromAnsiText . renderAnsiText + | otherwise = renderPlainText + + testOutput out = do + let pline = renderPlainText line + withMVar (outState out) $ \st -> do + case otype of + OutputTestRaw -> outPrint st $ TL.fromStrict pline + _ -> forM_ (testOutputLines otype (maybe "-" id prompt) pline) $ outPrint st . TL.fromStrict + + +normalOutputLines :: OutputType -> Text -> [ Text ] +normalOutputLines (OutputMatchFail (CallStack stack)) msg = concat + [ msg <> " on " <> textSourceLine stackTopLine : showVars stackTopVars + , concat $ flip map stackRest $ \( sline, vars ) -> + " called from " <> textSourceLine sline : showVars vars + ] + where + showVars = + map $ \(( name, sel ), value ) -> T.concat + [ " ", textFqVarName name, T.concat (map ("."<>) sel) + , " = ", textSomeVarValue value + ] + (( stackTopLine, stackTopVars ), stackRest ) = + case stack of + (stop : srest) -> ( stop, srest ) + [] -> (( SourceLine "unknown", [] ), [] ) +normalOutputLines _ msg = [ msg ] + + +testOutputLines :: OutputType -> Text -> Text -> [ Text ] +testOutputLines otype@(OutputMatchFail (CallStack stack)) _ msg = concat + [ [ T.concat [ outTestLabel otype, " ", msg ] ] + , concat $ flip map stack $ \( sline, vars ) -> + T.concat [ outTestLabel otype, "-line ", textSourceLine sline ] : showVars vars + , [ T.concat [ outTestLabel otype, "-done" ] ] + ] + where + showVars = + map $ \(( name, sel ), value ) -> T.concat + [ outTestLabel otype, "-var ", textFqVarName name, T.concat (map ("."<>) sel) + , " ", textSomeVarValue value + ] +testOutputLines otype prompt msg = [ T.concat [ outTestLabel otype, " ", prompt, " ", msg ] ] + + outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text) outPromptGetLine = outPromptGetLineCompletion noCompletion @@ -125,3 +294,14 @@ outPromptGetLineCompletion compl prompt = ioWithOutput $ \out -> do return (x, st' { outPrint = outPrint st, outHistory = hist' }) putMVar (outState out) st' return $ fmap T.pack x + + +collectOutput :: Output -> IO Text +collectOutput Output {..} = do + modifyMVar outState $ \st -> do + return ( st { outLines = [] }, T.unlines $ reverse $ outLines st ) + +collectErrorOutput :: Output -> IO Text +collectErrorOutput Output {..} = do + modifyMVar outState $ \st -> do + return ( st { outErrLines = [] }, T.unlines $ reverse $ outErrLines st ) diff --git a/src/Parser.hs b/src/Parser.hs index 6d6809b..cba119b 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,77 +1,270 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Parser ( - parseTestFile, + parseTestFiles, + CustomTestError(..), ) where import Control.Monad +import Control.Monad.Except import Control.Monad.State -import Control.Monad.Writer +import Data.IORef import Data.Map qualified as M import Data.Maybe +import Data.Proxy import Data.Set qualified as S import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.IO qualified as TL +import Data.Void import Text.Megaparsec hiding (State) import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L import System.Directory -import System.Exit import System.FilePath +import System.IO.Error +import Asset +import Network import Parser.Core import Parser.Expr import Parser.Statement +import Script.Expr +import Script.Module import Test import Test.Builtins -parseTestDefinition :: TestParser () +parseTestDefinition :: TestParser Toplevel parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do - block (\name steps -> return $ Test name $ concat steps) header testStep - where header = do - wsymbol "test" - lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') + localState $ do + modify $ \s -> s + { testContext = SomeExpr $ varExpr SourceLineBuiltin rootNetworkVar + } + href <- L.indentLevel + testNameBase <- header + testNameModule <- gets testCurrentModuleName + let testName = TestName {..} + + osymbol ":" <* eol <* scn + + ref <- L.indentGuard scn GT href + testTags <- preamble ref + testSteps <- fmap Scope <$> testBlock ref + return Test {..} + + where + header = do + wsymbol "test" + lexeme $ TL.toStrict <$> takeWhileP (Just "test name") (/=':') + + preamble :: Pos -> TestParser [ Expr Tag ] + preamble ref = fmap catMaybes $ many $ do + void $ L.indentGuard scn EQ ref + off <- stateOffset <$> getParserState + name <- try $ identifier <* osymbol ":" + <* ((eol >> mzero) <|> return ()) -- continue only if not on EOL + case name of + "tag" -> do + Just <$> typedExpr FunctionTerm <* eol <* scn + _ -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "unexpected test metadata ‘" <> T.unpack name <> "’" + takeWhileP Nothing (/= '\n') *> eol *> scn *> return Nothing + + +parseDefinition :: Pos -> TestParser ( VarName, SomeExpr ) +parseDefinition href = label "symbol definition" $ do + def@( name, expr ) <- localState $ do + wsymbol "def" + name <- varName + argsDecl <- functionArguments (\off _ -> return . ( off, )) + (typeAnnotated varName) mzero (\_ -> return . (, Nothing) . VarName) + atypes <- forM argsDecl $ \( off, ( vname :: VarName, mbstype :: Maybe SomeExprType ) ) -> do + stype <- maybe (ExprTypeVar <$> newTypeVar) return mbstype + modify $ \s -> s { testVars = ( vname, ( LocalVarName vname, stype )) : testVars s } + return ( off, vname, stype ) + SomeExpr expr <- choice + [ do + osymbol ":" + scn + ref <- L.indentGuard scn GT href + SomeExpr <$> testBlock ref + , do + osymbol "=" + someExpr FunctionTerm <* eol + ] + scn + atypes' <- getInferredTypes atypes + sexpr <- SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs expr + return ( name, sexpr ) + modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } + return def + where + getInferredTypes atypes = forM atypes $ \( _, vname, stype ) -> do + ( vname, ) . SomeArgumentType OptionalArgument <$> typeClosure stype + + replaceDynArgs :: forall a. Expr a -> TestParser (Expr a) + replaceDynArgs expr = do + unif <- gets testTypeUnif + return $ mapExpr (go unif) expr + where + go :: forall b. M.Map TypeVar SomeExprType -> Expr b -> Expr b + go unif = \case + ArgsApp args body -> ArgsApp (fmap replaceArgs args) body + where + replaceArgs (SomeExpr (DynVariable (ExprTypeVar tvar) sline vname)) + | Just (ExprTypePrim (Proxy :: Proxy v)) <- M.lookup tvar unif + = SomeExpr (Variable sline vname :: Expr v) + replaceArgs (SomeExpr e) = SomeExpr (go unif e) + e -> e + + typeAnnotated p = do + x <- p + choice + [ do + void $ osymbol ":" + stype <- typeExpr + return ( x, Just stype ) + + , do + return ( x, Nothing ) + ] + +parseAsset :: Pos -> TestParser ( VarName, SomeExpr ) +parseAsset href = label "asset definition" $ do + wsymbol "asset" + name <- varName + osymbol ":" + void eol + ref <- L.indentGuard scn GT href + + wsymbol "path" + osymbol ":" + off <- stateOffset <$> getParserState + path <- TL.unpack <$> takeWhile1P Nothing (/= '\n') + dir <- takeDirectory <$> gets testSourcePath + absPath <- liftIO (makeAbsolute $ dir </> path) + let assetPath = AssetPath absPath + liftIO (doesPathExist absPath) >>= \case + True -> return () + False -> registerParseError $ FancyError off $ S.singleton $ ErrorCustom $ FileNotFound absPath + + void $ L.indentGuard scn LT ref + let expr = SomeExpr $ Pure Asset {..} + modify $ \s -> s { testVars = ( name, ( GlobalVarName (testCurrentModuleName s) name, someExprType expr )) : testVars s } + return ( name, expr ) + +parseTag :: Pos -> TestParser ( VarName, SomeExpr ) +parseTag _ = label "tag definition" $ do + wsymbol "tag" + name <- constrName + void eol + cmn <- gets testCurrentModuleName + let expr = SomeExpr $ Pure $ Tag cmn name + modify $ \s -> s { testVars = ( name, ( GlobalVarName cmn name, someExprType expr )) : testVars s } + scn + return ( name, expr ) + +parseExport :: TestParser [ Toplevel ] +parseExport = label "export declaration" $ toplevel id $ do + ref <- L.indentLevel + wsymbol "export" + choice + [ do + def@( name, _ ) <- parseDefinition ref <|> parseAsset ref <|> parseTag ref + return [ ToplevelDefinition def, ToplevelExport name ] + , do + names <- listOf varName + eol >> scn + return $ map ToplevelExport names + ] + +parseImport :: TestParser [ Toplevel ] +parseImport = label "import declaration" $ toplevel (\() -> []) $ do + wsymbol "import" + modName <- parseModuleName + importedModule <- getOrParseModule modName + modify $ \s -> s { testVars = map (fmap (fmap someExprType)) (moduleExportedDefinitions importedModule) ++ testVars s } + eol >> scn parseTestModule :: FilePath -> TestParser Module parseTestModule absPath = do + scn moduleName <- choice [ label "module declaration" $ do wsymbol "module" off <- stateOffset <$> getParserState - x <- identifier - name <- (x:) <$> many (symbol "." >> identifier) - when (or (zipWith (/=) (reverse name) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do + name@(ModuleName tname) <- parseModuleName + when (or (zipWith (/=) (reverse tname) (reverse $ map T.pack $ splitDirectories $ dropExtension $ absPath))) $ do registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "module name does not match file path" eol >> scn return name , do - return $ [ T.pack $ takeBaseName absPath ] + return $ ModuleName [ T.pack $ takeBaseName absPath ] ] - (_, toplevels) <- listen $ many $ choice - [ parseTestDefinition + modify $ \s -> s { testCurrentModuleName = moduleName } + toplevels <- fmap concat $ many $ choice + [ (: []) <$> parseTestDefinition + , (: []) <$> toplevel ToplevelDefinition (parseDefinition pos1) + , (: []) <$> toplevel ToplevelDefinition (parseAsset pos1) + , (: []) <$> toplevel ToplevelDefinition (parseTag pos1) + , parseExport + , parseImport ] - let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; {- _ -> Nothing -}) toplevels + let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; _ -> Nothing) toplevels + moduleDefinitions = catMaybes $ map (\case ToplevelDefinition x -> Just x; _ -> Nothing) toplevels + moduleExports = catMaybes $ map (\case ToplevelExport x -> Just x; _ -> Nothing) toplevels eof - return Module { .. } + return Module {..} -parseTestFile :: FilePath -> IO Module -parseTestFile path = do - content <- TL.readFile path - absPath <- makeAbsolute path - let initState = TestParserState - { testVars = concat - [ map (fmap someVarValueType) builtins - ] - , testContext = SomeExpr RootNetwork - , testNextTypeVar = 0 - , testTypeUnif = M.empty - } - (res, _) = runWriter $ flip (flip runParserT path) content $ flip evalStateT initState $ parseTestModule absPath +parseTestFiles :: [ SomePrimType ] -> [ FilePath ] -> IO (Either CustomTestError ( [ Module ], [ Module ] )) +parseTestFiles builtinTypes paths = do + parsedModules <- newIORef [] + runExceptT $ do + requestedModules <- reverse <$> foldM (go parsedModules) [] paths + allModules <- map snd <$> liftIO (readIORef parsedModules) + return ( requestedModules, allModules ) + where + builtinTypes' = map (\(SomePrimType p) -> ( VarName (textExprType p), ExprTypePrim p )) builtinTypes + go parsedModules res path = do + liftIO (parseTestFile builtinTypes' parsedModules Nothing path) >>= \case + Left err -> do + throwError err + Right cur -> do + return $ cur : res - case res of - Left err -> putStr (errorBundlePretty err) >> exitFailure - Right testModule -> return testModule +parseTestFile :: [ ( VarName, SomeExprType ) ] -> IORef [ ( FilePath, Module ) ] -> Maybe ModuleName -> FilePath -> IO (Either CustomTestError Module) +parseTestFile builtinTypes parsedModules mbModuleName path = do + absPath <- makeAbsolute path + (lookup absPath <$> readIORef parsedModules) >>= \case + Just found -> return $ Right found + Nothing -> do + let initState = TestParserState + { testSourcePath = path + , testVars = concat + [ map (\(( mname, name ), value ) -> ( name, ( GlobalVarName mname name, someExprType value ))) $ M.toList builtins + ] + , testTypeVars = builtinTypes + , testContext = SomeExpr (Undefined "void" :: Expr Void) + , testNextTypeVar = 0 + , testTypeUnif = M.empty + , testCurrentModuleName = fromMaybe (error "current module name should be set at the beginning of parseTestModule") mbModuleName + , testParseModule = \(ModuleName current) mname@(ModuleName imported) -> do + let projectRoot = iterate takeDirectory absPath !! length current + parseTestFile builtinTypes parsedModules (Just mname) $ projectRoot </> foldr (</>) "" (map T.unpack imported) <.> takeExtension absPath + } + mbContent <- (Just <$> TL.readFile path) `catchIOError` \e -> + if isDoesNotExistError e then return Nothing else ioError e + case mbContent of + Just content -> do + runTestParser content initState (parseTestModule absPath) >>= \case + Left bundle -> do + return $ Left $ ImportModuleError bundle + Right testModule -> do + modifyIORef parsedModules (( absPath, testModule ) : ) + return $ Right testModule + Nothing -> return $ Left $ maybe (FileNotFound path) ModuleNotFound mbModuleName diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index cb66529..78fc666 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -1,39 +1,106 @@ module Parser.Core where +import Control.Applicative +import Control.Arrow import Control.Monad import Control.Monad.State import Control.Monad.Writer +import Data.List import Data.Map (Map) import Data.Map qualified as M import Data.Maybe import Data.Set qualified as S +import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Typeable -import Data.Void import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Network () +import Script.Expr +import Script.Expr.Class +import Script.Module import Test - -type TestParser = StateT TestParserState (ParsecT Void TestStream (Writer [ Toplevel ])) +import Util + +newtype TestParser a = TestParser (StateT TestParserState (ParsecT CustomTestError TestStream IO) a) + deriving + ( Functor, Applicative, Alternative, Monad + , MonadState TestParserState + , MonadPlus + , MonadFail + , MonadIO + , MonadParsec CustomTestError TestStream + ) type TestStream = TL.Text -type TestParseError = ParseError TestStream Void +type TestParseError = ParseError TestStream CustomTestError + +data CustomTestError + = ModuleNotFound ModuleName + | FileNotFound FilePath + | TestNotFound Text (Maybe FilePath) + | TestOrTagNotFound Text (Maybe FilePath) + | ImportModuleError (ParseErrorBundle TestStream CustomTestError) + deriving (Eq) + +instance Ord CustomTestError where + compare (ModuleNotFound a) (ModuleNotFound b) = compare a b + compare (ModuleNotFound _) _ = LT + compare _ (ModuleNotFound _) = GT + + compare (FileNotFound a) (FileNotFound b) = compare a b + compare (FileNotFound _) _ = LT + compare _ (FileNotFound _) = GT + + compare (TestNotFound a a') (TestNotFound b b') = compare ( a, a' ) ( b, b' ) + compare (TestNotFound _ _ ) _ = LT + compare _ (TestNotFound _ _ ) = GT + + compare (TestOrTagNotFound a a') (TestOrTagNotFound b b') = compare ( a, a' ) ( b, b' ) + compare (TestOrTagNotFound _ _ ) _ = LT + compare _ (TestOrTagNotFound _ _ ) = GT + + -- Ord instance is required to store errors in Set, but there shouldn't be + -- two ImportModuleErrors at the same possition, so "dummy" comparison + -- should be ok. + compare (ImportModuleError _) (ImportModuleError _) = EQ + +instance ShowErrorComponent CustomTestError where + showErrorComponent (ImportModuleError bundle) = "error parsing imported module:\n" <> errorBundlePretty bundle + showErrorComponent err = showCustomTestError err + +showCustomTestError :: CustomTestError -> String +showCustomTestError = \case + ModuleNotFound name -> "module ‘" <> T.unpack (textModuleName name) <> "’ not found" + FileNotFound path -> "file ‘" <> path <> "’ not found" + TestNotFound tname mbpath -> "test ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath + TestOrTagNotFound tname mbpath -> "test or tag ‘" <> T.unpack tname <> "’ not found" <> maybe "" (\path -> " in ‘" <> path <> "’") mbpath + ImportModuleError bundle -> errorBundlePretty bundle + +runTestParser :: TestStream -> TestParserState -> TestParser a -> IO (Either (ParseErrorBundle TestStream CustomTestError) a) +runTestParser content initState (TestParser parser) = flip (flip runParserT (testSourcePath initState)) content . flip evalStateT initState $ parser data Toplevel = ToplevelTest Test + | ToplevelDefinition ( VarName, SomeExpr ) + | ToplevelExport VarName + | ToplevelImport ( ModuleName, VarName ) data TestParserState = TestParserState - { testVars :: [ ( VarName, SomeExprType ) ] + { testSourcePath :: FilePath + , testVars :: [ ( VarName, ( FqVarName, SomeExprType )) ] + , testTypeVars :: [ ( VarName, SomeExprType ) ] , testContext :: SomeExpr , testNextTypeVar :: Int , testTypeUnif :: Map TypeVar SomeExprType + , testCurrentModuleName :: ModuleName + , testParseModule :: ModuleName -> ModuleName -> IO (Either CustomTestError Module) } newTypeVar :: TestParser TypeVar @@ -42,25 +109,77 @@ newTypeVar = do modify $ \s -> s { testNextTypeVar = idx + 1 } return $ TypeVar $ T.pack $ 'a' : show idx -lookupVarType :: Int -> VarName -> TestParser SomeExprType +lookupVarType :: Int -> VarName -> TestParser ( FqVarName, SomeExprType ) lookupVarType off name = do gets (lookup name . testVars) >>= \case Nothing -> do registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "variable not in scope: `" <> textVarName name <> "'" vtype <- ExprTypeVar <$> newTypeVar - modify $ \s -> s { testVars = ( name, vtype ) : testVars s } - return vtype - Just t@(ExprTypeVar tvar) -> do - gets (fromMaybe t . M.lookup tvar . testTypeUnif) + let fqName = LocalVarName name + modify $ \s -> s { testVars = ( name, ( fqName, vtype )) : testVars s } + return ( fqName, vtype ) + Just ( fqName, t@(ExprTypeVar tvar) ) -> do + ( fqName, ) <$> gets (fromMaybe t . M.lookup tvar . testTypeUnif) Just x -> return x lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr lookupVarExpr off sline name = do - lookupVarType off name >>= \case - ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline name :: Expr a) - ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline name - ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline name :: Expr (FunctionType a)) + ( fqn, etype ) <- lookupVarType off name + case etype of + ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a) + ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType) + ExprTypeFunction args (ExprTypePrim (_ :: Proxy a)) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a)) + stype -> return $ SomeExpr $ DynVariable stype sline fqn + +lookupScalarVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr +lookupScalarVarExpr off sline name = do + ( fqn, etype ) <- lookupVarType off name + case etype of + ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a) + ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType) + ExprTypeFunction args (ExprTypePrim (pa :: Proxy a)) -> do + SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a)) + stype -> return $ SomeExpr $ DynVariable stype sline fqn + +lookupType :: Int -> VarName -> TestParser SomeExprType +lookupType off name = do + gets (lookup name . testTypeVars) >>= \case + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ + "type not in scope: ‘" <> textVarName name <> "’" + return $ ExprTypeVar (TypeVar $ textVarName name) + Just x -> return x + + +resolveKnownTypeVars :: SomeExprType -> TestParser ( SomeExprType, [ TypeVar ] ) +resolveKnownTypeVars = fmap (fmap (uniq . sort)) . runWriterT . go + where + go stype = case stype of + ExprTypePrim {} -> return stype + ExprTypeConstr1 {} -> return stype + ExprTypeVar tvar -> do + gets (M.lookup tvar . testTypeUnif) >>= \case + Just stype' -> go stype' + Nothing -> tell [ tvar ] >> return stype + ExprTypeFunction args body -> ExprTypeFunction <$> go args <*> go body + ExprTypeArguments args -> ExprTypeArguments <$> mapM (\(SomeArgumentType a t) -> SomeArgumentType a <$> go t) args + ExprTypeApp ctor params -> do + ctor' <- go ctor + params' <- mapM go params + return $ case ( ctor', params' ) of + ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] ) + -> ExprTypePrim (Proxy :: Proxy (c' p')) + _ -> ExprTypeApp ctor' params' + ExprTypeForall tvar inner -> ExprTypeForall tvar <$> go inner + +typeClosure :: SomeExprType -> TestParser SomeExprType +typeClosure stype = do + ( stype', freeVars ) <- resolveKnownTypeVars stype + return $ go freeVars stype' + where + go [] t = t + go (v : vs) t = ExprTypeForall v $ go vs t unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do @@ -117,9 +236,53 @@ unify _ res@(ExprTypePrim (Proxy :: Proxy a)) (ExprTypePrim (Proxy :: Proxy b)) | Just (Refl :: a :~: b) <- eqT = return res +unify _ res@(ExprTypeConstr1 (Proxy :: Proxy a)) (ExprTypeConstr1 (Proxy :: Proxy b)) + | Just (Refl :: a :~: b) <- eqT + = return res + +unify off (ExprTypeFunction args res) (ExprTypeFunction args' res') + = ExprTypeFunction + <$> unify off args args' + <*> unify off res res' + +unify off (ExprTypeApp ac aparams) (ExprTypeApp bc bparams) + | length aparams == length bparams + = do + c <- unify off ac bc + params <- zipWithM (unify off) aparams bparams + return $ case ( c, params ) of + ( ExprTypeConstr1 (Proxy :: Proxy c'), [ ExprTypePrim (Proxy :: Proxy p') ] ) + -> ExprTypePrim (Proxy :: Proxy (c' p')) + _ -> ExprTypeApp c params + +unify off a@(ExprTypeApp {}) (ExprTypePrim bproxy) + | TypeDeconstructor1 c p <- matchTypeConstructor bproxy + = unify off a (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ]) + +unify off (ExprTypePrim aproxy) b@(ExprTypeApp {}) + | TypeDeconstructor1 c p <- matchTypeConstructor aproxy + = unify off (ExprTypeApp (ExprTypeConstr1 c) [ ExprTypePrim p ]) b + unify off a b = do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "couldn't match expected type `" <> textSomeExprType a <> "' with actual type `" <> textSomeExprType b <> "'" + "couldn't match expected type ‘" <> textSomeExprType a <> "’ with actual type ‘" <> textSomeExprType b <> "’" + + +unifyArguments + :: FunctionArguments SomeArgumentType + -> FunctionArguments ( Int, SomeExpr ) + -> TestParser ( FunctionArguments SomeExpr, ( FunctionArguments SomeArgumentType, FunctionArguments ( Int, SomeExpr ) ) ) +unifyArguments (FunctionArguments am) (FunctionArguments bm) = (toArgs *** (toArgs *** toArgs)) <$> go (M.toAscList am) (M.toAscList bm) + where + toArgs = FunctionArguments . M.fromAscList + go [] bs = return ( [], ( [], bs ) ) + go as [] = return ( [], ( as, [] ) ) + go (a@( ak, SomeArgumentType _ at ) : as) (b@( bk, ( off, expr ) ) : bs) + | ak < bk = second (first (a :)) <$> go as (b : bs) + | bk < ak = second (second (b :)) <$> go (a : as) bs + | otherwise = do + expr' <- unifySomeExpr off at expr + first (( ak, expr' ) :) <$> go as bs unifyExpr :: forall a b proxy. (ExprType a, ExprType b) => Int -> proxy a -> Expr b -> TestParser (Expr a) @@ -127,27 +290,33 @@ unifyExpr off pa expr = if | Just (Refl :: a :~: b) <- eqT -> return expr - | DynVariable tvar sline name <- expr + | DynVariable stype sline name <- expr + , ExprTypeForall qvar itype <- stype + -> do + tvar <- newTypeVar + res <- unify off (ExprTypePrim (Proxy :: Proxy a)) $ renameVarInType qvar tvar itype + rtype <- M.lookup tvar <$> gets testTypeUnif + return $ ExposePrimType $ TypeApp res (fromMaybe (ExprTypeVar tvar) rtype) (Variable sline name) + + | DynVariable stype sline name <- expr -> do - _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar) + _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) stype return $ Variable sline name - | Just (Refl :: FunctionType a :~: b) <- eqT + | HidePrimType (_ :: Expr b') <- expr + -> unifyExpr off pa (ExposePrimType expr :: Expr b') + + | HideFunType args (_ :: Expr (FunctionType b')) <- expr + -> unifyExpr off pa (ExposeFunType args expr :: Expr (FunctionType b')) + + | TypeLambda tvar t f <- expr -> do - let FunctionArguments remaining = exprArgs expr - showType ( Nothing, SomeArgumentType atype ) = "`<" <> textExprType atype <> ">'" - showType ( Just (ArgumentKeyword kw), SomeArgumentType atype ) = "`" <> kw <> " <" <> textExprType atype <> ">'" - err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack - - defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case - arg@(_, SomeArgumentType RequiredArgument) -> err $ "missing " <> showType arg <> " argument" - (_, SomeArgumentType OptionalArgument) -> return Nothing - (kw, SomeArgumentType (ExprDefault def)) -> return $ Just ( kw, SomeExpr def ) - (kw, SomeArgumentType atype@ContextDefault) -> do - SomeExpr context <- gets testContext - context' <- unifyExpr off atype context - return $ Just ( kw, SomeExpr context' ) - return (FunctionEval $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) + _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) t + Just (ExprTypePrim pt) <- M.lookup tvar <$> gets testTypeUnif + unifyExpr off pa (f $ ExprTypePrim pt) + + | Just (Refl :: FunctionType a :~: b) <- eqT + -> evalRemainingArguments off (exprArgs expr) expr | Just (Refl :: DynamicType :~: b) <- eqT , Undefined msg <- expr @@ -157,7 +326,79 @@ unifyExpr off pa expr = if | otherwise -> do parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'" + "couldn't match expected type ‘" <> textExprType pa <> "’ with actual type ‘" <> textExprType expr <> "’" + + +evalRemainingArguments :: ExprType a => Int -> FunctionArguments SomeArgumentType -> Expr (FunctionType a) -> TestParser (Expr a) +evalRemainingArguments off (FunctionArguments remaining) expr = do + let showType ( Nothing, SomeArgumentType _ stype ) = "‘<" <> textSomeExprType stype <> ">’" + showType ( Just (ArgumentKeyword kw), SomeArgumentType _ stype ) = "‘" <> kw <> " <" <> textSomeExprType stype <> ">’" + err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack + + defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case + arg@( _, SomeArgumentType RequiredArgument _ ) -> err $ "missing " <> showType arg <> " argument" + ( _, SomeArgumentType OptionalArgument _ ) -> return Nothing + ( kw, SomeArgumentType (ExprDefault def) _ ) -> return $ Just ( kw, def ) + ( kw, SomeArgumentType ContextDefault atype ) -> do + context <- unifySomeExpr off atype =<< gets testContext + return $ Just ( kw, context ) + sline <- getSourceLine + return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr) + + +unifySomeExpr :: Int -> SomeExprType -> SomeExpr -> TestParser SomeExpr +unifySomeExpr off stype sexpr@(SomeExpr (expr :: Expr a)) + | ExprTypePrim pa <- stype + = SomeExpr <$> unifyExpr off pa expr + + | ExprTypeConstr1 {} <- stype + = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "unification with incomplete type" + + | ExprTypeVar tvar <- stype + = do + _ <- unify off (ExprTypeVar tvar) (someExprType sexpr) + return sexpr + + | Just (Refl :: a :~: DynamicType) <- eqT + , ExprTypeForall qvar itype <- someExprType sexpr + = do + tvar <- newTypeVar + itype' <- unify off stype $ renameVarInType qvar tvar itype + rtype <- M.lookup tvar <$> gets testTypeUnif + return $ SomeExpr (TypeApp itype' (fromMaybe (ExprTypeVar tvar) rtype) expr) + + | ExprTypeFunction args res <- stype + = case someExprType sexpr of + ExprTypeFunction args' res' -> do + _ <- unify off args args' + _ <- unify off res res' + return sexpr + _ -> do + _ <- unify off args (ExprTypeArguments mempty) + SomeExpr expr' <- unifySomeExpr off res sexpr + return $ SomeExpr $ FunctionAbstraction expr' + + | ExprTypeApp _ _ <- stype + , ExprTypeFunction args' res' <- someExprType sexpr + = do + ( _, ( remaining, _ ) ) <- case args' of + ExprTypeArguments args'' -> do + unifyArguments args'' mempty + _ -> do + _ <- unify off (ExprTypeArguments mempty) args' + return ( mempty, ( mempty, mempty ) ) + unify off stype res' >>= \case + ExprTypePrim (Proxy :: Proxy r) | Just (Refl :: a :~: FunctionType r) <- eqT -> + SomeExpr <$> evalRemainingArguments off remaining expr + _ | Just (Refl :: a :~: FunctionType DynamicType) <- eqT -> + SomeExpr <$> evalRemainingArguments off remaining expr + _ -> + error $ "expecting function type, got: " <> show (typeRep expr) + + | otherwise + = do + _ <- unify off stype (someExprType sexpr) + return sexpr skipLineComment :: TestParser () @@ -181,33 +422,37 @@ osymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy operatorChar) wsymbol str = void $ try $ (string (TL.pack str) <* notFollowedBy wordChar) <* sc operatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) -operatorChar = satisfy $ (`elem` ['.', '+', '-', '*', '/', '=']) +operatorChar = satisfy $ (`elem` [ '!', '%', '&', '*', '+', '-', '.', '/', ':', '<', '=', '>', '?', '@', '^', '|', '~' ]) {-# INLINE operatorChar #-} localState :: TestParser a -> TestParser a localState inner = do s <- get x <- inner - put s + s' <- get + put s { testNextTypeVar = testNextTypeVar s', testTypeUnif = testTypeUnif s' } return x -toplevel :: (a -> Toplevel) -> TestParser a -> TestParser () -toplevel f = tell . (: []) . f <=< L.nonIndented scn - -block :: (a -> [b] -> TestParser c) -> TestParser a -> TestParser b -> TestParser c -block merge header item = L.indentBlock scn $ do - h <- header - choice - [ do symbol ":" - return $ L.IndentSome Nothing (merge h) item - , L.IndentNone <$> merge h [] - ] +toplevel :: (a -> b) -> TestParser a -> TestParser b +toplevel f = return . f <=< L.nonIndented scn listOf :: TestParser a -> TestParser [a] listOf item = do x <- item (x:) <$> choice [ symbol "," >> listOf item, return [] ] +blockOf :: Monoid a => Pos -> TestParser a -> TestParser a +blockOf indent step = go + where + go = do + scn + pos <- L.indentLevel + optional eof >>= \case + Just _ -> return mempty + _ | pos < indent -> return mempty + | pos == indent -> mappend <$> step <*> go + | otherwise -> L.incorrectIndent EQ indent pos + getSourceLine :: TestParser SourceLine getSourceLine = do @@ -217,3 +462,12 @@ getSourceLine = do , T.pack ": " , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate ] + + +getOrParseModule :: ModuleName -> TestParser Module +getOrParseModule name = do + current <- gets testCurrentModuleName + parseModule <- gets testParseModule + (TestParser $ lift $ lift $ parseModule current name) >>= \case + Right parsed -> return parsed + Left err -> customFailure err diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index 4ed0215..b2c6b84 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -1,17 +1,27 @@ module Parser.Expr ( identifier, + parseModuleName, varName, newVarName, - addVarName, + addVarName, addVarNameType, + constrName, + TermComplexity(..), someExpr, typedExpr, literal, variable, + constructor, + + someExpansion, expansionTypeCheck, + expressionExpansion, + stringExpansion, - checkFunctionArguments, functionArguments, + applyFunctionArguments, + + typeExpr, ) where import Control.Applicative (liftA2) @@ -33,18 +43,34 @@ import Data.Void import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L -import Text.Regex.TDFA qualified as RE -import Text.Regex.TDFA.Text qualified as RE +import Text.Megaparsec.Error.Builder qualified as Err import Parser.Core -import Test +import Script.Expr +import Script.Expr.Class + +reservedWords :: [ Text ] +reservedWords = + [ "test", "def", "let" + , "module", "export", "import" + ] identifier :: TestParser Text identifier = label "identifier" $ do - lexeme $ do + lexeme $ try $ do + off <- stateOffset <$> getParserState lead <- lowerChar rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_') - return $ TL.toStrict $ TL.fromChunks $ (T.singleton lead :) $ TL.toChunks rest + let ident = TL.toStrict $ TL.fromChunks $ (T.singleton lead :) $ TL.toChunks rest + when (ident `elem` reservedWords) $ parseError $ Err.err off $ mconcat + [ Err.utoks $ TL.fromStrict ident + ] + return ident + +parseModuleName :: TestParser ModuleName +parseModuleName = do + x <- identifier + ModuleName . (x :) <$> many (symbol "." >> identifier) varName :: TestParser VarName varName = label "variable name" $ VarName <$> identifier @@ -57,12 +83,22 @@ newVarName = do return name addVarName :: forall a. ExprType a => Int -> TypedVarName a -> TestParser () -addVarName off (TypedVarName name) = do +addVarName off tname = addVarNameType off tname (ExprTypePrim @a Proxy) + +addVarNameType :: forall a. ExprType a => Int -> TypedVarName a -> SomeExprType -> TestParser () +addVarNameType off (TypedVarName name) stype = do gets (lookup name . testVars) >>= \case Just _ -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.pack "variable '" <> textVarName name <> T.pack "' already exists" Nothing -> return () - modify $ \s -> s { testVars = ( name, ExprTypePrim @a Proxy ) : testVars s } + modify $ \s -> s { testVars = ( name, ( LocalVarName name, stype )) : testVars s } + +constrName :: TestParser VarName +constrName = label "contructor name" $ do + lexeme $ try $ do + lead <- upperChar + rest <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_') + return $ VarName $ TL.toStrict $ TL.fromChunks $ T.singleton lead : TL.toChunks rest someExpansion :: TestParser SomeExpr someExpansion = do @@ -71,20 +107,26 @@ someExpansion = do [do off <- stateOffset <$> getParserState sline <- getSourceLine name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') - lookupVarExpr off sline name - , between (char '{') (char '}') someExpr + lookupScalarVarExpr off sline name + , between (char '{') (char '}') (someExpr FunctionTerm) ] -stringExpansion :: ExprType a => Text -> (forall b. ExprType b => Expr b -> [Maybe (Expr a)]) -> TestParser (Expr a) -stringExpansion tname conv = do - off <- stateOffset <$> getParserState - SomeExpr e <- someExpansion +expansionTypeCheck :: forall a. ExprType a => Int -> Text -> SomeExpr -> TestParser (Expr a) +expansionTypeCheck off tname (SomeExpr e) = do let err = do registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [ tname, T.pack " expansion not defined for '", textExprType e, T.pack "'" ] return $ Undefined "expansion not defined for type" - maybe err return $ listToMaybe $ catMaybes $ conv e + maybe err (return . (<$> e)) $ listToMaybe $ catMaybes [ cast (id :: a -> a), exprExpansionConvTo, exprExpansionConvFrom ] + +expressionExpansion :: forall a. ExprType a => Text -> TestParser (Expr a) +expressionExpansion tname = do + off <- stateOffset <$> getParserState + expansionTypeCheck off tname =<< someExpansion + +stringExpansion :: TestParser (Expr Text) +stringExpansion = expressionExpansion "string" numberLiteral :: TestParser SomeExpr numberLiteral = label "number" $ lexeme $ do @@ -96,6 +138,13 @@ numberLiteral = label "number" $ lexeme $ do else return $ SomeExpr $ Pure x ] +boolLiteral :: TestParser SomeExpr +boolLiteral = label "bool" $ lexeme $ do + SomeExpr . Pure <$> choice + [ wsymbol "True" *> return True + , wsymbol "False" *> return False + ] + quotedString :: TestParser (Expr Text) quotedString = label "string" $ lexeme $ do void $ char '"' @@ -112,11 +161,7 @@ quotedString = label "string" $ lexeme $ do , char 't' >> return '\t' ] (Pure (T.singleton c) :) <$> inner - ,do e <- stringExpansion (T.pack "string") $ \e -> - [ cast e - , fmap (T.pack . show @Integer) <$> cast e - , fmap (T.pack . show @Scientific) <$> cast e - ] + ,do e <- stringExpansion (e:) <$> inner ] Concat <$> inner @@ -124,7 +169,7 @@ quotedString = label "string" $ lexeme $ do regex :: TestParser (Expr Regex) regex = label "regular expression" $ lexeme $ do off <- stateOffset <$> getParserState - void $ char '/' + void $ try $ char '/' <* notFollowedBy (char '=') -- TODO: better parsing rules for regexes let inner = choice [ char '/' >> return [] , takeWhile1P Nothing (`notElem` ['/', '\\', '$']) >>= \s -> (Pure (RegexPart (TL.toStrict s)) :) <$> inner @@ -134,19 +179,14 @@ regex = label "regular expression" $ lexeme $ do , anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c]) ] (s:) <$> inner - ,do e <- stringExpansion (T.pack "regex") $ \e -> - [ cast e - , fmap RegexString <$> cast e - , fmap (RegexString . T.pack . show @Integer) <$> cast e - , fmap (RegexString . T.pack . show @Scientific) <$> cast e - ] + ,do e <- expressionExpansion (T.pack "regex") (e:) <$> inner ] parts <- inner let testEval = \case Pure (RegexPart p) -> p _ -> "" - case RE.compile RE.defaultCompOpt RE.defaultExecOpt $ T.concat $ map testEval parts of + case regexCompile $ T.concat $ map testEval parts of Left err -> registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat [ "failed to parse regular expression: ", T.pack err ] Right _ -> return () @@ -155,40 +195,51 @@ regex = label "regular expression" $ lexeme $ do list :: TestParser SomeExpr list = label "list" $ do symbol "[" - SomeExpr x <- someExpr - let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ - "list range enumeration not defined for '" <> textExprType x <> "'" - let exprList = foldr (liftA2 (:)) (Pure []) - SomeExpr <$> choice + choice [do symbol "]" - return $ exprList [x] - - ,do off <- stateOffset <$> getParserState - osymbol ".." - ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x - y <- typedExpr - symbol "]" - return $ fromTo <$> x <*> y - - ,do symbol "," - y <- typedExpr - - choice + tvar <- newTypeVar + return $ SomeExpr $ + TypeLambda tvar (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) $ + \case + (ExprTypePrim (Proxy :: Proxy a)) -> HidePrimType $ Pure ([] :: [ a ]) + _ -> Undefined "incomplete type" + + ,do SomeExpr x <- someExpr FunctionTerm + let enumErr off = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ + "list range enumeration not defined for ‘" <> textExprType x <> "’" + let exprList = foldr (liftA2 (:)) (Pure []) + + SomeExpr <$> choice [do symbol "]" - return $ exprList [x, y] + return $ exprList [ x ] ,do off <- stateOffset <$> getParserState osymbol ".." - ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x - z <- typedExpr + ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x + y <- typedExpr FunctionTerm symbol "]" - return $ fromThenTo <$> x <*> y <*> z + return $ fromTo <$> x <*> y ,do symbol "," - xs <- listOf typedExpr - symbol "]" - return $ exprList (x:y:xs) + y <- typedExpr FunctionTerm + + choice + [do symbol "]" + return $ exprList [ x, y ] + + ,do off <- stateOffset <$> getParserState + osymbol ".." + ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x + z <- typedExpr FunctionTerm + symbol "]" + return $ fromThenTo <$> x <*> y <*> z + + ,do symbol "," + xs <- listOf (typedExpr FunctionTerm) + symbol "]" + return $ exprList (x : y : xs) + ] ] ] @@ -211,17 +262,31 @@ applyBinOp off op x y = do y' <- unifyExpr off (Proxy @b) y return $ op <$> x' <*> y' -someExpr :: TestParser SomeExpr -someExpr = join inner <?> "expression" +data TermComplexity + = SimpleTerm -- variable name, literal or more complex term in parentheses + | FunctionTerm -- simple term or function call + +someExpr :: TermComplexity -> TestParser SomeExpr +someExpr complexity = label "expression" $ do + case complexity of + SimpleTerm -> join termSimple + FunctionTerm -> join inner where - inner = makeExprParser term table + inner = typeAnnotated $ makeExprParser termFunction table parens = between (symbol "(") (symbol ")") - term = label "term" $ choice + termSimple = label "term" $ choice [ parens inner , return <$> literal , return <$> variable + , return <$> constructor + ] + + termFunction = label "term" $ choice + [ parens inner + , return <$> literal + , return <$> functionCall ] table = [ [ prefix "-" $ [ SomeUnOp (negate @Integer) @@ -244,15 +309,30 @@ someExpr = join inner <?> "expression" , SomeBinOp ((-) @Scientific) ] ] + , [ let tvar = TypeVar "a" + targs = FunctionArguments $ M.fromList + [ ( Just "$l", ( VarName "$l", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) ) + , ( Just "$r", ( VarName "$r", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) ) + ] + in infixrExpr "++" $ SomeExpr $ TypeLambda tvar (ExprTypeFunction (ExprTypeArguments $ fmap snd targs) (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ])) $ \case + ExprTypePrim (Proxy :: Proxy a) -> + HideFunType (fmap snd targs) $ ArgsReq targs $ + FunctionAbstraction $ ((++) @a) + <$> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$l") + <*> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$r") + t -> Undefined ("ambiguous type ‘" <> T.unpack (textSomeExprType t) <> "’ for operator ‘++’") :: Expr DynamicType + ] , [ binary' "==" (\op xs ys -> length xs == length ys && and (zipWith op xs ys)) $ [ SomeBinOp ((==) @Integer) , SomeBinOp ((==) @Scientific) , SomeBinOp ((==) @Text) + , SomeBinOp ((==) @Bool) ] , binary' "/=" (\op xs ys -> length xs /= length ys || or (zipWith op xs ys)) $ [ SomeBinOp ((/=) @Integer) , SomeBinOp ((/=) @Scientific) , SomeBinOp ((/=) @Text) + , SomeBinOp ((/=) @Bool) ] , binary ">" $ [ SomeBinOp ((>) @Integer) @@ -285,6 +365,17 @@ someExpr = join inner <?> "expression" choice $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp off op e) ops + infixrExpr :: String -> SomeExpr -> Operator TestParser (TestParser SomeExpr) + infixrExpr name fun = InfixR $ do + void $ osymbol name + return $ \p q -> do + loff <- stateOffset <$> getParserState + l <- p + roff <- stateOffset <$> getParserState + r <- q + applyFunctionArguments (FunctionArguments $ M.fromList [ ( Just "$l", ( loff, l ) ), ( Just "$r", ( roff, r ) ) ]) fun + + binary :: String -> [SomeBinOp] -> Operator TestParser (TestParser SomeExpr) binary name = binary' name (undefined :: forall a b. (a -> b -> Void) -> [a] -> [b] -> Integer) -- use 'Void' that can never match actually used type to disable recursion @@ -325,15 +416,34 @@ someExpr = join inner <?> "expression" region (const err) $ foldl1 (<|>) $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops -typedExpr :: forall a. ExprType a => TestParser (Expr a) -typedExpr = do + typeAnnotated :: TestParser (TestParser SomeExpr) -> TestParser (TestParser SomeExpr) + typeAnnotated p = do + off <- stateOffset <$> getParserState + p' <- p + choice + [ do + -- colon starts a type annotation, except when at the end of line + void $ try $ (string ":" <* notFollowedBy operatorChar <* sc <* notFollowedBy eol) + stype <- typeExpr + return $ do + se <- p' + unifySomeExpr off stype se + + , do + return p' + ] + + +typedExpr :: forall a. ExprType a => TermComplexity -> TestParser (Expr a) +typedExpr complexity = do off <- stateOffset <$> getParserState - SomeExpr e <- someExpr + SomeExpr e <- someExpr complexity unifyExpr off Proxy e literal :: TestParser SomeExpr literal = label "literal" $ choice [ numberLiteral + , boolLiteral , SomeExpr <$> quotedString , SomeExpr <$> regex , list @@ -344,45 +454,37 @@ variable = label "variable" $ do off <- stateOffset <$> getParserState sline <- getSourceLine name <- varName - lookupVarExpr off sline name >>= \case - SomeExpr e'@(FunVariable argTypes _ _) -> do - let check = checkFunctionArguments argTypes - args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff sline . VarName) - return $ SomeExpr $ ArgsApp args e' - e -> do - recordSelector e <|> return e + e <- lookupVarExpr off sline name + recordSelector e <|> return e - where - recordSelector :: SomeExpr -> TestParser SomeExpr - recordSelector (SomeExpr e) = do - void $ osymbol "." - off <- stateOffset <$> getParserState - m <- identifier - 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 "'" ] - e' <- maybe err return $ applyRecordSelector m e <$> lookup m recordMembers - recordSelector e' <|> return e' +constructor :: TestParser SomeExpr +constructor = label "constructor" $ do + off <- stateOffset <$> getParserState + sline <- getSourceLine + name <- constrName + lookupVarExpr off sline name + +functionCall :: TestParser SomeExpr +functionCall = do + sline <- getSourceLine + fun <- variable <|> constructor + args <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName) + applyFunctionArguments args fun +recordSelector :: SomeExpr -> TestParser SomeExpr +recordSelector (SomeExpr expr) = do + void $ osymbol "." + off <- stateOffset <$> getParserState + m <- identifier + let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat + [ T.pack "value of type ", textExprType expr, T.pack " does not have member '", m, T.pack "'" ] + e' <- maybe err return $ applyRecordSelector m expr <$> lookup m recordMembers + recordSelector e' <|> return e' + where applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e -checkFunctionArguments :: FunctionArguments SomeArgumentType - -> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr -checkFunctionArguments (FunctionArguments argTypes) poff kw expr = do - case M.lookup kw argTypes of - Just (SomeArgumentType (_ :: ArgumentType expected)) -> do - withRecovery registerParseError $ do - void $ unify poff (ExprTypePrim (Proxy @expected)) (someExprType expr) - return expr - Nothing -> do - registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $ - case kw of - Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword `" <> tkw <> "'" - Nothing -> "unexpected parameter" - return expr - - functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b) functionArguments check param lit promote = do args <- parseArgs True @@ -399,22 +501,10 @@ functionArguments check param lit promote = do [ T.pack "multiple unnamed parameters" ] parseArgs False - ,do off <- stateOffset <$> getParserState - x <- identifier - choice - [do off' <- stateOffset <$> getParserState - y <- pparam <|> (promote off' =<< identifier) - checkAndInsert off' (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed - - ,if allowUnnamed - then do - y <- promote off x - checkAndInsert off Nothing y $ return M.empty - else do - registerParseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat - [ T.pack "multiple unnamed parameters" ] - return M.empty - ] + ,do x <- identifier + off <- stateOffset <$> getParserState + y <- pparam <|> (promote off =<< identifier) + checkAndInsert off (Just (ArgumentKeyword x)) y $ parseArgs allowUnnamed ,do return M.empty ] @@ -422,3 +512,65 @@ functionArguments check param lit promote = do pparam = between (symbol "(") (symbol ")") param <|> lit checkAndInsert off kw x cont = M.insert kw <$> check off kw x <*> cont + + +applyFunctionArguments :: FunctionArguments ( Int, SomeExpr ) -> SomeExpr -> TestParser SomeExpr +applyFunctionArguments (FunctionArguments margs) sexpr + | M.null margs = return sexpr +applyFunctionArguments args sexpr@(SomeExpr (expr :: Expr a)) + | Just (Refl :: a :~: DynamicType) <- eqT + , ExprTypeForall qvar itype <- someExprType sexpr + = do + tvar <- newTypeVar + case renameVarInType qvar tvar itype of + ExprTypeFunction (ExprTypeArguments args') res' -> do + ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args + unexpectedArguments unexpectedArgs + t <- fromMaybe (ExprTypeVar tvar) . M.lookup tvar <$> gets testTypeUnif + resolveKnownTypeVars res' >>= \case + ( res''@(ExprTypePrim (Proxy :: Proxy r)), _ ) -> + return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp res'' t expr) :: Expr (FunctionType r))) + ( r, _ ) -> + return $ SomeExpr (ArgsApp used (ExposeFunType args' (TypeApp r t expr) :: Expr (FunctionType DynamicType))) + _ -> do + unexpectedArguments args + return sexpr + + | otherwise + = case someExprType sexpr of + ExprTypeFunction (ExprTypeArguments args') res' -> do + ( used, ( _, unexpectedArgs ) ) <- unifyArguments args' args + unexpectedArguments unexpectedArgs + resolveKnownTypeVars res' >>= \case + ( ExprTypePrim (Proxy :: Proxy r), _ ) + | Just (Refl :: a :~: FunctionType r) <- eqT + -> return $ SomeExpr (ArgsApp used expr) + _ + | Just (Refl :: a :~: FunctionType DynamicType) <- eqT + -> return $ SomeExpr (ArgsApp used expr) + _ -> + error $ "expecting function type, got: " <> show (typeRep expr) + _ -> do + unexpectedArguments args + return sexpr + where + unexpectedArguments (FunctionArguments amap) = do + forM_ (M.toAscList amap) $ \( kw, ( poff, _ ) ) -> + registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $ + case kw of + Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’" + Nothing -> "unexpected parameter" + + +typeExpr :: TestParser SomeExprType +typeExpr = do + off <- stateOffset <$> getParserState + choice + [ do + name <- constrName <?> "type constructor name" + lookupType off name + , do + between (symbol "[") (symbol "]") $ do + inner <- typeExpr + return $ ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ inner ] + ] diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs new file mode 100644 index 0000000..2d6026a --- /dev/null +++ b/src/Parser/Shell.hs @@ -0,0 +1,170 @@ +module Parser.Shell ( + ShellScript, + shellScript, +) where + +import Control.Applicative (liftA2) +import Control.Monad + +import Data.Char +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL + +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L + +import Parser.Core +import Parser.Expr +import Script.Expr +import Script.Shell + +parseTextArgument :: TestParser (Expr Text) +parseTextArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2 (:)) (Pure [])) $ some $ choice + [ doubleQuotedString + , singleQuotedString + , standaloneEscapedChar + , stringExpansion + , unquotedString + ] + where + specialChars = [ '"', '\'', '\\', '$', '#', '|', '>', '<', ';', '[', ']'{-, '{', '}' -}, '(', ')'{-, '*', '?', '~', '&', '!' -} ] + + stringSpecialChars = [ '"', '\\', '$' ] + + unquotedString :: TestParser (Expr Text) + unquotedString = do + Pure . TL.toStrict <$> takeWhile1P Nothing (\c -> not (isSpace c) && c `notElem` specialChars) + + doubleQuotedString :: TestParser (Expr Text) + doubleQuotedString = do + void $ char '"' + let inner = choice + [ char '"' >> return [] + , (:) <$> (Pure . TL.toStrict <$> takeWhile1P Nothing (`notElem` stringSpecialChars)) <*> inner + , (:) <$> stringEscapedChar <*> inner + , (:) <$> stringExpansion <*> inner + ] + App AnnNone (Pure T.concat) . foldr (liftA2 (:)) (Pure []) <$> inner + + singleQuotedString :: TestParser (Expr Text) + singleQuotedString = do + Pure . TL.toStrict <$> (char '\'' *> takeWhileP Nothing (/= '\'') <* char '\'') + + stringEscapedChar :: TestParser (Expr Text) + stringEscapedChar = do + void $ char '\\' + fmap Pure $ choice $ + map (\c -> char c >> return (T.singleton c)) stringSpecialChars ++ + [ char 'n' >> return "\n" + , char 'r' >> return "\r" + , char 't' >> return "\t" + , return "\\" + ] + + standaloneEscapedChar :: TestParser (Expr Text) + standaloneEscapedChar = do + void $ char '\\' + fmap T.singleton . Pure <$> printChar + +parseRedirection :: TestParser (Expr ShellArgument) +parseRedirection = choice + [ do + rsymbol "<" + fmap ShellRedirectStdin <$> parseTextArgument + , do + rsymbol ">" + fmap (ShellRedirectStdout False) <$> parseTextArgument + , do + rsymbol ">>" + fmap (ShellRedirectStdout True) <$> parseTextArgument + , do + rsymbol "2>" + fmap (ShellRedirectStderr False) <$> parseTextArgument + , do + rsymbol "2>>" + fmap (ShellRedirectStderr True) <$> parseTextArgument + ] + where + rsymbol str = void $ try $ (string str <* notFollowedBy (satisfy $ (`elem` [ '<', '>', '|' ]))) <* sc + +parseArgument :: TestParser (Expr ShellArgument) +parseArgument = choice + [ parseRedirection + , expressionExpansion "shell argument" <* sc + , fmap ShellArgument <$> parseTextArgument + ] + +parseArguments :: TestParser (Expr ShellArguments) +parseArguments = do + arglists <- many $ choice + [ do + off <- stateOffset <$> getParserState + se <- someExpansion + choice + [ do + notFollowedBy space1 + arg <- expansionTypeCheck off "shell argument" se + txt <- parseTextArgument + return $ joinArgument <$> arg <*> txt + , do + expansionTypeCheck off "shell arguments" se <* sc + ] + , fmap (ShellArguments . (: [])) <$> parseArgument + ] + return $ fmap mconcat $ foldr (liftA2 (:)) (Pure []) $ arglists + where + joinArgument (ShellArgument x) y = ShellArguments [ ShellArgument (x <> y) ] + joinArgument ax y = ShellArguments [ ax, ShellArgument y ] + +parseCommand :: TestParser (Expr ShellCommand) +parseCommand = label "shell statement" $ do + line <- getSourceLine + choice + [ do + args <- expressionExpansion "shell command" <* sc + args' <- parseArguments + return $ commandFromArgLists line <$> args <*> args' + , do + command <- parseTextArgument + args <- parseArguments + return $ ShellCommand + <$> command + <*> args + <*> pure line + ] + + where + commandFromArgLists line (ShellArguments (ShellArgument cmd : args)) (ShellArguments args') = + ShellCommand cmd (ShellArguments (args ++ args')) line + commandFromArgLists line (ShellArguments args) (ShellArguments args') = + ShellCommand "" (ShellArguments (args ++ args')) line + +parsePipeline :: Maybe (Expr ShellPipeline) -> TestParser (Expr ShellPipeline) +parsePipeline mbupper = do + cmd <- parseCommand + let pipeline = + case mbupper of + Nothing -> fmap (\ecmd -> ShellPipeline ecmd Nothing) cmd + Just upper -> liftA2 (\ecmd eupper -> ShellPipeline ecmd (Just eupper)) cmd upper + choice + [ do + psymbol "|" + parsePipeline (Just pipeline) + + , do + return pipeline + ] + where + psymbol str = void $ try $ (string str <* notFollowedBy (satisfy $ (`elem` [ '<', '>', '|', '&' ]))) <* sc + +parseStatement :: TestParser (Expr [ ShellStatement ]) +parseStatement = do + line <- getSourceLine + fmap ((: []) . flip ShellStatement line) <$> parsePipeline Nothing + +shellScript :: TestParser (Expr ShellScript) +shellScript = do + indent <- L.indentLevel + fmap ShellScript <$> blockOf indent parseStatement diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index c7cdf5a..1c1b805 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -1,16 +1,19 @@ module Parser.Statement ( testStep, + testBlock, ) where import Control.Monad import Control.Monad.Identity import Control.Monad.State +import Data.Bifunctor import Data.Kind import Data.Maybe import Data.Set qualified as S import Data.Text qualified as T import Data.Typeable +import Data.Void import Text.Megaparsec hiding (State) import Text.Megaparsec.Char @@ -19,11 +22,14 @@ import qualified Text.Megaparsec.Char.Lexer as L import Network (Network, Node) import Parser.Core import Parser.Expr +import Parser.Shell import Process (Process) +import Script.Expr +import Script.Expr.Class import Test import Util -letStatement :: TestParser [TestStep] +letStatement :: TestParser (Expr (TestBlock ())) letStatement = do line <- getSourceLine indent <- L.indentLevel @@ -31,18 +37,17 @@ letStatement = do off <- stateOffset <$> getParserState name <- varName osymbol "=" - SomeExpr e <- someExpr + se@(SomeExpr e) <- someExpr FunctionTerm localState $ do let tname = TypedVarName name - addVarName off tname + addVarNameType off tname (someExprType se) void $ eol body <- testBlock indent - return [Let line tname e body] + return $ Let line tname e (TestBlockStep EmptyTestBlock . Scope <$> body) -forStatement :: TestParser [TestStep] +forStatement :: TestParser (Expr (TestBlock ())) forStatement = do - line <- getSourceLine ref <- L.indentLevel wsymbol "for" voff <- stateOffset <$> getParserState @@ -50,7 +55,8 @@ forStatement = do wsymbol "in" loff <- stateOffset <$> getParserState - SomeExpr e <- someExpr + tvar <- newTypeVar + SomeExpr e <- unifySomeExpr loff (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy [])) [ ExprTypeVar tvar ]) =<< someExpr FunctionTerm let err = parseError $ FancyError loff $ S.singleton $ ErrorFail $ T.unpack $ "expected a list, expression has type '" <> textExprType e <> "'" ExprListUnpacker unpack _ <- maybe err return $ exprListUnpacker e @@ -62,36 +68,80 @@ forStatement = do let tname = TypedVarName name addVarName voff tname body <- testBlock indent - return [For line tname (unpack <$> e) body] + return $ (\xs f -> mconcat $ map f xs) + <$> (unpack <$> e) + <*> LambdaAbstraction tname (TestBlockStep EmptyTestBlock . Scope <$> body) + +shellStatement :: TestParser (Expr (TestBlock ())) +shellStatement = do + ref <- L.indentLevel + wsymbol "shell" + parseParams ref Nothing Nothing + + where + parseParamKeyword kw prev = do + off <- stateOffset <$> getParserState + wsymbol kw + when (isJust prev) $ do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "unexpected parameter with keyword ‘" <> kw <> "’" + + parseParams ref mbpname mbnode = choice + [ do + parseParamKeyword "as" mbpname + pname <- newVarName + parseParams ref (Just pname) mbnode + + , do + parseParamKeyword "on" mbnode + node <- typedExpr SimpleTerm + parseParams ref mbpname (Just node) -exprStatement :: TestParser [ TestStep ] + , do + off <- stateOffset <$> getParserState + symbol ":" + node <- case mbnode of + Just node -> return node + Nothing -> do + registerParseError $ FancyError off $ S.singleton $ ErrorFail $ + "missing parameter with keyword ‘on’" + return $ Undefined "" + + void eol + void $ L.indentGuard scn GT ref + script <- shellScript + cont <- fmap Scope <$> testBlock ref + let expr | Just pname <- mbpname = LambdaAbstraction pname cont + | otherwise = const <$> cont + return $ TestBlockStep EmptyTestBlock <$> + (SpawnShell mbpname <$> node <*> script <*> expr) + ] + +exprStatement :: TestParser (Expr (TestBlock ())) exprStatement = do ref <- L.indentLevel off <- stateOffset <$> getParserState - SomeExpr expr <- someExpr + SomeExpr expr <- someExpr FunctionTerm choice - [ do - continuePartial off ref expr - , do - stmt <- unifyExpr off Proxy expr - return [ ExprStatement stmt ] + [ continuePartial off ref expr + , unifyExpr off Proxy expr ] where - continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser [ TestStep ] + continuePartial :: ExprType a => Int -> Pos -> Expr a -> TestParser (Expr (TestBlock ())) continuePartial off ref expr = do symbol ":" void eol - (fun :: Expr (FunctionType TestBlock)) <- unifyExpr off Proxy expr + (fun :: Expr (FunctionType (TestBlock ()))) <- unifyExpr off Proxy expr scn indent <- L.indentGuard scn GT ref blockOf indent $ do coff <- stateOffset <$> getParserState sline <- getSourceLine - args <- functionArguments (checkFunctionArguments (exprArgs fun)) someExpr literal (\poff -> lookupVarExpr poff sline . VarName) - let fun' = ArgsApp args fun + args <- functionArguments (\poff _ e -> return ( poff, e )) (someExpr FunctionTerm) literal (\poff -> lookupVarExpr poff sline . VarName) + SomeExpr fun' <- applyFunctionArguments args (SomeExpr fun) choice [ continuePartial coff indent fun' - , (: []) . ExprStatement <$> unifyExpr coff Proxy fun' + , unifyExpr coff Proxy fun' ] class (Typeable a, Typeable (ParamRep a)) => ParamType a where @@ -104,37 +154,53 @@ class (Typeable a, Typeable (ParamRep a)) => ParamType a where paramDefault :: proxy a -> TestParser (ParamRep a) paramDefault _ = mzero + paramNewVariables :: proxy a -> ParamRep a -> NewVariables + paramNewVariables _ _ = NoNewVariables + paramNewVariablesEmpty :: proxy a -> NewVariables + paramNewVariablesEmpty _ = NoNewVariables -- to keep type info for optional parameters + paramFromSomeExpr :: proxy a -> SomeExpr -> Maybe (ParamRep a) paramFromSomeExpr _ (SomeExpr e) = cast e + paramExpr :: ParamRep a -> Expr a + default paramExpr :: ParamRep a ~ a => ParamRep a -> Expr a + paramExpr = Pure + instance ParamType SourceLine where parseParam _ = mzero showParamType _ = "<source line>" +instance ParamType CallStack where + type ParamRep CallStack = Expr CallStack + parseParam _ = mzero + showParamType _ = "<call stack>" + paramExpr = id + instance ExprType a => ParamType (TypedVarName a) where parseParam _ = newVarName showParamType _ = "<variable>" - -instance ExprType a => ParamType (Expr a) where - parseParam _ = do - off <- stateOffset <$> getParserState - SomeExpr e <- literal <|> variable <|> between (symbol "(") (symbol ")") someExpr - unifyExpr off Proxy e - showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" + paramNewVariables _ var = SomeNewVariables [ var ] + paramNewVariablesEmpty _ = SomeNewVariables @a [] instance ParamType a => ParamType [a] where type ParamRep [a] = [ParamRep a] parseParam _ = listOf (parseParam @a Proxy) showParamType _ = showParamType @a Proxy ++ " [, " ++ showParamType @a Proxy ++ " ...]" paramDefault _ = return [] + paramNewVariables _ = foldr (<>) (paramNewVariablesEmpty @a Proxy) . fmap (paramNewVariables @a Proxy) + paramNewVariablesEmpty _ = paramNewVariablesEmpty @a Proxy paramFromSomeExpr _ se@(SomeExpr e) = cast e <|> ((:[]) <$> paramFromSomeExpr @a Proxy se) + paramExpr = sequenceA . fmap paramExpr instance ParamType a => ParamType (Maybe a) where type ParamRep (Maybe a) = Maybe (ParamRep a) parseParam _ = Just <$> parseParam @a Proxy showParamType _ = showParamType @a Proxy paramDefault _ = return Nothing + paramNewVariables _ = foldr (<>) (paramNewVariablesEmpty @a Proxy) . fmap (paramNewVariables @a Proxy) + paramNewVariablesEmpty _ = paramNewVariablesEmpty @a Proxy paramFromSomeExpr _ se = Just <$> paramFromSomeExpr @a Proxy se + paramExpr = sequenceA . fmap paramExpr instance (ParamType a, ParamType b) => ParamType (Either a b) where type ParamRep (Either a b) = Either (ParamRep a) (ParamRep b) @@ -147,62 +213,109 @@ instance (ParamType a, ParamType b) => ParamType (Either a b) where (_ : _) -> fail "" showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy paramFromSomeExpr _ se = (Left <$> paramFromSomeExpr @a Proxy se) <|> (Right <$> paramFromSomeExpr @b Proxy se) + paramExpr = either (fmap Left . paramExpr) (fmap Right . paramExpr) + +instance ExprType a => ParamType (Traced a) where + type ParamRep (Traced a) = Expr a + parseParam _ = parseParam (Proxy @(ExprParam a)) + showParamType _ = showParamType (Proxy @(ExprParam a)) + paramExpr = Trace data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a)) -data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> a) +data NewVariables + = NoNewVariables + | forall a. ExprType a => SomeNewVariables [ TypedVarName a ] + +instance Semigroup NewVariables where + NoNewVariables <> x = x + x <> NoNewVariables = x + SomeNewVariables (xs :: [ TypedVarName a ]) <> SomeNewVariables (ys :: [ TypedVarName b ]) + | Just (Refl :: a :~: b) <- eqT = SomeNewVariables (xs <> ys) + | otherwise = error "new variables with different types" + +instance Monoid NewVariables where + mempty = NoNewVariables + +someParamVars :: Foldable f => SomeParam f -> NewVariables +someParamVars (SomeParam proxy rep) = foldr (\x nvs -> paramNewVariables proxy x <> nvs) (paramNewVariablesEmpty proxy) rep + +data CommandDef a = CommandDef [(String, SomeParam Proxy)] ([SomeParam Identity] -> Expr a) instance Functor CommandDef where - fmap f (CommandDef types ctor) = CommandDef types (f . ctor) + fmap f (CommandDef types ctor) = CommandDef types (fmap f . ctor) instance Applicative CommandDef where - pure x = CommandDef [] (\case [] -> x; _ -> error "command arguments mismatch") - CommandDef types1 ctor1 <*> CommandDef types2 ctor2 = - CommandDef (types1 ++ types2) $ \params -> - let (params1, params2) = splitAt (length types1) params - in ctor1 params1 $ ctor2 params2 + pure x = CommandDef [] (\case [] -> Pure x; _ -> error "command arguments mismatch") + CommandDef types1 ctor1 <*> CommandDef types2 ctor2 = + CommandDef (types1 ++ types2) $ \params -> + let (params1, params2) = splitAt (length types1) params + in ctor1 params1 <*> ctor2 params2 param :: forall a. ParamType a => String -> CommandDef a param name = CommandDef [(name, SomeParam (Proxy @a) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x + [SomeParam Proxy (Identity x)] -> paramExpr $ fromJust $ cast x _ -> error "command arguments mismatch" -data ParamOrContext a +newtype ParamOrContext a = ParamOrContext { fromParamOrContext :: a } + deriving (Functor, Foldable, Traversable) instance ParamType a => ParamType (ParamOrContext a) where - type ParamRep (ParamOrContext a) = ParamRep a - parseParam _ = parseParam @a Proxy + type ParamRep (ParamOrContext a) = ParamOrContext (ParamRep a) + parseParam _ = ParamOrContext <$> parseParam @a Proxy showParamType _ = showParamType @a Proxy paramDefault _ = gets testContext >>= \case se@(SomeExpr ctx) - | Just e <- paramFromSomeExpr @a Proxy se -> return e + | Just e <- paramFromSomeExpr @a Proxy se -> return (ParamOrContext e) | otherwise -> fail $ showParamType @a Proxy <> " not available from context type '" <> T.unpack (textExprType ctx) <> "'" + paramExpr = sequenceA . fmap paramExpr paramOrContext :: forall a. ParamType a => String -> CommandDef a -paramOrContext name = CommandDef [(name, SomeParam (Proxy @(ParamOrContext a)) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x - _ -> error "command arguments mismatch" +paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" -data InnerBlock +callStack :: CommandDef CallStack +callStack = param "" -instance ParamType InnerBlock where - type ParamRep InnerBlock = [TestStep] +newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } + +instance ExprType a => ParamType (InnerBlock a) where + type ParamRep (InnerBlock a) = ( [ TypedVarName a ], Expr (TestBlock ()) ) parseParam _ = mzero showParamType _ = "<code block>" + paramExpr ( vars, expr ) = fmap InnerBlock $ helper vars $ const <$> expr + where + helper :: ExprType a => [ TypedVarName a ] -> Expr ([ a ] -> b) -> Expr ([ a ] -> b) + helper ( v : vs ) = fmap combine . LambdaAbstraction v . helper vs + helper [] = id -instance ParamType TestStep where - parseParam _ = mzero - showParamType _ = "<code line>" + combine f (x : xs) = f x xs + combine _ [] = error "inner block parameter count mismatch" -innerBlock :: CommandDef [TestStep] -innerBlock = CommandDef [("", SomeParam (Proxy @InnerBlock) Proxy)] $ \case - [SomeParam Proxy (Identity x)] -> fromJust $ cast x - _ -> error "command arguments mismatch" +innerBlock :: CommandDef (TestStep ()) +innerBlock = ($ ([] :: [ Void ])) <$> innerBlockFunList + +innerBlockFun :: ExprType a => CommandDef (a -> TestStep ()) +innerBlockFun = (\f x -> f [ x ]) <$> innerBlockFunList + +innerBlockFunList :: ExprType a => CommandDef ([ a ] -> TestStep ()) +innerBlockFunList = (\ib -> Scope . fromInnerBlock ib) <$> param "" + +newtype ExprParam a = ExprParam { fromExprParam :: a } + deriving (Functor, Foldable, Traversable) + +instance ExprType a => ParamType (ExprParam a) where + type ParamRep (ExprParam a) = Expr a + parseParam _ = do + off <- stateOffset <$> getParserState + SomeExpr e <- someExpr SimpleTerm + unifyExpr off Proxy e + showParamType _ = "<" ++ T.unpack (textExprType @a Proxy) ++ ">" + paramExpr = fmap ExprParam -command :: String -> CommandDef TestStep -> TestParser [TestStep] +command :: String -> CommandDef (TestStep ()) -> TestParser (Expr (TestBlock ())) command name (CommandDef types ctor) = do indent <- L.indentLevel line <- getSourceLine @@ -210,19 +323,28 @@ command name (CommandDef types ctor) = do localState $ do restOfLine indent [] line $ map (fmap $ \(SomeParam p@(_ :: Proxy p) Proxy) -> SomeParam p $ Nothing @(ParamRep p)) types where - restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser [TestStep] + restOfLine :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> SourceLine -> [(String, SomeParam Maybe)] -> TestParser (Expr (TestBlock ())) restOfLine cmdi partials line params = choice [do void $ lookAhead eol + let definedVariables = mconcat $ map (someParamVars . snd) params iparams <- forM params $ \case (_, SomeParam (p :: Proxy p) Nothing) | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line - | Just (Refl :: p :~: InnerBlock) <- eqT -> SomeParam p . Identity <$> restOfParts cmdi partials + | Just (Refl :: p :~: CallStack) <- eqT -> return $ SomeParam p $ Identity $ Variable line callStackFqVarName + + | SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables + , Just (Refl :: p :~: InnerBlock a) <- eqT + -> SomeParam p . Identity . ( vars, ) <$> restOfParts cmdi partials + + | Just (Refl :: p :~: InnerBlock Void) <- eqT + -> SomeParam p . Identity . ( [], ) <$> restOfParts cmdi partials + (sym, SomeParam p Nothing) -> choice [ SomeParam p . Identity <$> paramDefault p , fail $ "missing " ++ (if null sym then "" else "'" ++ sym ++ "' ") ++ showParamType p ] (_, SomeParam (p :: Proxy p) (Just x)) -> return $ SomeParam p $ Identity x - return [ctor iparams] + return $ (TestBlockStep EmptyTestBlock) <$> ctor iparams ,do symbol ":" scn @@ -232,16 +354,16 @@ command name (CommandDef types ctor) = do ,do tryParams cmdi partials line [] params ] - restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser [TestStep] + restOfParts :: Pos -> [(Pos, [(String, SomeParam Maybe)])] -> TestParser (Expr (TestBlock ())) restOfParts cmdi [] = testBlock cmdi restOfParts cmdi partials@((partIndent, params) : rest) = do scn pos <- L.indentLevel line <- getSourceLine optional eof >>= \case - Just _ -> return [] + Just _ -> return $ Pure mempty _ | pos < partIndent -> restOfParts cmdi rest - | pos == partIndent -> (++) <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials + | pos == partIndent -> mappend <$> restOfLine cmdi partials line params <*> restOfParts cmdi partials | otherwise -> L.incorrectIndent EQ partIndent pos tryParam sym (SomeParam (p :: Proxy p) cur) = do @@ -258,7 +380,7 @@ command name (CommandDef types ctor) = do ] tryParams _ _ _ _ [] = mzero -testLocal :: TestParser [TestStep] +testLocal :: TestParser (Expr (TestBlock ())) testLocal = do ref <- L.indentLevel wsymbol "local" @@ -266,15 +388,16 @@ testLocal = do void $ eol indent <- L.indentGuard scn GT ref - localState $ testBlock indent + localState $ do + fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent -testWith :: TestParser [TestStep] +testWith :: TestParser (Expr (TestBlock ())) testWith = do ref <- L.indentLevel wsymbol "with" off <- stateOffset <$> getParserState - ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr + ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr SimpleTerm let expected = [ ExprTypePrim @Network Proxy , ExprTypePrim @Node Proxy @@ -292,75 +415,68 @@ testWith = do indent <- L.indentGuard scn GT ref localState $ do modify $ \s -> s { testContext = ctx } - testBlock indent + fmap (TestBlockStep EmptyTestBlock . Scope) <$> testBlock indent -testSubnet :: TestParser [TestStep] +testSubnet :: TestParser (Expr (TestBlock ())) testSubnet = command "subnet" $ Subnet <$> param "" - <*> paramOrContext "of" - <*> innerBlock + <*> (fromExprParam <$> paramOrContext "of") + <*> innerBlockFun -testNode :: TestParser [TestStep] +testNode :: TestParser (Expr (TestBlock ())) testNode = command "node" $ DeclNode <$> param "" - <*> paramOrContext "on" - <*> innerBlock + <*> (fromExprParam <$> paramOrContext "on") + <*> innerBlockFun -testSpawn :: TestParser [TestStep] +testSpawn :: TestParser (Expr (TestBlock ())) testSpawn = command "spawn" $ Spawn <$> param "as" - <*> paramOrContext "on" - <*> innerBlock + <*> (bimap fromExprParam fromExprParam <$> paramOrContext "on") + <*> (maybe [] fromExprParam <$> param "args") + <*> (maybe Nothing (Just . fromExprParam) <$> param "killwith") + <*> innerBlockFun -testExpect :: TestParser [TestStep] +testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect - <$> cmdLine - <*> paramOrContext "from" + <$> callStack + <*> cmdLine + <*> (fromExprParam <$> paramOrContext "from") <*> param "" + <*> (maybe 1 fromExprParam <$> param "timeout") <*> param "capture" - <*> innerBlock + <*> innerBlockFunList -testDisconnectNode :: TestParser [TestStep] +testDisconnectNode :: TestParser (Expr (TestBlock ())) testDisconnectNode = command "disconnect_node" $ DisconnectNode - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectNodes :: TestParser [TestStep] +testDisconnectNodes :: TestParser (Expr (TestBlock ())) testDisconnectNodes = command "disconnect_nodes" $ DisconnectNodes - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testDisconnectUpstream :: TestParser [TestStep] +testDisconnectUpstream :: TestParser (Expr (TestBlock ())) testDisconnectUpstream = command "disconnect_upstream" $ DisconnectUpstream - <$> paramOrContext "" + <$> (fromExprParam <$> paramOrContext "") <*> innerBlock -testPacketLoss :: TestParser [TestStep] +testPacketLoss :: TestParser (Expr (TestBlock ())) testPacketLoss = command "packet_loss" $ PacketLoss - <$> param "" - <*> paramOrContext "on" + <$> (fromExprParam <$> paramOrContext "") + <*> (fromExprParam <$> paramOrContext "on") <*> innerBlock -testBlock :: Pos -> TestParser [ TestStep ] +testBlock :: Pos -> TestParser (Expr (TestBlock ())) testBlock indent = blockOf indent testStep -blockOf :: Pos -> TestParser [ a ] -> TestParser [ a ] -blockOf indent step = concat <$> go - where - go = do - scn - pos <- L.indentLevel - optional eof >>= \case - Just _ -> return [] - _ | pos < indent -> return [] - | pos == indent -> (:) <$> step <*> go - | otherwise -> L.incorrectIndent EQ indent pos - -testStep :: TestParser [TestStep] +testStep :: TestParser (Expr (TestBlock ())) testStep = choice [ letStatement , forStatement + , shellStatement , testLocal , testWith , testSubnet diff --git a/src/Process.hs b/src/Process.hs index 48ed40f..1c2dbe5 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -1,13 +1,19 @@ module Process ( Process(..), - ProcName(..), - textProcName, unpackProcName, + ProcessId(..), textProcId, + ProcName(..), textProcName, unpackProcName, + Signal, send, - outProc, + outProc, outProcName, lineReadingLoop, + startProcessIOLoops, spawnOn, closeProcess, + closeTestProcess, withProcess, + + IgnoreProcessOutput(..), + flushProcessOutput, ) where import Control.Arrow @@ -18,49 +24,67 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Function +import Data.List +import Data.Maybe +import Data.Scientific import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Data.Text qualified as T +import Data.Text.IO qualified as T +import System.Directory +import System.Environment import System.Exit +import System.FilePath import System.IO import System.IO.Error -import System.Posix.Signals +import System.Posix.Process import System.Process import {-# SOURCE #-} GDB import Network import Network.Ip import Output +import Process.Signal import Run.Monad -import Test +import Script.Expr +import Script.Expr.Class +import Script.Object data Process = Process - { procName :: ProcName - , procHandle :: ProcessHandle + { procId :: ProcessId + , procName :: ProcName + , procHandle :: Either ProcessHandle ( ThreadId, MVar ExitCode ) , procStdin :: Handle - , procOutput :: TVar [Text] + , procOutput :: TVar [ Text ] + , procIgnore :: TVar ( Int, [ ( Int, Maybe Regex ) ] ) , procKillWith :: Maybe Signal , procNode :: Node + , procPid :: Maybe Pid } instance Eq Process where (==) = (==) `on` procStdin instance ExprType Process where - textExprType _ = T.pack "proc" - textExprValue n = T.pack "p:" <> textProcName (procName n) + textExprType _ = T.pack "Process" + textExprValue p = "<process:" <> textProcName (procName p) <> "#" <> textProcId (procId p) <> ">" recordMembers = map (first T.pack) - [ ("node", RecordSelector $ procNode) + [ ( "node", RecordSelector $ procNode ) + , ( "pid", RecordSelector $ maybe (0 :: Integer) fromIntegral . procPid ) ] +newtype ProcessId = ProcessId Int + data ProcName = ProcName Text | ProcNameTcpdump | ProcNameGDB deriving (Eq, Ord) +textProcId :: ProcessId -> Text +textProcId (ProcessId pid) = T.pack (show pid) + textProcName :: ProcName -> Text textProcName (ProcName name) = name textProcName ProcNameTcpdump = T.pack "tcpdump" @@ -75,69 +99,129 @@ send p line = liftIO $ do hFlush (procStdin p) outProc :: MonadOutput m => OutputType -> Process -> Text -> m () -outProc otype p line = outLine otype (Just $ textProcName $ procName p) line +outProc otype p line = outProcName otype (procName p) line + +outProcName :: MonadOutput m => OutputType -> ProcName -> Text -> m () +outProcName otype pname line = outLine otype (Just $ textProcName pname) line lineReadingLoop :: MonadOutput m => Process -> Handle -> (Text -> m ()) -> m () lineReadingLoop process h act = liftIO (tryIOError (T.hGetLine h)) >>= \case - Left err - | isEOFError err -> return () - | otherwise -> outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err + Left err -> do + when (not (isEOFError err)) $ do + outProc OutputChildFail process $ T.pack $ "IO error: " ++ show err + liftIO $ hClose h Right line -> do act line lineReadingLoop process h act +startProcessIOLoops :: Process -> Handle -> Handle -> TestRun () +startProcessIOLoops process@Process {..} hout herr = do + + void $ forkTest $ lineReadingLoop process hout $ \line -> do + outProc OutputChildStdout process line + ignored <- liftIO $ atomically $ do + ignores <- map snd . snd <$> readTVar procIgnore + let ignored = any (matches line) ignores + when (not ignored) $ do + modifyTVar procOutput (++ [ line ]) + return ignored + when ignored $ do + outProc OutputIgnored process line + + void $ forkTest $ lineReadingLoop process herr $ \line -> do + case procName of + ProcNameTcpdump -> return () + _ -> outProc OutputChildStderr process line + + where + matches _ Nothing + = True + matches line (Just re) + | Right (Just _) <- regexMatch re line = True + | otherwise = False + spawnOn :: Either Network Node -> ProcName -> Maybe Signal -> String -> TestRun Process -spawnOn target pname killWith cmd = do +spawnOn target procName procKillWith cmd = do + -- When executing command given with relative path, turn it to absolute one, + -- because working directory will be changed for the shell wrapper. + cmd' <- liftIO $ do + case span (/= ' ') cmd of + ( path, rest ) + | any isPathSeparator path && isRelative path + -> do + path' <- makeAbsolute path + return (path' ++ rest) + _ -> return cmd + + procId <- case procName of + ProcNameTcpdump -> return $ ProcessId (-1) + _ -> do + idVar <- asks $ teNextProcId . fst + liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x )) + let netns = either getNetns getNetns target - let prefix = T.unpack $ "ip netns exec \"" <> textNetnsName netns <> "\" " - (Just hin, Just hout, Just herr, handle) <- liftIO $ createProcess (shell $ prefix ++ cmd) - { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe - , env = Just [("EREBOS_DIR", either netDir nodeDir target)] - } - pout <- liftIO $ newTVarIO [] - - let process = Process - { procName = pname - , procHandle = handle - , procStdin = hin - , procOutput = pout - , procKillWith = killWith - , procNode = either (const undefined) id target + currentEnv <- liftIO $ getEnvironment + (Just procStdin, Just hout, Just herr, handle) <- liftIO $ do + runInNetworkNamespace netns $ createProcess (shell cmd') + { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe + , cwd = Just (either netDir nodeDir target) + , env = Just $ ( "EREBOS_DIR", "." ) : currentEnv } + let procHandle = Left handle + procOutput <- liftIO $ newTVarIO [] + procIgnore <- liftIO $ newTVarIO ( 0, [] ) + let procNode = either (const undefined) id target + procPid <- liftIO $ getPid handle + let process = Process {..} - forkTest $ lineReadingLoop process hout $ \line -> do - outProc OutputChildStdout process line - liftIO $ atomically $ modifyTVar pout (++[line]) - forkTest $ lineReadingLoop process herr $ \line -> do - case pname of - ProcNameTcpdump -> return () - _ -> outProc OutputChildStderr process line + startProcessIOLoops process hout herr asks (teGDB . fst) >>= maybe (return Nothing) (liftIO . tryReadMVar) >>= \case - Just gdb | ProcName _ <- pname -> addInferior gdb process + Just gdb | ProcName _ <- procName -> addInferior gdb process _ -> return () return process -closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Process -> m () -closeProcess p = do +closeProcess :: (MonadIO m, MonadOutput m, MonadError Failed m) => Scientific -> Process -> m () +closeProcess timeout p = do liftIO $ hClose $ procStdin p case procKillWith p of Nothing -> return () - Just sig -> liftIO $ getPid (procHandle p) >>= \case + Just sig -> case procPid p of Nothing -> return () Just pid -> signalProcess sig pid liftIO $ void $ forkIO $ do - threadDelay 1000000 - terminateProcess $ procHandle p - liftIO (waitForProcess (procHandle p)) >>= \case - ExitSuccess -> return () - ExitFailure code -> do - outProc OutputChildFail p $ T.pack $ "exit code: " ++ show code + threadDelay $ floor $ 1000000 * timeout + either terminateProcess (killThread . fst) $ procHandle p + + status <- case procPid p of + Nothing -> Just . Exited <$> liftIO (either waitForProcess (takeMVar . snd) (procHandle p)) + Just pid -> liftIO (getProcessStatus True False pid) + case status of + Just (Exited ExitSuccess) -> do + return () + Just (Exited (ExitFailure code)) -> do + outProc OutputChildFail p $ "exit code: " <> T.pack (show code) + throwError Failed + Just (Terminated sig _) + | Just (Signal sig) == procKillWith p -> return () + | otherwise -> do + outProc OutputChildFail p $ "killed with signal " <> T.pack (show sig) + throwError Failed + Just (Stopped sig) -> do + outProc OutputChildFail p $ "stopped with signal " <> T.pack (show sig) + throwError Failed + Nothing -> do + outProc OutputChildFail p $ "no exit status" throwError Failed +closeTestProcess :: Process -> TestRun () +closeTestProcess process = do + timeout <- getCurrentTimeout + closeProcess timeout process + withProcess :: Either Network Node -> ProcName -> Maybe Signal -> String -> (Process -> TestRun a) -> TestRun a withProcess target pname killWith cmd inner = do procVar <- asks $ teProcesses . fst @@ -147,5 +231,36 @@ withProcess target pname killWith cmd inner = do inner process `finally` do ps <- liftIO $ takeMVar procVar - closeProcess process `finally` do + closeTestProcess process `finally` do liftIO $ putMVar procVar $ filter (/=process) ps + + +data IgnoreProcessOutput = IgnoreProcessOutput Process Int + +instance ObjectType TestRun IgnoreProcessOutput where + type ConstructorArgs IgnoreProcessOutput = ( Process, Maybe Regex ) + + textObjectType _ _ = "IgnoreProcessOutput" + textObjectValue _ (IgnoreProcessOutput _ _) = "<IgnoreProcessOutput>" + + createObject oid ( process@Process {..}, regex ) = do + ( obj, flushed ) <- liftIO $ atomically $ do + flushed <- flushProcessOutput process regex + ( iid, list ) <- readTVar procIgnore + writeTVar procIgnore ( iid + 1, ( iid, regex ) : list ) + return ( Object oid $ IgnoreProcessOutput process iid, flushed ) + mapM_ (outProc OutputIgnored process) flushed + return obj + + destroyObject Object { objImpl = IgnoreProcessOutput Process {..} iid } = do + liftIO $ atomically $ do + writeTVar procIgnore . fmap (filter ((iid /=) . fst)) =<< readTVar procIgnore + +flushProcessOutput :: Process -> Maybe Regex -> STM [ Text ] +flushProcessOutput p mbre = do + current <- readTVar (procOutput p) + let ( ignore, keep ) = case mbre of + Nothing -> ( current, [] ) + Just re -> partition (either error isJust . regexMatch re) current + writeTVar (procOutput p) keep + return ignore diff --git a/src/Process/Signal.hs b/src/Process/Signal.hs new file mode 100644 index 0000000..e57b68d --- /dev/null +++ b/src/Process/Signal.hs @@ -0,0 +1,88 @@ +module Process.Signal ( + Signal(..), + signalBuiltins, + signalProcess, +) where + +import Control.Monad.IO.Class + +import Data.Text (Text) +import Data.Text qualified as T + +import Script.Expr + +import System.Posix qualified as Posix + + +newtype Signal = Signal Posix.Signal + deriving (Eq, Ord) + +instance ExprType Signal where + textExprType _ = "Signal" + textExprValue (Signal sig) + | sig == Posix.sigHUP = "SIGHUP" + | sig == Posix.sigINT = "SIGINT" + | sig == Posix.sigQUIT = "SIGQUIT" + | sig == Posix.sigILL = "SIGILL" + | sig == Posix.sigTRAP = "SIGTRAP" + | sig == Posix.sigABRT = "SIGABRT" + | sig == Posix.sigBUS = "SIGBUS" + | sig == Posix.sigFPE = "SIGFPE" + | sig == Posix.sigKILL = "SIGKILL" + | sig == Posix.sigUSR1 = "SIGUSR1" + | sig == Posix.sigSEGV = "SIGSEGV" + | sig == Posix.sigUSR2 = "SIGUSR2" + | sig == Posix.sigPIPE = "SIGPIPE" + | sig == Posix.sigALRM = "SIGALRM" + | sig == Posix.sigTERM = "SIGTERM" + | sig == Posix.sigCHLD = "SIGCHLD" + | sig == Posix.sigCONT = "SIGCONT" + | sig == Posix.sigSTOP = "SIGSTOP" + | sig == Posix.sigTSTP = "SIGTSTP" + | sig == Posix.sigTTIN = "SIGTTIN" + | sig == Posix.sigTTOU = "SIGTTOU" + | sig == Posix.sigURG = "SIGURG" + | sig == Posix.sigXCPU = "SIGXCPU" + | sig == Posix.sigXFSZ = "SIGXFSZ" + | sig == Posix.sigVTALRM = "SIGVTALRM" + | sig == Posix.sigPROF = "SIGPROF" + | sig == Posix.sigPOLL = "SIGPOLL" + | sig == Posix.sigSYS = "SIGSYS" + | otherwise = "<SIG_" <> T.pack (show sig) <> ">" + + +signalBuiltins :: [ ( Text, SomeExpr ) ] +signalBuiltins = map (fmap $ SomeExpr . Pure) + [ ( "SIGHUP", Signal Posix.sigHUP ) + , ( "SIGINT", Signal Posix.sigINT ) + , ( "SIGQUIT", Signal Posix.sigQUIT ) + , ( "SIGILL", Signal Posix.sigILL ) + , ( "SIGTRAP", Signal Posix.sigTRAP ) + , ( "SIGABRT", Signal Posix.sigABRT ) + , ( "SIGBUS", Signal Posix.sigBUS ) + , ( "SIGFPE", Signal Posix.sigFPE ) + , ( "SIGKILL", Signal Posix.sigKILL ) + , ( "SIGUSR1", Signal Posix.sigUSR1 ) + , ( "SIGSEGV", Signal Posix.sigSEGV ) + , ( "SIGUSR2", Signal Posix.sigUSR2 ) + , ( "SIGPIPE", Signal Posix.sigPIPE ) + , ( "SIGALRM", Signal Posix.sigALRM ) + , ( "SIGTERM", Signal Posix.sigTERM ) + , ( "SIGCHLD", Signal Posix.sigCHLD ) + , ( "SIGCONT", Signal Posix.sigCONT ) + , ( "SIGSTOP", Signal Posix.sigSTOP ) + , ( "SIGTSTP", Signal Posix.sigTSTP ) + , ( "SIGTTIN", Signal Posix.sigTTIN ) + , ( "SIGTTOU", Signal Posix.sigTTOU ) + , ( "SIGURG", Signal Posix.sigURG ) + , ( "SIGXCPU", Signal Posix.sigXCPU ) + , ( "SIGXFSZ", Signal Posix.sigXFSZ ) + , ( "SIGVTALRM", Signal Posix.sigVTALRM ) + , ( "SIGPROF", Signal Posix.sigPROF ) + , ( "SIGPOLL", Signal Posix.sigPOLL ) + , ( "SIGSYS", Signal Posix.sigSYS ) + ] + + +signalProcess :: MonadIO m => Signal -> Posix.ProcessID -> m () +signalProcess (Signal sig) pid = liftIO $ Posix.signalProcess sig pid @@ -1,41 +1,119 @@ module Run ( module Run.Monad, + Report(..), SingleTestReport(..), + TestName, textTestName, + runTests, runTest, + + LoadedModules(..), + loadModules', + evalGlobalDefs, + + TestFilter(..), + testFilterFromConfig, + filterTests, ) where import Control.Applicative +import Control.Arrow import Control.Concurrent import Control.Concurrent.STM import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Control.Monad.Writer +import Data.Char +import Data.Either +import Data.List import Data.Map qualified as M import Data.Maybe -import Data.Set qualified as S +import Data.Proxy import Data.Scientific +import Data.Set qualified as S import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T +import Data.Typeable import System.Directory +import System.FilePath import System.Exit import System.IO.Error import System.Posix.Process import System.Posix.Signals import System.Process +import Config import GDB import Network import Network.Ip import Output +import Parser import Process +import Process.Signal import Run.Monad +import Sandbox +import Script.Expr +import Script.Module +import Script.Object +import Script.Shell import Test import Test.Builtins -runTest :: Output -> TestOptions -> Test -> IO Bool -runTest out opts test = do - let testDir = optTestDir opts + +data Report = Report + { reportTotalCount :: Int + , reportPassedCount :: Int + , reportSkippedCount :: Int + , reportFailedCount :: Int + , reportFailedList :: [ TestName ] + , reportTotalTime :: Scientific + , reportTests :: [ SingleTestReport ] + } + +data SingleTestReport = SingleTestReport + { reportTestName :: TestName + , reportTestFailed :: Maybe Failed + , reportTime :: Scientific + , reportOutput :: Text + , reportOutputError :: Text + } + +runTests :: Output -> TestOptions -> GlobalDefs -> [ Test ] -> IO Report +runTests out opts gdefs tests = do + go $ concat $ replicate (optRepeat opts) tests + where + go (t : ts) = do + single <- runTest out opts gdefs t + let failed = isJust (reportTestFailed single) + r <- if + | failed && not (optKeepGoing opts) + -> go [] + | otherwise + -> go ts + return Report + { reportTotalCount = 1 + reportTotalCount r + , reportPassedCount = (if failed then 0 else 1) + reportPassedCount r + , reportSkippedCount = reportSkippedCount r + , reportFailedCount = (if failed then 1 else 0) + reportFailedCount r + , reportFailedList = (if failed then (reportTestName single :) else id) $ reportFailedList r + , reportTotalTime = reportTime single + reportTotalTime r + , reportTests = single : reportTests r + } + go [] = return Report + { reportTotalCount = 0 + , reportPassedCount = 0 + , reportSkippedCount = 0 + , reportFailedCount = 0 + , reportFailedList = [] + , reportTotalTime = 0 + , reportTests = [] + } + + +runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO SingleTestReport +runTest out opts gdefs test = do + let testDir = optTestDir opts </> T.unpack (textTestName $ testName test) when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e -> if isDoesNotExistError e then return () else ioError e exists <- doesPathExist testDir @@ -43,7 +121,10 @@ runTest out opts test = do createDirectoryIfMissing True testDir failedVar <- newTVarIO Nothing + objIdVar <- newMVar 1 + procIdVar <- newMVar 1 procVar <- newMVar [] + timeoutVar <- newMVar ( optTimeout opts, 0 ) mgdb <- if optGDB opts then flip runReaderT out $ do @@ -55,21 +136,26 @@ runTest out opts test = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teTestDir = testDir + , teNextObjId = objIdVar + , teNextProcId = procIdVar , teProcesses = procVar + , teTimeout = timeoutVar , teGDB = fst <$> mgdb } tstate = TestState - { tsNetwork = error "network not initialized" - , tsVars = builtins + { tsGlobals = gdefs + , tsLocals = [ ( callStackVarName, SomeExpr $ Pure $ CallStack [] ) ] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty } - let sigHandler SignalInfo { siginfoSpecific = chld } = do + let sigHandler SignalInfo { siginfoSpecific = NoSignalSpecificInfo } = return () + sigHandler SignalInfo { siginfoSpecific = chld } = do processes <- readMVar procVar forM_ processes $ \p -> do - mbpid <- getPid (procHandle p) + mbpid <- either getPid (\_ -> return Nothing) (procHandle p) when (mbpid == Just (siginfoPid chld)) $ flip runReaderT out $ do let err detail = outProc OutputChildFail p detail case siginfoStatus chld of @@ -83,120 +169,235 @@ runTest out opts test = do Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing - res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do - withInternet $ \_ -> do - evalSteps (testSteps test) - when (optWait opts) $ do - void $ outPromptGetLine $ "Test '" <> testName test <> "' completed, waiting..." + flip runReaderT out $ do + void $ outLine OutputGlobalInfo Nothing $ "Starting test ‘" <> textTestName (testName test) <> "’" + + resetOutputTime out + testRunResult <- newEmptyMVar + + void $ forkOS $ do + isolateFilesystem testDir >>= \case + True -> do + tres <- runWriterT $ runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do + withInternet $ \_ -> do + runStep =<< eval (testSteps test) + when (optWait opts) $ do + void $ outPromptGetLine $ "Test ‘" <> textTestName (testName test) <> "’ completed, waiting..." + putMVar testRunResult tres + _ -> do + putMVar testRunResult ( Left Failed, [] ) + + ( res, [] ) <- takeMVar testRunResult + reportTime <- getElapsedTime out + reportOutput <- collectOutput out + reportOutputError <- collectErrorOutput out void $ installHandler processStatusChanged oldHandler Nothing Right () <- runExceptT $ flip runReaderT out $ do - maybe (return ()) (closeProcess . snd) mgdb + maybe (return ()) (closeProcess 1 . snd) mgdb [] <- readMVar procVar failed <- atomically $ readTVar (teFailed tenv) - case (res, failed) of - (Right (), Nothing) -> do + reportTestFailed <- case ( res, failed ) of + ( Right (), Nothing ) -> do when (not $ optKeep opts) $ removeDirectoryRecursive testDir - return True - _ -> return False - -evalSteps :: [TestStep] -> TestRun () -evalSteps = mapM_ $ \case - Let (SourceLine sline) (TypedVarName name) expr inner -> do - cur <- asks (lookup name . tsVars . snd) - when (isJust cur) $ do - outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline - throwError Failed - value <- eval expr - withVar name value $ evalSteps inner - - For (SourceLine sline) (TypedVarName name) expr inner -> do - cur <- asks (lookup name . tsVars . snd) - when (isJust cur) $ do - outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline - throwError Failed - value <- eval expr - forM_ value $ \i -> do - withVar name i $ evalSteps inner - - ExprStatement expr -> do - TestBlock steps <- eval expr - evalSteps steps - - Subnet name@(TypedVarName vname) parentExpr inner -> do - parent <- eval parentExpr - withSubnet parent (Just name) $ \net -> do - withVar vname net $ evalSteps inner - - DeclNode name@(TypedVarName vname) net inner -> do - withNode net (Left name) $ \node -> do - withVar vname node $ evalSteps inner - - Spawn tvname@(TypedVarName vname@(VarName tname)) target inner -> do + return Nothing + _ -> do + flip runReaderT out $ do + void $ outLine OutputGlobalError Nothing $ "Test ‘" <> textTestName (testName test) <> "’ failed." + return $ either Just (const Nothing) res `mplus` failed + + (optHookTestResult opts) (testName test) (isNothing reportTestFailed) + let reportTestName = testName test + return SingleTestReport {..} + + +data LoadedModules = LoadedModules + { lmModules :: [ Module ] + , lmTags :: [ ( TestName, [ Tag ] ) ] + , lmGlobalDefs :: GlobalDefs + } + +loadModules' :: [ SomePrimType ] -> [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules) +loadModules' builtinTypes files = do + parseTestFiles builtinTypes (map fst files) >>= \case + Right ( modules, allModules ) -> return $ do + lmModules <- forM (zip files modules) $ \( ( path, tsel ), m ) -> do + tests <- case tsel of + Nothing -> return $ moduleTests m + Just tname + | Just test <- find ((tname ==) . testNameBase . testName) (moduleTests m) + -> return [ test ] + | otherwise + -> throwError $ TestNotFound tname (Just path) + return m { moduleTests = tests } + + let lmGlobalDefs = evalGlobalDefs $ concatMap (\m -> map (first ( moduleName m, )) $ moduleDefinitions m) allModules + evalTags test = map (\e -> runSimpleEval (eval e) lmGlobalDefs []) $ testTags test + lmTags = concatMap (\Module {..} -> map (\test -> ( testName test, evalTags test )) moduleTests) lmModules + Right $ LoadedModules {..} + Left err -> do + return $ Left err + + +evalGlobalDefs :: [ (( ModuleName, VarName ), SomeExpr ) ] -> GlobalDefs +evalGlobalDefs exprs = builtins `M.union` M.fromList exprs + + +data TestFilter = TestFilter + { tfSelect :: Maybe [ Text ] + , tfExclude :: [ Text ] + } + +instance Semigroup TestFilter where + a <> b + | isJust (tfSelect b) = b + | otherwise = a { tfExclude = tfExclude a <> tfExclude b } + +instance Monoid TestFilter where + mempty = TestFilter Nothing [] + +testFilterFromConfig :: Config -> TestFilter +testFilterFromConfig Config {..} = TestFilter + { tfSelect = configSelect + , tfExclude = configExclude + } + +filterTests :: TestFilter -> LoadedModules -> Either CustomTestError [ Test ] +filterTests TestFilter {..} LoadedModules {..} = do + let allTests = concatMap moduleTests lmModules + let evalTerm :: Text -> Either CustomTestError (Either TestName (Either Tag ModuleName)) + evalTerm term = + case (init &&& last) $ T.splitOn "." term of + ( [], name ) | maybe False (isUpper . fst) (T.uncons name) -> + case find ((VarName name ==) . snd . fst) $ M.toList lmGlobalDefs of + Just ( _, SomeExpr (expr :: Expr etype) ) + | Just (Refl :: etype :~: Tag) <- eqT + -> return $ Right $ Left $ runSimpleEval (eval expr) lmGlobalDefs [] + Nothing + | Just t <- find ((name ==) . testNameBase . testName) allTests + -> return $ Left $ testName t + Nothing + | mname <- ModuleName [ name ] + , Just _ <- find ((mname ==) . moduleName) lmModules + -> return $ Right $ Right mname + _ -> + throwError $ TestOrTagNotFound term Nothing + ( ms, name ) | maybe False (isUpper . fst) (T.uncons name) -> + case find ((( ModuleName ms, VarName name ) ==) . fst) $ M.toList lmGlobalDefs of + Just ( _, SomeExpr (expr :: Expr etype) ) + | Just (Refl :: etype :~: Tag) <- eqT + -> return $ Right $ Left $ runSimpleEval (eval expr) lmGlobalDefs [] + Nothing + | Just t <- find ((TestName (ModuleName ms) name ==) . testName) allTests + -> return $ Left $ testName t + Nothing + | mname <- ModuleName $ ms ++ [ name ] + , Just _ <- find ((mname ==) . moduleName) lmModules + -> return $ Right $ Right mname + _ -> + throwError $ TestOrTagNotFound term Nothing + ( ms, name ) | mname <- ModuleName $ ms ++ [ name ] -> + case find ((mname ==) . moduleName) lmModules of + Just _ -> return $ Right $ Right mname + _ -> throwError $ ModuleNotFound mname + + exclude <- fmap partitionEithers . partitionEithers <$> mapM evalTerm tfExclude + let matches ( tnames, ( tags, modules ) ) test = + testName test `elem` tnames + || maybe False (any (`elem` tags)) (lookup (testName test) lmTags) + || testNameModule (testName test) `elem` modules + filter (not . matches exclude) <$> case tfSelect of + Nothing -> return allTests + Just tnames -> do + selected <- fmap partitionEithers . partitionEithers <$> mapM evalTerm tnames + return $ filter (matches selected) allTests + + +runBlock :: TestBlock () -> TestRun () +runBlock EmptyTestBlock = return () +runBlock (TestBlockStep prev step) = runBlock prev >> runStep step + +runStep :: TestStep () -> TestRun () +runStep = \case + Scope block -> do + ( x, objs ) <- censor (const []) $ listen $ catchError (Right <$> runBlock block) (return . Left) + mapM_ destroySomeObject (reverse objs) + either throwError return x + + CreateObject (Proxy :: Proxy o) cargs -> do + objIdVar <- asks (teNextObjId . fst) + oid <- liftIO $ modifyMVar objIdVar (\x -> return ( x + 1, x )) + obj <- createObject @TestRun @o (ObjectId oid) cargs + tell [ toSomeObject obj ] + + Subnet name parent inner -> do + withSubnet parent (Just name) $ runStep . inner + + DeclNode name net inner -> do + withNode net (Left name) $ runStep . inner + + Spawn tvname@(TypedVarName (VarName tname)) target args killWith inner -> do case target of Left net -> withNode net (Right tvname) go - Right node -> go =<< eval node + Right node -> go node where go node = do opts <- asks $ teOptions . fst let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) - withProcess (Right node) pname Nothing tool $ \p -> do - withVar vname p (evalSteps inner) - - Send pname expr -> do - p <- eval pname - line <- eval expr + cmd = T.unwords $ T.pack tool : map escape args + escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" + outProcName OutputChildExec pname cmd + withProcess (Right node) pname killWith (T.unpack cmd) $ runStep . inner + + SpawnShell mbname node script inner -> do + let tname | Just (TypedVarName (VarName name)) <- mbname = name + | otherwise = "shell" + let pname = ProcName tname + withShellProcess node pname script $ runStep . inner + + Send p line -> do outProc OutputChildStdin p line send p line - Expect line pname expr captures inner -> do - p <- eval pname - expect line p expr captures $ evalSteps inner + Expect stack line p expr timeout captures inner -> do + expect stack line p expr timeout captures $ runStep . inner - Flush pname expr -> do - p <- eval pname - flush p expr + Flush p regex -> do + mapM_ (outProc OutputIgnored p) =<< + atomicallyTest (flushProcessOutput p regex) - Guard line expr -> do - testStepGuard line expr + Guard stack expr -> do + testStepGuard stack expr DisconnectNode node inner -> do - n <- eval node - withDisconnectedUp (nodeUpstream n) $ evalSteps inner + withDisconnectedUp (nodeUpstream node) $ runStep inner DisconnectNodes net inner -> do - n <- eval net - withDisconnectedBridge (netBridge n) $ evalSteps inner + withDisconnectedBridge (netBridge net) $ runStep inner DisconnectUpstream net inner -> do - n <- eval net - case netUpstream n of - Just link -> withDisconnectedUp link $ evalSteps inner - Nothing -> evalSteps inner + case netUpstream net of + Just link -> withDisconnectedUp link $ runStep inner + Nothing -> runStep inner PacketLoss loss node inner -> do - l <- eval loss - n <- eval node - withNodePacketLoss n l $ evalSteps inner + withNodePacketLoss node loss $ runStep inner Wait -> do void $ outPromptGetLine "Waiting..." -withVar :: ExprType e => VarName -> e -> TestRun a -> TestRun a -withVar name value = local (fmap $ \s -> s { tsVars = ( name, SomeVarValue mempty $ const $ const value ) : tsVars s }) - withInternet :: (Network -> TestRun a) -> TestRun a withInternet inner = do - testDir <- asks $ optTestDir . teOptions . fst + testDir <- asks $ teTestDir . fst inet <- newInternet testDir - res <- withNetwork (inetRoot inet) $ \net -> do - local (fmap $ \s -> s { tsNetwork = net }) $ inner net - delInternet inet - return res + flip finally (delInternet inet) $ do + withNetwork (inetRoot inet) $ \net -> do + withTypedVar rootNetworkVar net $ do + inner net withSubnet :: Network -> Maybe (TypedVarName Network) -> (Network -> TestRun a) -> TestRun a withSubnet parent tvname inner = do @@ -205,16 +406,15 @@ withSubnet parent tvname inner = do withNetwork :: Network -> (Network -> TestRun a) -> TestRun a withNetwork net inner = do - tcpdump <- liftIO (findExecutable "tcpdump") >>= return . \case - Just path -> withProcess (Left net) ProcNameTcpdump (Just softwareTermination) - (path ++ " -i br0 -w '" ++ netDir net ++ "/br0.pcap' -U -Z root") . const + tcpdump <- asks (optTcpdump . teOptions . fst) >>= return . \case + Just path -> withProcess (Left net) ProcNameTcpdump (Just (Signal softwareTermination)) + (path ++ " -i br0 -w './br0.pcap' -U -Z root") . const Nothing -> id tcpdump $ inner net -withNode :: Expr Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a -withNode netexpr tvname inner = do - net <- eval netexpr +withNode :: Network -> Either (TypedVarName Node) (TypedVarName Process) -> (Node -> TestRun a) -> TestRun a +withNode net tvname inner = do node <- newNode net (either fromTypedVarName fromTypedVarName tvname) either (flip withVar node . fromTypedVarName) (const id) tvname $ inner node @@ -273,22 +473,16 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just ( | otherwise = fmap (x:) <$> tryMatch re xs tryMatch _ [] = Nothing -exprFailed :: Text -> SourceLine -> Maybe ProcName -> Expr a -> TestRun () -exprFailed desc (SourceLine sline) pname expr = do +exprFailed :: Text -> CallStack -> Maybe ProcName -> TestRun () +exprFailed desc stack pname = do let prompt = maybe T.empty textProcName pname - exprVars <- gatherVars expr - outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline] - forM_ exprVars $ \((name, sel), value) -> - outLine OutputMatchFail (Just prompt) $ T.concat - [ " ", textVarName name, T.concat (map ("."<>) sel) - , " = ", textSomeVarValue (SourceLine sline) value - ] + outLine (OutputMatchFail stack) (Just prompt) $ desc <> " failed" throwError Failed -expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun () -expect (SourceLine sline) p expr tvars inner = do - re <- eval expr - timeout <- asks $ optTimeout . teOptions . fst +expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestRun ()) -> TestRun () +expect (CallStack cs) sline p (Traced trace re) etimeout tvars inner = do + let stack = CallStack (( sline, trace ) : cs) + timeout <- (etimeout *) <$> getCurrentTimeout delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do line <- readTVar (procOutput p) @@ -302,29 +496,14 @@ expect (SourceLine sline) p expr tvars inner = do let vars = map (\(TypedVarName n) -> n) tvars when (length vars /= length capture) $ do - outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` sline + outProc (OutputMatchFail stack) p $ T.pack "mismatched number of capture variables" throwError Failed - forM_ vars $ \name -> do - cur <- asks (lookup name . tsVars . snd) - when (isJust cur) $ do - outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline - throwError Failed - outProc OutputMatch p line - local (fmap $ \s -> s { tsVars = zip vars (map (SomeVarValue mempty . const . const) capture) ++ tsVars s }) inner - - Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) expr - -flush :: Process -> Maybe (Expr Regex) -> TestRun () -flush p mbexpr = do - mbre <- sequence $ fmap eval mbexpr - atomicallyTest $ do - writeTVar (procOutput p) =<< case mbre of - Nothing -> return [] - Just re -> filter (either error isNothing . regexMatch re) <$> readTVar (procOutput p) - -testStepGuard :: SourceLine -> Expr Bool -> TestRun () -testStepGuard sline expr = do - x <- eval expr - when (not x) $ exprFailed (T.pack "guard") sline Nothing expr + inner capture + + Nothing -> exprFailed (T.pack "expect") stack (Just $ procName p) + +testStepGuard :: CallStack -> Bool -> TestRun () +testStepGuard stack x = do + when (not x) $ exprFailed (T.pack "guard") stack Nothing diff --git a/src/Run/Builtins.hs b/src/Run/Builtins.hs new file mode 100644 index 0000000..409e723 --- /dev/null +++ b/src/Run/Builtins.hs @@ -0,0 +1,43 @@ +module Run.Builtins ( + module Run, + loadModules, +) where + +import Data.Proxy +import Data.Scientific +import Data.Text (Text) +import Data.Void + +import Asset (Asset) +import Network (Network, Node) +import Parser (CustomTestError) +import Process (Process) +import Process.Signal (Signal) +import Run +import Script.Expr +import Test (Test, Tag) + + +builtinTypes :: [ SomePrimType ] +builtinTypes = + [ SomePrimType @() Proxy + , SomePrimType @Integer Proxy + , SomePrimType @Scientific Proxy + , SomePrimType @Bool Proxy + , SomePrimType @Text Proxy + , SomePrimType @Void Proxy + , SomePrimType @Regex Proxy + + , SomePrimType @Test Proxy + , SomePrimType @Tag Proxy + , SomePrimType @Asset Proxy + + , SomePrimType @Network Proxy + , SomePrimType @Node Proxy + + , SomePrimType @Process Proxy + , SomePrimType @Signal Proxy + ] + +loadModules :: [ ( FilePath, Maybe Text ) ] -> IO (Either CustomTestError LoadedModules) +loadModules = loadModules' builtinTypes diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 9ec9065..8c772d5 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -7,6 +7,9 @@ module Run.Monad ( finally, forkTest, + forkTestUsing, + + getCurrentTimeout, ) where import Control.Concurrent @@ -14,33 +17,43 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Control.Monad.Writer import Data.Map (Map) -import Data.Set (Set) import Data.Scientific -import qualified Data.Text as T +import Data.Set (Set) +import Data.Text qualified as T import {-# SOURCE #-} GDB -import {-# SOURCE #-} Network import Network.Ip import Output import {-# SOURCE #-} Process -import Test +import Script.Expr +import Script.Object -newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed IO) a } - deriving (Functor, Applicative, Monad, MonadReader (TestEnv, TestState), MonadIO) +newtype TestRun a = TestRun { fromTestRun :: ReaderT (TestEnv, TestState) (ExceptT Failed (WriterT [ SomeObject TestRun ] IO)) a } + deriving + ( Functor, Applicative, Monad + , MonadReader ( TestEnv, TestState ) + , MonadWriter [ SomeObject TestRun ] + , MonadIO + ) data TestEnv = TestEnv { teOutput :: Output , teFailed :: TVar (Maybe Failed) , teOptions :: TestOptions - , teProcesses :: MVar [Process] + , teTestDir :: FilePath + , teNextObjId :: MVar Int + , teNextProcId :: MVar Int + , teProcesses :: MVar [ Process ] + , teTimeout :: MVar ( Scientific, Integer ) -- ( positive timeout, number of zero multiplications ) , teGDB :: Maybe (MVar GDB) } data TestState = TestState - { tsNetwork :: Network - , tsVars :: [(VarName, SomeVarValue)] + { tsGlobals :: GlobalDefs + , tsLocals :: [ ( VarName, SomeExpr ) ] , tsDisconnectedUp :: Set NetworkNamespace , tsDisconnectedBridge :: Set NetworkNamespace , tsNodePacketLoss :: Map NetworkNamespace Scientific @@ -51,10 +64,14 @@ data TestOptions = TestOptions , optProcTools :: [(ProcName, String)] , optTestDir :: FilePath , optTimeout :: Scientific + , optTcpdump :: Maybe FilePath , optGDB :: Bool , optForce :: Bool , optKeep :: Bool + , optRepeat :: Int + , optKeepGoing :: Bool , optWait :: Bool + , optHookTestResult :: TestName -> Bool -> IO () } defaultTestOptions :: TestOptions @@ -63,10 +80,14 @@ defaultTestOptions = TestOptions , optProcTools = [] , optTestDir = ".test" , optTimeout = 1 + , optTcpdump = Nothing , optGDB = False , optForce = False , optKeep = False + , optRepeat = 1 + , optKeepGoing = False , optWait = False + , optHookTestResult = \_ _ -> return () } data Failed = Failed @@ -93,8 +114,9 @@ instance MonadError Failed TestRun where catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler instance MonadEval TestRun where - lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< asks (lookup name . tsVars . snd) - rootNetwork = asks $ tsNetwork . snd + askGlobalDefs = asks (tsGlobals . snd) + askDictionary = asks (tsLocals . snd) + withDictionary f = local (fmap $ \s -> s { tsLocals = f (tsLocals s) }) instance MonadOutput TestRun where getOutput = asks $ teOutput . fst @@ -109,10 +131,20 @@ finally act handler = do void handler return x -forkTest :: TestRun () -> TestRun () -forkTest act = do +forkTest :: TestRun () -> TestRun ThreadId +forkTest = forkTestUsing forkIO + +forkTestUsing :: (IO () -> IO ThreadId) -> TestRun () -> TestRun ThreadId +forkTestUsing fork act = do tenv <- ask - void $ liftIO $ forkIO $ do - runExceptT (flip runReaderT tenv $ fromTestRun act) >>= \case + liftIO $ fork $ do + ( res, [] ) <- runWriterT (runExceptT $ flip runReaderT tenv $ fromTestRun act) + case res of Left e -> atomically $ writeTVar (teFailed $ fst tenv) (Just e) Right () -> return () + +getCurrentTimeout :: TestRun Scientific +getCurrentTimeout = do + ( timeout, zeros ) <- liftIO . readMVar =<< asks (teTimeout . fst) + return $ if zeros > 0 then 0 + else timeout diff --git a/src/Sandbox.hs b/src/Sandbox.hs new file mode 100644 index 0000000..a05a455 --- /dev/null +++ b/src/Sandbox.hs @@ -0,0 +1,16 @@ +module Sandbox ( + isolateFilesystem, +) where + +import Foreign.C.String +import Foreign.C.Types + +import System.Directory + + +isolateFilesystem :: FilePath -> IO Bool +isolateFilesystem rwDir = do + absDir <- makeAbsolute rwDir + withCString absDir c_isolate_fs >>= return . (== 0) + +foreign import ccall unsafe "erebos_tester_isolate_fs" c_isolate_fs :: CString -> IO CInt diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs new file mode 100644 index 0000000..e6f945d --- /dev/null +++ b/src/Script/Expr.hs @@ -0,0 +1,599 @@ +module Script.Expr ( + Expr(..), varExpr, mapExpr, + + MonadEval(..), VariableDictionary, GlobalDefs, + lookupVar, tryLookupVar, withVar, withTypedVar, + eval, evalSome, evalSomeWith, + runSimpleEval, + + FunctionType, DynamicType, + ExprType(..), SomeExpr(..), + SomePrimType(..), + TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, + renameTypeVar, renameVarInType, + + VarValue(..), SomeVarValue(..), + svvVariables, svvArguments, + someConstValue, fromConstValue, + fromSomeVarValue, textSomeVarValue, someVarValueType, + + ArgumentKeyword(..), FunctionArguments(..), + anull, exprArgs, + SomeArgumentType(..), ArgumentType(..), + + Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars, + AppAnnotation(..), + callStackVarName, callStackFqVarName, + + module Script.Var, + + Regex(RegexPart, RegexString), + regexCompile, regexMatch, +) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader + +import Data.Char +import Data.Foldable +import Data.List +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe +import Data.Scientific +import Data.String +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable + +import Text.Regex.TDFA qualified as RE +import Text.Regex.TDFA.Text qualified as RE + +import Script.Expr.Class +import Script.Var +import Util + + +data Expr a where + Let :: forall a b. ExprType b => SourceLine -> TypedVarName b -> Expr b -> Expr a -> Expr a + Variable :: ExprType a => SourceLine -> FqVarName -> Expr a + DynVariable :: SomeExprType -> SourceLine -> FqVarName -> Expr DynamicType + FunVariable :: ExprType a => SomeExprType -> SourceLine -> FqVarName -> Expr (FunctionType a) + OptVariable :: ExprType a => SourceLine -> FqVarName -> Expr (Maybe a) + ArgsReq :: ExprType a => FunctionArguments ( VarName, SomeArgumentType ) -> Expr (FunctionType a) -> Expr (FunctionType a) + ArgsApp :: ExprType a => FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) + FunctionAbstraction :: ExprType a => Expr a -> Expr (FunctionType a) + FunctionEval :: ExprType a => SourceLine -> Expr (FunctionType a) -> Expr a + HidePrimType :: forall a. ExprType a => Expr a -> Expr DynamicType + HideFunType :: forall a. ExprType a => FunctionArguments SomeArgumentType -> Expr (FunctionType a) -> Expr DynamicType + ExposePrimType :: forall a. ExprType a => Expr DynamicType -> Expr a + ExposeFunType :: forall a. ExprType a => FunctionArguments SomeArgumentType -> Expr DynamicType -> Expr (FunctionType a) + TypeLambda :: TypeVar -> SomeExprType -> (SomeExprType -> Expr DynamicType) -> Expr DynamicType + TypeApp :: SomeExprType {- result type -} -> SomeExprType {- type argument -} -> Expr DynamicType -> Expr DynamicType + LambdaAbstraction :: ExprType a => TypedVarName a -> Expr b -> Expr (a -> b) + Pure :: a -> Expr a + App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b + Concat :: [ Expr Text ] -> Expr Text + Regex :: [ Expr Regex ] -> Expr Regex + Undefined :: String -> Expr a + Trace :: Expr a -> Expr (Traced a) + +data AppAnnotation b = AnnNone + | ExprType b => AnnRecord Text + +instance Functor Expr where + fmap f x = Pure f <*> x + +instance Applicative Expr where + pure = Pure + (<*>) = App AnnNone + +instance Semigroup a => Semigroup (Expr a) where + e <> f = (<>) <$> e <*> f + +instance Monoid a => Monoid (Expr a) where + mempty = Pure mempty + +varExpr :: ExprType a => SourceLine -> TypedVarName a -> Expr a +varExpr sline (TypedVarName name) = Variable sline (LocalVarName name) + +mapExpr :: forall a. (forall b. Expr b -> Expr b) -> Expr a -> Expr a +mapExpr f = go + where + go :: forall c. Expr c -> Expr c + go = \case + Let sline vname vval expr -> f $ Let sline vname (go vval) (go expr) + e@Variable {} -> f e + e@DynVariable {} -> f e + e@FunVariable {} -> f e + e@OptVariable {} -> f e + ArgsReq args expr -> f $ ArgsReq args (go expr) + ArgsApp args expr -> f $ ArgsApp (fmap (\(SomeExpr e) -> SomeExpr (go e)) args) (go expr) + FunctionAbstraction expr -> f $ FunctionAbstraction (go expr) + FunctionEval sline expr -> f $ FunctionEval sline (go expr) + HidePrimType expr -> f $ HidePrimType $ go expr + HideFunType args expr -> f $ HideFunType args $ go expr + ExposePrimType expr -> f $ ExposePrimType $ go expr + ExposeFunType args expr -> f $ ExposeFunType args $ go expr + TypeLambda tvar stype efun -> TypeLambda tvar stype (go . efun) + TypeApp restype arg expr -> TypeApp restype arg (go expr) + LambdaAbstraction tvar expr -> f $ LambdaAbstraction tvar (go expr) + e@Pure {} -> f e + App ann efun earg -> f $ App ann (go efun) (go earg) + e@Concat {} -> f e + e@Regex {} -> f e + e@Undefined {} -> f e + Trace expr -> f $ Trace (go expr) + + + +class MonadFail m => MonadEval m where + askGlobalDefs :: m GlobalDefs + askDictionary :: m VariableDictionary + withDictionary :: (VariableDictionary -> VariableDictionary) -> m a -> m a + +type GlobalDefs = Map ( ModuleName, VarName ) SomeExpr + +type VariableDictionary = [ ( VarName, SomeExpr ) ] + +lookupVar :: MonadEval m => FqVarName -> m SomeExpr +lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackFqVarName name ++ "'") return =<< tryLookupVar name + +tryLookupVar :: MonadEval m => FqVarName -> m (Maybe SomeExpr) +tryLookupVar (LocalVarName name) = lookup name <$> askDictionary +tryLookupVar (GlobalVarName mname var) = M.lookup ( mname, var ) <$> askGlobalDefs + +withVar :: (MonadEval m, ExprType e) => VarName -> e -> m a -> m a +withVar name value = withDictionary (( name, SomeExpr (Pure value) ) : ) + +withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a +withTypedVar (TypedVarName name) = withVar name + +isInternalVar :: FqVarName -> Bool +isInternalVar (GlobalVarName {}) = False +isInternalVar (LocalVarName (VarName name)) + | Just ( '$', _ ) <- T.uncons name = True + | otherwise = False + + + +newtype SimpleEval a = SimpleEval (ReaderT ( GlobalDefs, VariableDictionary ) (Except String) a) + deriving (Functor, Applicative, Monad, MonadError String) + +runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a +runSimpleEval (SimpleEval x) gdefs dict = either error id $ runExcept $ runReaderT x ( gdefs, dict ) + +trySimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> Maybe a +trySimpleEval (SimpleEval x) gdefs dict = either (const Nothing) Just $ runExcept $ runReaderT x ( gdefs, dict ) + +instance MonadFail SimpleEval where + fail = throwError . ("eval failed: " <>) + +instance MonadEval SimpleEval where + askGlobalDefs = SimpleEval (asks fst) + askDictionary = SimpleEval (asks snd) + withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner) + +callStackVarName :: VarName +callStackVarName = VarName "$STACK" + +callStackFqVarName :: FqVarName +callStackFqVarName = LocalVarName callStackVarName + +eval :: forall m a. MonadEval m => Expr a -> m a +eval = \case + Let _ (TypedVarName name) valExpr expr -> do + val <- eval valExpr + withVar name val $ eval expr + Variable _ name -> evalSomeExpr name =<< lookupVar name + DynVariable _ _ name -> evalSomeExpr name =<< lookupVar name + FunVariable _ _ name -> evalSomeExpr name =<< lookupVar name + OptVariable _ name -> maybe (return Nothing) (fmap Just . evalSomeExpr name) =<< tryLookupVar name + ArgsReq (FunctionArguments req) efun -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ FunctionType $ \stack (FunctionArguments args) -> + let used = M.intersectionWith (\(SomeVarValue value) ( vname, _ ) -> ( vname, SomeExpr $ Pure $ vvFunction value (CallStack []) mempty )) args req + FunctionType fun = runSimpleEval (eval efun) gdefs (toList used ++ dict) + in fun stack $ FunctionArguments $ args `M.difference` req + ArgsApp eargs efun -> do + FunctionType fun <- eval efun + args <- mapM evalSome eargs + return $ FunctionType $ \stack args' -> fun stack (args <> args') + FunctionAbstraction expr -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ FunctionType $ \stack _ -> + runSimpleEval (eval expr) gdefs (( callStackVarName, SomeExpr (Pure stack) ) : filter ((callStackVarName /=) . fst) dict) + FunctionEval sline efun -> do + vars <- gatherVars efun + CallStack cs <- maybe (return $ CallStack []) (evalSomeExpr callStackFqVarName) =<< tryLookupVar callStackFqVarName + let cs' = CallStack (( sline, vars ) : cs) + FunctionType fun <- withVar callStackVarName cs' $ eval efun + return $ fun cs' mempty + HidePrimType expr -> DynamicType <$> eval expr + HideFunType _ expr -> DynamicType <$> eval expr + ExposePrimType expr -> do + DynamicType x <- eval expr + case cast x of + Just x' -> return x' + n@Nothing -> fail $ "type error in expose primitive type result " <> show ( typeOf x, typeOf n ) + ExposeFunType _ expr -> do + DynamicType x <- eval expr + case cast x of + Just x' -> return x' + n@Nothing -> fail $ "type error in expose function type result " <> show ( typeOf x, typeOf n ) + TypeLambda _ _ f -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ DynamicType $ \t -> runSimpleEval (eval $ f t) gdefs dict + TypeApp _ arg expr -> do + DynamicType f <- eval expr + case cast f of + Just f' -> return (f' arg) + n@Nothing -> fail $ "type error in type application " <> show ( typeOf f, typeOf n ) + LambdaAbstraction (TypedVarName name) expr -> do + gdefs <- askGlobalDefs + dict <- askDictionary + return $ \x -> runSimpleEval (eval expr) gdefs (( name, SomeExpr $ Pure x ) : dict) + Pure value -> return value + App _ f x -> eval f <*> eval x + Concat xs -> T.concat <$> mapM eval xs + Regex xs -> mapM eval xs >>= \case + [ re@RegexCompiled {} ] -> return re + parts -> case regexCompile $ T.concat $ map regexSource parts of + Left err -> fail err + Right re -> return re + Undefined err -> fail err + Trace expr -> Traced <$> gatherVars expr <*> eval expr + +evalSomeExpr :: forall m a. (MonadEval m, ExprType a) => FqVarName -> SomeExpr -> m a +evalSomeExpr name (SomeExpr (e :: Expr b)) = do + maybe (fail err) eval $ cast e + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable ‘", textFqVarName name, T.pack "’ has type type ", + textExprType @b Proxy ] + +evalToVarValue :: MonadEval m => Expr a -> m (VarValue a) +evalToVarValue expr = do + VarValue + <$> gatherVars expr + <*> pure mempty + <*> (const . const <$> eval expr) + +evalFunToVarValue :: MonadEval m => Expr (FunctionType a) -> m (VarValue a) +evalFunToVarValue expr = do + FunctionType fun <- eval expr + VarValue + <$> gatherVars expr + <*> pure (exprArgs expr) + <*> pure fun + +evalSome :: MonadEval m => SomeExpr -> m SomeVarValue +evalSome (SomeExpr expr) + | IsFunType <- asFunType expr = SomeVarValue <$> evalFunToVarValue expr + | otherwise = SomeVarValue <$> evalToVarValue expr + +evalSomeWith :: GlobalDefs -> SomeExpr -> SomeVarValue +evalSomeWith gdefs sexpr = runSimpleEval (evalSome sexpr) gdefs [] + + +data FunctionType a = FunctionType (CallStack -> FunctionArguments SomeVarValue -> a) + +instance ExprType a => ExprType (FunctionType a) where + textExprType _ = "function type" + textExprValue _ = "<function type>" + +data DynamicType = forall a. Typeable a => DynamicType a + +instance ExprType DynamicType where + textExprType _ = "ambiguous type" + textExprValue _ = "<dynamic type>" + + +data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) + +data SomePrimType = forall a. ExprType a => SomePrimType (Proxy a) + +newtype TypeVar = TypeVar Text + deriving (Eq, Ord) + +data SomeExprType + = forall a. ExprType a => ExprTypePrim (Proxy a) + | forall a. ExprTypeConstr1 a => ExprTypeConstr1 (Proxy a) + | ExprTypeVar TypeVar + | ExprTypeFunction SomeExprType SomeExprType + | ExprTypeArguments (FunctionArguments SomeArgumentType) + | ExprTypeApp SomeExprType [ SomeExprType ] + | ExprTypeForall TypeVar SomeExprType + +someExprType :: SomeExpr -> SomeExprType +someExprType (SomeExpr expr) = go expr + where + go :: forall e. ExprType e => Expr e -> SomeExprType + go = \case + DynVariable stype _ _ -> stype + e@(FunVariable args _ _) -> ExprTypeFunction args (ExprTypePrim (proxyOfFunctionType e)) + HidePrimType (_ :: Expr a) -> ExprTypePrim (Proxy @a) + HideFunType args e -> ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (proxyOfFunctionType e)) + e@(ExposeFunType args _) -> ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (proxyOfFunctionType e)) + TypeLambda tvar stype _ -> ExprTypeForall tvar stype + TypeApp stype _ _ -> stype + + ArgsReq args inner -> exprTypeFunction (fmap snd args) (go inner) + ArgsApp (FunctionArguments used) inner + | ExprTypeFunction (ExprTypeArguments (FunctionArguments args)) x <- go inner + -> ExprTypeFunction (ExprTypeArguments (FunctionArguments (args `M.difference` used))) x + FunctionAbstraction inner -> exprTypeFunction mempty (go inner) + FunctionEval _ inner + | ExprTypeFunction _ x <- go inner -> x + + (_ :: Expr a) -> ExprTypePrim (Proxy @a) + + exprTypeFunction :: FunctionArguments SomeArgumentType -> SomeExprType -> SomeExprType + exprTypeFunction args (ExprTypeFunction (ExprTypeArguments args') inner) = ExprTypeFunction (ExprTypeArguments (args <> args')) inner + exprTypeFunction args inner = ExprTypeFunction (ExprTypeArguments args) inner + + proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a + proxyOfFunctionType _ = Proxy + + +renameTypeVar :: TypeVar -> TypeVar -> Expr a -> Expr a +renameTypeVar a b = go + where + go :: Expr e -> Expr e + go orig = case orig of + Let sline vname x y -> Let sline vname (go x) (go y) + Variable {} -> orig + DynVariable stype sline name -> DynVariable (renameVarInType a b stype) sline name + FunVariable {} -> orig + OptVariable {} -> orig + ArgsReq args body -> ArgsReq args (go body) + ArgsApp args fun -> ArgsApp (fmap (renameTypeVarInSomeExpr a b) args) (go fun) + FunctionAbstraction expr -> FunctionAbstraction (go expr) + FunctionEval sline expr -> FunctionEval sline (go expr) + HidePrimType expr -> HidePrimType (go expr) + HideFunType args expr -> HideFunType args (go expr) + ExposePrimType {} -> orig + ExposeFunType {} -> orig + TypeLambda tvar stype expr + | tvar == a -> orig + | tvar == b -> error "type var collision" + | otherwise -> TypeLambda tvar (renameVarInType a b stype) (go . expr) + TypeApp restype arg expr -> TypeApp (renameVarInType a b restype) (renameVarInType a b arg) (go expr) + LambdaAbstraction vname expr -> LambdaAbstraction vname (go expr) + Pure {} -> orig + App ann f x -> App ann (go f) (go x) + Concat xs -> Concat (map go xs) + Regex xs -> Regex (map go xs) + Undefined {} -> orig + Trace expr -> Trace (go expr) + +renameTypeVarInSomeExpr :: TypeVar -> TypeVar -> SomeExpr -> SomeExpr +renameTypeVarInSomeExpr a b (SomeExpr e) = SomeExpr (renameTypeVar a b e) + +renameVarInType :: TypeVar -> TypeVar -> SomeExprType -> SomeExprType +renameVarInType a b = go + where + go orig = case orig of + ExprTypePrim {} -> orig + ExprTypeConstr1 {} -> orig + ExprTypeVar tvar | tvar == a -> ExprTypeVar b + | otherwise -> orig + ExprTypeFunction args result -> ExprTypeFunction (go args) (go result) + ExprTypeArguments args -> ExprTypeArguments (fmap (\(SomeArgumentType atype stype) -> SomeArgumentType atype (go stype)) args) + ExprTypeApp c xs -> ExprTypeApp (go c) (map go xs) + ExprTypeForall tvar stype + | tvar == a -> orig + | tvar == b -> error "type var collision" + | otherwise -> ExprTypeForall tvar (go stype) + + +textSomeExprType :: SomeExprType -> Text +textSomeExprType = go [] + where + go _ (ExprTypePrim p) = textExprType p + go (x : _) (ExprTypeConstr1 c) = textExprTypeConstr1 c x + go [] (ExprTypeConstr1 _) = "<incomplte type>" + go _ (ExprTypeVar (TypeVar name)) = name + go _ (ExprTypeFunction _ r) = "function:" <> textSomeExprType r + go _ (ExprTypeArguments _) = "{…}" + go _ (ExprTypeApp c xs) = go (map textSomeExprType xs) c + go _ (ExprTypeForall (TypeVar name) ctype) = "∀" <> name <> "." <> go [] ctype + +data AsFunType a + = forall b. (a ~ FunctionType b, ExprType b) => IsFunType + | NotFunType + +asFunType :: Expr a -> AsFunType a +asFunType = \case + Let _ _ _ expr -> asFunType expr + FunVariable {} -> IsFunType + ArgsReq {} -> IsFunType + ArgsApp {} -> IsFunType + FunctionAbstraction {} -> IsFunType + _ -> NotFunType + + +data VarValue a = VarValue + { vvVariables :: EvalTrace + , vvArguments :: FunctionArguments SomeArgumentType + , vvFunction :: CallStack -> FunctionArguments SomeVarValue -> a + } + +data SomeVarValue = forall a. ExprType a => SomeVarValue (VarValue a) + +svvVariables :: SomeVarValue -> EvalTrace +svvVariables (SomeVarValue vv) = vvVariables vv + +svvArguments :: SomeVarValue -> FunctionArguments SomeArgumentType +svvArguments (SomeVarValue vv) = vvArguments vv + +someConstValue :: ExprType a => a -> SomeVarValue +someConstValue = SomeVarValue . VarValue [] mempty . const . const + +fromConstValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> VarValue a -> m a +fromConstValue stack name (VarValue _ args value :: VarValue b) = do + maybe (fail err) return $ do + guard $ anull args + cast $ value stack mempty + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] + +fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => CallStack -> FqVarName -> SomeVarValue -> m a +fromSomeVarValue stack name (SomeVarValue (VarValue _ args value :: VarValue b)) = do + maybe (fail err) return $ do + guard $ anull args + cast $ value stack mempty + where + err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textFqVarName name, T.pack "' has type ", + if anull args then textExprType @b Proxy else "function type" ] + +textSomeVarValue :: SomeVarValue -> Text +textSomeVarValue (SomeVarValue (VarValue _ args value)) + | anull args = textExprValue $ value (CallStack []) mempty + | otherwise = "<function>" + +someVarValueType :: SomeVarValue -> SomeExprType +someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a)) + | anull args = ExprTypePrim (Proxy @a) + | otherwise = ExprTypeFunction (ExprTypeArguments args) (ExprTypePrim (Proxy @a)) + + +newtype ArgumentKeyword = ArgumentKeyword Text + deriving (Show, Eq, Ord, IsString) + +newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a) + deriving (Show, Semigroup, Monoid, Functor, Foldable, Traversable) + +anull :: FunctionArguments a -> Bool +anull (FunctionArguments args) = M.null args + +exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType +exprArgs = \case + Let _ _ _ expr -> exprArgs expr + Variable {} -> mempty + FunVariable (ExprTypeArguments args) _ _ -> args + FunVariable _ _ _ -> error "exprArgs: type-var args" + ArgsReq args expr -> fmap snd args <> exprArgs expr + ArgsApp (FunctionArguments applied) expr -> + let FunctionArguments args = exprArgs expr + in FunctionArguments (args `M.difference` applied) + FunctionAbstraction {} -> mempty + FunctionEval {} -> mempty + ExposePrimType {} -> mempty + ExposeFunType args _ -> args + Pure {} -> error "exprArgs: pure" + App {} -> error "exprArgs: app" + Undefined {} -> error "exprArgs: undefined" + +data SomeArgumentType = SomeArgumentType ArgumentType SomeExprType + +data ArgumentType + = RequiredArgument + | OptionalArgument + | ExprDefault SomeExpr + | ContextDefault + + +data Traced a = Traced EvalTrace a + +type VarNameSelectors = ( FqVarName, [ Text ] ) +type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ] +newtype CallStack = CallStack [ ( SourceLine, EvalTrace ) ] + +instance ExprType CallStack where + textExprType _ = T.pack "callstack" + textExprValue _ = T.pack "<callstack>" + +gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace +gatherVars = fmap (uniqOn fst . sortOn fst) . helper + where + helper :: forall b. Expr b -> m EvalTrace + helper = \case + Let _ (TypedVarName var) _ expr -> withDictionary (filter ((var /=) . fst)) $ helper expr + e@(Variable _ var) -> gatherLocalVar var e + e@(DynVariable _ _ var) -> gatherLocalVar var e + e@(FunVariable _ _ var) -> gatherLocalVar var e + e@(OptVariable _ var) -> gatherLocalVar var e + ArgsReq args expr -> withDictionary (filter ((`notElem` map fst (toList args)) . fst)) $ helper expr + ArgsApp (FunctionArguments args) fun -> do + v <- helper fun + vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args + return $ concat (v : vs) + FunctionAbstraction expr -> helper expr + FunctionEval _ efun -> helper efun + HidePrimType expr -> helper expr + HideFunType _ expr -> helper expr + ExposePrimType expr -> helper expr + ExposeFunType _ expr -> helper expr + TypeLambda {} -> return [] + TypeApp _ _ expr -> helper expr + LambdaAbstraction (TypedVarName var) expr -> withDictionary (filter ((var /=) . fst)) $ helper expr + Pure _ -> return [] + e@(App (AnnRecord sel) _ x) + | Just (var, sels) <- gatherSelectors x + -> do + gdefs <- askGlobalDefs + dict <- askDictionary + let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval e) gdefs dict + return $ catMaybes [ (( var, sels ++ [ sel ] ), ) <$> mbVal ] + | otherwise -> do + helper x + App _ f x -> (++) <$> helper f <*> helper x + Concat es -> concat <$> mapM helper es + Regex es -> concat <$> mapM helper es + Undefined {} -> return [] + Trace expr -> helper expr + + gatherLocalVar :: forall b. ExprType b => FqVarName -> Expr b -> m EvalTrace + gatherLocalVar var expr + | GlobalVarName {} <- var = return [] + | isInternalVar var = return [] + | otherwise = do + gdefs <- askGlobalDefs + dict <- askDictionary + let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval expr) gdefs dict + return $ maybe [] (\x -> [ ( ( var, [] ), x ) ]) mbVal + + gatherSelectors :: forall b. Expr b -> Maybe ( FqVarName, [ Text ] ) + gatherSelectors = \case + Variable _ var -> Just (var, []) + App (AnnRecord sel) _ x -> do + (var, sels) <- gatherSelectors x + return (var, sels ++ [sel]) + _ -> Nothing + + +data Regex = RegexCompiled Text RE.Regex + | RegexPart Text + | RegexString Text + +instance ExprType Regex where + textExprType _ = T.pack "Regex" + textExprValue _ = T.pack "<regex>" + + exprExpansionConvFrom = listToMaybe $ catMaybes + [ cast (RegexString) + , cast (RegexString . T.pack . show @Integer) + , cast (RegexString . T.pack . show @Scientific) + ] + +regexCompile :: Text -> Either String Regex +regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $ + T.singleton '^' <> src <> T.singleton '$' + +regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text])) +regexMatch (RegexCompiled _ re) text = RE.regexec re text +regexMatch _ _ = Left "regex not compiled" + +regexSource :: Regex -> Text +regexSource (RegexCompiled src _) = src +regexSource (RegexPart src) = src +regexSource (RegexString str) = T.concatMap escapeChar str + where + escapeChar c | isAlphaNum c = T.singleton c + | c `elem` ['`', '\'', '<', '>'] = T.singleton c + | otherwise = T.pack ['\\', c] diff --git a/src/Script/Expr/Class.hs b/src/Script/Expr/Class.hs new file mode 100644 index 0000000..1a6082a --- /dev/null +++ b/src/Script/Expr/Class.hs @@ -0,0 +1,108 @@ +module Script.Expr.Class ( + ExprType(..), + ExprTypeConstr1(..), + TypeDeconstructor(..), + RecordSelector(..), + ExprListUnpacker(..), + ExprEnumerator(..), +) where + +import Data.Kind +import Data.Maybe +import Data.Scientific +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable +import Data.Void + +class Typeable a => ExprType a where + textExprType :: proxy a -> Text + textExprValue :: a -> Text + + matchTypeConstructor :: proxy a -> TypeDeconstructor a + matchTypeConstructor _ = NoTypeDeconstructor + + recordMembers :: [(Text, RecordSelector a)] + recordMembers = [] + + exprExpansionConvTo :: ExprType b => Maybe (a -> b) + exprExpansionConvTo = Nothing + + exprExpansionConvFrom :: ExprType b => Maybe (b -> a) + exprExpansionConvFrom = Nothing + + exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a) + exprListUnpacker _ = Nothing + + exprEnumerator :: proxy a -> Maybe (ExprEnumerator a) + exprEnumerator _ = Nothing + +class (Typeable a, forall b. ExprType b => ExprType (a b)) => ExprTypeConstr1 (a :: Type -> Type) where + textExprTypeConstr1 :: proxy a -> Text -> Text + +data TypeDeconstructor a + = NoTypeDeconstructor + | forall c x. (ExprTypeConstr1 c, ExprType x, c x ~ a) => TypeDeconstructor1 (Proxy c) (Proxy x) + + +data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) + +data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e) + +data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) + + +instance ExprType () where + textExprType _ = "Unit" + textExprValue () = "()" + +instance ExprType Integer where + textExprType _ = T.pack "Integer" + textExprValue x = T.pack (show x) + + exprExpansionConvTo = listToMaybe $ catMaybes + [ cast (T.pack . show :: Integer -> Text) + ] + + exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo + +instance ExprType Scientific where + textExprType _ = T.pack "Number" + textExprValue x = T.pack (show x) + + exprExpansionConvTo = listToMaybe $ catMaybes + [ cast (T.pack . show :: Scientific -> Text) + ] + +instance ExprType Bool where + textExprType _ = T.pack "Bool" + textExprValue True = T.pack "True" + textExprValue False = T.pack "False" + +instance ExprType Text where + textExprType _ = T.pack "String" + textExprValue x = T.pack (show x) + +instance ExprType Void where + textExprType _ = T.pack "Void" + textExprValue _ = T.pack "<void>" + +instance ExprType a => ExprType [ a ] where + textExprType _ = textExprTypeConstr1 @[] Proxy (textExprType @a Proxy) + textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" + matchTypeConstructor _ = TypeDeconstructor1 Proxy Proxy + + exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) + +instance ExprTypeConstr1 [] where + textExprTypeConstr1 _ x = "[" <> x <> "]" + +instance ExprType a => ExprType (Maybe a) where + textExprType _ = textExprType @a Proxy <> "?" + textExprValue (Just x) = textExprValue x + textExprValue Nothing = "Nothing" + +instance (ExprType a, ExprType b) => ExprType (Either a b) where + textExprType _ = textExprType @a Proxy <> "|" <> textExprType @b Proxy + textExprValue (Left x) = "Left " <> textExprValue x + textExprValue (Right x) = "Right " <> textExprValue x diff --git a/src/Script/Module.hs b/src/Script/Module.hs new file mode 100644 index 0000000..3ea59bf --- /dev/null +++ b/src/Script/Module.hs @@ -0,0 +1,20 @@ +module Script.Module ( + Module(..), + ModuleName(..), textModuleName, + moduleExportedDefinitions, +) where + +import Script.Expr +import Test + +data Module = Module + { moduleName :: ModuleName + , moduleTests :: [ Test ] + , moduleDefinitions :: [ ( VarName, SomeExpr ) ] + , moduleExports :: [ VarName ] + } + +moduleExportedDefinitions :: Module -> [ ( VarName, ( FqVarName, SomeExpr )) ] +moduleExportedDefinitions Module {..} = + map (\( var, expr ) -> ( var, ( GlobalVarName moduleName var, expr ))) $ + filter ((`elem` moduleExports) . fst) moduleDefinitions diff --git a/src/Script/Object.hs b/src/Script/Object.hs new file mode 100644 index 0000000..7e60f80 --- /dev/null +++ b/src/Script/Object.hs @@ -0,0 +1,53 @@ +module Script.Object ( + ObjectId(..), + ObjectType(..), + Object(..), SomeObject(..), + toSomeObject, fromSomeObject, + destroySomeObject, +) where + +import Data.Kind +import Data.Text (Text) +import Data.Typeable + +import Script.Expr.Class + + +newtype ObjectId = ObjectId Int + +class Typeable a => ObjectType m a where + type ConstructorArgs a :: Type + type ConstructorArgs a = () + + textObjectType :: proxy (m a) -> proxy a -> Text + textObjectValue :: proxy (m a) -> a -> Text + + createObject :: ObjectId -> ConstructorArgs a -> m (Object m a) + destroyObject :: Object m a -> m () + +instance (Typeable m, ObjectType m a) => ExprType (Object m a) where + textExprType _ = textObjectType (Proxy @(m a)) (Proxy @a) + textExprValue = textObjectValue (Proxy @(m a)) . objImpl + + +data Object m a = ObjectType m a => Object + { objId :: ObjectId + , objImpl :: a + } + +data SomeObject m = forall a. ObjectType m a => SomeObject + { sobjId :: ObjectId + , sobjImpl :: a + } + +toSomeObject :: Object m a -> SomeObject m +toSomeObject Object {..} = SomeObject { sobjId = objId, sobjImpl = objImpl } + +fromSomeObject :: ObjectType m a => SomeObject m -> Maybe (Object m a) +fromSomeObject SomeObject {..} = do + let objId = sobjId + objImpl <- cast sobjImpl + return Object {..} + +destroySomeObject :: SomeObject m -> m () +destroySomeObject (SomeObject oid impl) = destroyObject (Object oid impl) diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs new file mode 100644 index 0000000..6f6eb64 --- /dev/null +++ b/src/Script/Shell.hs @@ -0,0 +1,344 @@ +module Script.Shell ( + ShellScript(..), + ShellStatement(ShellStatement), + ShellPipeline(ShellPipeline), + ShellCommand(ShellCommand), + ShellArguments(..), ShellArgument(..), + withShellProcess, +) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Reader + +import Data.Maybe +import Data.Scientific +import Data.Text (Text) +import Data.Text qualified as T +import Data.Typeable + +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Marshal.Array +import Foreign.Storable + +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.Posix.IO qualified as P +import System.Posix.Process +import System.Posix.Types +import System.Process hiding (ShellCommand) + +import Asset +import Network +import Network.Ip +import Output +import Process +import Run.Monad +import Script.Expr.Class +import Script.Var + + +newtype ShellScript = ShellScript [ ShellStatement ] + +data ShellState = ShellState + { shellWorkingDirectory :: FilePath + , shellOldWorkingDirectory :: FilePath + , shellExitOnError :: Bool + , shellLastExitCode :: ExitCode + } + +data ShellStatement = ShellStatement + { shellPipeline :: ShellPipeline + , shellSourceLine :: SourceLine + } + +data ShellPipeline = ShellPipeline + { pipeCommand :: ShellCommand + , pipeUpstream :: Maybe ShellPipeline + } + +data ShellCommand = ShellCommand + { cmdCommand :: Text + , cmdExtArguments :: ShellArguments + , cmdSourceLine :: SourceLine + } + +newtype ShellArguments = ShellArguments { fromShellArguments :: [ ShellArgument ] } + deriving (Semigroup, Monoid) + +data ShellArgument + = ShellArgument Text + | ShellRedirectStdin Text + | ShellRedirectStdout Bool Text + | ShellRedirectStderr Bool Text + +cmdArguments :: ShellCommand -> [ Text ] +cmdArguments = catMaybes . map (\case ShellArgument x -> Just x; _ -> Nothing) . fromShellArguments . cmdExtArguments + +instance ExprType ShellScript where + textExprType _ = T.pack "ShellScript" + textExprValue _ = "<shell-script>" + +instance ExprType ShellStatement where + textExprType _ = T.pack "ShellStatement" + textExprValue _ = "<shell-statement>" + +instance ExprType ShellPipeline where + textExprType _ = T.pack "ShellPipeline" + textExprValue _ = "<shell-pipeline>" + +instance ExprType ShellCommand where + textExprType _ = T.pack "ShellCommand" + textExprValue _ = "<shell-command>" + +instance ExprType ShellArguments where + textExprType _ = T.pack "ShellArguments" + textExprValue _ = "<shell-arguments>" + exprExpansionConvFrom = shellExpansionTemplate + (Just (ShellArguments . (: []) . ShellArgument)) + (Just (ShellArguments . map ShellArgument)) + +instance ExprType ShellArgument where + textExprType _ = T.pack "ShellArgument" + textExprValue _ = "<shell-argument>" + exprExpansionConvFrom = shellExpansionTemplate (Just ShellArgument) Nothing + + +shellExpansionTemplate :: forall a b. (Typeable a, ExprType b) => Maybe (Text -> a) -> Maybe ([ Text ] -> a) -> Maybe (b -> a) +shellExpansionTemplate fromSingle fromList = listToMaybe $ catMaybes + [ single id + , single (T.pack . show @Integer) + , single (T.pack . show @Scientific) + , single textAssetPath + ] + where + single :: forall c. (ExprType c) => (c -> Text) -> Maybe (b -> a) + single conv = listToMaybe $ catMaybes + [ fromSingle >>= \f -> cast (f . conv) + , fromList >>= \f -> cast (f . map conv) + ] + + +data ShellExecInfo = ShellExecInfo + { seiNode :: Node + , seiProcName :: ProcName + , seiStatusVar :: MVar ExitCode + } + + +data HandleHandling + = CloseHandle Handle + | KeepHandle Handle + +closeIfRequested :: MonadIO m => HandleHandling -> m () +closeIfRequested (CloseHandle h) = liftIO $ hClose h +closeIfRequested (KeepHandle _) = return () + +handledHandle :: HandleHandling -> Handle +handledHandle (CloseHandle h) = h +handledHandle (KeepHandle h) = h + + +executeCommand :: ShellExecInfo -> ShellState -> HandleHandling -> HandleHandling -> HandleHandling -> ShellCommand -> TestRun ShellState +executeCommand sei@ShellExecInfo {..} st pstdin pstdout pstderr scmd@ShellCommand {..} = do + let args = cmdArguments scmd + ( pstdin', pstdout', pstderr' ) <- (\f -> foldM f ( pstdin, pstdout, pstderr ) (fromShellArguments cmdExtArguments)) $ \cur@( cin, cout, cerr ) -> \case + ShellRedirectStdin path -> do + closeIfRequested cin + h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) ReadMode + return ( CloseHandle h, cout, cerr ) + ShellRedirectStdout append path -> do + closeIfRequested cout + h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) $ if append then AppendMode else WriteMode + return ( cin, CloseHandle h, cerr ) + ShellRedirectStderr append path -> do + closeIfRequested cerr + h <- liftIO $ openBinaryFile (nodeDir seiNode </> T.unpack path) $ if append then AppendMode else WriteMode + return ( cin, cout, CloseHandle h ) + _ -> do + return cur + + ( getExitStatus, st' ) <- executeCommandProcess sei st (handledHandle pstdin') (handledHandle pstdout') (handledHandle pstderr') args cmdCommand + let failedWithStatus status = do + when (shellExitOnError st) $ do + liftIO $ putMVar seiStatusVar status + throwError Failed + return st' { shellLastExitCode = status } + + mapM_ closeIfRequested [ pstdin', pstdout', pstderr' ] + getExitStatus >>= \case + Exited ExitSuccess -> do + return st' { shellLastExitCode = ExitSuccess } + Exited status -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "failed at: " <> textSourceLine cmdSourceLine + failedWithStatus status + Terminated sig _ -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "killed with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine + failedWithStatus (ExitFailure (- fromIntegral sig)) + Stopped sig -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "stopped with " <> T.pack (show sig) <> " at: " <> textSourceLine cmdSourceLine + failedWithStatus (ExitFailure (- fromIntegral sig)) + + +executeCommandProcess :: ShellExecInfo -> ShellState -> Handle -> Handle -> Handle -> [ Text ] -> Text -> TestRun ( TestRun ProcessStatus, ShellState ) +executeCommandProcess sei@ShellExecInfo {..} st@ShellState {..} pstdin pstdout pstderr args = \case + "!" + | (cmd : args') <- args -> do + ( exit, st' ) <- executeCommandProcess sei st pstdin pstdout pstderr args' cmd + let exit' = exit >>= \case Exited ExitSuccess -> return (Exited (ExitFailure (-1))) + _ -> return (Exited ExitSuccess) + return ( exit', st' ) + + | [] <- args -> do + return ( return (Exited (ExitFailure (-1))), st ) + + "cd" + | [] <- args -> liftIO $ do + hPutStrLn pstdout (nodeDir seiNode) + return ( return (Exited ExitSuccess), st + { shellWorkingDirectory = nodeDir seiNode + , shellOldWorkingDirectory = shellWorkingDirectory + } ) + | [ "-" ] <- args -> liftIO $ do + hPutStrLn pstdout shellOldWorkingDirectory + return ( return (Exited ExitSuccess), st + { shellWorkingDirectory = shellOldWorkingDirectory + , shellOldWorkingDirectory = shellWorkingDirectory + } ) + | [ dir ] <- args -> liftIO $ do + cd <- canonicalizePath $ shellWorkingDirectory </> T.unpack dir + doesDirectoryExist cd >>= \case + True -> return ( return (Exited ExitSuccess), st + { shellWorkingDirectory = cd + , shellOldWorkingDirectory = shellWorkingDirectory + } ) + False -> do + hPutStrLn pstderr $ "cd: no such directory: " <> T.unpack dir + return ( return (Exited (ExitFailure (-1))), st ) + | otherwise -> do + liftIO $ hPutStrLn pstderr $ "cd: too many arguments" + return ( return (Exited (ExitFailure (-1))), st ) + + "pwd" + | [] <- args -> do + liftIO $ hPutStrLn pstdout shellWorkingDirectory + return ( return (Exited ExitSuccess), st ) + | otherwise -> do + liftIO $ hPutStrLn pstderr $ "pwd: too many arguments" + return ( return (Exited (ExitFailure (-1))), st ) + + "set" + | [ "+e" ] <- args -> do + return ( return (Exited ExitSuccess), st { shellExitOnError = False } ) + | [ "-e" ] <- args -> do + return ( return (Exited ExitSuccess), st { shellExitOnError = True } ) + | otherwise -> do + liftIO $ hPutStrLn pstderr $ "set: " <> T.unpack (T.unwords args) <> ": not implemented" + return ( return (Exited (ExitFailure (-1))), st ) + + cmd -> liftIO $ do + (_, _, _, phandle) <- createProcess_ "shell" + (proc (T.unpack cmd) (map T.unpack args)) + { std_in = UseHandle pstdin + , std_out = UseHandle pstdout + , std_err = UseHandle pstderr + , cwd = Just shellWorkingDirectory + , env = Just [] + } + Just pid <- getPid phandle + let getProcessStatus' = + liftIO (getProcessStatus True False pid) >>= \case + Just status -> return status + Nothing -> do + outLine OutputChildFail (Just $ textProcName seiProcName) $ "no exit status" + return (Exited (ExitFailure (-1))) + return ( getProcessStatus', st ) + + +executePipeline :: ShellExecInfo -> ShellState -> HandleHandling -> HandleHandling -> HandleHandling -> ShellPipeline -> TestRun ShellState +executePipeline sei st pstdin pstdout pstderr ShellPipeline {..} = do + case pipeUpstream of + Nothing -> do + executeCommand sei st pstdin pstdout pstderr pipeCommand + + Just upstream -> do + ( pipeRead, pipeWrite ) <- createPipeCloexec + void $ forkTestUsing forkOS $ do + void $ executePipeline sei st pstdin (CloseHandle pipeWrite) (KeepHandle $ handledHandle pstderr) upstream + + state' <- executeCommand sei st (CloseHandle pipeRead) pstdout (KeepHandle $ handledHandle pstderr) pipeCommand + closeIfRequested pstderr + return state' + +executeScript :: ShellExecInfo -> Handle -> Handle -> Handle -> ShellScript -> TestRun () +executeScript sei@ShellExecInfo {..} pstdin pstdout pstderr (ShellScript statements) = do + setNetworkNamespace $ getNetns seiNode + let initialState = ShellState + { shellWorkingDirectory = nodeDir seiNode + , shellOldWorkingDirectory = nodeDir seiNode + , shellExitOnError = True + , shellLastExitCode = ExitSuccess + } + finalState <- (\f -> foldM f initialState statements) $ \st ShellStatement {..} -> do + executePipeline sei st (KeepHandle pstdin) (KeepHandle pstdout) (KeepHandle pstderr) shellPipeline + + liftIO $ putMVar seiStatusVar (shellLastExitCode finalState) + +spawnShell :: Node -> ProcName -> ShellScript -> TestRun Process +spawnShell procNode procName script = do + idVar <- asks $ teNextProcId . fst + procId <- liftIO $ modifyMVar idVar (\x -> return ( x + 1, ProcessId x )) + + procOutput <- liftIO $ newTVarIO [] + procIgnore <- liftIO $ newTVarIO ( 0, [] ) + seiStatusVar <- liftIO $ newEmptyMVar + ( pstdin, procStdin ) <- createPipeCloexec + ( hout, pstdout ) <- createPipeCloexec + ( herr, pstderr ) <- createPipeCloexec + procHandle <- fmap (Right . (, seiStatusVar)) $ forkTestUsing forkOS $ do + let seiNode = procNode + seiProcName = procName + executeScript ShellExecInfo {..} pstdin pstdout pstderr script + liftIO $ do + hClose pstdin + hClose pstdout + hClose pstderr + + let procKillWith = Nothing + let procPid = Nothing + let process = Process {..} + + startProcessIOLoops process hout herr + return process + +withShellProcess :: Node -> ProcName -> ShellScript -> (Process -> TestRun a) -> TestRun a +withShellProcess node pname script inner = do + procVar <- asks $ teProcesses . fst + + process <- spawnShell node pname script + liftIO $ modifyMVar_ procVar $ return . (process:) + + inner process `finally` do + ps <- liftIO $ takeMVar procVar + closeTestProcess process `finally` do + liftIO $ putMVar procVar $ filter (/=process) ps + + +foreign import ccall "shell_pipe_cloexec" c_pipe_cloexec :: Ptr Fd -> IO CInt + +createPipeCloexec :: (MonadIO m, MonadFail m) => m ( Handle, Handle ) +createPipeCloexec = liftIO $ do + allocaArray 2 $ \ptr -> do + c_pipe_cloexec ptr >>= \case + 0 -> do + rh <- P.fdToHandle =<< peekElemOff ptr 0 + wh <- P.fdToHandle =<< peekElemOff ptr 1 + return ( rh, wh ) + _ -> do + fail $ "failed to create pipe" diff --git a/src/Script/Var.hs b/src/Script/Var.hs new file mode 100644 index 0000000..a3620f4 --- /dev/null +++ b/src/Script/Var.hs @@ -0,0 +1,78 @@ +module Script.Var ( + VarName(..), textVarName, unpackVarName, + FqVarName(..), textFqVarName, unpackFqVarName, unqualifyName, + TypedVarName(..), + ModuleName(..), textModuleName, + TestName(..), textTestName, + SourceLine(..), textSourceLine, +) where + +import Data.Text (Text) +import Data.Text qualified as T + +import Script.Expr.Class + + +newtype VarName = VarName Text + deriving (Eq, Ord) + +textVarName :: VarName -> Text +textVarName (VarName name) = name + +unpackVarName :: VarName -> String +unpackVarName = T.unpack . textVarName + + +data FqVarName + = GlobalVarName ModuleName VarName + | LocalVarName VarName + deriving (Eq, Ord) + +textFqVarName :: FqVarName -> Text +textFqVarName (GlobalVarName mname vname) = textModuleName mname <> "." <> textVarName vname +textFqVarName (LocalVarName vname) = textVarName vname + +unpackFqVarName :: FqVarName -> String +unpackFqVarName = T.unpack . textFqVarName + +unqualifyName :: FqVarName -> VarName +unqualifyName (GlobalVarName _ name) = name +unqualifyName (LocalVarName name) = name + + +newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName } + deriving (Eq, Ord) + +instance ExprType a => ExprType (TypedVarName a) where + textExprType _ = "TypedVarName" + textExprValue = textVarName . fromTypedVarName + + +newtype ModuleName = ModuleName [ Text ] + deriving (Eq, Ord, Show) + +textModuleName :: ModuleName -> Text +textModuleName (ModuleName parts) = T.intercalate "." parts + + +data TestName = TestName + { testNameModule :: ModuleName + , testNameBase :: Text + } + deriving (Eq, Ord) + +textTestName :: TestName -> Text +textTestName (TestName (ModuleName mparts) base) = T.intercalate "." (mparts ++ [ base ]) + + +data SourceLine + = SourceLine Text + | SourceLineBuiltin + +textSourceLine :: SourceLine -> Text +textSourceLine (SourceLine text) = text +textSourceLine SourceLineBuiltin = "<builtin>" + +instance ExprType SourceLine where + textExprType _ = "SourceLine" + textExprValue = textSourceLine diff --git a/src/Test.hs b/src/Test.hs index 719e3e2..26f5bff 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,340 +1,104 @@ module Test ( - Module(..), Test(..), + Tag(..), TestStep(..), TestBlock(..), - SourceLine(..), - MonadEval(..), - VarName(..), TypedVarName(..), textVarName, unpackVarName, - ExprType(..), SomeExpr(..), - TypeVar(..), SomeExprType(..), someExprType, textSomeExprType, - FunctionType, DynamicType, - SomeVarValue(..), fromSomeVarValue, textSomeVarValue, someVarValueType, - RecordSelector(..), - ExprListUnpacker(..), - ExprEnumerator(..), - Expr(..), eval, gatherVars, evalSome, - AppAnnotation(..), - - ArgumentKeyword(..), FunctionArguments(..), - anull, exprArgs, - SomeArgumentType(..), ArgumentType(..), - - Regex(RegexPart, RegexString), regexMatch, + MultiplyTimeout(..), ) where -import Control.Monad +import Control.Concurrent.MVar +import Control.Monad.Except +import Control.Monad.Reader -import Data.Char -import Data.List -import Data.Map (Map) -import Data.Map qualified as M +import Data.Bifunctor import Data.Scientific -import Data.String -import Data.Text (Text) -import Data.Text qualified as T +import Data.Text (Text, pack) import Data.Typeable -import Text.Regex.TDFA qualified as RE -import Text.Regex.TDFA.Text qualified as RE - -import {-# SOURCE #-} Network -import {-# SOURCE #-} Process -import Util - -data Module = Module - { moduleName :: [ Text ] - , moduleTests :: [ Test ] - } +import Network +import Output +import Process +import Run.Monad +import Script.Expr +import Script.Object +import Script.Shell data Test = Test - { testName :: Text - , testSteps :: [TestStep] + { testName :: TestName + , testTags :: [ Expr Tag ] + , testSteps :: Expr (TestStep ()) } -newtype TestBlock = TestBlock [ TestStep ] - -data TestStep = forall a. ExprType a => Let SourceLine (TypedVarName a) (Expr a) [TestStep] - | forall a. ExprType a => For SourceLine (TypedVarName a) (Expr [a]) [TestStep] - | ExprStatement (Expr TestBlock) - | Subnet (TypedVarName Network) (Expr Network) [TestStep] - | DeclNode (TypedVarName Node) (Expr Network) [TestStep] - | Spawn (TypedVarName Process) (Either (Expr Network) (Expr Node)) [TestStep] - | Send (Expr Process) (Expr Text) - | Expect SourceLine (Expr Process) (Expr Regex) [TypedVarName Text] [TestStep] - | Flush (Expr Process) (Maybe (Expr Regex)) - | Guard SourceLine (Expr Bool) - | DisconnectNode (Expr Node) [TestStep] - | DisconnectNodes (Expr Network) [TestStep] - | DisconnectUpstream (Expr Network) [TestStep] - | PacketLoss (Expr Scientific) (Expr Node) [TestStep] - | Wait - -newtype SourceLine = SourceLine Text - - -class MonadFail m => MonadEval m where - lookupVar :: VarName -> m SomeVarValue - rootNetwork :: m Network - - -newtype VarName = VarName Text - deriving (Eq, Ord, Show) - -newtype TypedVarName a = TypedVarName { fromTypedVarName :: VarName } - deriving (Eq, Ord) - -textVarName :: VarName -> Text -textVarName (VarName name ) = name - -unpackVarName :: VarName -> String -unpackVarName = T.unpack . textVarName - - -class Typeable a => ExprType a where - textExprType :: proxy a -> Text - textExprValue :: a -> Text - - recordMembers :: [(Text, RecordSelector a)] - recordMembers = [] - - exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a) - exprListUnpacker _ = Nothing - - exprEnumerator :: proxy a -> Maybe (ExprEnumerator a) - exprEnumerator _ = Nothing - -instance ExprType Integer where - textExprType _ = T.pack "integer" - textExprValue x = T.pack (show x) - - exprEnumerator _ = Just $ ExprEnumerator enumFromTo enumFromThenTo - -instance ExprType Scientific where - textExprType _ = T.pack "number" - textExprValue x = T.pack (show x) - -instance ExprType Bool where - textExprType _ = T.pack "bool" - textExprValue True = T.pack "true" - textExprValue False = T.pack "false" - -instance ExprType Text where - textExprType _ = T.pack "string" - textExprValue x = T.pack (show x) - -instance ExprType Regex where - textExprType _ = T.pack "regex" - textExprValue _ = T.pack "<regex>" - -instance ExprType a => ExprType [a] where - textExprType _ = "[" <> textExprType @a Proxy <> "]" - textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]" - - exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy) - -instance ExprType TestBlock where - textExprType _ = "test block" - textExprValue _ = "<test block>" - - -data FunctionType a = FunctionType (FunctionArguments SomeExpr -> a) - -instance ExprType a => ExprType (FunctionType a) where - textExprType _ = "function type" - textExprValue _ = "<function type>" - -data DynamicType - -instance ExprType DynamicType where - textExprType _ = "ambiguous type" - textExprValue _ = "<dynamic type>" - -data SomeExpr = forall a. ExprType a => SomeExpr (Expr a) - -newtype TypeVar = TypeVar Text - deriving (Eq, Ord) - -data SomeExprType - = forall a. ExprType a => ExprTypePrim (Proxy a) - | ExprTypeVar TypeVar - | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a) - -someExprType :: SomeExpr -> SomeExprType -someExprType (SomeExpr (DynVariable tvar _ _)) = ExprTypeVar tvar -someExprType (SomeExpr fun@(FunVariable params _ _)) = ExprTypeFunction params (proxyOfFunctionType fun) - where - proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a - proxyOfFunctionType _ = Proxy -someExprType (SomeExpr (_ :: Expr a)) = ExprTypePrim (Proxy @a) - -textSomeExprType :: SomeExprType -> Text -textSomeExprType (ExprTypePrim p) = textExprType p -textSomeExprType (ExprTypeVar (TypeVar name)) = name -textSomeExprType (ExprTypeFunction _ r) = "function:" <> textExprType r - - -data SomeVarValue = forall a. ExprType a => SomeVarValue (FunctionArguments SomeArgumentType) (SourceLine -> FunctionArguments SomeExpr -> a) - -fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m a -fromSomeVarValue sline name (SomeVarValue args (value :: SourceLine -> args -> b)) = do - maybe (fail err) return $ do - guard $ anull args - cast $ value sline mempty - where - err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", - if anull args then textExprType @b Proxy else "function type" ] - -textSomeVarValue :: SourceLine -> SomeVarValue -> Text -textSomeVarValue sline (SomeVarValue args value) - | anull args = textExprValue $ value sline mempty - | otherwise = "<function>" - -someVarValueType :: SomeVarValue -> SomeExprType -someVarValueType (SomeVarValue args (_ :: SourceLine -> args -> a)) - | anull args = ExprTypePrim (Proxy @a) - | otherwise = ExprTypeFunction args (Proxy @a) - - -data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b) - -data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e) - -data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) - - -data Expr a where - Variable :: ExprType a => SourceLine -> VarName -> Expr a - DynVariable :: TypeVar -> SourceLine -> VarName -> Expr DynamicType - FunVariable :: ExprType a => FunctionArguments SomeArgumentType -> SourceLine -> VarName -> Expr (FunctionType a) - ArgsApp :: FunctionArguments SomeExpr -> Expr (FunctionType a) -> Expr (FunctionType a) - FunctionEval :: Expr (FunctionType a) -> Expr a - Pure :: a -> Expr a - App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b - Concat :: [Expr Text] -> Expr Text - Regex :: [Expr Regex] -> Expr Regex - RootNetwork :: Expr Network - Undefined :: String -> Expr a - -data AppAnnotation b = AnnNone - | ExprType b => AnnRecord Text - -instance Functor Expr where - fmap f x = Pure f <*> x - -instance Applicative Expr where - pure = Pure - (<*>) = App AnnNone - -eval :: MonadEval m => Expr a -> m a -eval (Variable sline name) = fromSomeVarValue sline name =<< lookupVar name -eval (DynVariable _ _ _) = fail "ambiguous type" -eval (FunVariable _ sline name) = funFromSomeVarValue sline name =<< lookupVar name -eval (ArgsApp args efun) = do - FunctionType fun <- eval efun - return $ FunctionType $ \args' -> fun (args <> args') -eval (FunctionEval efun) = do - FunctionType fun <- eval efun - return $ fun mempty -eval (Pure value) = return value -eval (App _ f x) = eval f <*> eval x -eval (Concat xs) = T.concat <$> mapM eval xs -eval (Regex xs) = mapM eval xs >>= \case - [re@RegexCompiled {}] -> return re - parts -> case regexCompile $ T.concat $ map regexSource parts of - Left err -> fail err - Right re -> return re -eval (RootNetwork) = rootNetwork -eval (Undefined err) = fail err - -evalSome :: MonadEval m => SomeExpr -> m SomeVarValue -evalSome (SomeExpr expr) = SomeVarValue mempty . const . const <$> eval expr - -gatherVars :: forall a m. MonadEval m => Expr a -> m [((VarName, [Text]), SomeVarValue)] -gatherVars = fmap (uniqOn fst . sortOn fst) . helper - where - helper :: forall b. Expr b -> m [((VarName, [Text]), SomeVarValue)] - helper (Variable _ var) = (:[]) . ((var, []),) <$> lookupVar var - helper (DynVariable _ _ var) = (:[]) . ((var, []),) <$> lookupVar var - helper (FunVariable _ _ var) = (:[]) . ((var, []),) <$> lookupVar var - helper (ArgsApp (FunctionArguments args) fun) = do - v <- helper fun - vs <- mapM (\(SomeExpr e) -> helper e) $ M.elems args - return $ concat (v : vs) - helper (FunctionEval efun) = helper efun - helper (Pure _) = return [] - helper e@(App (AnnRecord sel) _ x) - | Just (var, sels) <- gatherSelectors x - = do val <- SomeVarValue mempty . const . const <$> eval e - return [((var, sels ++ [sel]), val)] - | otherwise = helper x - helper (App _ f x) = (++) <$> helper f <*> helper x - helper (Concat es) = concat <$> mapM helper es - helper (Regex es) = concat <$> mapM helper es - helper (RootNetwork) = return [] - helper (Undefined {}) = return [] - - gatherSelectors :: forall b. Expr b -> Maybe (VarName, [Text]) - gatherSelectors = \case - Variable _ var -> Just (var, []) - App (AnnRecord sel) _ x -> do - (var, sels) <- gatherSelectors x - return (var, sels ++ [sel]) - _ -> Nothing - - -newtype ArgumentKeyword = ArgumentKeyword Text - deriving (Show, Eq, Ord, IsString) - -newtype FunctionArguments a = FunctionArguments (Map (Maybe ArgumentKeyword) a) - deriving (Show, Semigroup, Monoid) - -anull :: FunctionArguments a -> Bool -anull (FunctionArguments args) = M.null args - -exprArgs :: Expr (FunctionType a) -> FunctionArguments SomeArgumentType -exprArgs (FunVariable args _ _) = args -exprArgs (ArgsApp (FunctionArguments applied) expr) = - let FunctionArguments args = exprArgs expr - in FunctionArguments (args `M.difference` applied) -exprArgs _ = error "exprArgs on unexpected type" - -funFromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => SourceLine -> VarName -> SomeVarValue -> m (FunctionType a) -funFromSomeVarValue sline name (SomeVarValue args (value :: SourceLine -> args -> b)) = do - maybe (fail err) return $ do - guard $ not $ anull args - FunctionType <$> cast (value sline) - where - err = T.unpack $ T.concat [ T.pack "expected function returning ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has ", - (if anull args then "type" else "function type returting ") <> textExprType @b Proxy ] - -data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a) - -data ArgumentType a - = RequiredArgument - | OptionalArgument - | ExprDefault (Expr a) - | ContextDefault - - -data Regex = RegexCompiled Text RE.Regex - | RegexPart Text - | RegexString Text - -regexCompile :: Text -> Either String Regex -regexCompile src = either Left (Right . RegexCompiled src) $ RE.compile RE.defaultCompOpt RE.defaultExecOpt $ - T.singleton '^' <> src <> T.singleton '$' - -regexMatch :: Regex -> Text -> Either String (Maybe (Text, Text, Text, [Text])) -regexMatch (RegexCompiled _ re) text = RE.regexec re text -regexMatch _ _ = Left "regex not compiled" - -regexSource :: Regex -> Text -regexSource (RegexCompiled src _) = src -regexSource (RegexPart src) = src -regexSource (RegexString str) = T.concatMap escapeChar str - where - escapeChar c | isAlphaNum c = T.singleton c - | c `elem` ['`', '\'', '<', '>'] = T.singleton c - | otherwise = T.pack ['\\', c] +instance ExprType Test where + textExprType _ = "Test" + textExprValue _ = "<test>" + +data Tag = Tag ModuleName VarName + deriving (Eq) + +instance ExprType Tag where + textExprType _ = "Tag" + textExprValue (Tag mname vname) = "<tag:" <> textModuleName mname <> "." <> textVarName vname <> ">" + +data TestBlock a where + EmptyTestBlock :: TestBlock () + TestBlockStep :: TestBlock () -> TestStep a -> TestBlock a + +instance Semigroup (TestBlock ()) where + EmptyTestBlock <> block = block + block <> EmptyTestBlock = block + block <> TestBlockStep block' step = TestBlockStep (block <> block') step + +instance Monoid (TestBlock ()) where + mempty = EmptyTestBlock + +data TestStep a where + Scope :: TestBlock a -> TestStep a + CreateObject :: forall o. ObjectType TestRun o => Proxy o -> ConstructorArgs o -> TestStep () + Subnet :: TypedVarName Network -> Network -> (Network -> TestStep a) -> TestStep a + DeclNode :: TypedVarName Node -> Network -> (Node -> TestStep a) -> TestStep a + Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> Maybe Signal -> (Process -> TestStep a) -> TestStep a + SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a + Send :: Process -> Text -> TestStep () + Expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a + Flush :: Process -> Maybe Regex -> TestStep () + Guard :: CallStack -> Bool -> TestStep () + DisconnectNode :: Node -> TestStep a -> TestStep a + DisconnectNodes :: Network -> TestStep a -> TestStep a + DisconnectUpstream :: Network -> TestStep a -> TestStep a + PacketLoss :: Scientific -> Node -> TestStep a -> TestStep a + Wait :: TestStep () + +instance ExprType a => ExprType (TestBlock a) where + textExprType _ = "TestBlock" + textExprValue _ = "<test-block>" + +instance ExprType a => ExprType (TestStep a) where + textExprType _ = "TestStep" + textExprValue _ = "<test-step>" + + +data MultiplyTimeout = MultiplyTimeout Scientific + +instance ObjectType TestRun MultiplyTimeout where + type ConstructorArgs MultiplyTimeout = Scientific + + textObjectType _ _ = "MultiplyTimeout" + textObjectValue _ (MultiplyTimeout x) = pack (show x) <> "@MultiplyTimeout" + + createObject oid timeout + | timeout >= 0 = do + var <- asks (teTimeout . fst) + liftIO $ modifyMVar_ var $ return . + (if timeout == 0 then second (+ 1) else first (* timeout)) + return $ Object oid $ MultiplyTimeout timeout + + | otherwise = do + outLine OutputError Nothing "timeout must not be negative" + throwError Failed + + destroyObject Object { objImpl = MultiplyTimeout timeout } = do + var <- asks (teTimeout . fst) + liftIO $ modifyMVar_ var $ return . + (if timeout == 0 then second (subtract 1) else first (/ timeout)) diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs index 6c6c2f0..85f7b86 100644 --- a/src/Test/Builtins.hs +++ b/src/Test/Builtins.hs @@ -3,50 +3,86 @@ module Test.Builtins ( ) where import Data.Map qualified as M -import Data.Maybe +import Data.Proxy +import Data.Scientific import Data.Text (Text) -import Data.Typeable +import Data.Text qualified as T -import Process (Process) +import Process +import Process.Signal +import Script.Expr import Test -builtins :: [ ( VarName, SomeVarValue ) ] -builtins = - [ ( VarName "send", builtinSend ) - , ( VarName "flush", builtinFlush ) - , ( VarName "guard", builtinGuard ) - , ( VarName "wait", builtinWait ) +builtins :: GlobalDefs +builtins = M.fromList $ concat + [ [ fq "send" builtinSend + , fq "flush" builtinFlush + , fq "ignore" builtinIgnore + , fq "guard" builtinGuard + , fq "multiply_timeout" builtinMultiplyTimeout + , fq "wait" builtinWait + , fq "concat" builtinConcat + ] + , map (uncurry fq) signalBuiltins ] + where + fq name impl = (( ModuleName [ "$" ], VarName name ), impl ) + +biVar :: ExprType a => Text -> Expr a +biVar = Variable SourceLineBuiltin . LocalVarName . VarName -getArg :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> (Expr a) -getArg args = fromMaybe (error "parameter mismatch") . getArgMb args +biOpt :: ExprType a => Text -> Expr (Maybe a) +biOpt = OptVariable SourceLineBuiltin . LocalVarName . VarName -getArgMb :: Typeable a => FunctionArguments SomeExpr -> Maybe ArgumentKeyword -> Maybe (Expr a) -getArgMb (FunctionArguments args) kw = do - SomeExpr expr <- M.lookup kw args - cast expr +biArgs :: [ ( Maybe ArgumentKeyword, a ) ] -> FunctionArguments ( VarName, a ) +biArgs = FunctionArguments . M.fromList . map (\( kw, atype ) -> ( kw, ( VarName $ maybe "$0" (\(ArgumentKeyword tkw) -> "$" <> tkw) kw, atype ) )) + +builtinSend :: SomeExpr +builtinSend = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Send <$> biVar "$to" <*> biVar "$0") + where + atypes = + [ ( Just "to", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) ) + , ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Text)) ) + ] -builtinSend :: SomeVarValue -builtinSend = SomeVarValue (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Send (getArg args (Just "to")) (getArg args Nothing) ] +builtinFlush :: SomeExpr +builtinFlush = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Flush <$> biVar "$from" <*> biOpt "$matching") where atypes = - [ ( Just "to", SomeArgumentType (ContextDefault @Process) ) - , ( Nothing, SomeArgumentType (RequiredArgument @Text) ) + [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) ) + , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) ) ] -builtinFlush :: SomeVarValue -builtinFlush = SomeVarValue (FunctionArguments $ M.fromList atypes) $ - \_ args -> TestBlock [ Flush (getArg args (Just "from")) (getArgMb args Nothing) ] +builtinIgnore :: SomeExpr +builtinIgnore = SomeExpr $ ArgsReq (biArgs atypes) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @IgnoreProcessOutput) <$> ((,) <$> biVar "$from" <*> biOpt "$matching")) where atypes = - [ ( Just "from", SomeArgumentType (ContextDefault @Process) ) - , ( Nothing, SomeArgumentType (OptionalArgument @Regex) ) + [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) ) + , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) ) ] -builtinGuard :: SomeVarValue -builtinGuard = SomeVarValue (FunctionArguments $ M.singleton Nothing (SomeArgumentType (RequiredArgument @Bool))) $ - \sline args -> TestBlock [ Guard sline (getArg args Nothing) ] +builtinGuard :: SomeExpr +builtinGuard = SomeExpr $ + ArgsReq (biArgs [ ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Bool)) ) ]) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Guard <$> Variable SourceLineBuiltin callStackFqVarName <*> biVar "$0") + +builtinMultiplyTimeout :: SomeExpr +builtinMultiplyTimeout = SomeExpr $ ArgsReq (biArgs $ [ ( Just "by", SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Scientific)) ) ]) $ + FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @MultiplyTimeout) <$> biVar "$by") + +builtinWait :: SomeExpr +builtinWait = SomeExpr $ Pure $ TestBlockStep EmptyTestBlock Wait -builtinWait :: SomeVarValue -builtinWait = SomeVarValue mempty $ const . const $ TestBlock [ Wait ] +builtinConcat :: SomeExpr +builtinConcat = SomeExpr $ TypeLambda (TypeVar "a") + (ExprTypeFunction + (ExprTypeArguments $ FunctionArguments $ M.singleton Nothing $ SomeArgumentType RequiredArgument + (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar (TypeVar "a") ] ] )) + (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar (TypeVar "a") ]) + ) $ \case + ExprTypePrim (pa :: Proxy a) -> HideFunType (FunctionArguments $ M.singleton Nothing $ SomeArgumentType RequiredArgument (ExprTypePrim (Proxy :: Proxy [[ a ]]))) $ + ArgsReq (biArgs [ ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim pa) ) ]) $ FunctionAbstraction $ (concat :: [[ a ]] -> [ a ]) <$> biVar "$0" + t -> Undefined ("ambiguous type ‘" <> T.unpack (textSomeExprType t) <> "’ for concat") :: Expr DynamicType diff --git a/src/TestMode.hs b/src/TestMode.hs new file mode 100644 index 0000000..2ccf5a4 --- /dev/null +++ b/src/TestMode.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE CPP #-} + +module TestMode ( + testMode, +) where + +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State + +import Data.List +import Data.Maybe +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T + +import System.IO.Error + +import Text.Megaparsec.Error +import Text.Megaparsec.Pos + +import Config +import Output +import Parser +import Run.Builtins +import Script.Expr +import Test + + +data TestModeInput = TestModeInput + { tmiOutput :: Output + , tmiConfig :: Maybe Config + , tmiParams :: [ Text ] + } + +data TestModeState = TestModeState + { tmsModules :: Maybe LoadedModules + , tmsNextTestNumber :: Int + } + +initTestModeState :: TestModeState +initTestModeState = TestModeState + { tmsModules = Nothing + , tmsNextTestNumber = 1 + } + +testMode :: Maybe Config -> IO () +testMode tmiConfig = do + tmiOutput <- startOutput OutputStyleTest False + let testLoop = getLineMb >>= \case + Just line -> do + case T.words line of + cname : tmiParams + | Just (CommandM cmd) <- lookup cname commands -> do + runReaderT cmd $ TestModeInput {..} + | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'" + [] -> return () + testLoop + + Nothing -> return () + + runExceptT (evalStateT testLoop initTestModeState) >>= \case + Left err -> flip runReaderT tmiOutput $ outLine OutputError Nothing $ T.pack err + Right () -> return () + +getLineMb :: MonadIO m => m (Maybe Text) +getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) + +cmdOut :: Text -> Command +cmdOut line = do + out <- asks tmiOutput + flip runReaderT out $ outLine OutputTestRaw Nothing line + +getNextTestNumber :: CommandM Int +getNextTestNumber = do + num <- gets tmsNextTestNumber + modify $ \s -> s { tmsNextTestNumber = num + 1 } + return num + +runTestsC :: [ Test ] -> CommandM Report +runTestsC tests = do + out <- asks tmiOutput + num <- getNextTestNumber + Just LoadedModules {..} <- gets tmsModules + mbconfig <- asks tmiConfig + let opts = defaultTestOptions + { optDefaultTool = fromMaybe "/bin/true" $ configTool =<< mbconfig + , optTestDir = ".test" <> show num + , optKeep = True + , optKeepGoing = True + , optHookTestResult = \tname res -> do + flip runReaderT out $ outLine OutputTestRaw Nothing $ + "run-test-result " <> testNameBase tname <> " " <> (if res then "done" else "failed") + } + liftIO (runTests out opts lmGlobalDefs tests) + + +newtype CommandM a = CommandM (ReaderT TestModeInput (StateT TestModeState (ExceptT String IO)) a) + deriving + ( Functor, Applicative, Monad, MonadIO + , MonadReader TestModeInput, MonadState TestModeState, MonadError String + ) + +instance MonadFail CommandM where + fail = throwError + +type Command = CommandM () + +commands :: [ ( Text, Command ) ] +commands = + [ ( "load", cmdLoad ) + , ( "load-config", cmdLoadConfig ) + , ( "run", cmdRun ) + ] + +showError :: Text -> CustomTestError -> Command +showError prefix = \case + ModuleNotFound moduleName -> do + cmdOut $ prefix <> " module-not-found" <> textModuleName moduleName + FileNotFound notFoundPath -> do + cmdOut $ prefix <> " file-not-found " <> T.pack notFoundPath + TestNotFound tname mbfile -> do + cmdOut $ prefix <> " test-not-found " <> tname <> maybe "" ((" " <>) . T.pack) mbfile + TestOrTagNotFound tname mbfile -> do + cmdOut $ prefix <> " test-or-tag-not-found " <> tname <> maybe "" ((" " <>) . T.pack) mbfile + ImportModuleError bundle -> do +#if MIN_VERSION_megaparsec(9,7,0) + mapM_ (cmdOut . T.pack) $ lines $ errorBundlePrettyWith showParseError bundle +#endif + cmdOut $ prefix <> " parse-error" + where + showParseError _ SourcePos {..} _ = concat + [ "parse-error" + , " ", sourceName + , ":", show $ unPos sourceLine + , ":", show $ unPos sourceColumn + ] + +cmdLoad :: Command +cmdLoad = do + [ path ] <- asks tmiParams + liftIO (loadModules [ ( T.unpack path, Nothing ) ]) >>= \case + Right modules -> do + modify $ \s -> s { tmsModules = Just modules } + cmdOut "load-done" + Left err -> showError "load-failed" err + +cmdLoadConfig :: Command +cmdLoadConfig = do + Just config <- asks tmiConfig + liftIO (getConfigTestFiles config >>= loadModules . (map (, Nothing ))) >>= \case + Right modules -> do + modify $ \s -> s { tmsModules = Just modules } + cmdOut "load-config-done" + Left err -> showError "load-config-failed" err + +cmdRun :: Command +cmdRun = do + params <- asks tmiParams + let ( select, exclude ) = fmap (map (T.drop 1)) $ partition (("^" /=) . T.take 1) params + pfilter = (TestFilter (if select == [ "*" ] then Nothing else Just select) exclude) + cfilter <- asks $ maybe mempty testFilterFromConfig . tmiConfig + Just lm <- gets tmsModules + case filterTests (cfilter <> pfilter) lm of + Left err -> showError "run-failed" err + Right tests -> do + Report {..} <- runTestsC tests + cmdOut $ T.unwords + [ "run-done" + , T.pack (show reportTotalCount) + , T.pack (show reportPassedCount) + , T.pack (show reportSkippedCount) + , T.pack (show reportFailedCount) + ] diff --git a/src/TextFormat.hs b/src/TextFormat.hs new file mode 100644 index 0000000..7b8152f --- /dev/null +++ b/src/TextFormat.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TextFormat ( + FormattedText, + plainText, + + TextStyle, + withStyle, noStyle, + + Color(..), + setForegroundColor, setBackgroundColor, + + endWithNewline, + + renderPlainText, + formattedTextLength, + formattedTextHeight, +) where + +import Data.Text (Text) +import Data.Text qualified as T + +import TextFormat.Types + + +plainText :: Text -> FormattedText +plainText = PlainText + + +withStyle :: TextStyle -> FormattedText -> FormattedText +withStyle = FormattedText + +noStyle :: TextStyle +noStyle = CustomTextColor Nothing Nothing + +setForegroundColor :: Color -> TextStyle -> TextStyle +setForegroundColor color (CustomTextColor _ bg) = CustomTextColor (Just color) bg + +setBackgroundColor :: Color -> TextStyle -> TextStyle +setBackgroundColor color (CustomTextColor fg _) = CustomTextColor fg (Just color) + + +endWithNewline :: FormattedText -> FormattedText +endWithNewline = EndWithNewline + + +renderPlainText :: FormattedText -> Text +renderPlainText = \case + PlainText text -> text + ConcatenatedText ftexts -> mconcat $ map renderPlainText ftexts + FormattedText _ ftext -> renderPlainText ftext + EndWithNewline ftext -> let res = renderPlainText ftext + in case T.unsnoc res of + Just ( _, '\n') -> res + _ -> res <> "\n" + +formattedTextLength :: FormattedText -> Int +formattedTextLength = \case + PlainText text -> T.length text + ConcatenatedText ftexts -> sum $ map formattedTextLength ftexts + FormattedText _ ftext -> formattedTextLength ftext + EndWithNewline ftext -> formattedTextLength ftext + +formattedTextHeight :: FormattedText -> Int +formattedTextHeight = countLines . collectParts + where + collectParts = \case + PlainText text -> [ text ] + ConcatenatedText ftexts -> concatMap collectParts ftexts + FormattedText _ ftext -> collectParts ftext + EndWithNewline ftext -> collectParts ftext + countLines (t : ts) + | T.null t = countLines ts + | otherwise = 1 + countLines (dropLine (t : ts)) + countLines [] = 0 + dropLine (t : ts) + | Just ( '\n', t' ) <- T.uncons (T.dropWhile (/= '\n') t) = t' : ts + | otherwise = dropLine ts + dropLine [] = [] diff --git a/src/TextFormat/Ansi.hs b/src/TextFormat/Ansi.hs new file mode 100644 index 0000000..0e8d030 --- /dev/null +++ b/src/TextFormat/Ansi.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TextFormat.Ansi ( + FormattedText, + + AnsiText(..), + renderAnsiText, +) where + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Writer + +import Data.String +import Data.Text (Text) +import Data.Text qualified as T + +import TextFormat.Types + + +newtype AnsiText = AnsiText { fromAnsiText :: Text } + deriving (Eq, Ord, Semigroup, Monoid, IsString) + + +data RenderState = RenderState + { rsEndedWithNewline :: Bool + } + +initialRenderState :: RenderState +initialRenderState = RenderState + { rsEndedWithNewline = True + } + +renderAnsiText :: FormattedText -> AnsiText +renderAnsiText ft = AnsiText $ T.concat $ execWriter $ flip evalStateT initialRenderState $ go ( Nothing, Nothing ) ft + where + go :: ( Maybe Color, Maybe Color ) -> FormattedText -> StateT RenderState (Writer [ Text ]) () + go cur@( cfg, cbg ) = \case + PlainText text -> do + tell [ text ] + case T.unsnoc text of + Just ( _, c ) -> modify (\s -> s { rsEndedWithNewline = c == '\n' }) + Nothing -> return () + ConcatenatedText ftexts -> mconcat <$> mapM (go cur) ftexts + FormattedText (CustomTextColor fg bg) ftext -> do + tell [ ansiColor fg bg ] + go ( fg <|> cfg, bg <|> cbg ) ftext + tell [ ansiColor + (if fg /= cfg then cfg <|> Just DefaultColor else Nothing) + (if bg /= cbg then cbg <|> Just DefaultColor else Nothing) + ] + EndWithNewline ftext -> do + go cur ftext + gets rsEndedWithNewline >>= \case + True -> return () + False -> tell [ "\n" ] >> modify (\s -> s { rsEndedWithNewline = True }) + + +ansiColor :: Maybe Color -> Maybe Color -> Text +ansiColor Nothing Nothing = "" +ansiColor (Just fg) Nothing = "\ESC[" <> T.pack (show (colorNum fg)) <> "m" +ansiColor Nothing (Just bg) = "\ESC[" <> T.pack (show (colorNum bg + 10)) <> "m" +ansiColor (Just fg) (Just bg) = "\ESC[" <> T.pack (show (colorNum fg)) <> ";" <> T.pack (show (colorNum bg + 10)) <> "m" + +colorNum :: Color -> Int +colorNum = \case + DefaultColor -> 39 + Black -> 30 + Red -> 31 + Green -> 32 + Yellow -> 33 + Blue -> 34 + Magenta -> 35 + Cyan -> 36 + White -> 37 + BrightBlack -> 90 + BrightRed -> 91 + BrightGreen -> 92 + BrightYellow -> 93 + BrightBlue -> 94 + BrightMagenta -> 95 + BrightCyan -> 96 + BrightWhite -> 97 diff --git a/src/TextFormat/Types.hs b/src/TextFormat/Types.hs new file mode 100644 index 0000000..40deabd --- /dev/null +++ b/src/TextFormat/Types.hs @@ -0,0 +1,58 @@ +module TextFormat.Types ( + FormattedText(..), + TextStyle(..), + Color(..), +) where + +import Data.String +import Data.Text (Text) + + +data FormattedText + = PlainText Text + | ConcatenatedText [ FormattedText ] + | FormattedText TextStyle FormattedText + | EndWithNewline FormattedText + +instance IsString FormattedText where + fromString = PlainText . fromString + +instance Semigroup FormattedText where + ConcatenatedText xs <> ConcatenatedText ys = ConcatenatedText (xs ++ ys) + x <> ConcatenatedText ys = ConcatenatedText (x : ys) + ConcatenatedText xs <> y = ConcatenatedText (xs ++ [ y ]) + x <> y = ConcatenatedText [ x, y ] + +instance Monoid FormattedText where + mempty = ConcatenatedText [] + mconcat [] = ConcatenatedText [] + mconcat [ x ] = x + mconcat xs = ConcatenatedText $ concatMap flatten xs + where + flatten (ConcatenatedText ys) = ys + flatten y = [ y ] + + +data TextStyle + = CustomTextColor (Maybe Color) (Maybe Color) + + +data Color + = DefaultColor + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + | BrightBlack + | BrightRed + | BrightGreen + | BrightYellow + | BrightBlue + | BrightMagenta + | BrightCyan + | BrightWhite + deriving (Eq) diff --git a/src/Wrapper.hs b/src/Wrapper.hs deleted file mode 100644 index 544e37c..0000000 --- a/src/Wrapper.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Main where - -import Control.Monad - -import GHC.Environment - -import System.Directory -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" - - epath <- takeDirectory <$> getExecutablePath -- directory containing executable - fpath <- map takeDirectory . filter (any isPathSeparator) . take 1 <$> getFullArgs - -- directory used for invocation, can differ from above for symlinked executable - - let dirs = concat - [ [ epath ] - , [ epath </> "../../../erebos-tester-core/build/erebos-tester-core" ] - , fpath - ] - - args <- getArgs - mapM_ (\file -> executeFile file False args Nothing) =<< - findExecutablesInDirectories dirs "erebos-tester-core" - when (null fpath) $ - mapM_ (\file -> executeFile file False args Nothing) =<< - findExecutables "erebos-tester-core" - - fail "core binary not found" diff --git a/src/main.c b/src/main.c new file mode 100644 index 0000000..9a6abcb --- /dev/null +++ b/src/main.c @@ -0,0 +1,203 @@ +#include "HsFFI.h" + +#if defined(__GLASGOW_HASKELL__) +#include "Main_stub.h" +#endif + +#include <errno.h> +#include <fcntl.h> +#include <sched.h> +#include <stdbool.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <sys/mount.h> +#include <sys/stat.h> +#include <sys/syscall.h> +#include <unistd.h> + +/* + * The unshare call with CLONE_NEWUSER needs to happen before starting + * additional threads, which means before initializing the Haskell RTS. + * To achieve that, replace Haskell main with a custom one here that does + * the unshare work and then executes the Haskell code. + */ + +static bool writeProcSelfFile( const char * file, const char * data, size_t size ) +{ + char path[ 256 ]; + if( snprintf( path, sizeof( path ), "/proc/self/%s", file ) + >= sizeof( path ) ){ + fprintf( stderr, "buffer too small\n" ); + return false; + } + + int fd = open( path, O_WRONLY ); + if( fd < 0 ){ + fprintf( stderr, "failed to open %s: %s", path, strerror( errno )); + return false; + } + + ssize_t written = write( fd, data, size ); + if( written < 0 ) + fprintf( stderr, "failed to write to %s: %s\n", path, strerror( errno )); + + close( fd ); + return written == size; +} + +int main( int argc, char * argv[] ) +{ + int ret; + + uid_t uid = geteuid(); + gid_t gid = getegid(); + ret = unshare( CLONE_NEWUSER | CLONE_NEWNET | CLONE_NEWNS ); + if( ret < 0 ){ + fprintf( stderr, "unsharing user, network and mount namespaces failed: %s\n", strerror( errno )); + return 1; + } + + char buf[ 256 ]; + int len; + + len = snprintf( buf, sizeof( buf ), "%d %d %d\n", 0, uid, 1 ); + if( len >= sizeof( buf ) ){ + fprintf( stderr, "buffer too small\n" ); + return 1; + } + if ( ! writeProcSelfFile( "uid_map", buf, len ) ) + return 1; + + if ( ! writeProcSelfFile( "setgroups", "deny\n", 5 ) ) + return 1; + + len = snprintf( buf, sizeof( buf ), "%d %d %d\n", 0, gid, 1 ); + if( len >= sizeof( buf ) ){ + fprintf( stderr, "buffer too small\n" ); + return 1; + } + if ( ! writeProcSelfFile( "gid_map", buf, len ) ) + return 1; + + /* + * Prepare for future filesystem isolation within additional mount namespace: + * - clone whole mount tree as read-only under new /tmp/new_root + * - keep writable /proc and /tmp + */ + + ret = mount( "tmpfs", "/run", "tmpfs", 0, "size=4m" ); + if( ret < 0 ){ + fprintf( stderr, "failed to mount tmpfs on /run: %s\n", strerror( errno )); + return 1; + } + + ret = mkdir( "/run/new_root", 0700 ); + if( ret < 0 ){ + fprintf( stderr, "failed to create new_root directory: %s\n", strerror( errno )); + return 1; + } + + ret = mount( "/", "/run/new_root", NULL, MS_BIND | MS_REC, NULL ); + if( ret < 0 ){ + fprintf( stderr, "failed to bind-mount / on new_root: %s\n", strerror( errno )); + return 1; + } + + struct mount_attr * attr_ro = &( struct mount_attr ) { + .attr_set = MOUNT_ATTR_RDONLY, + }; + ret = mount_setattr( -1, "/run/new_root", AT_RECURSIVE, attr_ro, sizeof( * attr_ro ) ); + if( ret < 0 ){ + fprintf( stderr, "failed set sandbox root as read-only: %s\n", strerror( errno )); + return 1; + } + + struct mount_attr * attr_rw = &( struct mount_attr ) { + .attr_clr = MOUNT_ATTR_RDONLY, + }; + ret = mount_setattr( -1, "/run/new_root/proc", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) ); + if( ret < 0 ){ + fprintf( stderr, "failed set sandbox /proc as read-write: %s\n", strerror( errno )); + return 1; + } + ret = mount_setattr( -1, "/run/new_root/tmp", AT_RECURSIVE, attr_rw, sizeof( * attr_rw ) ); + if( ret < 0 ){ + if( errno == EINVAL ){ + // Original /tmp is not a separate filesystem, so we can't just change the attributes + ret = mount( "/tmp", "/run/new_root/tmp", NULL, MS_BIND, NULL ); + if( ret < 0 ) + fprintf( stderr, "failed to bind-mount original /tmp in sandbox as read-write: %s\n", strerror( errno )); + } else { + fprintf( stderr, "failed set sandbox /tmp as read-write: %s\n", strerror( errno )); + } + } + + ret = mount( "tmpfs", "/run/new_root/run", "tmpfs", 0, "size=4m" ); + if( ret < 0 ){ + fprintf( stderr, "failed to mount tmpfs on sandbox /run: %s\n", strerror( errno )); + return 1; + } + + ret = mkdir( "/run/new_root/run/old_root", 0700 ); + if( ret < 0 ){ + fprintf( stderr, "failed to create old_root directory: %s\n", strerror( errno )); + return 1; + } + + hs_init( &argc, &argv ); + testerMain(); + hs_exit(); + + return 0; +} + +/* + * - Replace filesystem hierarchy with read-only version, + * - bind-mound rwdir from writable tree, and + * - keep writeable /tmp from host. + */ +int erebos_tester_isolate_fs( const char * rwdir ) +{ + int ret; + + ret = unshare( CLONE_NEWNS ); + if( ret < 0 ){ + fprintf( stderr, "unsharing mount namespace failed: %s\n", strerror( errno )); + return -1; + } + + char * cwd = getcwd( NULL, 0 ); + ret = syscall( SYS_pivot_root, "/run/new_root", "/run/new_root/run/old_root" ); + if( ret < 0 ){ + fprintf( stderr, "failed to pivot_root: %s\n", strerror( errno )); + free( cwd ); + return -1; + } + + char oldrwdir[ strlen(rwdir) + 15 ]; + snprintf( oldrwdir, sizeof oldrwdir, "/run/old_root/%s", rwdir ); + ret = mount( oldrwdir, rwdir, NULL, MS_BIND, NULL ); + if( ret < 0 ){ + fprintf( stderr, "failed to bind-mount %s on %s: %s\n", oldrwdir, rwdir, strerror( errno )); + free( cwd ); + return -1; + } + + ret = umount2( "/run/old_root", MNT_DETACH ); + if( ret < 0 ){ + fprintf( stderr, "failed to detach /run/old_root: %s\n", strerror( errno )); + free( cwd ); + return -1; + } + + ret = chdir( cwd ); + if( ret < 0 ){ + fprintf( stderr, "failed to chdir to %s: %s\n", cwd, strerror( errno )); + free( cwd ); + return -1; + } + free( cwd ); + + return 0; +} diff --git a/src/shell.c b/src/shell.c new file mode 100644 index 0000000..d832078 --- /dev/null +++ b/src/shell.c @@ -0,0 +1,8 @@ +#define _GNU_SOURCE +#include <fcntl.h> +#include <unistd.h> + +int shell_pipe_cloexec( int pipefd[ 2 ] ) +{ + return pipe2( pipefd, O_CLOEXEC ); +} |