shellmate 0.1.6 → 0.2

raw patch · 6 files changed

+665/−342 lines, 6 filesdep +bytestringdep +containersdep +download-curldep −timedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, containers, download-curl, feed, tagsoup, xml

Dependencies removed: time

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Control/Shell.hs +165/−338
• Control/Shell/Concurrent.hs +74/−0
• Control/Shell/Download.hs +53/−0
• Control/Shell/Handle.hs +78/−0
• Control/Shell/Internal.hs +280/−0
• shellmate.cabal +15/−4

@@ -1,317 +1,166 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable,-             MultiParamTypeClasses, FunctionalDependencies,-             CPP,-             UndecidableInstances #-}+{-# LANGUAGE TypeFamilies, CPP #-} -- | Simple interface for shell scripting-like tasks.-module Control.Shell ( -    Shell,-    Guard (..),-    File (..),-    shell,-    mayFail, orElse,-    withEnv, getEnv, lookupEnv,-    run, run_, runInteractive, genericRun, sudo,-    cd, cpDir, pwd, ls, mkdir, rmdir, inDirectory, isDirectory,-    withHomeDirectory, inHomeDirectory, withAppDirectory, inAppDirectory,-    forEachFile, forEachFile_, cpFiltered,-    isFile, rm, mv, cp,-    withTempFile, withCustomTempFile,-    withTempDirectory, withCustomTempDirectory, inTempDirectory,-    hPutStr, hPutStrLn, hClose, echo,+module Control.Shell (+    -- * Running Shell programs+    Shell, ExitReason (..),+    shell, shell_, exitString,++    -- * Error handling and control flow     (|>),-    module System.FilePath, liftIO-  ) where-import Control.Applicative-import Control.Monad (ap, forM, filterM, forM_, when)-import Control.Monad.IO.Class-import Data.Time.Clock-import Data.Typeable-import System.FilePath-import System.IO.Unsafe-import qualified System.Process as Proc-import qualified System.Directory as Dir-import qualified System.Exit as Exit-import qualified System.IO as IO-import qualified Control.Exception as Ex-import qualified Control.Concurrent as Conc-import qualified System.IO.Temp as Temp-import qualified System.Environment as Env+    try, orElse, exit,+    Guard (..), guard, when, unless, -newtype ShellException = ShellException String deriving (Typeable, Show)-instance Ex.Exception ShellException+    -- * Environment handling+    setEnv, getEnv, withEnv, lookupEnv, cmdline, --- | Environment variables.-type Env = [(String, String)]+    -- * Running commands+    MonadIO (..),+    run, run_, genericRun, runInteractive, sudo, --- | A command name plus a ProcessHandle.-data Pid = Pid {pidName :: String, pidHandle :: Proc.ProcessHandle}+    -- * Working with directories+    cd, cpdir, pwd, ls, mkdir, rmdir, inDirectory, isDirectory,+    withHomeDirectory, inHomeDirectory, withAppDirectory, inAppDirectory,+    forEachFile, forEachFile_, forEachDirectory, forEachDirectory_, --- | Monad for running shell commands. If a command fails, the entire---   computation is aborted unless @mayFail@ is used.-newtype Shell a = Shell {-    unSh :: Env -> IO (Either String a, [Pid])-  }+    -- * Working with files+    isFile, rm, mv, cp, input, output, -instance Monad Shell where-  fail err = Shell $ \_ -> return (Left err, [])-  return x = Shell $ \_ -> return (Right x, [])-  -- | The bind operation of the Shell monad is effectively a barrier; all-  --   commands on the left hand side of a bind will complete before any-  --   command on the right hand side is attempted.-  --   To lazily stream data between two commands, use the @|>@ combinator.-  (Shell m) >>= f = Shell $ \env -> do-    (x, pids) <- m env-    merr <- waitPids pids-    case (x, merr) of-      (Left err, _) -> return (Left err, [])-      (_, Just err) -> return (Left err, [])-      (Right x', _) -> unSh (f x') env+    -- * Working with temporary files and directories+    withTempFile, withCustomTempFile,+    withTempDirectory, withCustomTempDirectory, inTempDirectory, -instance MonadIO Shell where-  liftIO act = Shell $ \_ -> flip Ex.catch exHandler $ do-    x <- act-    return (Right x, [])+    -- * Working with handles+    Handle, IOMode (..),+    stdin, stdout, stderr,+    hFlush, hClose, withFile, withBinaryFile, openFile, openBinaryFile, -instance Applicative Shell where-  pure  = return-  (<*>) = ap+    -- * Text I/O+    hPutStr, hPutStrLn, echo, ask,+    hGetLine, hGetContents, -instance Functor Shell where-  fmap f x = do-    x' <- x-    return $! f x'+    -- * ByteString I/O+    hGetBytes, hPutBytes, hGetByteLine, hGetByteContents, --- | Enable the user to use 'file "foo" |> fmap reverse |> file "bar"' as---   syntax for reading the file 'foo', reversing the contents and writing the---   result to 'bar'.---   Note that this uses lazy IO in the form of read/writeFile.-class File a where-  file :: FilePath -> a+    -- * Convenient re-exports+    module System.FilePath,+    module Control.Monad+  ) where+#if __GLASGOW_HASKELL__ <= 708+import Control.Applicative+#endif+import Control.Monad hiding (guard, when, unless)+import System.FilePath+import qualified System.Directory as Dir+import qualified System.Environment as Env+import System.IO.Unsafe+import Control.Shell.Handle+import Control.Shell.Internal -instance File (String -> Shell ()) where-  file f = liftIO . writeFile f+-- | Convert an 'ExitReason' into a 'String'. Successful termination yields+--   the empty string, while abnormal termination yields the termination+--   error message. If the program terminaged abnormally but without an error+--   message - i.e. the error message is empty string - the error message will+--   be shown as @"abnormal termination"@.+exitString :: ExitReason -> String+exitString Success      = ""+exitString (Failure "") = "abnormal termination"+exitString (Failure s)  = s -instance File (Shell String) where-  file f = liftIO $ readFile f+-- | Lazily read a file.+input :: FilePath -> Shell String+input = liftIO . readFile --- | Lazy counterpart to monadic bind. To stream data from a command 'a' to a---   command 'b', do 'a |> b'.-(|>) :: Shell String -> (String -> Shell a) -> Shell a-(Shell m) |> f = Shell $ \env -> do-  (x, pids) <- m env-  (x', pids') <- case x of-    Left err -> return (Left err, [])-    Right x' -> unSh (f x') env-  return (x', pids ++ pids')-infixl 1 |>+-- | Lazily write a file.+output :: MonadIO m => FilePath -> String -> m ()+output f = liftIO . writeFile f --- | Wait for all processes in the given list. If a process has failed, its---   error message is returned and the rest are killed.-waitPids :: [Pid] -> IO (Maybe String)-waitPids (p:ps) = do-  exCode <- Proc.waitForProcess (pidHandle p)-  case exCode of-    Exit.ExitFailure ec -> do-      killPids ps-      return . Just $ "Command '" ++ (pidName p) ++ "' failed with error "-                    ++" code " ++ show ec-    _ -> do-      waitPids ps-waitPids _ = do-  return Nothing+-- | The executable's command line arguments.+cmdline :: [String]+cmdline = unsafePerformIO Env.getArgs --- | Kill all processes in the list.-killPids :: [Pid] -> IO ()-killPids = mapM_ (Proc.terminateProcess . pidHandle)+-- | Set an environment variable.+setEnv :: MonadIO m => String -> String -> m ()+setEnv k v = liftIO $ Env.setEnv k v --- | Run a Shell computation. The program's working directory  will be restored ---   after executing the computation.-shell :: Shell a -> IO (Either String a)-shell act = do-  dir <- Dir.getCurrentDirectory-  env <- Env.getEnvironment-  (res, pids) <- unSh act env-  merr <- waitPids pids-  Dir.setCurrentDirectory dir-  case merr of-    Just err -> return $ Left err-    _        -> return res+-- | Get the value of an environment variable. Returns Nothing if the variable +--   doesn't exist.+lookupEnv :: String -> Shell (Maybe String)+lookupEnv = liftIO . Env.lookupEnv  -- | Run a computation with a new value for an environment variable. --   Note that this will *not* affect external commands spawned using @liftIO@ --   or which directory is considered the system temp directory. withEnv :: String -> (String -> String) -> Shell a -> Shell a-withEnv key f (Shell act) = Shell $ \env -> do-    act $ insert env-  where-    insert (x@(k,v):xs) | k == key  = (key, f v) : xs-                        | otherwise = x : insert xs-    insert _                        = [(key, f "")]---- | Get the value of an environment variable. Returns Nothing if the variable ---   doesn't exist.-lookupEnv :: String -> Shell (Maybe String)-lookupEnv key = Shell $ \env -> return (Right $ lookup key env, [])+withEnv key f act = do+  v <- lookupEnv key+  setEnv key $ f (maybe "" id v)+  x <- act+  maybe (return ()) (setEnv key) v+  return x  -- | Get the value of an environment variable. Returns the empty string if --   the variable doesn't exist. getEnv :: String -> Shell String getEnv key = maybe "" id `fmap` lookupEnv key --- | General exception handler; any exception causes failure.-exHandler :: Ex.SomeException -> IO (Either String a, [Pid])-exHandler x = return (Left $ show x, [])---- | Execute an external command. No globbing, escaping or other external shell---   magic is performed on either the command or arguments. The program's text---   output will be returned, and not echoed to the screen.-run :: FilePath -> [String] -> String -> Shell String-run p args stdin = do-  (Just inp, Just out, pid) <- runP p args Proc.CreatePipe Proc.CreatePipe-  Shell $ \_ -> do-    let feed str = do-          case splitAt 4096 str of-            ([], [])      -> IO.hClose inp-            (first, str') -> IO.hPutStr inp first >> feed str'-    Conc.forkIO $ feed stdin-    s <- IO.hGetContents out-    s `seq` return (Right s, [Pid p pid])---- | Run a program and return a boolean indicating whether the command---   succeeded, the output from stdout, and the output from stderr.---   This command will never fail.-genericRun :: FilePath -> [String] -> String -> Shell (Bool, String, String)-genericRun p args stdin = do-    (Just inp, Just out, Just err, pid) <- createproc-    Shell $ \_ -> do-      let feed str = do-            case splitAt 4096 str of-              ([], [])      -> IO.hClose inp-              (first, str') -> IO.hPutStr inp first >> feed str'-      Conc.forkIO $ feed stdin-      o <- IO.hGetContents out-      e <- IO.hGetContents err-      merr <- waitPids [Pid p pid]-      return (Right (maybe True (const False) merr, o, e), [])-  where-    createproc = Shell $ \env -> do-      (inp, out, err, pid) <- Proc.createProcess (cproc env)-      return (Right (inp, out, err, pid), [])-    cproc env = Proc.CreateProcess {-        Proc.cmdspec      = Proc.RawCommand p args,-        Proc.cwd          = Nothing,-        Proc.env          = Just env,-        Proc.std_in       = Proc.CreatePipe,-        Proc.std_out      = Proc.CreatePipe,-        Proc.std_err      = Proc.CreatePipe,-        Proc.close_fds    = False,-#if MIN_VERSION_process(1,2,0)-        Proc.delegate_ctlc = False,-#endif-        Proc.create_group = False-      }----- | Like @run@, but echoes the command's text output to the screen instead of---   returning it.-run_ :: FilePath -> [String] -> String -> Shell ()-run_ p args stdin = do-  (Just inp, _, pid) <- runP p args Proc.CreatePipe Proc.Inherit-  exCode <- liftIO $ do-    IO.hPutStr inp stdin-    IO.hClose inp-    Proc.waitForProcess pid-  case exCode of-    Exit.ExitFailure ec -> fail $ "Command '" ++ p ++ "' failed with error " -                                ++" code " ++ show ec-    _                   -> return ()- -- | Run a command with elevated privileges. sudo :: FilePath -> [String] -> String -> Shell String-sudo cmd args stdin = run "sudo" (cmd:args) stdin---- | Create a process. Helper for @run@ and friends.-runP :: String-     -> [String]-     -> Proc.StdStream-     -> Proc.StdStream-     -> Shell (Maybe IO.Handle, Maybe IO.Handle, Proc.ProcessHandle)-runP p args stdin stdout = Shell $ \env -> do-    (inp, out, _, pid) <- Proc.createProcess (cproc env)-    return (Right (inp, out, pid), [])-  where-    cproc env = Proc.CreateProcess {-        Proc.cmdspec      = Proc.RawCommand p args,-        Proc.cwd          = Nothing,-        Proc.env          = Just env,-        Proc.std_in       = stdin,-        Proc.std_out      = stdout,-        Proc.std_err      = Proc.Inherit,-        Proc.close_fds    = False,-#if MIN_VERSION_process(1,2,0)-        Proc.delegate_ctlc = False,-#endif-        Proc.create_group = False-      }---- | Run an interactive process.-runInteractive :: FilePath -> [String] -> Shell ()-runInteractive p args = do-  (_, _, pid) <- runP p args Proc.Inherit Proc.Inherit-  exitCode <- liftIO $ Proc.waitForProcess pid-  case exitCode of-    Exit.ExitFailure ec -> fail (show ec)-    _                   -> return ()+sudo cmd as = run "sudo" (cmd:as)  -- | Change working directory.-cd :: FilePath -> Shell ()+cd :: MonadIO m => FilePath -> m () cd = liftIO . Dir.setCurrentDirectory  -- | Get the current working directory.-pwd :: Shell FilePath+pwd :: MonadIO m => m FilePath pwd = liftIO $ Dir.getCurrentDirectory  -- | Remove a file.-rm :: FilePath -> Shell ()+rm :: MonadIO m => FilePath -> m () rm = liftIO . Dir.removeFile  -- | Rename a file.-mv :: FilePath -> FilePath -> Shell ()+mv :: MonadIO m => FilePath -> FilePath -> m () mv from to = liftIO $ Dir.renameFile from to  -- | Recursively copy a directory. If the target is a directory that already --   exists, the source directory is copied into that directory using its --   current name.-cpDir :: FilePath -> FilePath -> Shell ()-cpDir from to = do-  todir <- isDirectory to-  if todir-    then do-      cpDir from (to </> takeBaseName from)-    else do-      cpfile <- isFile from-      if cpfile-        then do-          cp from to-        else do-          liftIO $ Dir.createDirectoryIfMissing False to-          ls from >>= mapM_ (\f -> cpDir (from </> f) (to </> f))+cpdir :: FilePath -> FilePath -> Shell ()+cpdir fromdir todir = do+    dir <- isDirectory todir+    if dir+      then go fromdir todir id+      else go fromdir todir (joinPath . drop 1 . splitPath)+  where+    go from to dropFirstDir = do+      forEachDirectory_ from (\dir -> mkdir True (to </> dropFirstDir dir))+      forEachFile_ from $ \file -> do+        let file' = to </> dropFirstDir file+        assert (errOverwrite file') (not <$> isDirectory file')+        cp file file'+    errOverwrite f = "cannot overwrite directory `" ++ f+                     ++ "' with non-directory" --- | Recursively copy a directory, but omit all files that do not match the---   give predicate.-cpFiltered :: (FilePath -> Bool) -> FilePath -> FilePath -> Shell ()-cpFiltered pred from to = do-  isdir <- isDirectory to-  -- Lazily create directories only when needed!-  let to' = unsafePerformIO $ do-        when (not isdir) $ Dir.createDirectory to-        return to-  files <- ls from-  mapM_ ((`cp` to') . (from </>)) (filter pred files)-  fromdirs <- filterM (\d -> isDirectory (from </> d)) files-  forM_ fromdirs $ \dir -> do-    cpFiltered pred (from </> dir) (to </> dir)+-- | Recursively perform an action on each subdirectory of the given directory.+--   The action will *not* be performed on the given directory itself.+forEachDirectory :: FilePath -> (FilePath -> Shell a) -> Shell [a]+forEachDirectory dir f = do+  files <- map (dir </>) <$> ls dir+  fromdirs <- filterM isDirectory files+  xs <- forM fromdirs $ \d -> do+    x <- f d+    xs <- forEachDirectory d f+    return (x:xs)+  return (concat xs) +-- | Like 'forEachDirectory', but discards its result.+forEachDirectory_ :: FilePath -> (FilePath -> Shell ()) -> Shell ()+forEachDirectory_ dir f = do+  files <- map (dir </>) <$> ls dir+  fromdirs <- filterM isDirectory files+  forM_ fromdirs $ \d -> f d >> forEachDirectory d f+ -- | Perform an action on each file in the given directory. --   This function will traverse any subdirectories of the given as well. --   File paths are given relative to the given directory; the current working@@ -352,29 +201,30 @@  -- | Create a directory. Optionally create any required missing directories as --   well.-mkdir :: Bool -> FilePath -> Shell ()+mkdir :: MonadIO m => Bool -> FilePath -> m () mkdir True = liftIO . Dir.createDirectoryIfMissing True mkdir _    = liftIO . Dir.createDirectory  -- | Recursively remove a directory. Follows symlinks, so be careful.-rmdir :: FilePath -> Shell ()+rmdir :: MonadIO m => FilePath -> m () rmdir = liftIO . Dir.removeDirectoryRecursive  -- | Do something with the user's home directory. withHomeDirectory :: (FilePath -> Shell a) -> Shell a withHomeDirectory act = liftIO Dir.getHomeDirectory >>= act --- | Do something *in* the user's home directory.+-- | Perform an action with the user's home directory as the working directory. inHomeDirectory :: Shell a -> Shell a-inHomeDirectory act = withHomeDirectory $ \dir -> inDirectory dir act+inHomeDirectory act = withHomeDirectory $ flip inDirectory act  -- | Do something with the given application's data directory. withAppDirectory :: String -> (FilePath -> Shell a) -> Shell a withAppDirectory app act = liftIO (Dir.getAppUserDataDirectory app) >>= act --- | Do something *in* the given application's data directory.+-- | Do something with the given application's data directory as the working+--   directory. inAppDirectory :: FilePath -> Shell a -> Shell a-inAppDirectory app act = withAppDirectory app $ \dir -> inDirectory dir act+inAppDirectory app act = withAppDirectory app $ flip inDirectory act  -- | Execute a command in the given working directory, then restore the --   previous working directory.@@ -394,91 +244,68 @@ isFile :: FilePath -> Shell Bool isFile = liftIO . Dir.doesFileExist --- | Create a temp directory in the standard system temp directory, do---   something with it, then remove it.-withTempDirectory :: String -> (FilePath -> Shell a) -> Shell a-withTempDirectory template act = Shell $ \env -> do-    Temp.withSystemTempDirectory template (act' env)-  where-    act' env fp = Ex.catch (unSh (act fp) env) exHandler---- | Create a temp directory in given directory, do something with it, then---   remove it.-withCustomTempDirectory :: FilePath -> (FilePath -> Shell a) -> Shell a-withCustomTempDirectory dir act = Shell $ \env -> do-    Temp.withTempDirectory dir "shellmate" (act' env)-  where-    act' env fp = Ex.catch (unSh (act fp) env) exHandler- -- | Performs a command inside a temporary directory. The directory will be --   cleaned up after the command finishes. inTempDirectory :: Shell a -> Shell a inTempDirectory = withTempDirectory "shellmate" . flip inDirectory --- | Create a temp file in the standard system temp directory, do something---   with it, then remove it.-withTempFile :: String -> (FilePath -> IO.Handle -> Shell a) -> Shell a-withTempFile template act = Shell $ \env -> do-    Temp.withSystemTempFile template (act' env)-  where-    act' env fp h = Ex.catch (unSh (act fp h) env) exHandler---- | Create a temp file in the standard system temp directory, do something---   with it, then remove it.-withCustomTempFile :: FilePath -> (FilePath -> IO.Handle -> Shell a) -> Shell a-withCustomTempFile dir act = Shell $ \env -> do-    Temp.withTempFile dir "shellmate" (act' env)-  where-    act' env fp h = Ex.catch (unSh (act fp h) env) exHandler---- | Perform an action that may fail without aborting the entire computation.---   Forces serialization.-mayFail :: Shell a -> Shell (Either String a)-mayFail (Shell act) = Shell $ \env -> do-  (x, pids) <- Ex.catch (act env) exHandler-  merr <- waitPids pids-  case merr of-    Just err -> return (Right (Left err), [])-    _        -> return (Right x, [])- -- | Attempt to run the first command. If the first command fails, run the --   second. Forces serialization of the first command. orElse :: Shell a -> Shell a -> Shell a orElse a b = do-  ex <- mayFail a+  ex <- try a   case ex of     Right x -> return x     _       -> b --- | @IO.hPutStr@ lifted into Shell for convenience.-hPutStr :: IO.Handle -> String -> Shell ()-hPutStr h s = liftIO $ IO.hPutStr h s---- | @IO.hPutStrLn@ lifted into Shell for convenience.-hPutStrLn :: IO.Handle -> String -> Shell ()-hPutStrLn h s = liftIO $ IO.hPutStrLn h s+-- | Write a string to @stdout@ followed by a newline.+echo :: MonadIO m => String -> m ()+echo = liftIO . putStrLn --- | @IO.hClose@ lifted into Shell for convenience.-hClose :: IO.Handle -> Shell ()-hClose h = liftIO $ IO.hClose h+-- | Read one line of input from @stdin@.+ask :: Shell String+ask = liftIO getLine --- | @putStrLn@ lifted into Shell for convenience.-echo :: String -> Shell ()-echo = liftIO . putStrLn+class Guard guard where+  -- | The type of the guard's return value, if it succeeds.+  type Result guard -class Guard guard a | guard -> a where   -- | Perform a Shell computation; if the computation succeeds but returns   --   a false-ish value, the outer Shell computation fails with the given   --   error message.-  guard :: String -> guard -> Shell a+  assert :: String -> guard -> Shell (Result guard) -instance Guard (Maybe a) a where-  guard _ (Just x) = return x-  guard desc _     = fail $ "Guard failed: " ++ desc+instance Guard (Maybe a) where+  type Result (Maybe a) = a+  assert _ (Just x) = return x+  assert ""  _      = fail $ "Guard failed!"+  assert desc _     = fail desc -instance Guard Bool () where-  guard _ True = return ()-  guard desc _ = fail $ "Guard failed: " ++ desc+instance Guard Bool where+  type Result Bool = ()+  assert _ True = return ()+  assert ""  _  = fail $ "Guard failed!"+  assert desc _ = fail desc -instance Guard a b => Guard (Shell a) b where-  guard desc m = m >>= \x -> guard desc x+instance Guard a => Guard (Shell a) where+  type Result (Shell a) = Result a+  assert desc m = m >>= \x -> assert desc x++-- | Perform a Shell computation; if the computation succeeds but returns+--   a false-ish value, the outer Shell computation fails.+guard :: Guard g => g -> Shell (Result g)+guard = assert ""++-- | Perform the given computation if the given guard passes, otherwise do+--   nothing.+when :: Guard g => g -> Shell a -> Shell ()+when g m = do+  res <- try (guard g)+  case res of+    Right _ -> void m+    _       -> pure ()++-- | Perform the given computation if the given guard fails, otherwise do+--   nothing.+unless :: Guard g => g -> Shell a -> Shell ()+unless g m = void (guard g) `orElse` void m

