diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,14 +1,19 @@ # Revision history for THSH -## 0.3.0.0 -- WIP +## 0.0.0.5 -- 2024-10-15 +- Fix: standard handles did not work as expected in an interactive session. + +## 0.0.0.3 -- 2024-10-14 + - Built for GHC versions from 9.2.8 +- Fix haddock on hackage -## 0.2.0.0 -- 2024-10-14 +## 0.0.0.2 -- 2024-10-13 * Demoed at MuniHac 2024. * Published to hackage. -## 0.1.0.0 -- 2024-10-13 +## 0.0.0.1 -- 2024-10-13 * First version. Released on an unsuspecting world. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -166,8 +166,9 @@ **Known Bugs and Limitations** - [x] Test with GHC 9.2, 9.4, 9.6, 9.8. -- [ ] User pragma fields should be rearranged. -- [ ] stdin doesn't work interactively. +- [x] User pragma fields should be rearranged. +- [x] stdin doesn't work interactively. +- [ ] withSystemTempDirectory is not water-proof. - [ ] Better quoting syntax, e.g. "!{ ... }": to replace the `PyF` parser or work with the upstream to reuse. **Features** @@ -190,3 +191,4 @@ - [x] Curate a live demo. - [x] Publish to hackage. +- [ ] A "how does it work" section in README. diff --git a/THSH.cabal b/THSH.cabal --- a/THSH.cabal +++ b/THSH.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.0.4 +version: 0.0.0.5 -- A short (one-line) description of the package. synopsis: A "noDSL" approach to mixing shell scripting with Haskell programs using Template Haskell diff --git a/src/THSH/Fn.hs b/src/THSH/Fn.hs --- a/src/THSH/Fn.hs +++ b/src/THSH/Fn.hs @@ -13,19 +13,13 @@ , LineReadFn (..), lineReadFn , Fn, fn ) where -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) -import Control.Exception (bracket) -import System.Exit (ExitCode (..)) -import System.IO (BufferMode (NoBuffering), Handle, hClose, hGetContents, hGetLine, hIsEOF, - hPutStr, hSetBuffering) --- process -import System.Process (createPipe) +import System.Exit (ExitCode (..)) +import System.IO (Handle, hGetContents, hGetLine, hIsEOF, hPutStr) -- text -import qualified Data.Text as T +import qualified Data.Text as T import qualified Data.Text.IO -- -import THSH.Funclet (Funclet (..)) +import THSH.Funclet (Funclet (..)) -- | A 'FnFunction' is a function that, given a set of handles to communicate with it, it returns an exit code. @@ -35,7 +29,7 @@ -- | The new type wrapper of any "FnFunction" instance. newtype Fn f = MkFn f --- | Marker for the thsh quasi-quote to recognize a 'FnFunction' code block. +-- | The marker for the 'thsh' quasi-quote to recognize a 'FnFunction' code block. fn :: FnFunction f => f -> Fn f fn = MkFn @@ -98,18 +92,6 @@ True -> pure Nothing) pure ExitSuccess +-- | The 'FnFunction' instance of 'Funclet'. instance FnFunction f => Funclet (Fn f) where - runFunclet (MkFn f) cb = do - handles <- newEmptyMVar - _ <- forkIO $ bracket - (do - (hInR, hInW) <- createPipe - (hOutR, hOutW) <- createPipe - (hErrR, hErrW) <- createPipe - mapM_ (`hSetBuffering` NoBuffering) [hInR, hInW, hOutR, hOutW, hErrR, hErrW] - putMVar handles (hInW, hOutR, hErrR) - pure (hInR, hOutW, hErrW) - ) - (\(hInR, hOutW, hErrW) -> mapM_ hClose [hInR, hOutW, hErrW]) - (\(hInR, hOutW, hErrW) -> cb =<< runFn f (hInR, hOutW, hErrW)) - takeMVar handles + runFuncletWithHandles (MkFn f) cb handles = cb =<< runFn f handles diff --git a/src/THSH/Funclet.hs b/src/THSH/Funclet.hs --- a/src/THSH/Funclet.hs +++ b/src/THSH/Funclet.hs @@ -14,31 +14,60 @@ , runFuncletWithStdHandles ) where +-- base module import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) +import Control.Exception (bracket) import System.Exit (ExitCode) -import System.IO (Handle, stderr, stdin, stdout) +import System.IO (BufferMode (NoBuffering), Handle, hClose, hSetBuffering, stderr, stdin, + stdout) -- +import System.Process (createPipe) +-- import THSH.Internal.ProcessUtils (binaryCat) --- | A funclet is an IO process that communicates through handles and returns an exit code. +-- | A funclet is an IO process that communicates through handles and calls back with an exit code. class Funclet f where + {-# MINIMAL runFunclet | runFuncletWithHandles #-} + + -- | Run the funclet which creates a set of handles itself. runFunclet :: f -> (ExitCode -> IO ()) -> IO (Handle, Handle, Handle) + -- ^ It has a default implementation that calls `runFuncletWithHandles` with created pipes. + runFunclet f cb = do + handles <- newEmptyMVar + _ <- forkIO $ bracket + (do + (hInR, hInW) <- createPipe + (hOutR, hOutW) <- createPipe + (hErrR, hErrW) <- createPipe + mapM_ (`hSetBuffering` NoBuffering) [hInR, hInW, hOutR, hOutW, hErrR, hErrW] + putMVar handles (hInW, hOutR, hErrR) + pure (hInR, hOutW, hErrW) + ) + (\(hInR, hOutW, hErrW) -> mapM_ hClose [hInR, hOutW, hErrW]) + (\(hInR, hOutW, hErrW) -> runFuncletWithHandles f cb (hInR, hOutW, hErrW)) + takeMVar handles --- | Run a funclet with standard handles + -- | Run the funclet with the set of handles provided. + runFuncletWithHandles :: f -> (ExitCode -> IO ()) -> (Handle, Handle, Handle) -> IO () + -- ^ It has a default implementation that simply piping data between `runFunclet` and the provided handles. + runFuncletWithHandles f cb (hInR, hOutW, hErrW) = do + (hInW, hOutR, hErrR) <- runFunclet f cb + mapM_ forkIO [ binaryCat hInR hInW + , binaryCat hOutR hOutW + , binaryCat hErrR hErrW + ] + +-- | Run a 'Funclet' with standard handles synchronously. runFuncletWithStdHandles :: Funclet f => f -> IO ExitCode runFuncletWithStdHandles f = do - ecVar <- newEmptyMVar - (hInW, hOutR, hErrR) <- runFunclet f (putMVar ecVar) - mapM_ forkIO [ binaryCat stdin hInW - , binaryCat hOutR stdout - , binaryCat hErrR stderr - ] - ec <- takeMVar ecVar - pure ec + mExitCode <- newEmptyMVar + runFuncletWithHandles f (putMVar mExitCode) (stdin, stdout, stderr) + takeMVar mExitCode --- | Existential wrapper of any funclet. +-- | Existential wrapper of any 'Funclet'. data AnyFunclet = forall f. Funclet f => MkAnyFunclet f +-- | 'AnyFunclet' is of course also a 'Funclet'. instance Funclet AnyFunclet where runFunclet (MkAnyFunclet f) = runFunclet f diff --git a/src/THSH/Script.hs b/src/THSH/Script.hs --- a/src/THSH/Script.hs +++ b/src/THSH/Script.hs @@ -18,15 +18,17 @@ import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar) import Control.Exception (bracket, catch) import Control.Monad (unless, void) +import Data.Function ((&)) +import Data.Maybe (fromJust) import System.Exit (ExitCode (..)) -import System.IO (BufferMode (NoBuffering), IOMode (ReadMode, ReadWriteMode, WriteMode), - hClose, hGetLine, hPutStr, hPutStrLn, hSetBuffering, openBinaryFile, - stderr, withFile) +import System.IO (BufferMode (NoBuffering), Handle, + IOMode (ReadMode, ReadWriteMode, WriteMode), hClose, hGetLine, hPutStr, + hPutStrLn, hSetBuffering, openBinaryFile, stderr, withFile) -- filepath module import System.FilePath (()) -- process module -import System.Process (CreateProcess (std_err, std_in, std_out), StdStream (CreatePipe), - callCommand, createProcess, shell) +import System.Process (CreateProcess (..), StdStream (CreatePipe, UseHandle), callCommand, + createProcess, shell) -- temporary module import System.IO.Temp (withSystemTempDirectory) -- PyF module @@ -36,66 +38,107 @@ import THSH.Internal.ProcessUtils (binaryCat, pollProcessExitCode) --- | A script is a funclet that has its source code and a list of other funclets it depends on. +-- | A script contains shell source code and a list of other funclets it depends on. data Script = MkScript { source :: String , funclets :: [AnyFunclet] } --- | Marker for the thsh quasi-quote to recognize a 'Script'. +-- | The marker for the 'thsh' quasi-quote to recognize a 'Script'. sh :: Script -> Script sh = id +-- | The 'Script' instance of 'Funclet'. instance Funclet Script where - runFunclet (MkScript { source, funclets }) cb = do - handles <- newEmptyMVar - _ <- forkIO $ withSystemTempDirectory "thsh-script.d" $ \ dir -> do - let initCodePath = dir "init.sh" - srcPath = dir "source.sh" - ctlFifo = dir "cr.fifo" + runFunclet script cb = run_script_funclet script cb Nothing >>= pure . fromJust - -- write init code - withFile initCodePath WriteMode $ \fh -> hPutStr fh (gen_init_code (length funclets)) + runFuncletWithHandles script cb providedHandles = void (run_script_funclet script cb (Just providedHandles)) - -- call init code - callCommand ("sh " <> initCodePath) +-- | The piping code snippet that should substitute the funclet occurrences during quasi quoting. +genFuncletPipeCode :: Int -> String +genFuncletPipeCode i = "__pipeFunclet " <> (show i) - -- write source file - withFile srcPath WriteMode $ \fh -> do - hPutStr fh gen_stub_code - hPutStr fh source +{- INTERNAL FUNCTIONS -} - -- create the main process - (Just hInW, Just hOutR, Just hErrR, mainProc) <- createProcess $ - (shell ("sh " <> srcPath)) { std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe - } - putMVar handles (hInW, hOutR, hErrR) +run_script_funclet :: Script -> (ExitCode -> IO ()) -> Maybe (Handle, Handle, Handle) + -> IO (Maybe (Handle, Handle, Handle)) +run_script_funclet (MkScript { source, funclets }) cb providedHandles = do + mProcHandles <- newEmptyMVar - -- create control thread - unless (length funclets == 0) $ void . forkIO $ withFile ctlFifo ReadMode $ \ ch -> let - go = do - catch (hGetLine ch) (\ (e :: IOError) -> hPutStrLn stderr (show e) >> pure []) >>= \cmd -> do - case cmd of - [] -> pure () -- likely end of file - 's':' ':i -> start_funclet_proc (funclets !! (read i :: Int)) (dir i) >> pure () - _ -> hPutStrLn stderr $ "[thsh-script] unknown control command: " <> cmd - if cmd /= "" then go else pure () - in go + _ <- forkIO $ withSystemTempDirectory "thsh-script.d" $ \ dir -> do + let initCodePath = dir "init.sh" + srcPath = dir "source.sh" + ctlFifo = dir "cr.fifo" - -- wait for the main sub process to finish - ec <- pollProcessExitCode mainProc + -- write init code + withFile initCodePath WriteMode $ \fh -> hPutStr fh (gen_init_code (length funclets)) - cb ec + -- call init code + callCommand ("sh " <> initCodePath) - (hInW, hOutR, hErrR) <- takeMVar handles - pure (hInW, hOutR, hErrR) + -- write source file + withFile srcPath WriteMode $ \fh -> do + hPutStr fh gen_stub_code + hPutStr fh source --- | The piping code snippet that should substitute the funclet occurrences during quasi quoting. -genFuncletPipeCode :: Int -> String -genFuncletPipeCode i = "__pipeFunclet " <> (show i) + -- create the shell script process + mMainProc <- newEmptyMVar + -- TODO: I can't make this work with withCreateProcess + -- withCreateProcess + -- (shell ("sh " <> srcPath) & \ procSpec -> case providedHandles of + -- Just (hInR, hOutW, hErrW) -> procSpec { std_in = UseHandle hInR + -- , std_out = UseHandle hOutW + -- , std_err = UseHandle hErrW + -- } + -- Nothing -> procSpec { std_in = CreatePipe + -- , std_out = CreatePipe + -- , std_err = CreatePipe + -- } + -- ) + -- (\ cases + -- (Just hInW) (Just hOutR) (Just hErrR) mainProc -> putMVar mProcHandles (Just (hInW, hOutR, hErrR)) + -- >> putMVar mMainProc mainProc + -- _ _ _ mainProc -> putMVar mProcHandles Nothing + -- >> putMVar mMainProc mainProc + -- ) + createProcess + (shell ("sh " <> srcPath) & \ procSpec -> case providedHandles of + Just (hInR, hOutW, hErrW) -> procSpec { std_in = UseHandle hInR + , std_out = UseHandle hOutW + , std_err = UseHandle hErrW + } + Nothing -> procSpec { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + ) + >>= (\ cases + (Just hInW, Just hOutR, Just hErrR, mainProc) -> putMVar mProcHandles (Just (hInW, hOutR, hErrR)) + >> putMVar mMainProc mainProc + (_, _, _, mainProc) -> putMVar mProcHandles Nothing + >> putMVar mMainProc mainProc + ) -{- INTERNAL FUNCTIONS -} + -- create control thread + unless (length funclets == 0) $ void . forkIO $ withFile ctlFifo ReadMode $ \ ch -> let + go = do + catch + (hGetLine ch) + (\ (e :: IOError) -> hPutStrLn stderr ("THSH.Script control thread error: " <> show e) >> pure []) + >>= \cmd -> do + case cmd of + [] -> pure () -- likely end of file + 's':' ':i -> start_funclet_proc (funclets !! (read i :: Int)) (dir i) >> pure () + _ -> hPutStrLn stderr $ "[thsh-script] unknown control command: " <> cmd + if cmd /= "" then go else pure () + in go + + catch + (takeMVar mMainProc >>= pollProcessExitCode >>= cb) + (\ (e :: IOError) -> hPutStrLn stderr ("THSH.Script funclet thread error: " <> show e) + >> cb (ExitFailure 2)) + + takeMVar mProcHandles + start_funclet_proc :: Funclet f => f -> FilePath -> IO () start_funclet_proc f procDir = do