Redirection in shell scriptsHEADmaster

Changelog: Implemented input/output redirection in shell scripts

5 files changed, 88 insertions, 8 deletions

diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index f44e721..786fb2e 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -236,7 +236,7 @@ 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
diff --git a/src/Parser/Shell.hs b/src/Parser/Shell.hs
index ffc8cf1..b575842 100644
--- a/src/Parser/Shell.hs
+++ b/src/Parser/Shell.hs
@@ -71,9 +71,29 @@ parseTextArgument = lexeme $ fmap (App AnnNone (Pure T.concat) <$> foldr (liftA2
             [ char ' ' >> return " "
             ]
 
+parseRedirection :: TestParser (Expr ShellArgument)
+parseRedirection = choice
+    [ do
+        osymbol "<"
+        fmap ShellRedirectStdin <$> parseTextArgument
+    , do
+        osymbol ">"
+        fmap (ShellRedirectStdout False) <$> parseTextArgument
+    , do
+        osymbol ">>"
+        fmap (ShellRedirectStdout True) <$> parseTextArgument
+    , do
+        osymbol "2>"
+        fmap (ShellRedirectStderr False) <$> parseTextArgument
+    , do
+        osymbol "2>>"
+        fmap (ShellRedirectStderr True) <$> parseTextArgument
+    ]
+
 parseArgument :: TestParser (Expr ShellArgument)
 parseArgument = choice
-    [ fmap ShellArgument <$> parseTextArgument
+    [ parseRedirection
+    , fmap ShellArgument <$> parseTextArgument
     ]
 
 parseArguments :: TestParser (Expr [ ShellArgument ])
diff --git a/src/Script/Shell.hs b/src/Script/Shell.hs
index d53fe2e..15c0c2c 100644
--- a/src/Script/Shell.hs
+++ b/src/Script/Shell.hs
@@ -24,6 +24,7 @@ import Foreign.Marshal.Array
 import Foreign.Storable
 
 import System.Exit
+import System.FilePath
 import System.IO
 import System.Posix.IO qualified as P
 import System.Posix.Process
@@ -59,9 +60,12 @@ data ShellCommand = ShellCommand
 
 data ShellArgument
     = ShellArgument Text
+    | ShellRedirectStdin Text
+    | ShellRedirectStdout Bool Text
+    | ShellRedirectStderr Bool Text
 
 cmdArguments :: ShellCommand -> [ Text ]
-cmdArguments = catMaybes . map (\case ShellArgument x -> Just x) . cmdExtArguments
+cmdArguments = catMaybes . map (\case ShellArgument x -> Just x; _ -> Nothing) . cmdExtArguments
 
 instance ExprType ShellScript where
     textExprType _ = T.pack "ShellScript"
@@ -107,19 +111,35 @@ handledHandle (KeepHandle h) = h
 executeCommand :: ShellExecInfo -> HandleHandling -> HandleHandling -> HandleHandling -> ShellCommand -> TestRun ()
 executeCommand ShellExecInfo {..} pstdin pstdout pstderr scmd@ShellCommand {..} = do
     let args = cmdArguments scmd
+    ( pstdin', pstdout', pstderr' ) <- (\f -> foldM f ( pstdin, pstdout, pstderr ) 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
+
     pid <- liftIO $ do
         (_, _, _, phandle) <- createProcess_ "shell"
             (proc (T.unpack cmdCommand) (map T.unpack args))
-                { std_in = UseHandle $ handledHandle pstdin
-                , std_out = UseHandle $ handledHandle pstdout
-                , std_err = UseHandle $ handledHandle pstderr
+                { std_in = UseHandle $ handledHandle pstdin'
+                , std_out = UseHandle $ handledHandle pstdout'
+                , std_err = UseHandle $ handledHandle pstderr'
                 , cwd = Just (nodeDir seiNode)
                 , env = Just []
                 }
         Just pid <- getPid phandle
         return pid
 
-    mapM_ closeIfRequested [ pstdin, pstdout, pstderr ]
+    mapM_ closeIfRequested [ pstdin', pstdout', pstderr' ]
     liftIO (getProcessStatus True False pid) >>= \case
         Just (Exited ExitSuccess) -> do
             return ()
diff --git a/test/asset/shell/pipe.et b/test/asset/shell/pipe.et
index 64dcb07..a00360a 100644
--- a/test/asset/shell/pipe.et
+++ b/test/asset/shell/pipe.et
@@ -3,3 +3,23 @@ test Pipe:
     shell on n as sh:
         echo abcd | grep -o '[bc]*'
         echo abcd | grep -o '[bcd]*' | grep -o '[ab]*'
+
+
+test Redirect:
+    node n
+    shell on n as sh:
+        echo a > file
+        echo b > file
+        echo c >> file
+        echo x
+        cat file
+        echo y
+        cat < file
+        echo z
+
+test PipeRedirect:
+    node n
+    shell on n as sh:
+        echo abcdefghi | grep -o '[b-h]*' | grep -o '[a-g]*' > file
+        cat < file | grep -o '[acegi]' | cat > file2
+        cat file2 - < file
diff --git a/test/script/shell.et b/test/script/shell.et
index 2fe4ec3..282df37 100644
--- a/test/script/shell.et
+++ b/test/script/shell.et
@@ -74,7 +74,27 @@ test ShellPipe:
     expect_next_stdout from p:
         "bc"
         "b"
-
     with p:
         expect /run-test-result Pipe done/
+
+    expect_next_stdout from p:
+        "x"
+        "b"
+        "c"
+        "y"
+        "b"
+        "c"
+        "z"
+    with p:
+        expect /run-test-result Redirect done/
+
+    expect_next_stdout from p:
+        "c"
+        "e"
+        "g"
+        "bcdefg"
+    with p:
+        expect /run-test-result PipeRedirect done/
+
+    with p:
         expect /run-all-done/