@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+-- | Concurrency for Shellmate programs.+module Control.Shell.Concurrent (+    Future,+    future, await, check,+    parallel, parallel_,+    chunks+  ) where+#if __GLASGOW_HASKELL__ <= 708+import Control.Applicative+#endif+import Control.Concurrent+import Control.Monad+import Control.Shell+import Data.IORef++type FinalizerHandle = IORef ThreadId++-- | A future is a computation which is run in parallel with a program's main+--   thread and which may at some later point finish and return a value.+--+--   Note that future computations are killed when their corresponding @Future@+--   is garbage collected. This means that a future should *always* be+--   'await'ed at some point or otherwise kept alive, to ensure that the+--   computation finishes.+data Future a = Future !FinalizerHandle !(MVar (Either ExitReason a))++-- | Create a future value.+future :: Shell a -> Shell (Future a)+future m = liftIO $ do+  v <- newEmptyMVar+  tid <- forkIO $ shell m >>= putMVar v+  -- We need a WeakRef to something that's not referenced by the computation+  -- to be able to kill it when the result is not reachable. IORef to TID is+  -- as good as anything.+  r <- newIORef tid+  _ <- mkWeakIORef r (killThread tid)+  return $ Future r v++-- | Inspect a result from a previous shell computation and make it the result+--   of this computation as well.+fromResult :: Either ExitReason a -> Shell a+fromResult x =+  case x of+    Left Success       -> exit+    Left (Failure err) -> fail err+    Right x'           -> return x'++-- | Wait for a future value.+await :: Future a -> Shell a+await (Future h v) = liftIO (readMVar v <* readIORef h) >>= fromResult++-- | Check whether a future value has arrived or not.+check :: Future a -> Shell (Maybe a)+check (Future h v) = do+  mx <- liftIO $ tryReadMVar v <* readIORef h+  maybe (pure Nothing) (fmap Just . fromResult) (h `seq` mx)++-- | Perform the given computations in parallel.+parallel :: [Shell a] -> Shell [a]+parallel = mapM future >=> mapM await++-- | Like 'parallel', but discards any return values.+parallel_ :: [Shell a] -> Shell ()+parallel_ = mapM future >=> mapM_ await++-- | Break a list into chunks. This is quite useful for when performing *every*+--   computation in parallel is too much. For instance, to download a list of+--   files three at a time, one would do+--   @mapM_ (parallel_ downloadFile) (chunks 3 files)@.+chunks :: Int -> [a] -> [[a]]+chunks _ []                 = []+chunks n xs | length xs > n = take n xs : chunks n (drop n xs)+            | otherwise     = [xs]

