THSH 0.0.0.4 → 0.0.0.5
raw patch · 6 files changed
+151/−90 lines, 6 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ THSH.Funclet: runFuncletWithHandles :: Funclet f => f -> (ExitCode -> IO ()) -> (Handle, Handle, Handle) -> IO ()
Files
- CHANGELOG.md +8/−3
- README.md +4/−2
- THSH.cabal +1/−1
- src/THSH/Fn.hs +7/−25
- src/THSH/Funclet.hs +41/−12
- src/THSH/Script.hs +90/−47
CHANGELOG.md view
@@ -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.
README.md view
@@ -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.
THSH.cabal view
@@ -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
src/THSH/Fn.hs view
@@ -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
src/THSH/Funclet.hs view
@@ -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
src/THSH/Script.hs view
@@ -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