packages feed

shellmate 0.2.3 → 0.3

raw patch · 11 files changed

+797/−712 lines, 11 filesdep −HTTPdep −feeddep −network-uridep ~basedep ~transformers

Dependencies removed: HTTP, feed, network-uri, tagsoup, xml

Dependency ranges changed: base, transformers

Files

Control/Shell.hs view
@@ -1,60 +1,66 @@ {-# LANGUAGE TypeFamilies, CPP #-} -- | Simple interface for shell scripting-like tasks.-module Control.Shell (-    -- * Running Shell programs-    Shell, ExitReason (..),-    shell, shell_, exitString,+module Control.Shell+  ( -- * Running Shell programs+    Shell, ExitReason (..)+  , shell, shell_, exitString      -- * Error handling and control flow-    (|>),-    try, orElse, exit,-    Guard (..), guard, when, unless,+  , (|>), capture, stream, lift+  , try, orElse, exit+  , Guard (..), guard, when, unless      -- * Environment handling-    setEnv, getEnv, withEnv, lookupEnv, cmdline,+  , withEnv, withoutEnv, lookupEnv, getEnv, cmdline -    -- * Running commands-    MonadIO (..),-    run, run_, genericRun, runInteractive, sudo,+    -- * Running external commands+  , MonadIO (..), Env (..)+  , run, sudo+  , unsafeLiftIO+  , absPath, shellEnv, getShellEnv, joinResult, runSh      -- * Working with directories-    cd, cpdir, pwd, ls, mkdir, rmdir, inDirectory, isDirectory,-    withHomeDirectory, inHomeDirectory, withAppDirectory, inAppDirectory,-    forEachFile, forEachFile_, forEachDirectory, forEachDirectory_,+  , cpdir, pwd, ls, mkdir, rmdir, inDirectory, isDirectory+  , withHomeDirectory, inHomeDirectory, withAppDirectory, inAppDirectory+  , forEachFile, forEachFile_, forEachDirectory, forEachDirectory_      -- * Working with files-    isFile, rm, mv, cp, input, output,+  , isFile, rm, mv, cp, input, output+  , withFile, withBinaryFile, openFile, openBinaryFile      -- * Working with temporary files and directories-    withTempFile, withCustomTempFile,-    withTempDirectory, withCustomTempDirectory, inTempDirectory,+  , FileMode+  , withTempFile, withCustomTempFile+  , withTempDirectory, withCustomTempDirectory+  , inTempDirectory, inCustomTempDirectory      -- * Working with handles-    Handle, IOMode (..),-    stdin, stdout, stderr,-    hFlush, hClose, withFile, withBinaryFile, openFile, openBinaryFile,+  , Handle, IOMode (..)+  , hFlush, hClose+  , getStdIn, getStdOut, getStdErr      -- * Text I/O-    hPutStr, hPutStrLn, echo, ask,-    hGetLine, hGetContents,+  , hPutStr, hPutStrLn, echo, echo_, ask, stdin+  , hGetLine, hGetContents      -- * ByteString I/O-    hGetBytes, hPutBytes, hGetByteLine, hGetByteContents,+  , hGetBytes, hPutBytes, hGetByteLine, hGetByteContents      -- * Convenient re-exports-    module System.FilePath,-    module Control.Monad+  , 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.Base hiding (getEnv, takeEnvLock, releaseEnvLock, setShellEnv)+import qualified Control.Shell.Base as CSB import Control.Shell.Handle-import Control.Shell.Internal+import Control.Shell.File+import Control.Shell.Directory+import Control.Shell.Temp+import Control.Shell.Control+import Control.Monad hiding (guard, when, unless)+import System.FilePath  -- | Convert an 'ExitReason' into a 'String'. Successful termination yields --   the empty string, while abnormal termination yields the termination@@ -66,37 +72,42 @@ exitString (Failure "") = "abnormal termination" exitString (Failure s)  = s --- | Lazily read a file.-input :: FilePath -> Shell String-input = liftIO . readFile+-- | Get the complete environment for the current computation.+getShellEnv :: Shell Env+getShellEnv = CSB.getEnv --- | Lazily write a file.-output :: MonadIO m => FilePath -> String -> m ()-output f = liftIO . writeFile f+insert :: Eq k => k -> v -> [(k, v)] -> [(k, v)]+insert k' v' (kv@(k, _) : kvs)+  | k == k'   = (k', v') : kvs+  | otherwise = kv : insert k' v' kvs+insert _ _ _  = [] +delete :: Eq k => k -> [(k, v)] -> [(k, v)]+delete k' (kv@(k, _) : kvs)+  | k == k'   = kvs+  | otherwise = kv : delete k' kvs+delete _ _    = []+ -- | The executable's command line arguments. cmdline :: [String] cmdline = unsafePerformIO Env.getArgs --- | Set an environment variable.-setEnv :: MonadIO m => String -> String -> m ()-setEnv k v = liftIO $ Env.setEnv k v+-- | Run a computation with the given environment variable set.+withEnv :: String -> String -> Shell a -> Shell a+withEnv k v m = do+  e <- CSB.getEnv+  inEnv (e {envEnvVars = insert k v (envEnvVars e)}) m +-- | Run a computation with the given environment variable unset.+withoutEnv :: String -> Shell a -> Shell a+withoutEnv k m = do+  e <- CSB.getEnv+  inEnv (e {envEnvVars = delete k (envEnvVars e)}) m+ -- | 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 act = do-  v <- lookupEnv key-  setEnv key $ f (maybe "" id v)-  x <- act-  setEnv key $ maybe "" id v-  return x+lookupEnv k = lookup k . envEnvVars <$> CSB.getEnv  -- | Get the value of an environment variable. Returns the empty string if --   the variable doesn't exist.@@ -104,232 +115,21 @@ getEnv key = maybe "" id `fmap` lookupEnv key  -- | Run a command with elevated privileges.-sudo :: FilePath -> [String] -> String -> Shell String-sudo cmd as = run "sudo" (cmd:as)---- | Change working directory.-cd :: MonadIO m => FilePath -> m ()-cd = liftIO . Dir.setCurrentDirectory---- | Get the current working directory.-pwd :: MonadIO m => m FilePath-pwd = liftIO $ Dir.getCurrentDirectory---- | Remove a file.-rm :: MonadIO m => FilePath -> m ()-rm = liftIO . Dir.removeFile---- | Rename a file.-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 fromdir todir = do-    assert ("`" ++ fromdir ++ "' is not a directory") (isDirectory fromdir)-    exists <- isDirectory todir-    if exists-      then do-        mkdir True (todir </> takeFileName fromdir)-        go fromdir (todir </> takeFileName fromdir)-      else mkdir True todir >> go fromdir todir-  where-    go from to = do-      forEachDirectory_ from (\dir -> mkdir True (to </> dir))-      forEachFile_ from $ \file -> do-        let file' = to </> file-        assert (errOverwrite file') (not <$> isDirectory file')-        cp (from </> file) file'-    errOverwrite f = "cannot overwrite directory `" ++ f-                     ++ "' with non-directory"---- | Recursively perform an action on each subdirectory of the given directory.---   The path passed to the callback is relative to the given directory.---   The action will *not* be performed on the given directory itself.-forEachDirectory :: FilePath -> (FilePath -> Shell a) -> Shell [a]-forEachDirectory root f = go ""-  where-    dir = if null root then "." else root-    go subdir = do-      let dir' = dir </> subdir-      files <- ls dir'-      fromdirs <- filterM (\d -> isDirectory (dir' </> d)) files-      xs <- forM fromdirs $ \d -> do-        let d' = subdir </> d-        x <- f d'-        (x:) <$> go d'-      return (concat xs)---- | Like 'forEachDirectory', but discards its result.-forEachDirectory_ :: FilePath -> (FilePath -> Shell ()) -> Shell ()-forEachDirectory_ root f = go ""-  where-    dir = if null root then "." else root-    go subdir = do-      let dir' = dir </> subdir-      files <- ls dir'-      fromdirs <- filterM (\d -> isDirectory (dir' </> d)) files-      forM_ fromdirs $ \d -> let d' = subdir </> d in f d' >> go d'---- | 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---   directory is not affected.-forEachFile :: FilePath -> (FilePath -> Shell a) -> Shell [a]-forEachFile root f = go ""-  where-    dir = if null root then "." else root-    go subdir = do-      let dir' = dir </> subdir-      files <- ls dir'-      -      -- For each file in this directory...-      onlyfiles <- filterM (\fl -> isFile (dir' </> fl)) files-      xs <- mapM (\x -> f (subdir </> x)) onlyfiles--      -- For each subdirectory...-      fromdirs <- filterM (\fl -> isDirectory (dir' </> fl)) files-      xss <- forM fromdirs $ \d -> do-        go (subdir </> d)-      return $ concat (xs:xss)---- | Like @forEachFile@ but only performs a side effect.-forEachFile_ :: FilePath -> (FilePath -> Shell ()) -> Shell ()-forEachFile_ root f = go ""-  where-    dir = if null root then "." else root-    go subdir = do-      let dir' = dir </> subdir-      files <- ls dir'-      filterM (\fl -> isFile (dir' </> fl)) files >>= mapM_ (f . (subdir </>))-      fromdirs <- filterM (\fl -> isDirectory (dir' </> fl)) files-      forM_ fromdirs $ \d -> go (subdir </> d)---- | Copy a file. Fails if the source is a directory. If the target is a---   directory, the source file is copied into that directory using its current---   name.-cp :: FilePath -> FilePath -> Shell ()-cp from to = do-  todir <- isDirectory to-  if todir-    then cp from (to </> takeFileName from)-    else liftIO $ Dir.copyFile from to---- | List the contents of a directory, sans '.' and '..'.-ls :: FilePath -> Shell [FilePath]-ls dir = do-  contents <- liftIO $ Dir.getDirectoryContents dir-  return [f | f <- contents, f /= ".", f /= ".."]---- | Create a directory. Optionally create any required missing directories as---   well.-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 :: 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---- | Perform an action with the user's home directory as the working directory.-inHomeDirectory :: Shell a -> Shell a-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 with the given application's data directory as the working---   directory.-inAppDirectory :: FilePath -> Shell a -> Shell a-inAppDirectory app act = withAppDirectory app $ flip inDirectory act---- | Execute a command in the given working directory, then restore the---   previous working directory.-inDirectory :: FilePath -> Shell a -> Shell a-inDirectory dir act = do-  curDir <- pwd-  cd dir-  x <- act-  cd curDir-  return x---- | Does the given path lead to a directory?-isDirectory :: FilePath -> Shell Bool-isDirectory = liftIO . Dir.doesDirectoryExist---- | Does the given path lead to a file?-isFile :: FilePath -> Shell Bool-isFile = liftIO . Dir.doesFileExist+sudo :: FilePath -> [String] -> Shell ()+sudo cmd as = run "sudo" (cmd:"--":as)  -- | 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---- | 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 <- try a-  case ex of-    Right x -> return x-    _       -> b---- | Write a string to @stdout@ followed by a newline.-echo :: MonadIO m => String -> m ()-echo = liftIO . putStrLn---- | Read one line of input from @stdin@.-ask :: Shell String-ask = liftIO getLine--class Guard guard where-  -- | The type of the guard's return value, if it succeeds.-  type Result guard--  -- | Perform a Shell computation; if the computation succeeds but returns-  --   a false-ish value, the outer Shell computation fails with the given-  --   error message.-  assert :: String -> guard -> Shell (Result guard)--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-  type Result Bool = ()-  assert _ True = return ()-  assert ""  _  = fail $ "Guard failed!"-  assert desc _ = fail desc--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 ""+inTempDirectory = withTempDirectory . flip inDirectory --- | 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 ()+-- | Performs a command inside a temporary directory. The directory will be+--   cleaned up after the command finishes.+inCustomTempDirectory :: FilePath -> Shell a -> Shell a+inCustomTempDirectory dir m = withCustomTempDirectory dir $ flip inDirectory m --- | 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+-- | Get the standard input, output and error handle respectively.+getStdIn, getStdOut, getStdErr :: Shell Handle+getStdIn  = envStdIn  <$> CSB.getEnv+getStdOut = envStdOut <$> CSB.getEnv+getStdErr = envStdErr <$> CSB.getEnv
+ Control/Shell/Base.hs view
@@ -0,0 +1,129 @@+-- | Basic operations such as reading input/output, etc.+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Control.Shell.Base+  ( module Control.Shell.Internal+  , module System.FilePath+  , IO.Handle, FileMode (..)+  , MonadIO (..), shellEnv+  , shell_+  , stdin, echo, echo_, ask+  , capture, stream, lift+  , takeEnvLock, releaseEnvLock, setShellEnv, joinResult, absPath+  ) where+import qualified System.Process as Proc+import qualified System.IO as IO+import qualified Control.Concurrent as Conc+import qualified System.Directory as Dir+import qualified System.Environment as Env+import System.FilePath+import Data.IORef+import Control.Monad.IO.Class+import System.IO.Unsafe+import Control.Shell.Internal++-- | Perform a file operation in binary or text mode?+data FileMode = BinaryMode | TextMode+  deriving (Show, Eq)++-- | Create an absolute path from the environment and a potentially relative+--   path. Has no effect if the path is already absolute.+absPath :: Env -> FilePath -> FilePath+absPath env fp+  | isAbsolute fp = fp+  | otherwise     = envWorkDir env </> fp++{-# NOINLINE globalEnvLock #-}+globalEnvLock :: Conc.MVar ()+globalEnvLock = unsafePerformIO $ Conc.newMVar ()++{-# NOINLINE globalEnv #-}+globalEnv :: IORef Env+globalEnv = unsafePerformIO $ newIORef undefined++-- | Take the global environment lock.+takeEnvLock :: Shell ()+takeEnvLock = unsafeLiftIO $ Conc.takeMVar globalEnvLock++-- | Release the global environment lock.+releaseEnvLock :: Shell ()+releaseEnvLock = unsafeLiftIO $ Conc.putMVar globalEnvLock ()++-- | Set the global shell environment to the one of the current computation.+--   Returns the current global environment.+--   Should never, ever, be called without holding the global environment lock.+setShellEnv :: Env -> IO Env+setShellEnv env = do+  evs <- Env.getEnvironment+  wd <- Dir.getCurrentDirectory+  writeIORef globalEnv env+  Dir.setCurrentDirectory (envWorkDir env)+  mapM_ Env.unsetEnv (map fst evs)+  mapM_ (uncurry Env.setEnv) (envEnvVars env)+  return $ Env IO.stdin IO.stdout IO.stderr wd evs++-- | Get the current global shell environment, including standard input,+--   output and error handles. Only safe to call within a computation lifted+--   into 'Shell' by 'liftIO'.+shellEnv :: IO Env+shellEnv = readIORef globalEnv++instance MonadIO Shell where+  liftIO m = do+    env <- getEnv+    unsafeLiftIO $ Conc.withMVar globalEnvLock $ \_ -> do+      oldenv <- setShellEnv env+      m <* setShellEnv oldenv++-- | Run a shell computation and return its result. If the computation calls+--   'exit', the return value will be undefined. If the computation fails,+--   an error will be thrown.+shell_ :: Shell a -> IO a+shell_ m = do+  res <- shell m+  case res of+    Right x          -> pure x+    Left Success     -> pure $ error "Shell computation terminated successfully"+    Left (Failure e) -> error e++-- | Perform the given computation and return its standard output.+capture :: Shell () -> Shell String+capture m = do+  env <- getEnv+  (r, w) <- unsafeLiftIO Proc.createPipe+  inEnv (env {envStdOut = w}) m+  unsafeLiftIO $ IO.hClose w >> IO.hGetContents r++-- | Lift a pure function to a computation over standard input/output.+--   Similar to 'interact'.+stream :: (String -> String) -> Shell ()+stream f = stdin >>= echo_ . f++-- | Lift a shell computation to a function over stdin and stdout.+--   Similar to 'interact'.+lift :: (String -> Shell String) -> Shell ()+lift f = stdin >>= f >>= echo_++-- | Get the contents of the computation's standard input.+stdin :: Shell String+stdin = getEnv >>= unsafeLiftIO . IO.hGetContents . envStdIn++-- | Write a string to standard output, followed by a newline.+echo :: String -> Shell ()+echo s = getEnv >>= unsafeLiftIO . flip IO.hPutStrLn s . envStdOut++-- | Write a string to standard output, without appending a newline.+echo_ :: String -> Shell ()+echo_ s = getEnv >>= unsafeLiftIO . flip IO.hPutStr s . envStdOut++-- | Read a line of text from standard input.+ask :: Shell String+ask = getEnv >>= unsafeLiftIO . IO.hGetLine . envStdIn++-- | Propagate an explicit 'ExitResult' through the computation.+joinResult :: Shell (Either ExitReason a) -> Shell a+joinResult m = do+  res <- m+  case res of+    Right x          -> pure x+    Left Success     -> exit+    Left (Failure e) -> fail e
Control/Shell/Concurrent.hs view
@@ -6,14 +6,12 @@     parallel, parallel_,     chunks   ) where-#if __GLASGOW_HASKELL__ <= 708-import Control.Applicative-#endif import Control.Concurrent import Control.Monad import Control.Shell import Data.IORef +-- | Only used to have something reliable to attach the futures' weakrefs to. type FinalizerHandle = IORef ThreadId  -- | A future is a computation which is run in parallel with a program's main@@ -23,40 +21,43 @@ --   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.+--+--   Note that all any code called in a future using 'unsafeLiftIO' must+--   refrain from using environment variables, standard input/output, relative+--   paths and the current working directory, in order to avoid race+--   conditions. Code within the 'Shell' monad, code imported using 'liftIO'+--   and external processes spawned from within 'Shell' is perfectly safe. 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'+future m = do+  env <- getShellEnv+  unsafeLiftIO $ do+    v <- newEmptyMVar+    tid <- forkIO $ runSh env 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  -- | Wait for a future value. await :: Future a -> Shell a-await (Future h v) = liftIO (readMVar v <* readIORef h) >>= fromResult+await (Future h v) = joinResult $ unsafeLiftIO (readMVar v <* readIORef h)  -- | 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)+  mx <- unsafeLiftIO $ tryReadMVar v <* readIORef h+  case h `seq` mx of+    Just x -> Just <$> joinResult (pure x)+    _      -> pure Nothing  -- | Perform the given computations in parallel.+--   The race condition warning for 'Future' when modifying environment+--   variables or using relative paths still applies. parallel :: [Shell a] -> Shell [a] parallel = mapM future >=> mapM await
+ Control/Shell/Control.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TypeFamilies #-}+-- | Control flow constructs.+module Control.Shell.Control+  ( module Control.Monad+  , Guard (..)+  , guard, when, unless, orElse+  ) where+import Control.Shell.Internal+import Control.Monad hiding (when, unless, guard)++-- | 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 <- try a+  case ex of+    Right x -> return x+    _       -> b++class Guard guard where+  -- | The type of the guard's return value, if it succeeds.+  type Result guard++  -- | Perform a Shell computation; if the computation succeeds but returns+  --   a false-ish value, the outer Shell computation fails with the given+  --   error message.+  assert :: String -> guard -> Shell (Result guard)++instance Guard (Maybe a) where+  type Result (Maybe a) = a+  assert _ (Just x) = return x+  assert desc _     = fail desc++instance Guard Bool where+  type Result Bool = ()+  assert _ True = return ()+  assert desc _ = fail desc++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.+--   Corresponds to 'CM.guard'.+guard :: Guard g => g -> Shell (Result g)+guard = assert "Guard failed!"++-- | Perform the given computation if the given guard passes, otherwise do+--   nothing.The guard raising an error counts as failure as far as this+--   function is concerned.+--   Corresponds to 'CM.when'.+when :: Guard g => g -> Shell () -> Shell ()+when g m = do+  res <- try (guard g)+  case res of+    Right _ -> m+    _       -> return ()++-- | Perform the given computation if the given guard fails, otherwise do+--   nothing. The guard raising an error counts as failure as far as this+--   function is concerned.+--   Corresponds to 'CM.unless'.+unless :: Guard g => g -> Shell () -> Shell ()+unless g m = void (guard g) `orElse` m
+ Control/Shell/Directory.hs view
@@ -0,0 +1,161 @@+-- | Working with directories.+module Control.Shell.Directory where+import qualified System.Directory as Dir+import Control.Monad+import Control.Shell.Base+import Control.Shell.Control+import Control.Shell.File++-- | Get the current working directory.+pwd :: Shell FilePath+pwd = envWorkDir <$> getEnv++-- | 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 f t = do+    e <- getEnv+    let fromdir = absPath e f+        todir = absPath e t+    assert ("`" ++ fromdir ++ "' is not a directory") (isDirectory fromdir)+    exists <- isDirectory todir+    if exists+      then do+        mkdir True (todir </> takeFileName fromdir)+        go fromdir (todir </> takeFileName fromdir)+      else mkdir True todir >> go fromdir todir+  where+    go from to = do+      forEachDirectory_ from (\dir -> mkdir True (to </> dir))+      forEachFile_ from $ \file -> do+        let file' = to </> file+        assert (errOverwrite file') (not <$> isDirectory file')+        cp (from </> file) file'+    errOverwrite d = "cannot overwrite directory `" ++ d+                     ++ "' with non-directory"++-- | Recursively perform an action on each subdirectory of the given directory.+--   The path passed to the callback is relative to the given directory.+--   The action will *not* be performed on the given directory itself.+forEachDirectory :: FilePath -> (FilePath -> Shell a) -> Shell [a]+forEachDirectory r f = do+    e <- getEnv+    go (absPath e $ if null r then "." else r) ""+  where+    go dir subdir = do+      let dir' = dir </> subdir+      files <- ls dir'+      fromdirs <- filterM (\d -> isDirectory (dir' </> d)) files+      xs <- forM fromdirs $ \d -> do+        let d' = subdir </> d+        x <- f d'+        (x:) <$> go dir d'+      return (concat xs)++-- | Like 'forEachDirectory', but discards its result.+forEachDirectory_ :: FilePath -> (FilePath -> Shell ()) -> Shell ()+forEachDirectory_ r f = do+    e <- getEnv+    go (absPath e $ if null r then "." else r) ""+  where+    go dir subdir = do+      let dir' = dir </> subdir+      files <- ls dir'+      fromdirs <- filterM (\d -> isDirectory (dir' </> d)) files+      forM_ fromdirs $ \d -> let d' = subdir </> d in f d' >> go dir d'++-- | 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+--   directory is not affected.+forEachFile :: FilePath -> (FilePath -> Shell a) -> Shell [a]+forEachFile r f = do+    e <- getEnv+    go (absPath e $ if null r then "." else r) ""+  where+    go dir subdir = do+      let dir' = dir </> subdir+      files <- ls dir'+      +      -- For each file in this directory...+      onlyfiles <- filterM (\fl -> isFile (dir' </> fl)) files+      xs <- mapM (\x -> f (subdir </> x)) onlyfiles++      -- For each subdirectory...+      fromdirs <- filterM (\fl -> isDirectory (dir' </> fl)) files+      xss <- forM fromdirs $ \d -> do+        go dir (subdir </> d)+      return $ concat (xs:xss)++-- | Like @forEachFile@ but only performs a side effect.+forEachFile_ :: FilePath -> (FilePath -> Shell ()) -> Shell ()+forEachFile_ r f = do+    e <- getEnv+    go (absPath e $ if null r then "." else r) ""+  where+    go dir subdir = do+      let dir' = dir </> subdir+      files <- ls dir'+      filterM (\fl -> isFile (dir' </> fl)) files >>= mapM_ (f . (subdir </>))+      fromdirs <- filterM (\fl -> isDirectory (dir' </> fl)) files+      forM_ fromdirs $ \d -> go dir (subdir </> d)++-- | List the contents of a directory, sans '.' and '..'.+ls :: FilePath -> Shell [FilePath]+ls dir = do+  e <- getEnv+  contents <- unsafeLiftIO $ Dir.getDirectoryContents (absPath e dir)+  return [f | f <- contents, f /= ".", f /= ".."]++-- | Create a directory. Optionally create any required missing directories as+--   well.+mkdir :: Bool -> FilePath -> Shell ()+mkdir True dir = do+  e <- getEnv+  unsafeLiftIO $ Dir.createDirectoryIfMissing True (absPath e dir)+mkdir _    dir = do+  e <- getEnv+  unsafeLiftIO $ Dir.createDirectory (absPath e dir)++-- | Recursively remove a directory. Follows symlinks, so be careful.+rmdir :: FilePath -> Shell ()+rmdir dir = do+  e <- getEnv+  unsafeLiftIO $ Dir.removeDirectoryRecursive (absPath e dir)++-- | Do something with the user's home directory.+withHomeDirectory :: (FilePath -> Shell a) -> Shell a+withHomeDirectory act = liftIO Dir.getHomeDirectory >>= act++-- | Perform an action with the user's home directory as the working directory.+inHomeDirectory :: Shell a -> Shell a+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 with the given application's data directory as the working+--   directory.+inAppDirectory :: FilePath -> Shell a -> Shell a+inAppDirectory app act = withAppDirectory app $ flip inDirectory act++-- | Execute a command in the given working directory, then restore the+--   previous working directory.+inDirectory :: FilePath -> Shell a -> Shell a+inDirectory dir act = do+  env <- getEnv+  inEnv (env {envWorkDir = absPath env dir}) act++-- | Does the given path lead to a directory?+isDirectory :: FilePath -> Shell Bool+isDirectory dir = do+  e <- getEnv+  unsafeLiftIO $ Dir.doesDirectoryExist (absPath e dir)++-- | Does the given path lead to a file?+isFile :: FilePath -> Shell Bool+isFile f = do+  e <- getEnv+  unsafeLiftIO $ Dir.doesFileExist (absPath e f)
− Control/Shell/Download.hs 
@@ -1,84 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-}--- | High level functions for downloading files.-module Control.Shell.Download-  ( URI-  , fetch, fetchBytes-  , fetchFile-#if DOWNLOAD_EXTRAS-  , fetchTags, fetchXML, fetchFeed-#endif-  ) where-import Data.ByteString as BS (ByteString, writeFile)-import Data.String-import Network.HTTP-import qualified Network.URI as U-#if DOWNLOAD_EXTRAS-import Text.Feed.Import (parseFeedString)-import Text.Feed.Types (Feed)-import Text.HTML.TagSoup (Tag, parseTags)-import Text.XML.Light (Content, parseXML)-#endif-import Control.Shell---- | A Uniform Resource Locator.-type URI = String--liftE :: Show e => IO (Either e a) -> Shell a-liftE m = do-  res <- liftIO m-  case res of-    Left e  -> fail (show e)-    Right x -> return x--httpFail :: (Int, Int, Int) -> String -> Shell a-httpFail (a,b,c) reason =-  fail $ "HTTP error " ++ concat [show a, show b, show c] ++ ": " ++ reason--fetchSomething :: (IsString a, HStream a) => URI -> Shell a-fetchSomething uri = do-    u <- assert ("could not parse URI `" ++ uri ++ "'") (U.parseURI uri)-    rsp <- liftE $ simpleHTTP (req u)-    case rspCode rsp of-      (2,_,_) -> return (rspBody rsp)-      code    -> httpFail code (rspReason rsp)-  where-    req u = Request {-        rqURI = u,-        rqMethod = GET,-        rqHeaders = [],-        rqBody = ""-      }---- | Download content specified by a url using curl, returning the content---   as a strict 'ByteString'.-fetchBytes :: URI -> Shell ByteString-fetchBytes = fetchSomething---- | Download content specified by a url using curl, returning the content---   as a 'String'.-fetch :: URI -> Shell String-fetch = fetchSomething---- | 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--#if DOWNLOAD_EXTRAS--- | 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 = fmap parseTags . fetch---- | Download the content as for 'fetch', but return it as parsed XML, using---   the xml-light parser.-fetchXML :: URI -> Shell [Content]-fetchXML = fmap parseXML . fetch---- | 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 uri = do-  str <- fetch uri-  assert ("could not parse feed from `" ++ uri ++ "'") (parseFeedString str)-#endif
+ Control/Shell/File.hs view
@@ -0,0 +1,71 @@+-- | Working with files.+module Control.Shell.File+  ( rm, mv, cp+  , input, output+  , IO.IOMode (..)+  , withFile, withBinaryFile+  , openFile, openBinaryFile+  ) where+import qualified System.Directory as Dir+import qualified System.IO as IO+import Control.Shell.Base++-- | Lazily read a file.+input :: FilePath -> Shell String+input f = do+  e <- getEnv+  unsafeLiftIO $ readFile (absPath e f)++-- | Lazily write a file.+output :: FilePath -> String -> Shell ()+output f s = do+  e <- getEnv+  unsafeLiftIO $ writeFile (absPath e f) s++-- | Remove a file.+rm :: FilePath -> Shell ()+rm dir = do+  e <- getEnv+  unsafeLiftIO $ Dir.removeFile (absPath e dir)++-- | Rename a file.+mv :: FilePath -> FilePath -> Shell ()+mv from to = do+  e <- getEnv+  unsafeLiftIO $ Dir.renameFile (absPath e from) (absPath e to)++-- | Copy a file. Fails if the source is a directory. If the target is a+--   directory, the source file is copied into that directory using its current+--   name.+cp :: FilePath -> FilePath -> Shell ()+cp f t = do+  e <- getEnv+  let (from, to) = (absPath e f, absPath e t)+  todir <- unsafeLiftIO $ Dir.doesDirectoryExist to+  if todir+    then cp from (to </> takeFileName from)+    else liftIO $ Dir.copyFile from to++-- | Perform a computation over a file.+withFile :: FilePath -> IO.IOMode -> (IO.Handle -> Shell a) -> Shell a+withFile file mode f = joinResult $ do+  e <- getEnv+  unsafeLiftIO (IO.withFile (absPath e file) mode (shell . f))++-- | Perform a computation over a binary file.+withBinaryFile :: FilePath -> IO.IOMode -> (IO.Handle -> Shell a) -> Shell a+withBinaryFile file mode f = joinResult $ do+  e <- getEnv+  unsafeLiftIO (IO.withBinaryFile (absPath e file) mode (shell . f))++-- | Open a file, returning a handle to it.+openFile :: FilePath -> IO.IOMode -> Shell IO.Handle+openFile file mode = do+  e <- getEnv+  unsafeLiftIO $ IO.openFile (absPath e file) mode++-- | Open a file in binary mode, returning a handle to it.+openBinaryFile :: FilePath -> IO.IOMode -> Shell IO.Handle+openBinaryFile file mode = do+  e <- getEnv+  unsafeLiftIO $ IO.openBinaryFile (absPath e file) mode
Control/Shell/Handle.hs view
@@ -1,78 +1,50 @@ -- | 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+    hFlush, hClose   ) where import qualified System.IO as IO import qualified Data.ByteString as BS-import Control.Shell.Internal+import Control.Shell.Base  -- | Write a string to a handle. hPutStr :: IO.Handle -> String -> Shell ()-hPutStr h s = liftIO $ IO.hPutStr h s+hPutStr h s = unsafeLiftIO $ 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+hPutStrLn h s = unsafeLiftIO $ IO.hPutStrLn h s  -- | Close a handle. hClose :: IO.Handle -> Shell ()-hClose = liftIO . IO.hClose+hClose = unsafeLiftIO . IO.hClose  -- | Flush a handle. hFlush :: IO.Handle -> Shell ()-hFlush = liftIO . IO.hFlush+hFlush = unsafeLiftIO . IO.hFlush  -- | Read a line of input from a handle. hGetLine :: IO.Handle -> Shell String-hGetLine = liftIO . IO.hGetLine+hGetLine = unsafeLiftIO . IO.hGetLine  -- | Lazily read all remaining input from a handle. hGetContents :: IO.Handle -> Shell String-hGetContents = liftIO . IO.hGetContents+hGetContents = unsafeLiftIO . IO.hGetContents  -- | Read @n@ bytes from a handle. hGetBytes :: IO.Handle -> Int -> Shell BS.ByteString-hGetBytes h = liftIO . BS.hGet h+hGetBytes h = unsafeLiftIO . 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+hGetByteLine = unsafeLiftIO . 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+hGetByteContents = unsafeLiftIO . 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+hPutBytes h = unsafeLiftIO . BS.hPutStr h
Control/Shell/Internal.hs view
@@ -1,303 +1,219 @@-{-# 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+{-# LANGUAGE CPP, GADTs, RecordWildCards #-}+-- | Primitives and run function.+module Control.Shell.Internal+  ( Shell+  , ExitReason (..), Env (..)+  , shell, runSh+  , exit, run, try, getEnv, inEnv, unsafeLiftIO, (|>)   ) where-#if __GLASGOW_HASKELL__ <= 708-import Control.Applicative-#endif-import Control.Monad (ap)-import Control.Monad.IO.Class+import Control.Monad (when, ap) import qualified Control.Concurrent as Conc import qualified Control.Exception as Ex-import Data.List (sort)-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+import qualified System.Directory as Dir (getCurrentDirectory)+import qualified System.Environment as Env (getEnvironment)  -- | A command name plus a ProcessHandle.-data Pid = Pid {pidName :: String, pidHandle :: Proc.ProcessHandle}+data Pid = PID !String                         !Proc.ProcessHandle+         | TID !(Conc.MVar (Maybe ExitReason)) !Conc.ThreadId --- | 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)+-- | A shell environment: consists of the current standard input, output and+--   error handles used by the computation, as well as the current working+--   directory and set of environment variables.+data Env = Env+  { envStdIn   :: !IO.Handle+  , envStdOut  :: !IO.Handle+  , envStdErr  :: !IO.Handle+  , envWorkDir :: !FilePath+  , envEnvVars :: ![(String, String)]   } -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+-- | A shell command: either an IO computation or a pipeline of at least one+--   step.+data Shell a where+  Lift   :: !(IO a) -> Shell a+  Pipe   :: ![PipeStep] -> Shell ()+  Bind   :: Shell a -> (a -> Shell b) -> Shell b+  GetEnv :: Shell Env+  InEnv  :: Env -> Shell a -> Shell a+  Try    :: Shell a -> Shell (Either String a)+  Done   :: Shell a+  Fail   :: String -> Shell a -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)+-- | A step in a pipeline: either a shell computation or an external process.+data PipeStep+  = Proc     !String ![String]+  | Internal !(Shell ()) -instance MonadIO Shell where-  liftIO act = Shell $ flip Ex.catch exHandler $ do-    x <- act-    return ([], Next x)+instance Functor Shell where+  fmap f m = m >>= return . f  instance Applicative Shell where-  pure  = return   (<*>) = ap+  pure  = return -instance Functor Shell where-  fmap f (Shell x) = Shell (fmap (fmap (fmap f)) x)+instance Monad Shell where+  return = Lift . return+  (>>=)  = Bind+  fail   = Fail --- | Given a list of old key-value pairs and a list of new key-value pairs,---   returns the list of key-value pairs where the key exists in both the old---   and the new list, and the values are different between the new and the old---   list. The values in the returned list are taken from the old list.---   Keys must be unique.---   @oldValues [(a, 1), (c, 2)] [(b, 3), (c, 4)] == [(c, 2)]@-oldValues :: (Ord a, Eq a, Eq b) => [(a, b)] -> [(a, b)] -> [(a, b)]-oldValues xxs@((k1, v1):xs) yys@((k2, v2):ys)-  | k1 <  k2             = oldValues xs yys-  | k1 >  k2             = oldValues xxs ys-  | k1 == k2 && v1 /= v2 = (k1, v1) : oldValues xs ys-  | otherwise            = oldValues xs ys-oldValues _ _            = []+-- | Lift an IO computation into a shell. The lifted computation is not+--   thread-safe, and should thus absolutely not use environment variables,+--   relative paths or standard input/output.+unsafeLiftIO :: IO a -> Shell a+unsafeLiftIO = Lift --- | Remove all given keys from the given key-value list. Both lists must be---   sorted, and the keys in the key-value list must be unique.-(\\) :: (Ord a, Eq a) => [(a, b)] -> [(a, b)] -> [(a, b)]-xxs@(x@(k1,_):xs) \\ kks@((k,_):ks)-  | k <  k1 = xxs \\ ks-  | k >  k1 = x:(xs \\ kks)-  | k == k1 = xs \\ ks-xs \\ _     = xs+-- | Why did the computation terminate?+data ExitReason = Success | Failure !String+  deriving (Show, Eq) --- | Run a Shell computation. The program's working directory and environment---   will be restored after after the computation finishes.+-- | Run a shell computation. If part of the computation fails, the whole+--   computation fails. The computation's environment is initially that of the+--   whole process. shell :: Shell a -> IO (Either ExitReason a)-shell act = do-    dir <- Dir.getCurrentDirectory-    env <- sort <$> 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+shell m = do+    evs <- Env.getEnvironment+    wd <- Dir.getCurrentDirectory+    runSh (env wd evs) m   where-    resultToEither (Next x) = Right x-    resultToEither (Fail e) = Left (Failure e)-    resultToEither (Done)   = Left Success--    resetEnv :: [(String, String)] -> IO ()-    resetEnv old = do-      new <- sort <$> Env.getEnvironment-      mapM_ (Env.unsetEnv . fst) (new \\ old)-      mapM_ (uncurry Env.setEnv) (oldValues old new)+    env wd evs = Env+      { envStdIn   = IO.stdin+      , envStdOut  = IO.stdout+      , envStdErr  = IO.stderr+      , envWorkDir = wd+      , envEnvVars = evs+      } --- | 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+runSh :: Env -> Shell a -> IO (Either ExitReason a)+runSh _ (Lift m) = do+  Ex.catch (Right <$> m)+           (\(Ex.SomeException e) -> pure $ Left (Failure (show e)))+runSh env (Pipe p) = do+  ((stepenv, step) : steps) <- mkEnvs env p+  ma <- waitPids =<< mapM (uncurry (runStep True)) steps+  mb <- waitPids . (:[]) =<< runStep False stepenv step+  case ma >> mb of+    Just err -> pure $ Left err+    _        -> pure $ Right ()+runSh _ Done = do+  return $ Left Success+runSh env (Bind m f) = do+  res <- runSh env m   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+    Right x -> runSh env (f x)+    Left e  -> pure $ Left e+runSh env GetEnv = do+  pure $ Right env+runSh _ (InEnv env m) = do+  runSh env m+runSh env (Try m) = do+  res <- runSh env m+  case res of+    Right x          -> pure $ Right (Right x)+    Left (Failure e) -> pure $ Right (Left e)+    Left Success     -> pure $ Left Success+runSh _ (Fail e) = do+  pure $ Left (Failure e) --- | 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'+-- | Start a pipeline step.+runStep :: Bool -> Env -> PipeStep -> IO Pid+runStep closefds Env{..} (Proc cmd args) = do+    (_, _, _, ph) <- Proc.createProcess cproc+    pure $ PID cmd ph   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'+    cproc = Proc.CreateProcess+      { Proc.cmdspec      = Proc.RawCommand cmd args+      , Proc.cwd          = Just envWorkDir+      , Proc.env          = Just envEnvVars+      , Proc.std_in       = Proc.UseHandle envStdIn+      , Proc.std_out      = Proc.UseHandle envStdOut+      , Proc.std_err      = Proc.UseHandle envStdErr+      , Proc.close_fds    = closefds+#if MIN_VERSION_process(1,2,0)+      , Proc.delegate_ctlc = False+#endif+      , Proc.create_group = False+      }+runStep closefds env (Internal cmd) = do+  v <- Conc.newEmptyMVar+  tid <- Conc.forkFinally (runSh env cmd >>= done) $ \res -> do+    case res of+      Right (Left e) -> Conc.putMVar v (Just e)+      Left e         -> Conc.putMVar v (Just $ Failure $ show e)+      _              -> Conc.putMVar v Nothing+  pure $ TID v tid   where-    act' fp h = Ex.catch (unSh (act fp h)) exHandler+    done x = do+      when closefds $ IO.hClose (envStdOut env)+      return x --- | 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'+-- | Pair up pipe steps with corresponding environments, ensuring that each+--   step is connected to the next via a pipe.+mkEnvs :: Env -> [PipeStep] -> IO [(Env, PipeStep)]+mkEnvs env = go [] (envStdIn env)   where-    act' fp h = Ex.catch (unSh (act fp h)) exHandler+    go acc stdi (step : steps) = do+      (next, stdo) <- Proc.createPipe+      go ((env {envStdIn = stdi, envStdOut = stdo}, step):acc) next steps+    go ((e, s) : steps) _ _ = do+      pure ((e {envStdOut = envStdOut env}, s) : steps)+    go acc _ _ = pure acc --- | 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)+-- | Terminate a pid, be it process or thread.+killPid :: Pid -> IO ()+killPid (PID _ p) = Proc.terminateProcess p+killPid (TID _ t) = Conc.killThread t  -- | 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)+waitPids :: [Pid] -> IO (Maybe ExitReason)+waitPids (PID cmd p : ps) = do+  exCode <- Proc.waitForProcess p   case exCode of     Exit.ExitFailure ec -> do-      killPids ps-      return . Just $ "Command '" ++ (pidName p) ++ "' failed with error "-                    ++" code " ++ show ec+      mapM_ killPid ps+      return . Just $ Failure $ "Command '" ++ cmd ++ "' failed with error "+                              ++" code " ++ show ec     _ -> do       waitPids ps+waitPids (TID v _ : ps) = do+  merr <- Conc.takeMVar v+  case merr of+    Just e -> mapM_ killPid ps >> return (Just e)+    _      -> 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)+--   stdout will be written to stdout.+run :: FilePath -> [String] -> Shell ()+run p args = Pipe [Proc p args] --- | 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))+-- | Terminate the program successfully.+exit :: Shell a+exit = Done --- | 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)+-- | Connect the standard output of the first argument to the standard input+--   of the second argument, and run the two computations in parallel.+(|>) :: Shell () -> Shell () -> Shell ()+Pipe m |> Pipe n = Pipe (m ++ n)+Pipe m |> n      = Pipe (m ++ [Internal n])+m      |> Pipe n = Pipe (Internal m : n)+m      |> n      = Pipe [Internal m, Internal n]+infixl 5 |> --- | 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-      }+-- | Run a computation in the given environment.+inEnv :: Env -> Shell a -> Shell a+inEnv = InEnv++-- | Get the current environment.+getEnv :: Shell Env+getEnv = GetEnv++-- | Attempt to run a computation. If the inner computation fails, the outer+--   computations returns its error message, otherwise its result is returned.+try :: Shell a -> Shell (Either String a)+try = Try
+ Control/Shell/Temp.hs view
@@ -0,0 +1,66 @@+-- | Temporary files and directories.+module Control.Shell.Temp+  ( withTempDirectory, withCustomTempDirectory+  , withTempFile, withCustomTempFile+  ) where+import Control.Shell.Base+import qualified System.IO.Temp as Temp+import qualified System.IO as IO++-- | Create a temp directory in the standard system temp directory, do+--   something with it, then remove it.+withTempDirectory :: (FilePath -> Shell a) -> Shell a+withTempDirectory act = joinResult $ do+  env <- getEnv+  takeEnvLock+  unsafeLiftIO $ do+    oldenv <- setShellEnv env+    Temp.withSystemTempDirectory "shellmate" $ \fp -> do+      setShellEnv oldenv+      runSh env $ do+        releaseEnvLock+        act fp++-- | Create a temp directory in given directory, do something with it, then+--   remove it.+withCustomTempDirectory :: FilePath -> (FilePath -> Shell a) -> Shell a+withCustomTempDirectory dir act = joinResult $ do+  env <- getEnv+  takeEnvLock+  unsafeLiftIO $ do+    oldenv <- setShellEnv env+    Temp.withTempDirectory dir "shellmate" $ \fp -> do+      setShellEnv oldenv+      runSh env $ do+        releaseEnvLock+        act fp++-- | Create a temp file in the standard system temp directory, do something+--   with it, then remove it.+withTempFile :: FileMode -> (FilePath -> IO.Handle -> Shell a) -> Shell a+withTempFile fm act = joinResult $ do+  env <- getEnv+  takeEnvLock+  unsafeLiftIO $ do+    oldenv <- setShellEnv env+    Temp.withSystemTempFile "shellmate" $ \fp h -> do+      setShellEnv oldenv+      runSh env $ do+        releaseEnvLock+        unsafeLiftIO $ IO.hSetBinaryMode h (fm == BinaryMode)+        act fp h++-- | Create a temp file in the standard system temp directory, do something+--   with it, then remove it.+withCustomTempFile :: FileMode -> FilePath -> (FilePath -> IO.Handle -> Shell a) -> Shell a+withCustomTempFile fm dir act = joinResult $ do+  env <- getEnv+  takeEnvLock+  unsafeLiftIO $ do+    oldenv <- setShellEnv env+    Temp.withTempFile dir "shellmate" $ \fp h -> do+      setShellEnv oldenv+      runSh env $ do+        releaseEnvLock+        unsafeLiftIO $ IO.hSetBinaryMode h (fm == BinaryMode)+        act fp h
shellmate.cabal view
@@ -1,52 +1,40 @@ name:                shellmate-version:             0.2.3+version:             0.3 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+homepage:            https://github.com/valderman/shellmate license:             BSD3 license-file:        LICENSE author:              Anton Ekblad maintainer:          anton@ekblad.cc--- copyright:            category:            System build-type:          Simple-cabal-version:       >=1.8-bug-reports:         http://github.com/valderman/shellmate/issues+cabal-version:       >=1.10+bug-reports:         https://github.com/valderman/shellmate/issues  source-repository head     type:       git     location:   https://github.com/valderman/shellmate.git--flag download-extras-    default: True-    description: Build Control.Shell.Download with extras for parsing downloaded HTML, XML, RSS and Atom feeds.      library   exposed-modules:     Control.Shell     Control.Shell.Concurrent-    Control.Shell.Download   other-modules:     Control.Shell.Handle     Control.Shell.Internal+    Control.Shell.Base+    Control.Shell.Temp+    Control.Shell.Control+    Control.Shell.File+    Control.Shell.Directory   build-depends:-    base         >=4.7    && <5,-    transformers >=0.3    && <0.5,-    bytestring   >=0.10   && <0.11,-    filepath     >=1.3    && <1.5,-    process      >=1.1    && <1.5,-    directory    >=1.1    && <1.3,-    temporary    >=1.1    && <1.3,-    -- for Control.Shell.Download-    HTTP         >=4000.2 && <4000.3,-    network-uri  >=2.6    && <2.7--  if flag(download-extras)-    build-depends:            -      feed    >=0.3    && <0.4,-      tagsoup >=0.13   && <0.14,-      xml     >=1.3    && <1.4-    cpp-options:-      -DDOWNLOAD_EXTRAS=1-  ghc-options:-    -Wall+    base         >=4.8  && <5,+    transformers >=0.3  && <0.5,+    bytestring   >=0.10 && <0.11,+    filepath     >=1.3  && <1.5,+    process      >=1.1  && <1.5,+    directory    >=1.1  && <1.3,+    temporary    >=1.1  && <1.3+  default-language:+    Haskell2010