@@ -0,0 +1,53 @@+-- | Shellmate wrapper for @download-curl@.+module Control.Shell.Download (+    URI,+    fetch, fetchBytes,+    fetchFile,+    fetchTags, fetchXML, fetchFeed+  ) where+import Data.ByteString as BS (ByteString, writeFile)+import Network.Curl.Download as C+import Text.HTML.TagSoup (Tag)+import Text.XML.Light.Types (Content)+import Text.Feed.Types (Feed)+import Control.Shell++-- | A Uniform Resource Locator.+type URI = String++liftE :: IO (Either String a) -> Shell a+liftE m = do+  res <- liftIO m+  case res of+    Left e  -> fail e+    Right x -> return x++-- | Download content specified by a url using curl, returning the content+--   as a strict 'ByteString'.+fetchBytes :: URI -> Shell ByteString+fetchBytes = liftE . C.openURI++-- | Download content specified by a url using curl, returning the content+--   as a 'String'.+fetch :: URI -> Shell String+fetch = liftE . C.openURIString++-- | Download content specified by a url using curl, writing the content to+--   the file specified by the given 'FilePath'.+fetchFile :: FilePath -> URI -> Shell ()+fetchFile file = fetchBytes >=> liftIO . BS.writeFile file++-- | Download the content as for 'fetch', but return it as a list of parsed+--   tags using the tagsoup html parser.+fetchTags :: URI -> Shell [Tag String]+fetchTags = liftE . C.openAsTags++-- | Download the content as for 'fetch', but return it as parsed XML, using+--   the xml-light parser.+fetchXML :: URI -> Shell [Content]+fetchXML = liftE . C.openAsXML++-- | Download the content as for 'fetch', but return it as as parsed RSS or+--   Atom content, using the feed library parser.+fetchFeed :: URI -> Shell Feed+fetchFeed = liftE . C.openAsFeed

