handsy 0.0.9 → 0.0.10
raw patch · 7 files changed
+290/−136 lines, 7 filesdep +data-default-classdep +handsydep +retry
Dependencies added: data-default-class, handsy, retry, tasty-th
Files
- handsy.cabal +10/−10
- src/System/Handsy.hs +47/−28
- src/System/Handsy/Core.hs +0/−60
- src/System/Handsy/Internal.hs +59/−0
- src/System/Handsy/Remote.hs +77/−15
- src/System/Handsy/Util.hs +59/−0
- test/Test.hs +38/−23
handsy.cabal view
@@ -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
src/System/Handsy.hs view
@@ -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])+
− src/System/Handsy/Core.hs
@@ -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)
+ src/System/Handsy/Internal.hs view
@@ -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)
src/System/Handsy/Remote.hs view
@@ -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
+ src/System/Handsy/Util.hs view
@@ -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
test/Test.hs view
@@ -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)