diff --git a/handsy.cabal b/handsy.cabal --- a/handsy.cabal +++ b/handsy.cabal @@ -1,8 +1,8 @@ name: handsy -version: 0.0.13.1 +version: 0.0.14 synopsis: A DSL to describe common shell operations and interpeters for running them locally and remotely. description: - DEPRECATED. @handsy@ is a small library mainly for applications which should make some + @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,10 @@ 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.9 , bytestring , transformers @@ -43,8 +42,6 @@ , retry , data-default-class , split - , errors - , lifted-base hs-source-dirs: src default-language: Haskell2010 @@ -55,7 +52,7 @@ main-is: Test.hs default-language: Haskell2010 hs-source-dirs: test - build-depends: base >=4.6 && <4.9 + build-depends: base >=4.6 && < 4.8 , 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,59 +3,108 @@ module System.Handsy ( Handsy - , handsyIO - , handsyLeft - - -- * Interpreters - , Options (..) - - -- ** Local , run - -- ** Remote - , runRemote - , Host - , SSHOptions (..) - - -- * Actions - , CommandOptions (..) - , command + -- * Commands , shell - , command_ - , shell_ + , command , readFile , writeFile , appendFile - , sleep - , mkTemp - , mkTempDir - , isRunning - , os - -- ** For remote actions - , pushFile - , pullFile + -- * Helpers + , shell_ + , command_ - -- * Utils - , IsReturnValue - , stdout - , stderr - , exitCode - , isSuccessful - , isExitSuccess - , strLines + -- * Options + , CommandOptions (..) + , Options (..) -- * Re-exports , ExitCode (..) , def ) where -import Prelude hiding (appendFile, readFile, writeFile) +import Prelude hiding (appendFile, readFile, + writeFile) -import System.Handsy.Actions -import System.Handsy.Internal -import System.Handsy.Local -import System.Handsy.Remote +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.Exit +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]) + diff --git a/src/System/Handsy/Actions.hs b/src/System/Handsy/Actions.hs deleted file mode 100644 --- a/src/System/Handsy/Actions.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# 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 @@ -2,14 +2,18 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -module System.Handsy.Internal where +module System.Handsy.Internal + ( Handsy + , interpret + , interpretSimple + , shell + , Options (..) + ) + where -import Control.Error -import Control.Exception.Lifted (bracket) +import Control.Exception (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) @@ -21,10 +25,10 @@ data HandsyInstruction a where Shell :: String -> B.ByteString -> HandsyInstruction (ExitCode, StdOut, StdErr) -type Handsy a = ProgramT HandsyInstruction Script a +type Handsy a = ProgramT HandsyInstruction IO a -shellF :: FilePath -> B.ByteString -> Handsy (ExitCode, B.ByteString, B.ByteString) -shellF cmd stdin = singleton $ Shell cmd stdin +shell :: FilePath -> B.ByteString -> Handsy (ExitCode, B.ByteString, B.ByteString) +shell cmd stdin = singleton $ Shell cmd stdin data Options = Options { debug :: Bool -- ^ Log commands to stderr before running @@ -34,27 +38,23 @@ def = Options False interpret :: forall r . forall a - . Script r -- ^ Acquire resource - -> (r -> Script ()) -- ^ Release resource - -> (r -> String -> B.ByteString -> Script (ExitCode, B.ByteString, B.ByteString)) + . IO r -- ^ Acquire resource + -> (r -> IO ()) -- ^ Release resource + -> (r -> String -> B.ByteString + -> IO (ExitCode, B.ByteString, B.ByteString)) -> Options -> Handsy a - -> EitherT String IO a + -> IO a interpret acquire destroy f opts handsy = bracket acquire destroy (`go` handsy) - where go :: r -> Handsy a -> Script a + where go :: r -> Handsy a -> IO a go res h = viewT h >>= \case - Return x -> right x - Shell cmdline stdin :>>= k -> when (debug opts) (liftIO $ hPutStrLn stderr cmdline) + Return x -> return x + Shell cmdline stdin :>>= k -> when (debug opts) (hPutStrLn stderr cmdline) >> f res cmdline stdin >>= go res . k -interpretSimple :: (FilePath -> B.ByteString -> Script (ExitCode, B.ByteString, B.ByteString)) -- ^ 'readProcessWithExitCode' +interpretSimple :: (FilePath -> B.ByteString + -> IO (ExitCode, B.ByteString, B.ByteString)) -- ^ 'readProcessWithExitCode' -> Options -> Handsy a - -> Script a + -> IO 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 deleted file mode 100644 --- a/src/System/Handsy/Local.hs +++ /dev/null @@ -1,12 +0,0 @@ -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,62 +1,67 @@ {-# 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.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, - - -- | User - sshUser :: Maybe String, + sshPath :: FilePath, -- | Port to connect - sshPort :: Int, - - -- | Identity file to use - identityFile :: Maybe FilePath, - - -- | Connect timeout - connectTimeout :: Int, + sshPort :: 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" Nothing 22 Nothing 30 True + def = SSHOptions "ssh" 22 True -acquireCM :: Host -> SSHOptions -> Script FilePath +acquireCM :: Host -> SSHOptions -> IO FilePath acquireCM host opts = do - cm <- scriptIO (run def $ head . strLines . fst <$> command_ "mktemp" ["-u", "--suffix=.handsy"] def) >>= hoistEither + cm <- run def $ head . strLines . fst <$> command_ "mktemp" ["-u", "--suffix=.handsy"] def let (ssh, params) = genSsh opts (Just cm) - _ <- scriptIO . forkIO . void . run def . void $ command_ ssh (params ++ ["-M", "-N", host]) def - scriptIO (waitForCM cm) >>= bool (left "Error establishing ControlMaster connection") (right ()) + _ <- forkIO . run def . void $ command_ ssh (params ++ ["-M", "-N", host]) def + bool (error "Error establishing ControlMaster connection") () <$> waitForCM cm return cm where checkCM :: FilePath -> IO Bool - checkCM p = fmap (either (const False) id) . run def $ do + 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 @@ -64,30 +69,24 @@ waitForCM p = retrying (limitRetries 30) (\_ n -> return (not n)) (checkCM p) -releaseCM :: FilePath -> Script () -releaseCM p = (scriptIO . run def{debug=False} $ void $ command_ "rm" ["-f", p] def) >>= hoistEither +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 - , "-o", "ConnectTimeout=" ++ show (connectTimeout opts)] - <> maybe mempty (("-l":) . pure) (sshUser opts) - <> maybe mempty (("-i":) . pure) (identityFile opts) - <> maybe mempty (("-S":) . pure) cm - ) +genSsh opts cm = (sshPath opts, ["-p", show $ sshPort opts] ++ maybe [] (\i->["-S", i]) cm) runSsh :: Host -> SSHOptions -> Maybe FilePath -> String -> B.ByteString - -> Script (ExitCode, B.ByteString, B.ByteString) + -> IO (ExitCode, B.ByteString, B.ByteString) runSsh host opts cm cmdline stdin' = let (ssh, params) = genSsh opts cm - in runS def{debug=False} $ command ssh (params ++ [host] ++ [cmdline]) def{stdin=stdin'} + 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 (Either String a) -runRemote opts host sshOpts = runEitherT . +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) + True -> interpret (acquireCM host sshOpts) releaseCM (runSsh host sshOpts . Just) opts @@ -96,10 +95,10 @@ pushFile :: FilePath -- ^ Local path of source -> FilePath -- ^ Remote path of destination -> Handsy () -pushFile local remote = handsyIO (B.readFile local) >>= writeFile remote +pushFile local remote = liftIO (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 >>= handsyIO . B.writeFile local +pullFile remote local = readFile remote >>= liftIO . 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,6 +9,8 @@ ) 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 new file mode 100644 --- /dev/null +++ b/src/System/Handsy/Util.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} + +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,14 +1,15 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Main where -import Prelude hiding (appendFile, readFile, - writeFile) +import System.Handsy as H -import System.Handsy +{- 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 @@ -22,67 +23,58 @@ arbitraryBinary = B.pack [1..255] case_writeFile = do - f <- run def $ do + f <- H.run def $ do tmp <- mkTemp "" - writeFile tmp arbitraryBinary + H.writeFile tmp arbitraryBinary return tmp - case f of - Right fname -> B.readFile fname >>= assertEqual "" arbitraryBinary - Left err -> assertFailure err + ret <- B.readFile f + assertEqual "" arbitraryBinary ret case_readFile = do - 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 + tmp <- H.run def $ mkTemp "" + B.writeFile tmp arbitraryBinary + ret <- H.run def $ H.readFile tmp + assertEqual "" arbitraryBinary ret case_appendFile = do - ret <- run def $ do + ret <- H.run def $ do tmp <- mkTemp "" - writeFile tmp "ut" - appendFile tmp "demir" + H.writeFile tmp "ut" + H.appendFile tmp "demir" - readFile tmp + H.readFile tmp - either assertFailure (assertEqual "" "utdemir") ret + assertEqual "" "utdemir" ret case_shell = do - ret <- run def $ do + (h1, h2) <- H.run def $ do tmp <- mkTemp "" - writeFile tmp (B.pack [1..255]) + H.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) - case ret of - Left err -> assertFailure err - Right (h1, h2) -> assertEqual "" h1 h2 + assertEqual "" h1 h2 case_exit = do - ret <- run def $ do + (e1, e2) <- H.run def $ do (e1, _, _) <- command "grep" [] def (e2, _, _) <- command "id" [] def return (e1, e2) - case ret of - Right (ExitFailure _, ExitSuccess) -> return () - other -> assertFailure $ "Invalid return values: " ++ show other + case (e1, e2) of + (ExitFailure _, ExitSuccess) -> return () + _ -> assertFailure $ "Invalid return values: " ++ show (e1, e2) case_cwd = do - ret <- run def $ do + (temp, pwd) <- H.run def $ do temp <- mkTempDir "" pwd:[] <- strLines . stdout <$> command_ "pwd" [] def{cwd=temp} return (temp, pwd) - - case ret of - Right (temp, pwd) -> assertEqual "" temp pwd - other -> assertFailure $ "Invalid paths: " ++ show other + assertEqual "" temp pwd main :: IO () main = $(defaultMainGenerator)