@@ -0,0 +1,78 @@+-- | Writing Shell programs using 'Handle's.+module Control.Shell.Handle (+    IO.Handle, IO.IOMode (..),+    IO.stdin, IO.stdout, IO.stderr,++    hPutStr, hPutStrLn,+    hGetLine, hGetContents,++    hGetBytes, hPutBytes, hGetByteLine, hGetByteContents,++    hFlush, hClose, withFile, withBinaryFile, openFile, openBinaryFile+  ) where+import qualified System.IO as IO+import qualified Data.ByteString as BS+import Control.Shell.Internal++-- | Write a string to a handle.+hPutStr :: IO.Handle -> String -> Shell ()+hPutStr h s = liftIO $ IO.hPutStr h s++-- | Write a string to a handle, followed by a newline.+hPutStrLn :: IO.Handle -> String -> Shell ()+hPutStrLn h s = liftIO $ IO.hPutStrLn h s++-- | Close a handle.+hClose :: IO.Handle -> Shell ()+hClose = liftIO . IO.hClose++-- | Flush a handle.+hFlush :: IO.Handle -> Shell ()+hFlush = liftIO . IO.hFlush++-- | Read a line of input from a handle.+hGetLine :: IO.Handle -> Shell String+hGetLine = liftIO . IO.hGetLine++-- | Lazily read all remaining input from a handle.+hGetContents :: IO.Handle -> Shell String+hGetContents = liftIO . IO.hGetContents++-- | Read @n@ bytes from a handle.+hGetBytes :: IO.Handle -> Int -> Shell BS.ByteString+hGetBytes h = liftIO . BS.hGet h++-- | Read a line of input from a handle and return it as a 'BS.ByteString'.+hGetByteLine :: IO.Handle -> Shell BS.ByteString+hGetByteLine = liftIO . BS.hGetLine++-- | Read all remaining input from a handle and return it as a 'BS.ByteString'.+hGetByteContents :: IO.Handle -> Shell BS.ByteString+hGetByteContents = liftIO . BS.hGetContents++-- | Write a 'BS.ByteString' to a handle. Newline is not appended.+hPutBytes :: IO.Handle -> BS.ByteString -> Shell ()+hPutBytes h = liftIO . BS.hPutStr h++-- | Perform a computation over a file.+withFile :: FilePath -> IO.IOMode -> (IO.Handle -> Shell a) -> Shell a+withFile file mode f =+  liftIO (IO.withFile file mode (shell . f)) >>= liftResult++-- | Perform a computation over a binary file.+withBinaryFile :: FilePath -> IO.IOMode -> (IO.Handle -> Shell a) -> Shell a+withBinaryFile file mode f =+  liftIO (IO.withBinaryFile file mode (shell . f)) >>= liftResult++-- | Open a file, returning a handle to it.+openFile :: FilePath -> IO.IOMode -> Shell IO.Handle+openFile file = liftIO . IO.openFile file++-- | Open a file in binary mode, returning a handle to it.+openBinaryFile :: FilePath -> IO.IOMode -> Shell IO.Handle+openBinaryFile file = liftIO . IO.openBinaryFile file++liftResult :: Either ExitReason a -> Shell a+liftResult (Right x)            = return x+liftResult (Left Success)       = exit+liftResult (Left (Failure err)) = fail err

