diff --git a/handsy.cabal b/handsy.cabal --- a/handsy.cabal +++ b/handsy.cabal @@ -1,8 +1,8 @@ name: handsy -version: 0.0.13 +version: 0.0.13.1 synopsis: A DSL to describe common shell operations and interpeters for running them locally and remotely. description: - @handsy@ is a small library mainly for applications which should make some + DEPRECATED. @handsy@ is a small library mainly for applications which should make some operations on remote machines by SSH. It currently provides you: . * A DSL describing basic system operations('command', 'readFile', 'writeFile' etc.) @@ -29,11 +29,12 @@ library exposed-modules: System.Handsy + System.Handsy.Tutorial + other-modules: System.Handsy.Actions + System.Handsy.Local System.Handsy.Remote - System.Handsy.Util System.Handsy.Internal - System.Handsy.Tutorial - build-depends: base >=4.6 && <4.8 + build-depends: base >=4.6 && <4.9 , bytestring , transformers , operational @@ -42,6 +43,8 @@ , retry , data-default-class , split + , errors + , lifted-base hs-source-dirs: src default-language: Haskell2010 @@ -52,7 +55,7 @@ main-is: Test.hs default-language: Haskell2010 hs-source-dirs: test - build-depends: base >=4.6 && < 4.8 + build-depends: base >=4.6 && <4.9 , handsy , bytestring , tasty diff --git a/src/System/Handsy.hs b/src/System/Handsy.hs --- a/src/System/Handsy.hs +++ b/src/System/Handsy.hs @@ -3,108 +3,59 @@ module System.Handsy ( Handsy + , handsyIO + , handsyLeft + + -- * Interpreters + , Options (..) + + -- ** Local , run - -- * Commands - , shell + -- ** Remote + , runRemote + , Host + , SSHOptions (..) + + -- * Actions + , CommandOptions (..) , command + , shell + , command_ + , shell_ , readFile , writeFile , appendFile + , sleep + , mkTemp + , mkTempDir + , isRunning + , os - -- * Helpers - , shell_ - , command_ + -- ** For remote actions + , pushFile + , pullFile - -- * Options - , CommandOptions (..) - , Options (..) + -- * Utils + , IsReturnValue + , stdout + , stderr + , exitCode + , isSuccessful + , isExitSuccess + , strLines -- * Re-exports , ExitCode (..) , def ) where -import Prelude hiding (appendFile, readFile, - writeFile) +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 System.Handsy.Actions +import System.Handsy.Internal +import System.Handsy.Local +import System.Handsy.Remote import Data.Default.Class -import System.Process.ByteString.Lazy - -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 - -> CommandOptions - -> Handsy (ExitCode, B.ByteString, B.ByteString) -- ^ (status, stdout, stderr) -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] 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] def{stdin=s} >>= \case - (ExitSuccess, _, _) -> return () - (_, _, 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"] def{stdin=s} >>= \case - (ExitSuccess, _, _) -> return () - (_, _, stderr) -> error $ "Error appending to " ++ fp ++ "\nStderr was: " ++ C.unpack stderr - --- | Same as 'command', but ExitFailure is a runtime error. -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 -> 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 (\cmdline -> readProcessWithExitCode "bash" ["-c", cmdline]) - +import System.Exit diff --git a/src/System/Handsy/Actions.hs b/src/System/Handsy/Actions.hs new file mode 100644 --- /dev/null +++ b/src/System/Handsy/Actions.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.Handsy.Actions where + +import Control.Applicative +import Control.Concurrent +import Control.Error +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Default.Class +import Data.List.Split +import Prelude hiding (appendFile, readFile, + writeFile) +import System.Exit +import System.Handsy.Internal +import Text.ShellEscape + +-- | Runs a command +command :: FilePath -- ^ Command to run + -> [String] -- ^ Arguments + -> CommandOptions + -> Handsy (ExitCode, BL.ByteString, BL.ByteString) -- ^ (status, stdout, stderr) +command cmd args opts = let cmd' = B8.unpack . B8.intercalate " " . map (bytes . bash . B8.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, BL.ByteString, BL.ByteString) -- ^ (ExitCode, Stdout, Stderr) +shell cmd opts = let esc = B8.unpack . bytes . bash . B8.pack + CommandOptions stdin' cwd' = opts + in shellF ((if null cwd' then "" else ("cd " ++ esc cwd' ++ "; ")) ++ cmd) stdin' + +data CommandOptions = + CommandOptions { stdin :: BL.ByteString + , cwd :: String + } + +instance Default CommandOptions where + def = CommandOptions "" "" + +-- | Reads a file and returns the contents of the file. +readFile :: FilePath -> Handsy BL.ByteString +readFile fp = command "cat" [fp] def >>= \case + (ExitSuccess, sout, _) -> return sout + (_, _, serr) -> lift . left $ "Serror reading " ++ fp ++ "\nSerr was: " ++ BL8.unpack serr + +-- | @writeFile file str@ function writes the bytestring @str@, to the file @file@. +writeFile :: FilePath -> BL.ByteString -> Handsy () +writeFile fp s = command "dd" ["of=" ++ fp] def{stdin=s} >>= \case + (ExitSuccess, _, _) -> return () + (_, _, serr) -> lift . left $ "Serror writing to " ++ fp ++ "\nSerr was: " ++ BL8.unpack serr + +-- | @appendFile file str@ function appends the bytestring @str@, to the file @file@. +appendFile :: FilePath -> BL.ByteString -> Handsy () +appendFile fp s = command "dd" ["of=" ++ fp, "conv=notrunc", "oflag=append"] def{stdin=s} >>= \case + (ExitSuccess, _, _) -> return () + (_, _, serr) -> lift . left $ "Serror appending to " ++ fp ++ "\nSerr was: " ++ BL8.unpack serr + +-- | Same as 'command', but ExitFailure ends the computation. +command_ :: FilePath -> [String] -> CommandOptions -> Handsy (BL.ByteString, BL.ByteString) +command_ path args opts = command path args opts >>= \case + (ExitFailure code, _, serr) -> lift $ left ('`':path ++ ' ' : show args ++ "` returned " ++ show code + ++ "\nSerr was: " ++ BL8.unpack serr) + (ExitSuccess, sout, serr) -> return (sout, serr) + +-- | Same as 'shell', but ExitFailure ends the computation. +shell_ :: String -> CommandOptions -> Handsy (BL.ByteString, BL.ByteString) +shell_ cmd opts = shell cmd opts >>= \case + (ExitFailure code, _, serr) -> lift $ left ('`':cmd ++ "` returned " ++ show code + ++ "\nSerr was: " ++ BL8.unpack serr) + (ExitSuccess, sout, serr) -> return (sout, serr) + +-- * Helpers for parsing return values of 'command' and 'shell' + +class IsReturnValue a where + stdout :: a -> BL.ByteString + stderr :: a -> BL.ByteString + exitCode :: a -> ExitCode + +instance IsReturnValue (BL.ByteString, BL.ByteString) where + stdout = fst + stderr = snd + exitCode = const ExitSuccess + +instance IsReturnValue (ExitCode, BL.ByteString, BL.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 + +-- | Extract lines from a ByteString. Useful for parsing unix commands. +strLines :: BL.ByteString -> [String] +strLines = lines . BL8.unpack + +-- | Waits specified number of seconds +sleep :: Int -> Handsy () +sleep = liftIO . threadDelay . (* 1000000) + +-- | Creates a temporary file +mkTemp :: String -> Handsy String +mkTemp suffix = do + out <- strLines .stdout <$> command_ "mktemp" (bool ["--suffix=" ++ suffix] [] (null suffix)) def + lift $ tryHead ("weird output from mktemp: " ++ show out) out + +-- | Creates a temporary directory +mkTempDir :: String -> Handsy String +mkTempDir suffix + = command_ "mktemp" ("-d" : bool ["--suffix" ++ suffix] [] (null suffix)) def + >>= lift . tryHead "weird output from mktemp" . strLines . stdout + +-- | Returns if the specified process is running. Uses `pidof` +isRunning :: String -> Handsy Bool +isRunning p = isSuccessful <$> command "pidof" ["-s", "-x", p] def + +data OS = NixOS | Debian | Ubuntu | RHEL | CentOS | Fedora | ArchLinux + deriving (Show, Eq) + +{-| Guesses the os using `/etc/os-release`. This currently only supports Linux distributions + abiding systemd standards. -} +os :: Handsy (Maybe OS) +os = parseOsRelease <$> readFile "/etc/os-release" >>= return . \case + Just "ubuntu" -> Just Ubuntu + Just "debian" -> Just Debian + Just "nixos" -> Just NixOS + Just "rhel" -> Just RHEL + Just "centos" -> Just CentOS + Just "fedora" -> Just Fedora + Just "arch" -> Just ArchLinux + _ -> Nothing + where parseOsRelease = fmap (filter $ not . flip elem ['\'', '"']) -- Hack to unquote + <$> lookup "ID" . map ((\(x:xs) -> (x, concat xs)) . splitOn "=") . strLines diff --git a/src/System/Handsy/Internal.hs b/src/System/Handsy/Internal.hs --- a/src/System/Handsy/Internal.hs +++ b/src/System/Handsy/Internal.hs @@ -1,18 +1,15 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} -module System.Handsy.Internal - ( Handsy - , interpret - , interpretSimple - , shell - , Options (..) - ) - where +module System.Handsy.Internal where -import Control.Exception (bracket) +import Control.Error +import Control.Exception.Lifted (bracket) import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Operational +import Control.Monad.Trans.Class import qualified Data.ByteString.Lazy as B import Data.Default.Class import System.Exit (ExitCode) @@ -24,10 +21,10 @@ data HandsyInstruction a where Shell :: String -> B.ByteString -> HandsyInstruction (ExitCode, StdOut, StdErr) -type Handsy a = ProgramT HandsyInstruction IO a +type Handsy a = ProgramT HandsyInstruction Script a -shell :: FilePath -> B.ByteString -> Handsy (ExitCode, B.ByteString, B.ByteString) -shell cmd stdin = singleton $ Shell cmd stdin +shellF :: FilePath -> B.ByteString -> Handsy (ExitCode, B.ByteString, B.ByteString) +shellF cmd stdin = singleton $ Shell cmd stdin data Options = Options { debug :: Bool -- ^ Log commands to stderr before running @@ -36,23 +33,28 @@ 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)) +interpret :: forall r . forall a + . Script r -- ^ Acquire resource + -> (r -> Script ()) -- ^ Release resource + -> (r -> String -> B.ByteString -> Script (ExitCode, B.ByteString, B.ByteString)) -> Options -> Handsy a - -> IO a + -> EitherT String IO a interpret acquire destroy f opts handsy = bracket acquire destroy (`go` handsy) - where -- go :: r -> Handsy a -> IO a + where go :: r -> Handsy a -> Script a go res h = viewT h >>= \case - Return x -> return x - Shell cmdline stdin :>>= k -> when (debug opts) (hPutStrLn stderr cmdline) + Return x -> right x + Shell cmdline stdin :>>= k -> when (debug opts) (liftIO $ hPutStrLn stderr cmdline) >> f res cmdline stdin >>= go res . k -interpretSimple :: (FilePath -> B.ByteString - -> IO (ExitCode, B.ByteString, B.ByteString)) -- ^ 'readProcessWithExitCode' +interpretSimple :: (FilePath -> B.ByteString -> Script (ExitCode, B.ByteString, B.ByteString)) -- ^ 'readProcessWithExitCode' -> Options -> Handsy a - -> IO a + -> Script a interpretSimple f = interpret (return ()) (const (return ())) (const f) + +handsyIO :: IO a -> Handsy a +handsyIO = lift . scriptIO + +handsyLeft :: String -> Handsy a +handsyLeft = lift . left diff --git a/src/System/Handsy/Local.hs b/src/System/Handsy/Local.hs new file mode 100644 --- /dev/null +++ b/src/System/Handsy/Local.hs @@ -0,0 +1,12 @@ +module System.Handsy.Local where + +import Control.Error +import System.Handsy.Internal +import System.Process.ByteString.Lazy + +runS :: Options -> Handsy a -> Script a +runS opts = interpretSimple (\cmdline -> scriptIO . readProcessWithExitCode "bash" ["-c", cmdline]) opts + +-- | Executes the actions locally +run :: Options -> Handsy a -> IO (Either String a) +run opts = runEitherT . runS opts 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,67 +1,62 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module System.Handsy.Remote - ( runRemote - , Host - - -- * Options - , SSHOptions (..) - - -- * Helpers - , pushFile - , pullFile - - -- * Re-exports - , def - ) where +module System.Handsy.Remote where import Prelude hiding (appendFile, readFile, writeFile) -import System.Handsy -import System.Handsy.Internal (interpret, interpretSimple) -import System.Handsy.Util - import Control.Applicative import Control.Concurrent +import Control.Error 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 Data.Monoid +import System.Exit +import System.Handsy.Actions +import System.Handsy.Internal +import System.Handsy.Local type Host = String data SSHOptions = SSHOptions { -- | Path of `ssh` command - sshPath :: FilePath, + sshPath :: FilePath, + -- | User + sshUser :: Maybe String, + -- | Port to connect - sshPort :: Int, + sshPort :: Int, + -- | Identity file to use + identityFile :: Maybe FilePath, + + -- | Connect timeout + connectTimeout :: Int, + {-| Whether to use control master for SSH connections. This significantly reduces execution time. -} - controlMaster :: Bool + controlMaster :: Bool } instance Default SSHOptions where - def = SSHOptions "ssh" 22 True + def = SSHOptions "ssh" Nothing 22 Nothing 30 True -acquireCM :: Host -> SSHOptions -> IO FilePath +acquireCM :: Host -> SSHOptions -> Script FilePath acquireCM host opts = do - cm <- run def $ head . strLines . fst <$> command_ "mktemp" ["-u", "--suffix=.handsy"] def + cm <- scriptIO (run def $ head . strLines . fst <$> command_ "mktemp" ["-u", "--suffix=.handsy"] def) >>= hoistEither 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 + _ <- scriptIO . forkIO . void . run def . void $ command_ ssh (params ++ ["-M", "-N", host]) def + scriptIO (waitForCM cm) >>= bool (left "Error establishing ControlMaster connection") (right ()) return cm where checkCM :: FilePath -> IO Bool - checkCM p = run def $ do + checkCM p = fmap (either (const False) id) . run def $ do let args = snd (genSsh opts Nothing) ++ ["-o", "ControlPath=" ++ p, "-O", "check"] command (sshPath opts) args def >>= return . \case (ExitSuccess, _, _) -> True @@ -69,24 +64,30 @@ 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 +releaseCM :: FilePath -> Script () +releaseCM p = (scriptIO . run def{debug=False} $ void $ command_ "rm" ["-f", p] def) >>= hoistEither genSsh :: SSHOptions -> Maybe FilePath -> (FilePath, [String]) -genSsh opts cm = (sshPath opts, ["-p", show $ sshPort opts] ++ maybe [] (\i->["-S", i]) cm) +genSsh opts cm = (sshPath opts, + [ "-p", show $ sshPort opts + , "-o", "ConnectTimeout=" ++ show (connectTimeout opts)] + <> maybe mempty (("-l":) . pure) (sshUser opts) + <> maybe mempty (("-i":) . pure) (identityFile opts) + <> maybe mempty (("-S":) . pure) cm + ) runSsh :: Host -> SSHOptions -> Maybe FilePath -> String -> B.ByteString - -> IO (ExitCode, B.ByteString, B.ByteString) + -> Script (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'} + in runS 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 = +runRemote :: Options -> Host -> SSHOptions -> Handsy a -> IO (Either String a) +runRemote opts host sshOpts = runEitherT . case controlMaster sshOpts of False -> interpretSimple (runSsh host sshOpts Nothing) opts - True -> interpret (acquireCM host sshOpts) + True -> interpret (acquireCM host sshOpts) releaseCM (runSsh host sshOpts . Just) opts @@ -95,10 +96,10 @@ pushFile :: FilePath -- ^ Local path of source -> FilePath -- ^ Remote path of destination -> Handsy () -pushFile local remote = liftIO (B.readFile local) >>= writeFile remote +pushFile local remote = handsyIO (B.readFile local) >>= writeFile remote -- | Fetches a file from remote host pullFile :: FilePath -- ^ Remote path of source -> FilePath -- ^ Local path of destination -> Handsy () -pullFile remote local = readFile remote >>= liftIO . B.writeFile local +pullFile remote local = readFile remote >>= handsyIO . B.writeFile local diff --git a/src/System/Handsy/Tutorial.hs b/src/System/Handsy/Tutorial.hs --- a/src/System/Handsy/Tutorial.hs +++ b/src/System/Handsy/Tutorial.hs @@ -9,8 +9,6 @@ ) where import System.Handsy -import System.Handsy.Remote -import System.Handsy.Util {- $introduction @handsy@ is a small library mainly for applications which should make some diff --git a/src/System/Handsy/Util.hs b/src/System/Handsy/Util.hs deleted file mode 100644 --- a/src/System/Handsy/Util.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# 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 Data.List.Split -import Prelude hiding (appendFile, readFile, - writeFile) -import System.Handsy - --- * Helpers for parsing return values of 'command' and 'shell' - -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 - --- | Extract lines from a ByteString. Useful for parsing unix commands. -strLines :: C.ByteString -> [String] -strLines = lines . C.unpack - --- * Frequently used functionality - --- | Waits specified number of seconds -sleep :: Int -> Handsy () -sleep = liftIO . threadDelay . (* 1000000) - --- | 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 - -data OS = NixOS | Debian | Ubuntu | RHEL | CentOS | Fedora | ArchLinux - deriving (Show, Eq) - -{-| Guesses the os using `/etc/os-release`. This currently only supports Linux distributions - abiding systemd standards. -} -os :: Handsy (Maybe OS) -os = parseOsRelease <$> readFile "/etc/os-release" >>= return . \case - Just "ubuntu" -> Just Ubuntu - Just "debian" -> Just Debian - Just "nixos" -> Just NixOS - Just "rhel" -> Just RHEL - Just "centos" -> Just CentOS - Just "fedora" -> Just Fedora - Just "arch" -> Just ArchLinux - _ -> Nothing - where parseOsRelease = fmap (filter $ not . flip elem "'\"") -- Hack to unquote - <$> lookup "ID" . map ((\(x:xs) -> (x, concat xs)) . splitOn "=") . strLines diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,15 +1,14 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Main where -import System.Handsy as H +import Prelude hiding (appendFile, readFile, + writeFile) -{- 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 System.Handsy import Control.Applicative import qualified Data.ByteString.Lazy as B @@ -23,58 +22,67 @@ arbitraryBinary = B.pack [1..255] case_writeFile = do - f <- H.run def $ do + f <- run def $ do tmp <- mkTemp "" - H.writeFile tmp arbitraryBinary + writeFile tmp arbitraryBinary return tmp - ret <- B.readFile f - assertEqual "" arbitraryBinary ret + case f of + Right fname -> B.readFile fname >>= assertEqual "" arbitraryBinary + Left err -> assertFailure err case_readFile = do - tmp <- H.run def $ mkTemp "" - B.writeFile tmp arbitraryBinary - ret <- H.run def $ H.readFile tmp - assertEqual "" arbitraryBinary ret + run def (mkTemp "") >>= \case + Left err -> assertFailure err + Right tmp -> do + B.writeFile tmp arbitraryBinary + run def (readFile tmp) >>= \case + Left err -> assertFailure err + Right ret -> assertEqual "" arbitraryBinary ret case_appendFile = do - ret <- H.run def $ do + ret <- run def $ do tmp <- mkTemp "" - H.writeFile tmp "ut" - H.appendFile tmp "demir" + writeFile tmp "ut" + appendFile tmp "demir" - H.readFile tmp + readFile tmp - assertEqual "" "utdemir" ret + either assertFailure (assertEqual "" "utdemir") ret case_shell = do - (h1, h2) <- H.run def $ do + ret <- run def $ do tmp <- mkTemp "" - H.writeFile tmp (B.pack [1..255]) + writeFile tmp (B.pack [1..255]) 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 + case ret of + Left err -> assertFailure err + Right (h1, h2) -> assertEqual "" h1 h2 case_exit = do - (e1, e2) <- H.run def $ do + ret <- 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) + case ret of + Right (ExitFailure _, ExitSuccess) -> return () + other -> assertFailure $ "Invalid return values: " ++ show other case_cwd = do - (temp, pwd) <- H.run def $ do + ret <- run def $ do temp <- mkTempDir "" pwd:[] <- strLines . stdout <$> command_ "pwd" [] def{cwd=temp} return (temp, pwd) - assertEqual "" temp pwd + + case ret of + Right (temp, pwd) -> assertEqual "" temp pwd + other -> assertFailure $ "Invalid paths: " ++ show other main :: IO () main = $(defaultMainGenerator)