diff --git a/handsy.cabal b/handsy.cabal --- a/handsy.cabal +++ b/handsy.cabal @@ -1,5 +1,5 @@ name: handsy -version: 0.0.9 +version: 0.0.10 synopsis: A DSL to describe common shell operations and interpeters for running them locally and remotely. -- description: Homepage: https://github.com/utdemir/handsy @@ -10,7 +10,6 @@ build-type: Simple cabal-version: >=1.10 - source-repository head type: git location: https://github.com/utdemir/master @@ -18,7 +17,8 @@ library exposed-modules: System.Handsy System.Handsy.Remote - System.Handsy.Core + System.Handsy.Util + System.Handsy.Internal build-depends: base >=4.6 && <4.8 , bytestring , process @@ -26,21 +26,21 @@ , free , process-extras , shell-escape + , retry + , data-default-class hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall + ghc-options: -Wall test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs default-language: Haskell2010 - hs-source-dirs: src test + hs-source-dirs: test build-depends: base >=4.6 && < 4.8 + , handsy , bytestring - , process - , transformers - , free - , process-extras - , shell-escape , tasty , tasty-hunit + , tasty-th diff --git a/src/System/Handsy.hs b/src/System/Handsy.hs --- a/src/System/Handsy.hs +++ b/src/System/Handsy.hs @@ -6,86 +6,105 @@ , run -- * Commands + , shell , command , readFile , writeFile , appendFile - , shell -- * Helpers - , command_ , shell_ + , command_ -- * Options + , CommandOptions (..) , Options (..) - , options -- * Re-exports , ExitCode (..) + , def ) where import Prelude hiding (appendFile, readFile, writeFile) +import Data.Bool +import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as C import System.Exit +import Data.Default.Class import System.Process.ByteString.Lazy -import System.Handsy.Core hiding (command) -import qualified System.Handsy.Core as I +import Text.ShellEscape +import System.Handsy.Internal hiding (shell) +import qualified System.Handsy.Internal as I + -- * Commands -- | Runs a command command :: FilePath -- ^ Command to run -> [String] -- ^ Arguments - -> B.ByteString -- ^ Standart Input + -> CommandOptions -> Handsy (ExitCode, B.ByteString, B.ByteString) -- ^ (status, stdout, stderr) -command = I.command +command cmd args opts = let cmd' = C8.unpack . C8.intercalate " " . map (bytes . bash . C8.pack) $ (cmd:args) + in shell cmd' opts +{-| Executes the given string in shell. Example: + + > shell "ls" $~ def{cwd="/var/www"} +-} +shell :: String -- ^ String to execute + -> CommandOptions + -> Handsy (ExitCode, B.ByteString, B.ByteString) -- ^ (ExitCode, Stdout, Stderr) +shell cmd opts = let esc = C8.unpack . bytes . bash . C8.pack + CommandOptions stdin' cwd' = opts + in I.shell (bool ("cd " ++ esc cwd' ++ "; ") "" (null cwd') ++ cmd) stdin' + +data CommandOptions = + CommandOptions { stdin :: B.ByteString + , cwd :: String + } + deriving Show + +instance Default CommandOptions where + def = CommandOptions "" "" + -- | Reads a file and returns the contents of the file. readFile :: FilePath -> Handsy B.ByteString -readFile fp = command "cat" [fp] "" >>= \case - (ExitSuccess, stdin, _) -> return stdin - _ -> error $ "Error reading " ++ fp +readFile fp = command "cat" [fp] def >>= \case + (ExitSuccess, stdout, _) -> return stdout + (_, _, stderr) -> error $ "Error reading " ++ fp ++ "\nStderr was: " ++ C.unpack stderr -- | @writeFile file str@ function writes the bytestring @str@, to the file @file@. writeFile :: FilePath -> B.ByteString -> Handsy () -writeFile fp s = command "dd" ["of=" ++ fp] s >>= \case +writeFile fp s = command "dd" ["of=" ++ fp] def{stdin=s} >>= \case (ExitSuccess, _, _) -> return () - _ -> error $ "Error writing to " ++ fp + (_, _, stderr) -> error $ "Error writing to " ++ fp ++ "\nStderr was: " ++ C.unpack stderr -- | @appendFile file str@ function appends the bytestring @str@, to the file @file@. appendFile :: FilePath -> B.ByteString -> Handsy () -appendFile fp s = command "dd" ["of=" ++ fp, "conv=notrunc", "oflag=append"] s >>= \case +appendFile fp s = command "dd" ["of=" ++ fp, "conv=notrunc", "oflag=append"] def{stdin=s} >>= \case (ExitSuccess, _, _) -> return () - _ -> error $ "Error appending to " ++ fp - -{-| Executes the given string in shell - - > shell cmd stdin = command "/usr/bin/env" ["sh", "-c", cmd] stdin --} -shell :: String -- ^ String to execute - -> B.ByteString -- ^ Standart input - -> Handsy (ExitCode, B.ByteString, B.ByteString) -- ^ (ExitCode, Stdout, Stderr) -shell cmd = command "sh" ["-c", cmd] + (_, _, stderr) -> error $ "Error appending to " ++ fp ++ "\nStderr was: " ++ C.unpack stderr -- | Same as 'command', but ExitFailure is a runtime error. -command_ :: FilePath -> [String] -> B.ByteString -> Handsy (B.ByteString, B.ByteString) -command_ path args stdin = command path args stdin >>= \case +command_ :: FilePath -> [String] -> CommandOptions -> Handsy (B.ByteString, B.ByteString) +command_ path args opts = command path args opts >>= \case (ExitFailure code, _, stderr) -> error ('`':path ++ ' ' : show args ++ "` returned " ++ show code ++ "\nStderr was: " ++ C.unpack stderr) (ExitSuccess, stdout, stderr) -> return (stdout, stderr) -- | Same as 'shell', but ExitFailure is a runtime error. -shell_ :: String -> B.ByteString -> Handsy (B.ByteString, B.ByteString) -shell_ cmd stdin = shell cmd stdin >>= \case +shell_ :: String -> CommandOptions -> Handsy (B.ByteString, B.ByteString) +shell_ cmd opts = shell cmd opts >>= \case (ExitFailure code, _, stderr) -> error ('`':cmd ++ "` returned " ++ show code ++ "\nStderr was: " ++ C.unpack stderr) (ExitSuccess, stdout, stderr) -> return (stdout, stderr) -- | Executes the actions locally run :: Options -> Handsy a -> IO a -run = interpretSimple readProcessWithExitCode +run = interpretSimple (\cmdline -> readProcessWithExitCode "bash" ["-c", cmdline]) + diff --git a/src/System/Handsy/Core.hs b/src/System/Handsy/Core.hs deleted file mode 100644 --- a/src/System/Handsy/Core.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} - -module System.Handsy.Core - ( Handsy - , interpret - , interpretSimple - , command - , Options (..) - , options - ) where - -import Control.Exception (bracket) -import Control.Monad -import Control.Monad.Free.TH -import Control.Monad.Trans.Free -import qualified Data.ByteString.Lazy as B -import System.Exit -import System.IO (hPutStrLn, stderr) - -data HandsyF k = - Command FilePath [String] B.ByteString ((ExitCode, B.ByteString, B.ByteString) -> k) - deriving (Functor) - -makeFree ''HandsyF - --- | Main monad -type Handsy = FreeT HandsyF IO - -data Options = - Options { debug :: Bool -- ^ Log commands to stderr before running - } - --- | Default options -options :: Options -options = Options False - -interpret :: IO r -- ^ Acquire resource - -> (r -> IO ()) -- ^ Release resource - -> (r -> String -> [String] -> B.ByteString - -> IO (ExitCode, B.ByteString, B.ByteString)) -- ^ 'readProcessWithExitCode' + resource - -> Options - -> Handsy a - -> IO a -interpret acquire destroy f opts handsy = bracket acquire destroy (`go` handsy) - where go res h = do - x <- runFreeT h - case x of - Pure r -> return r - Free (Command prg args stdin next) - -> when (debug opts) (hPutStrLn stderr $ prg ++ ' ' : show args) - >> f res prg args stdin >>= go res . next - -interpretSimple :: (String -> [String] -> B.ByteString - -> IO (ExitCode, B.ByteString, B.ByteString)) -- ^ 'readProcessWithExitCode' - -> Options - -> Handsy a - -> IO a -interpretSimple f = interpret (return ()) (const (return ())) (const f) diff --git a/src/System/Handsy/Internal.hs b/src/System/Handsy/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Handsy/Internal.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} + +module System.Handsy.Internal + ( Handsy + , interpret + , interpretSimple + , shell + , Options (..) + ) where + +import Control.Exception (bracket) +import Control.Monad +import Control.Monad.Free.TH +import Control.Monad.Trans.Free +import qualified Data.ByteString.Lazy as B +import Data.Default.Class +import System.Exit +import System.IO (hPutStrLn, stderr) + +data HandsyF k = + Shell FilePath B.ByteString ((ExitCode, B.ByteString, B.ByteString) -> k) + deriving (Functor) + +makeFree ''HandsyF + +-- | Main monad +type Handsy = FreeT HandsyF IO + +data Options = + Options { debug :: Bool -- ^ Log commands to stderr before running + } + +instance Default Options where + def = Options False + +interpret :: IO r -- ^ Acquire resource + -> (r -> IO ()) -- ^ Release resource + -> (r -> String -> B.ByteString + -> IO (ExitCode, B.ByteString, B.ByteString)) + -> Options + -> Handsy a + -> IO a +interpret acquire destroy f opts handsy = bracket acquire destroy (`go` handsy) + where go res h = do + x <- runFreeT h + case x of + Pure r -> return r + Free (Shell cmdline stdin next) + -> when (debug opts) (hPutStrLn stderr cmdline) + >> f res cmdline stdin >>= go res . next + +interpretSimple :: (FilePath -> B.ByteString + -> IO (ExitCode, B.ByteString, B.ByteString)) -- ^ 'readProcessWithExitCode' + -> Options + -> Handsy a + -> IO a +interpretSimple f = interpret (return ()) (const (return ())) (const f) diff --git a/src/System/Handsy/Remote.hs b/src/System/Handsy/Remote.hs --- a/src/System/Handsy/Remote.hs +++ b/src/System/Handsy/Remote.hs @@ -1,33 +1,95 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module System.Handsy.Remote where +module System.Handsy.Remote + ( runRemote + , Host + -- * Options + , SSHOptions (..) + + -- * Helpers + , pushFile + , pullFile + + -- * Re-exports + , def + ) where + import Prelude hiding (appendFile, readFile, writeFile) import System.Handsy -import System.Handsy.Core (interpretSimple) +import System.Handsy.Internal (interpret, interpretSimple) +import System.Handsy.Util -import qualified Data.ByteString.Char8 as C8 +import Control.Applicative +import Control.Concurrent +import Control.Monad +import Control.Retry +import Data.Bool import qualified Data.ByteString.Lazy as B import Control.Monad.IO.Class +import Data.Default.Class -import Text.ShellEscape +type Host = String +data SSHOptions = + SSHOptions { + -- | Path of `ssh` command + sshPath :: FilePath, -data RemoteOptions = - RemoteOptions { - -- | Path of `ssh` command and command line arguments - sshCommand :: (FilePath, [String]) + -- | Port to connect + sshPort :: Int, + + {-| Whether to use control master for SSH connections. + This significantly reduces execution time. + -} + controlMaster :: Bool } --- | Executes the actions at a remote host -runRemote :: Options -> RemoteOptions -> Handsy a -> IO a -runRemote opts remote = interpretSimple runSsh opts +instance Default SSHOptions where + def = SSHOptions "ssh" 22 True + +acquireCM :: Host -> SSHOptions -> IO FilePath +acquireCM host opts = do + cm <- run def $ head . strLines . fst <$> command_ "mktemp" ["-u", "--suffix=.handsy"] def + + let (ssh, params) = genSsh opts (Just cm) + _ <- forkIO . run def . void $ command_ ssh (params ++ ["-M", "-N", host]) def + bool (error "Error establishing ControlMaster connection") () <$> waitForCM cm + + return cm where - runSsh :: String -> [String] -> B.ByteString -> IO (ExitCode, B.ByteString, B.ByteString) - runSsh prg args stdin = let c = C8.unpack . C8.intercalate " " . map (bytes . bash . C8.pack) $ (prg:args) - (ssh, sshOpts) = sshCommand remote - in run options $ command ssh (sshOpts ++ [c]) stdin + checkCM :: FilePath -> IO Bool + checkCM p = run def $ do + let args = snd (genSsh opts Nothing) ++ ["-o", "ControlPath=" ++ p, "-O", "check"] + command (sshPath opts) args def >>= return . \case + (ExitSuccess, _, _) -> True + _ -> False + waitForCM p = retrying (limitRetries 30) (\_ n -> return (not n)) (checkCM p) + + +releaseCM :: FilePath -> IO () +releaseCM p = run def{debug=False} $ void $ command_ "rm" ["-f", p] def + +genSsh :: SSHOptions -> Maybe FilePath -> (FilePath, [String]) +genSsh opts cm = (sshPath opts, ["-p", show $ sshPort opts] ++ maybe [] (\i->["-S", i]) cm) + +runSsh :: Host -> SSHOptions -> Maybe FilePath -> String -> B.ByteString + -> IO (ExitCode, B.ByteString, B.ByteString) +runSsh host opts cm cmdline stdin' = + let (ssh, params) = genSsh opts cm + in run def{debug=False} $ command ssh (params ++ [host] ++ [cmdline]) def{stdin=stdin'} + +-- | Executes the actions at a remote host +runRemote :: Options -> Host -> SSHOptions -> Handsy a -> IO a +runRemote opts host sshOpts = + case controlMaster sshOpts of + False -> interpretSimple (runSsh host sshOpts Nothing) opts + True -> interpret (acquireCM host sshOpts) + releaseCM + (runSsh host sshOpts . Just) + opts -- | Copies a local file to remote host pushFile :: FilePath -- ^ Local path of source diff --git a/src/System/Handsy/Util.hs b/src/System/Handsy/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Handsy/Util.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.Handsy.Util where + +import Control.Applicative +import Control.Concurrent +import Control.Monad.IO.Class +import Data.Bool +import qualified Data.ByteString.Lazy.Char8 as C +import Prelude hiding (appendFile, readFile, + writeFile) +import System.Handsy + +class IsReturnValue a where + stdout :: a -> C.ByteString + stderr :: a -> C.ByteString + exitCode :: a -> ExitCode + +instance IsReturnValue (C.ByteString, C.ByteString) where + stdout = fst + stderr = snd + exitCode = const ExitSuccess + +instance IsReturnValue (ExitCode, C.ByteString, C.ByteString) where + stdout = \case (_, a, _) -> a + stderr = \case (_, _, a) -> a + exitCode = \case (a, _, _) -> a + +isSuccessful :: IsReturnValue a => a -> Bool +isSuccessful = isExitSuccess . exitCode + +isExitSuccess :: ExitCode -> Bool +isExitSuccess = \case + ExitSuccess -> True + ExitFailure _ -> False + +-- | Waits specified number of seconds +sleep :: Int -> Handsy () +sleep = liftIO . threadDelay . (* 1000000) + +-- | Extract lines from a ByteString. Useful for parsing unix commands. +strLines :: C.ByteString -> [String] +strLines = lines . C.unpack + +-- | Creates a temporary file +mkTemp :: String -> Handsy String +mkTemp suffix = head . strLines . fst + <$> command_ "mktemp" (bool ["--suffix=" ++ suffix] [] (null suffix)) def + +-- | Creates a temporary directory +mkTempDir :: String -> Handsy String +mkTempDir suffix = head . strLines . fst + <$> command_ "mktemp" ("-d" : bool ["--suffix" ++ suffix] [] (null suffix)) def + +-- | Returns if the specified process is running. Uses `pidof` +isRunning :: String -> Handsy Bool +isRunning p = isSuccessful <$> command "pidof" ["-s", "-x", p] def diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,9 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where import System.Handsy as H + +{- These aren't currently used in tests, but I + import them for coverage reports. -} import System.Handsy.Remote as H +import System.Handsy.Util as H import Control.Applicative import qualified Data.ByteString.Lazy as B @@ -14,25 +19,28 @@ import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.TH arbitraryBinary :: B.ByteString arbitraryBinary = B.pack [1..255] -createTempFile :: Handsy String -createTempFile = dropWhileEnd isSpace . C.unpack . fst <$> command_ "mktemp" [] "" - -test1 = testCase "writeFile . readFile == id" $ do - ret <- H.run options{debug=True} $ do - tmp <- createTempFile - +case_writeFile = do + f <- H.run def $ do + tmp <- mkTemp "" H.writeFile tmp arbitraryBinary - H.readFile tmp + return tmp + ret <- B.readFile f + assertEqual "" arbitraryBinary ret +case_readFile = do + tmp <- H.run def $ mkTemp "" + B.writeFile tmp arbitraryBinary + ret <- H.run def $ H.readFile tmp assertEqual "" arbitraryBinary ret -test2 = testCase "appendFile" $ do - ret <- H.run options{debug=True} $ do - tmp <- createTempFile +case_appendFile = do + ret <- H.run def $ do + tmp <- mkTemp "" H.writeFile tmp "ut" H.appendFile tmp "demir" @@ -41,27 +49,34 @@ assertEqual "" "utdemir" ret -test3 = testCase "shell" $ do - (h1, h2) <- H.run options{debug=True} $ do - tmp <- createTempFile +case_shell = do + (h1, h2) <- H.run def $ do + tmp <- mkTemp "" H.writeFile tmp (B.pack [1..255]) - h1 <- takeWhile isHexDigit . C.unpack . fst <$> command_ "md5sum" [tmp] "" - h2 <- takeWhile isHexDigit . C.unpack . fst <$> shell_ ("cat " ++ tmp ++ " | md5sum -") "" + h1 <- takeWhile isHexDigit . C.unpack . fst <$> command_ "md5sum" [tmp] def + h2 <- takeWhile isHexDigit . C.unpack . fst <$> shell_ ("cat " ++ tmp ++ " | md5sum -") def return (h1, h2) assertEqual "" h1 h2 -test4 = testCase "exit" $ do - (e1, e2) <- H.run options{debug=True} $ do - (e1, _, _) <- command "grep" [] "" - (e2, _, _) <- command "id" [] "" +case_exit = do + (e1, e2) <- H.run def $ do + (e1, _, _) <- command "grep" [] def + (e2, _, _) <- command "id" [] def return (e1, e2) case (e1, e2) of - (ExitFailure _, ExitSuccess) -> return () - _ -> assertFailure $ "Invalid return values: " ++ show (e1, e2) + (ExitFailure _, ExitSuccess) -> return () + _ -> assertFailure $ "Invalid return values: " ++ show (e1, e2) +case_cwd = do + (temp, pwd) <- H.run def $ do + temp <- mkTempDir "" + pwd:[] <- strLines . stdout <$> command_ "pwd" [] def{cwd=temp} + return (temp, pwd) + assertEqual "" temp pwd + main :: IO () -main = defaultMain (testGroup "handsy" [test1, test2, test3, test4]) +main = $(defaultMainGenerator)