@@ -0,0 +1,280 @@+{-# LANGUAGE CPP #-}+-- | Internal, hairy bits of Shellmate.+module Control.Shell.Internal (+    MonadIO (..), Shell, ExitReason (..),+    shell, shell_,+    (|>), exit,+    run, run_, genericRun, runInteractive,+    withTempDirectory, withCustomTempDirectory,+    withTempFile, withCustomTempFile,+    try+  ) where+#if __GLASGOW_HASKELL__ <= 708+import Control.Applicative+#endif+import Control.Monad (ap)+import Control.Monad.IO.Class+import qualified Control.Concurrent as Conc+import qualified Control.Exception as Ex+import qualified Data.Map as M+import qualified System.Directory as Dir+import qualified System.Environment as Env+import qualified System.Exit as Exit+import qualified System.Process as Proc+import qualified System.IO as IO+import qualified System.IO.Temp as Temp++-- | A command name plus a ProcessHandle.+data Pid = Pid {pidName :: String, pidHandle :: Proc.ProcessHandle}++-- | Monad for running shell commands. If a command fails, the entire+--   computation is aborted unless @mayFail@ is used.+newtype Shell a = Shell {+    unSh :: IO ([Pid], Result a)+  }++data Result a = Fail !String | Next !a | Done++data ExitReason = Success | Failure !String+  deriving (Show, Eq)++instance Functor Result where+  fmap f (Next x) = Next (f x)+  fmap _ (Fail x) = Fail x+  fmap _ Done     = Done++instance Monad Shell where+  fail err = Shell $ return ([], Fail err)+  return x = Shell $ return ([], Next x)+  -- | The bind operation of the Shell monad is effectively a barrier; all+  --   commands on the left hand side of a bind will complete before any+  --   command on the right hand side is attempted.+  --   To lazily stream data between two commands, use the @|>@ combinator.+  (Shell m) >>= f = Shell $ do+    (pids, x) <- m+    merr <- waitPids pids+    case (x, merr) of+      (Fail err, _) -> return ([], Fail err)+      (_, Just err) -> return ([], Fail err)+      (Next x', _)  -> unSh (f x')+      (Done, _)     -> return ([], Done)++instance MonadIO Shell where+  liftIO act = Shell $ flip Ex.catch exHandler $ do+    x <- act+    return ([], Next x)++instance Applicative Shell where+  pure  = return+  (<*>) = ap++instance Functor Shell where+  fmap f (Shell x) = Shell (fmap (fmap (fmap f)) x)++-- | Run a Shell computation. The program's working directory and environment+--   will be restored after after the computation finishes.+shell :: Shell a -> IO (Either ExitReason a)+shell act = do+    dir <- Dir.getCurrentDirectory+    env <- M.fromList <$> Env.getEnvironment+    (pids, res) <- unSh act+    merr <- waitPids pids+    Dir.setCurrentDirectory dir+    resetEnv env+    case merr of+      Just err -> return $ Left $ Failure err+      _        -> return $ resultToEither res+  where+    resultToEither (Next x) = Right x+    resultToEither (Fail e) = Left (Failure e)+    resultToEither (Done)   = Left Success+    +    resetEnv old = do+      new <- M.fromList <$> Env.getEnvironment+      mapM_ (Env.unsetEnv . fst) (M.toList (new M.\\ old))+      mapM_ (uncurry Env.setEnv) (M.toList (M.filterWithKey (changed old) new))+    changed old k v = maybe True (/= v) (M.lookup k old)++-- | Run a shell computation and discard its return value. If the computation+--   fails, print its error message to @stderr@ and exit.+shell_ :: Shell a -> IO ()+shell_ act = do+  res <- shell act+  case res of+    Left (Failure err) -> IO.hPutStrLn IO.stderr err >> Exit.exitFailure+    _                  -> return ()++-- | Lazy counterpart to monadic bind. To stream data from a command 'a' to a+--   command 'b', do 'a |> b'.+(|>) :: Shell String -> (String -> Shell a) -> Shell a+(Shell m) |> f = Shell $ do+  (pids, x) <- m+  (pids', x') <- case x of+    Fail err -> return ([], Fail err)+    Next x'  -> unSh (f x')+    Done     -> return ([], Done)+  return (pids ++ pids', x')+infixl 1 |>++-- | Terminate a computation, successfully.+exit :: Shell a+exit = Shell $ return ([], Done)++-- | Create a temp directory in the standard system temp directory, do+--   something with it, then remove it.+withTempDirectory :: String -> (FilePath -> Shell a) -> Shell a+withTempDirectory template act = Shell $ do+    Temp.withSystemTempDirectory template act'+  where+    act' fp = Ex.catch (unSh (act fp)) exHandler++-- | Create a temp directory in given directory, do something with it, then+--   remove it.+withCustomTempDirectory :: FilePath -> (FilePath -> Shell a) -> Shell a+withCustomTempDirectory dir act = Shell $ do+    Temp.withTempDirectory dir "shellmate" act'+  where+    act' fp = Ex.catch (unSh (act fp)) exHandler++-- | Create a temp file in the standard system temp directory, do something+--   with it, then remove it.+withTempFile :: String -> (FilePath -> IO.Handle -> Shell a) -> Shell a+withTempFile template act = Shell $ do+    Temp.withSystemTempFile template act'+  where+    act' fp h = Ex.catch (unSh (act fp h)) exHandler++-- | Create a temp file in the standard system temp directory, do something+--   with it, then remove it.+withCustomTempFile :: FilePath -> (FilePath -> IO.Handle -> Shell a) -> Shell a+withCustomTempFile dir act = Shell $ do+    Temp.withTempFile dir "shellmate" act'+  where+    act' fp h = Ex.catch (unSh (act fp h)) exHandler++-- | Perform an action that may fail without aborting the entire computation.+--   Forces serialization. If the inner computation terminates successfully,+--   the outer computation terminates as well.+try :: Shell a -> Shell (Either String a)+try (Shell act) = Shell $ do+  (pids, x) <- Ex.catch act exHandler+  merr <- waitPids pids+  case (merr, x) of+    (Just err, _) -> return ([], Next (Left err))+    (_, Next x')  -> return ([], Next (Right x'))+    (_, Fail err) -> return ([], Next (Left err))+    (_, Done)     -> return ([], Done)++-- | Wait for all processes in the given list. If a process has failed, its+--   error message is returned and the rest are killed.+waitPids :: [Pid] -> IO (Maybe String)+waitPids (p:ps) = do+  exCode <- Proc.waitForProcess (pidHandle p)+  case exCode of+    Exit.ExitFailure ec -> do+      killPids ps+      return . Just $ "Command '" ++ (pidName p) ++ "' failed with error "+                    ++" code " ++ show ec+    _ -> do+      waitPids ps+waitPids _ = do+  return Nothing++-- | Kill all processes in the list.+killPids :: [Pid] -> IO ()+killPids = mapM_ (Proc.terminateProcess . pidHandle)++-- | General exception handler; any exception causes failure.+exHandler :: Ex.SomeException -> IO ([Pid], Result a)+exHandler x = return ([], Fail $ show x)++-- | Like 'run', but echoes the command's text output to the screen instead of+--   returning it.+run_ :: FilePath -> [String] -> String -> Shell ()+run_ p args stdin = do+  exCode <- liftIO $ do+    (Just inp, _, _, pid) <- runP p args Proc.CreatePipe+                                         Proc.Inherit+                                         Proc.Inherit+    IO.hPutStr inp stdin+    IO.hClose inp+    Proc.waitForProcess pid+  case exCode of+    Exit.ExitFailure ec -> fail $ "Command '" ++ p ++ "' failed with error " +                                ++" code " ++ show ec+    _                   -> return ()++-- | Run an interactive process.+runInteractive :: FilePath -> [String] -> Shell ()+runInteractive p args = do+  exCode <- liftIO $ do+    (_, _, _, pid) <- runP p args Proc.Inherit Proc.Inherit Proc.Inherit+    Proc.waitForProcess pid+  case exCode of+    Exit.ExitFailure ec -> fail $ "Command '" ++ p ++ "' failed with error " +                                ++" code " ++ show ec+    _                   -> return ()++-- | Execute an external command. No globbing, escaping or other external shell+--   magic is performed on either the command or arguments. The program's+--   stdout will be returned, and not echoed to the screen.+run :: FilePath -> [String] -> String -> Shell String+run p args stdin = Shell $ do+  (output, _, pid) <- runHelper p args stdin Proc.Inherit+  return ([Pid p pid], Next output)++-- | Like 'run', but always succeeds and returns the program's standard+--   error stream and exit code.+genericRun :: FilePath -> [String] -> String -> Shell (Int, String, String)+genericRun p args stdin = Shell $ do+  (output, Just errh, pid) <- runHelper p args stdin Proc.CreatePipe+  exCode <- Proc.waitForProcess pid+  errstr <- liftIO $ IO.hGetContents errh+  case errstr `seq` exCode of+    Exit.ExitSuccess    -> return ([], Next (0, output, errstr))+    Exit.ExitFailure ec -> return ([], Next (ec, output, errstr))++-- | Helper for 'run' and 'runWithStderr'.+runHelper :: FilePath+           -> [String]+           -> String+           -> Proc.StdStream+           -> IO (String, Maybe IO.Handle, Proc.ProcessHandle)+runHelper p args inpstr errstream = do+  (Just inp, Just out, merr, pid) <- runP p args Proc.CreatePipe+                                                 Proc.CreatePipe+                                                 errstream+  let feed str = do+        case splitAt 4096 str of+          ([], [])      -> IO.hClose inp+          (first, str') -> IO.hPutStr inp first >> feed str'+  _ <- Conc.forkIO $ feed inpstr+  output <- IO.hGetContents out+  output `seq` return (output, merr, pid)++-- | Create a process. Helper for 'run' and friends.+runP :: String+     -> [String]+     -> Proc.StdStream+     -> Proc.StdStream+     -> Proc.StdStream+     -> IO (Maybe IO.Handle,+            Maybe IO.Handle,+            Maybe IO.Handle,+            Proc.ProcessHandle)+runP p args stdin stdout stderr =+    Proc.createProcess cproc+  where+    cproc = Proc.CreateProcess {+        Proc.cmdspec      = Proc.RawCommand p args,+        Proc.cwd          = Nothing,+        Proc.env          = Nothing,+        Proc.std_in       = stdin,+        Proc.std_out      = stdout,+        Proc.std_err      = stderr,+        Proc.close_fds    = False,+#if MIN_VERSION_process(1,2,0)+        Proc.delegate_ctlc = False,+#endif+        Proc.create_group = False+      }

@@ -1,5 +1,5 @@ name:                shellmate-version:             0.1.6+version:             0.2 synopsis:            Simple interface for shell scripting in Haskell. description:         Aims to simplify development of cross-platform shell scripts and similar things. homepage:            http://github.com/valderman/shellmate@@ -20,12 +20,23 @@ library   exposed-modules:     Control.Shell-  -- other-modules:       +    Control.Shell.Concurrent+    Control.Shell.Download+  other-modules:+    Control.Shell.Handle+    Control.Shell.Internal   build-depends:-    base >=4.5 && <5,+    base >=4.7 && <5,+    containers,     transformers >=0.3,-    time,+    download-curl,+    feed,+    tagsoup,+    xml,+    bytestring,     filepath,     process,     directory,     temporary+  ghc-options:+    -Wall