diff --git a/Extra.cabal b/Extra.cabal --- a/Extra.cabal +++ b/Extra.cabal @@ -1,5 +1,5 @@ Name: Extra -Version: 1.42 +Version: 1.45 License: BSD3 License-File: COPYING Author: David Fox @@ -7,17 +7,53 @@ Description: A hodge-podge of functions and modules that do not have a better home Maintainer: David Fox Homepage: http://src.seereason.com/haskell-extra -Build-Depends: base < 5, unix, regex-compat, time >= 1.1, Unixutils >= 1.32 , mtl, network, pretty, directory, bytestring, process, containers, old-time, old-locale, QuickCheck >= 2 && < 3, HUnit, random, filepath, zlib, bzlib +Build-Depends: + base < 5, + bytestring, + bzlib, + containers, + directory, + filepath, + HUnit, + mtl, + network >= 2.4, + old-locale, + old-time, + pretty, + process, + pureMD5, + QuickCheck >= 2 && < 3, + random, + regex-compat, + time >= 1.1, + unix, + Unixutils >= 1.51, + zlib Synopsis: A grab bag of modules. ghc-options: -O2 -W C-Sources: cbits/gwinsz.c Include-Dirs: cbits Install-Includes: gwinsz.h Exposed-modules: - Extra.Bool, Extra.Either, Extra.Exit, Extra.Files, - Extra.GPGSign,Extra.List, Extra.HughesPJ, Extra.Lock, Extra.Misc, Extra.Net, Extra.SSH, - Extra.Time, Extra.Terminal, Extra.CIO, Extra.TIO, Extra.IO, Extra.URI, Extra.URIQuery, - Test.QUnit, Test.QuickCheck.Properties, Extra.IOThread + Extra.Bool, + Extra.Either, + Extra.Exit, + Extra.Files, + Extra.GPGSign, + Extra.List, + Extra.HughesPJ, + Extra.Lock, + Extra.Misc, + Extra.Net, + Extra.SSH, + Extra.Time, + Extra.Terminal, + Extra.IO, + Extra.URI, + Extra.URIQuery, + Test.QUnit, + Test.QuickCheck.Properties, + Extra.IOThread Build-Type: Simple -- For more complex build options see: diff --git a/Extra/CIO.hs b/Extra/CIO.hs deleted file mode 100644 --- a/Extra/CIO.hs +++ /dev/null @@ -1,308 +0,0 @@ --- |CIO is a type class for the TIO monad, which tracks the cursor --- position of the console so that indentation and prefixes can be --- added to the output. TIO also has a style component which lets you --- control the output verbosity and the appearance of the prefix. --- There is an instance for the regular IO monad which doesn't use any --- of these features, to allow functions which do not use the TIO --- monad call functions in the Debian library. --- --- NOTE: a copy of this library is in the Extra library as --- well. Please update both locations. --- --- This code is provided for backwards compatibility, I don't --- endorse its use in new projects. -module Extra.CIO - ( -- * The CIO class - CIO(..) - - -- * Style constructors and transformers - , TStyle(..) - , defStyle - , withStyle - - , setVerbosity - , addVerbosity - , setPrefix - , addPrefix - , appPrefix - , setPrefixes - , addPrefixes - , appPrefixes - , hGetPrefix - - -- * Output functions - , putStr - , ePutStr - , vPutStr - , vEPutStr - - , hPutChar - , putChar - , ePutChar - , vHPutChar - , vPutChar - , vEPutChar - - , hPutStrBl - , putStrBl - , ePutStrBl - , vHPutStrBl - , vPutStrBl - , vEPutStrBl - - , hPutStrLn - , putStrLn - , ePutStrLn - , vHPutStrLn - , vPutStrLn - , vEPutStrLn - - , bol - , eBOL - , vHBOL - , vBOL - , vEBOL - - , hColor - , blue - , green - , red - , magenta - ) where - -import Prelude hiding (putStr, putChar, putStrLn) -import qualified System.IO as IO -import Control.Monad.Trans -import Control.Exception - --- |Class representing ways of doing console (terminal?) output. -class MonadIO m => CIO m where - -- |Write output to a handle. - hPutStr :: IO.Handle -> String -> m () - -- |If we are not already at the beginning of a line, move the cursor - -- to the beginning of the next one. - hBOL :: IO.Handle -> m () - -- |Return the \"effective verbosity\" for a task. If the argument - -- is 2 it means the caller is computing ev for a task that - -- normally does output when the verbosity level is 2 or higher. - -- If the verbosity of the current style is 1, then the ev or - -- effective verbosity is 2-1 = -1, so the output should be - -- quieter. - ev :: Int -> m Int - -- |Modify the current output style. - setStyle :: (TStyle -> TStyle) -> m a -> m a - -- |Implementation of try for this monad - tryCIO :: m a -> m (Either SomeException a) - --- |A record used to hold the output style information for a task. --- This The prefixes that will appear at the beginning of each line, --- and the desired verbosity level. Suggested verbosity level policy: --- --- * -1: No output of any kind, as if you were directing all output to /dev/null --- --- * 0: Error output only, suitable for a run whose log you might examine later --- --- * 1: casual progress reporting - if you were running on a console but didn't --- expect anything to go wrong --- --- * 2: detailed progress reporting - show more progress, particularly things --- that might fail during the normal operation of the autobuilder: patches --- that fail to apply, dpkg-buildpackage runs that return errors, etc. --- --- * 3: Debugging output - use this level or higher if you suspect the --- autobuilder itself is failing, or you are doing development work on --- the autobuilder. -data TStyle - = TStyle { prefix :: String -- ^ Add this string at the beginning of each line - , verbosity :: Int -- ^ Ignore v functions whose argument is more than this - , hPrefix :: [(IO.Handle, String)] -- ^ Per-handle prefix - } deriving Show - -defStyle :: TStyle -defStyle = TStyle { prefix = ": " - , hPrefix = [] - , verbosity = 0 - } - --- |Use a new style for the TIO action -withStyle :: CIO m => TStyle -> m a -> m a -withStyle newStyle = setStyle (const newStyle) - -setVerbosity :: Int -> TStyle -> TStyle -setVerbosity n style = style {verbosity = n} -addVerbosity :: Int -> TStyle -> TStyle -addVerbosity n style = setVerbosity (n + verbosity style) style - --- |Set the output style for a handle to prefixed. -setPrefix :: String -> TStyle -> TStyle -setPrefix prefix style = style {prefix = prefix} - --- | Prepend some text to the prefix. -addPrefix :: String -> TStyle -> TStyle -addPrefix newPrefix style = style {prefix = newPrefix ++ prefix style} - --- | Append some text to the prefix. -appPrefix :: String -> TStyle -> TStyle -appPrefix newPrefix style = style {prefix = prefix style ++ newPrefix} - -hSetPrefix :: IO.Handle -> String -> TStyle -> TStyle -hSetPrefix handle string style = - style {hPrefix = (handle, string) : filter ((/= handle) . fst) (hPrefix style)} - -hAddPrefix :: IO.Handle -> String -> TStyle -> TStyle -hAddPrefix handle string style = - hSetPrefix handle (string ++ prefix) style - where prefix = maybe "" id (lookup handle (hPrefix style)) - -hAppPrefix :: IO.Handle -> String -> TStyle -> TStyle -hAppPrefix handle string style = - hSetPrefix handle (prefix ++ string) style - where prefix = maybe "" id (lookup handle (hPrefix style)) - --- |Get the current prefix for a particular handle -hGetPrefix :: IO.Handle -> TStyle -> String -hGetPrefix handle style = prefix style ++ maybe "" id (lookup handle (hPrefix style)) - --- |Set the output style for the stdout and stderr handle to prefixed, --- using whatever prefixes were most recently set (default is [1] and [2].) -setPrefixes :: String -> String -> TStyle -> TStyle -setPrefixes stdoutPrefix stderrPrefix style = - hSetPrefix IO.stdout stdoutPrefix . hSetPrefix IO.stderr stderrPrefix $ style - --- |Switch to prefixed mode and modify both the stdout and stderr prefixes. -addPrefixes :: String -> String -> TStyle -> TStyle -addPrefixes oPrefix ePrefix style = - hAddPrefix IO.stdout oPrefix . hAddPrefix IO.stderr ePrefix $ style - -appPrefixes :: String -> String -> TStyle -> TStyle -appPrefixes oPrefix ePrefix style = - hAppPrefix IO.stdout oPrefix . hAppPrefix IO.stderr ePrefix $ style - --- |Perform an action if the effective verbosity level is >= 0, --- otherwise return the default value d. -vIO :: CIO m => Int -> a -> m a -> m a -vIO v d f = - do v' <- ev v - if v' >= 0 then f else return d - --- |Write a string to stdout. -putStr :: CIO m => String -> m () -putStr = hPutStr IO.stdout - --- |Write a string to stderr. -ePutStr :: CIO m => String -> m () -ePutStr = hPutStr IO.stderr - --- |Verbosity controlled version of ePutStr -vEPutStr :: CIO m => Int -> String -> m () -vEPutStr = vHPutStr IO.stderr - --- |Write a string to stdout depending on the verbosity level. -vPutStr :: CIO m => Int -> String -> m () -vPutStr = vHPutStr IO.stdout - --- |Write a character. -hPutChar :: CIO m => IO.Handle -> Char -> m () -hPutChar h c = hPutStr h [c] - --- |Write a character to stdout. -putChar :: CIO m => Char -> m () -putChar = hPutChar IO.stdout - --- |Write a character to stderr. -ePutChar :: CIO m => Char -> m () -ePutChar = hPutChar IO.stderr - --- |Verbosity controlled version of hPutStr -vHPutStr :: CIO m => IO.Handle -> Int -> String -> m () -vHPutStr h v s = vIO v () (hPutStr h s) - --- |Verbosity controlled version of hPutChar. -vHPutChar :: CIO m => IO.Handle -> Int -> Char -> m () -vHPutChar h v c = vHPutStr h v [c] - --- |Verbosity controlled version of putChar -vPutChar :: CIO m => Int -> Char -> m () -vPutChar = vHPutChar IO.stdout - --- |Verbosity controlled version of ePutChar -vEPutChar :: CIO m => Int -> Char -> m () -vEPutChar = vHPutChar IO.stderr - --- |Move to beginning of next line (if necessary) and output a string. -hPutStrBl :: CIO m => IO.Handle -> String -> m () -hPutStrBl h s = hBOL h >> hPutStr h s - --- |hPutStrBl to stdout. -putStrBl :: CIO m => String -> m () -putStrBl = hPutStrBl IO.stdout - --- |hPutStrBl to stderr. -ePutStrBl :: CIO m => String -> m () -ePutStrBl = hPutStrBl IO.stderr - --- |Verbosity controlled version of hPutStrBl -vHPutStrBl :: CIO m => IO.Handle -> Int -> String -> m () -vHPutStrBl h v s = vHBOL h v >> vHPutStr h v s - --- |Verbosity controlled version of putStrBl -vPutStrBl :: CIO m => Int -> String -> m () -vPutStrBl = vHPutStrBl IO.stdout - --- |Verbosity controlled version of ePutStrBl -vEPutStrBl :: CIO m => Int -> String -> m () -vEPutStrBl = vHPutStrBl IO.stderr - --- |Write a newline character and a string. -hPutStrLn :: CIO m => IO.Handle -> String -> m () -hPutStrLn h s = hBOL h >> hPutStr h s - --- |hPutStrLn to stdout. -putStrLn :: CIO m => String -> m () -putStrLn s = hPutStrLn IO.stdout s - --- |hPutStrLn to stderr. -ePutStrLn :: CIO m => String -> m () -ePutStrLn = hPutStrLn IO.stderr - --- |Verbosity controlled version of hPutStrLn. -vHPutStrLn :: CIO m => IO.Handle -> Int -> String -> m () -vHPutStrLn h v s = vHBOL h v >> vHPutStr h v s - --- |Verbosity controlled version of putStrLn -vPutStrLn :: CIO m => Int -> String -> m () -vPutStrLn = vHPutStrLn IO.stdout - --- |Verbosity controlled version of ePutStrLn -vEPutStrLn :: CIO m => Int -> String -> m () -vEPutStrLn = vHPutStrLn IO.stderr - --- |hBOL to stdout. -bol :: CIO m => m () -bol = hBOL IO.stdout - --- |hBOL to stderr. -eBOL :: CIO m => m () -eBOL = hBOL IO.stderr - -vHBOL :: CIO m => IO.Handle -> Int -> m () -vHBOL h v = vIO v () (hBOL h) - --- |Verbosity controlled version of BOL -vBOL :: CIO m => Int -> m () -vBOL = vHBOL IO.stdout - --- |Verbosity controlled version of eBOL -vEBOL :: CIO m => Int -> m () -vEBOL = vHBOL IO.stderr - --- These only work in a terminal, not in an emacs shell. -hColor h s = case h of - _ | h == IO.stdout -> green s - _ | h == IO.stdout -> red s - _ -> magenta s - -blue s = "\ESC[34m" ++ s ++ "\ESC[30m" -green s = "\ESC[32m" ++ s ++ "\ESC[30m" -red s = "\ESC[31m" ++ s ++ "\ESC[30m" -magenta s = "\ESC[35m" ++ s ++ "\ESC[30m" diff --git a/Extra/Either.hs b/Extra/Either.hs --- a/Extra/Either.hs +++ b/Extra/Either.hs @@ -1,10 +1,6 @@ module Extra.Either where -lefts :: [Either a b] -> [a] -lefts xs = fst (partitionEithers xs) - -rights :: [Either a b] -> [b] -rights xs = snd (partitionEithers xs) +import Data.Either (partitionEithers, rights) isRight (Right _) = True isRight (Left _) = False @@ -18,15 +14,7 @@ ([], rs) -> Right rs (ls, _) -> Left ls --- |Return a pair of the lefts and the rights -partitionEithers :: [Either a b] -> ([a], [b]) -partitionEithers xs = - part ([], []) (reverse xs) - where - part (ls, rs) [] = (ls, rs) - part (ls, rs) (Left l : more) = part (l : ls, rs) more - part (ls, rs) (Right r : more) = part (ls, r : rs) more - --- Deprecated +{-# DEPRECATED rightOnly "Use rights" #-} rightOnly = rights +{-# DEPRECATED eitherFromList "Use concatEithers" #-} eitherFromList = concatEithers diff --git a/Extra/Files.hs b/Extra/Files.hs --- a/Extra/Files.hs +++ b/Extra/Files.hs @@ -24,7 +24,7 @@ import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.BZip as BZip -import Control.Exception hiding (catch) +import Control.Exception import Control.Monad import qualified Data.ByteString.Lazy as B import Data.List @@ -151,7 +151,7 @@ -- |like removeLink, but does not fail if link did not exist forceRemoveLink :: FilePath -> IO () -forceRemoveLink fp = removeLink fp `Prelude.catch` (\e -> unless (isDoesNotExistError e) (ioError e)) +forceRemoveLink fp = removeLink fp `Control.Exception.catch` (\e -> unless (isDoesNotExistError e) (ioError e)) -- | Write out three versions of a file, regular, gzipped, and bzip2ed. writeAndZipFileWithBackup :: FilePath -> B.ByteString -> IO (Either [String] ()) @@ -242,7 +242,7 @@ f where f :: IO () - f = removeFile path `catch` (\ e -> if isDoesNotExistError e then return () else ioError e) >> writeFile path text + f = removeFile path `Control.Exception.catch` (\ e -> if isDoesNotExistError e then return () else ioError e) >> writeFile path text -- Try something n times, returning the first Right or the last Left -- if it never succeeds. Sleep between tries. diff --git a/Extra/IO.hs b/Extra/IO.hs --- a/Extra/IO.hs +++ b/Extra/IO.hs @@ -1,4 +1,4 @@ -module Extra.IO where +module Extra.IO {-# DEPRECATED "CIO is deprecated" #-} where import Extra.CIO import qualified System.IO as IO diff --git a/Extra/List.hs b/Extra/List.hs --- a/Extra/List.hs +++ b/Extra/List.hs @@ -16,6 +16,7 @@ import Control.Monad import Data.List +{-# DEPRECATED consperse "Use intercalate" #-} consperse :: [a] -> [[a]] -> [a] -- ^ The mighty consperse function - e.g. consperse "," ["a", "b"] -> "a,b" -- consperse = MissingH.List.join diff --git a/Extra/Lock.hs b/Extra/Lock.hs --- a/Extra/Lock.hs +++ b/Extra/Lock.hs @@ -6,49 +6,44 @@ import Control.Exception import Control.Monad.RWS +import Prelude hiding (catch) import System.Directory import System.IO -import System.IO.Error hiding (try) +import System.IO.Error hiding (try, catch) import System.Posix.Files import System.Posix.IO import System.Posix.Unistd ---withLock :: (MonadIO m) => FilePath -> m a -> m (Either Exception a) +withLock :: (MonadIO m) => FilePath -> m a -> m a withLock path task = - liftIO checkLock >>= liftIO . takeLock >>= doTask task >>= liftIO . dropLock + liftIO (checkLock >> takeLock) >> task >>= \ result -> liftIO dropLock >> return result where -- Return True if file is locked by a running process, false otherwise --checkLock :: IO (Either Exception ()) - checkLock = try (readFile path) >>= either (return . checkReadError) (processRunning . lines) - checkReadError (e :: IOException) | isDoesNotExistError e = (Right ()) - checkReadError e = Left e + checkLock = readFile path `catch` checkReadError >>= processRunning . lines + checkReadError :: IOError -> IO String + checkReadError e | isDoesNotExistError e = return "" + checkReadError e = throw e + processRunning :: [String] -> IO () processRunning (pid : _) = do exists <- doesDirectoryExist ("/proc/" ++ pid) case exists of - True -> return (Left (lockedBy pid)) + True -> throw (lockedBy pid path) False -> breakLock processRunning [] = breakLock - lockedBy pid = mkIOError alreadyInUseErrorType ("Locked by " ++ pid) Nothing (Just path) - breakLock = do try (removeFile path) >>= return . either checkBreakError (const (Right ())) - checkBreakError (e :: IOException) | isDoesNotExistError e = (Right ()) - checkBreakError e = Left e - --takeLock :: Either Exception () -> IO (Either Exception ()) - takeLock (Right ()) = + breakLock = removeFile path `catch` checkBreakError + checkBreakError (e :: IOException) | isDoesNotExistError e = return () + checkBreakError e = throw e + takeLock :: IO () + takeLock = -- Try to create the lock file in exclusive mode, if this -- succeeds then we have a lock. Then write the process ID -- into the lock and close. - try (openFd path ReadWrite (Just 0o600) (defaultFileFlags {exclusive = True, trunc = True})) >>= - either (return . Left) - (\ fd -> do h <- fdToHandle fd - processID >>= hPutStrLn h >> hClose h >> return (Right ())) - takeLock (Left e) = return (Left e) - doTask task (Right ()) = task >>= return . Right - doTask _ (Left e) = return (Left e) - dropLock (Right a) = try (removeFile path) >>= return . checkDrop a - dropLock (Left e) = return (Left e) - checkDrop a (Right ()) = Right a - checkDrop a (Left (e :: IOException)) | isDoesNotExistError e = Right a - checkDrop _ (Left e) = Left e + openFd path ReadWrite (Just 0o600) (defaultFileFlags {exclusive = True, trunc = True}) >>= + fdToHandle >>= \ h -> processID >>= hPutStrLn h >> hClose h + dropLock = removeFile path `catch` checkDrop + checkDrop (e :: IOException) | isDoesNotExistError e = return () + checkDrop e = throw e -- |Like withLock, but instead of giving up immediately, try n times -- with a wait between each. @@ -56,8 +51,13 @@ awaitLock tries usecs path task = attempt 0 where - attempt n | n >= tries = return (Left (ErrorCall "Too many failures")) - attempt n = withLock path task >>= either (\ _ -> liftIO (usleep usecs) >> attempt (n + 1)) (return . Right) + attempt n | n >= tries = error "awaitLock: too many failures" + attempt n = withLock path task `catch` checkLockError + where + checkLockError e | isAlreadyInUseError e = liftIO (usleep usecs) >> attempt (n + 1) + checkLockError e = throw e processID :: IO String processID = readSymbolicLink "/proc/self" + +lockedBy pid path = mkIOError alreadyInUseErrorType ("Locked by " ++ pid) Nothing (Just path) diff --git a/Extra/Misc.hs b/Extra/Misc.hs --- a/Extra/Misc.hs +++ b/Extra/Misc.hs @@ -1,5 +1,5 @@ module Extra.Misc - (-- * List functions + ( -- * String functions columns , justify @@ -11,39 +11,35 @@ -- * Map and Set functions , listMap , listDiff - -- * Either functions - -- * System.IO functions - --ePut, - --ePutList, -- * System.Posix , checkSuperUser - -- removeRecursiveSafely, , md5sum , sameInode , sameMd5sum , tarDir -- * Processes - -- , Extra.Misc.processOutput - -- , processOutput2 - , splitOutput - -- ByteString + -- , splitOutput + -- * ByteString , cd - -- Debugging + -- * Debugging , read' ) where import Control.Exception import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.Digest.Pure.MD5 import Data.List import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set import Extra.List +import System.Exit import System.FilePath -import System.Unix.Process import System.Directory import System.Posix.Files import System.Posix.User (getEffectiveUserID) +import System.Process (readProcessWithExitCode) +-- import System.Process.Progress (keepStdout, keepStderr, keepResult) import Text.Regex mapSnd :: (b -> c) -> (a, b) -> (a, c) @@ -51,22 +47,6 @@ -- Control file stuff -{- -mergeControls :: [Control] -> Control -mergeControls (Control p1 : Control p2 : etc) = mergeControls (Control (p1 ++ p2) : etc) -mergeControls [Control p1] = Control p1 -mergeControls [] = Control [] - -fieldValue :: String -> Paragraph -> Maybe String -fieldValue fieldName paragraph = - maybe Nothing value (lookupP fieldName paragraph) - where value (Field (_, value)) = (Just . stripWS) value - -hasField :: String -> String -> Paragraph -> Bool -hasField field value paragraph = - maybe False (== value) (fieldValue field paragraph) --} - -- |Pad strings so the columns line up. The argument and return value -- elements are the rows of a table. Do not pad the rightmost column. columns :: [[String]] -> [[String]] @@ -91,11 +71,6 @@ parentPath :: FilePath -> FilePath parentPath path = fst (splitFileName path) -{- -baseName :: FilePath -> String -baseName path = snd (splitFileName path) --} - -- |Turn a list of (k, a) pairs into a map from k -> [a]. The order of the elements in -- the a list is preserved. listMap :: (Ord k) => [(k, a)] -> Map.Map k [a] @@ -121,20 +96,10 @@ merge (x : xs) = x : merge xs merge [] = [] +{-# DEPRECATED md5sum "Use Data.ByteString.Lazy.Char8.readFile path >>= return . show . Data.Digest.Pure.MD5.md5" #-} -- | Run md5sum on a file and return the resulting checksum as text. -md5sum :: FilePath -> IO (Either String String) -md5sum path = - do output <- lazyCommand cmd B.empty - let result = - case exitCodeOnly output of - ExitFailure n -> Left ("Error " ++ show n ++ " running '" ++ cmd ++ "'") - ExitSuccess -> - case listToMaybe . words . B.unpack . stdoutOnly $ output of - Nothing -> Left $ "Error in output of '" ++ cmd ++ "'" - Just checksum -> Right checksum - return result - where - cmd = "md5sum " ++ path +md5sum :: FilePath -> IO String +md5sum path = B.readFile path >>= return . show . Data.Digest.Pure.MD5.md5 -- | Predicate to decide if two files have the same inode. sameInode :: FilePath -> FilePath -> IO Bool @@ -153,127 +118,27 @@ return (asum == bsum) {- --- | Backwards compatibility functions. -processOutput :: String -> IO (Either Int String) -processOutput command = - do - output <- lazyCommand command B.empty - case exitCodeOnly output of - ExitSuccess -> return . Right . B.unpack . stdoutOnly $ output - ExitFailure n -> return . Left $ n - _ -> error "My.processOutput: Internal error 13" - -processOutput2 :: String -> IO (String, ExitCode) -processOutput2 command = - do - output <- lazyCommand command B.empty - return ((B.unpack . stdoutOnly $ output), exitCodeOnly output) +splitOutput :: [Output B.ByteString] -> (B.ByteString, B.ByteString, [ExitCode]) +splitOutput output = (B.concat (keepStdout output), B.concat (keepStderr output), keepResult output) -} -splitOutput :: [Output] -> (B.ByteString, B.ByteString, ExitCode) -splitOutput output = (stdoutOnly output, stderrOnly output, exitCodeOnly output) - -- |A version of read with a more helpful error message. read' s = case reads s of [] -> error $ "read - no parse: " ++ show s ((x, _s) : _) -> x -{- -type DryRunFn = IO () -> (Bool, String) -> IO () - -(-?-) :: DryRunFn --- ^ If this is a dry run (dryRun params is True) do *not* evaluate f, --- but instead print a message. -(-?-) f (dryRun, "") = if dryRun then return () else f -(-?-) f (dryRun, msg) = - do - hPutStrLn stderr msg - if dryRun then return () else f -infixr 9 -?- --} - -{- -(+/+) :: FilePath -> FilePath -> FilePath -(+/+) path1 "" = path1 -(+/+) "" path2 = path2 -(+/+) path1 path2 = - case (last path1, head path2) of - ('/', '/') -> path1 +/+ (tail path2) - (_, '/') -> path1 ++ path2 - ('/', _) -> path1 ++ path2 - (_, _) -> path1 ++ "/" ++ path2 --} - -{- --------------- From MissingH -------------- - --- | Split the path into directory and file name --- --- Examples: --- --- \[Posix\] --- --- > splitFileName "/" == ("/", ".") --- > splitFileName "/foo/bar.ext" == ("/foo", "bar.ext") --- > splitFileName "bar.ext" == (".", "bar.ext") --- > splitFileName "/foo/." == ("/foo", ".") --- > splitFileName "/foo/.." == ("/foo", "..") --- --- \[Windows\] --- --- > splitFileName "\\" == ("\\", "") --- > splitFileName "c:\\foo\\bar.ext" == ("c:\\foo", "bar.ext") --- > splitFileName "bar.ext" == (".", "bar.ext") --- > splitFileName "c:\\foo\\." == ("c:\\foo", ".") --- > splitFileName "c:\\foo\\.." == ("c:\\foo", "..") --- --- The first case in the Windows examples returns an empty file name. --- This is a special case because the \"\\\\\" path doesn\'t refer to --- an object (file or directory) which resides within a directory. - -splitFileName :: FilePath -> (String, String) -splitFileName p = (reverse path1, reverse fname1) - where - (fname,path) = break isPathSeparator (reverse p) - path1 = case path of - "" -> "." - _ -> case dropWhile isPathSeparator path of - "" -> [pathSeparator] - p -> p - fname1 = case fname of - "" -> "." - _ -> fname - --- | Checks whether the character is a valid path separator for the host --- platform. The valid character is a 'pathSeparator' but since the Windows --- operating system also accepts a slash (\"\/\") since DOS 2, the function --- checks for it on this platform, too. -isPathSeparator :: Char -> Bool -isPathSeparator ch = - ch == '/' - --- | Provides a platform-specific character used to separate directory levels in --- a path string that reflects a hierarchical file system organization. The --- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash --- (@\"\\\"@) on the Windows operating system. -pathSeparator :: Char -pathSeparator = '/' --} - - checkSuperUser :: IO Bool checkSuperUser = getEffectiveUserID >>= return . (== 0) -- | Given a tarball, return the name of the top directory. tarDir :: FilePath -> IO (Maybe String) tarDir path = - lazyCommand cmd B.empty >>= \ output -> - case exitCodeOnly output of - ExitSuccess -> return . dir . lines . B.unpack . stdoutOnly $ output + readProcessWithExitCode "tar" ["tfz", path] "" >>= \ (code, out, _) -> + case code of + ExitSuccess -> return . dir . lines $ out _ -> return Nothing where - cmd = "tar tfz '" ++ path ++ "'" dir [] = Nothing dir (file : _) = case wordsBy (== '/') file of [] -> Nothing diff --git a/Extra/SSH.hs b/Extra/SSH.hs --- a/Extra/SSH.hs +++ b/Extra/SSH.hs @@ -1,6 +1,6 @@ module Extra.SSH ( sshVerify - , sshExport + , sshExportDeprecated , sshCopy ) where @@ -10,12 +10,10 @@ import System.Environment import System.Exit import System.IO -import qualified Data.ByteString.Lazy.Char8 as B -import System.Unix.Process - +import System.Process (readProcessWithExitCode, showCommandForUser) -- |Set up access to destination (user\@host). -sshExport :: String -> Maybe Int -> IO (Either String ()) -sshExport dest port = +sshExportDeprecated :: String -> Maybe Int -> IO (Either String ()) +sshExportDeprecated dest port = generatePublicKey >>= either (return . Left) (testAccess dest port) >>= either (return . Left) (openAccess dest port) @@ -35,11 +33,10 @@ True -> return . Right $ keypath False -> do hPutStrLn stderr $ "generatePublicKey " ++ " -> " ++ keypath - result <- lazyCommand cmd B.empty - case exitCodeOnly result of + code <- system cmd + case code of ExitFailure n -> - return . Left $ "Failure: " ++ show cmd ++ " -> " ++ show n ++ - "\n\noutput: " ++ B.unpack (outputOnly result) + return . Left $ "Failure: " ++ show cmd ++ " -> " ++ show n _ -> return . Right $ keypath -- |See if we already have access to the destination (user\@host). @@ -61,20 +58,19 @@ True -> return . Right $ Nothing False -> return . Right . Just $ keypath --- |Try to set up the keys so we have access to the account +-- |Try to set up the keys so we have access to the account. I don't +-- think we use this any more, and I don't think you should either. openAccess :: String -> Maybe Int -> Maybe FilePath -> IO (Either String ()) openAccess _ _ Nothing = return . Right $ () openAccess dest port (Just keypath) = do hPutStrLn stderr $ "openAccess " ++ show dest ++ " " ++ show port ++ " " ++ show keypath - let cmd = sshOpenCmd dest port keypath - result <- lazyCommand cmd B.empty - case exitCodeOnly result of - ExitFailure n -> return . Left $ "Failure: " ++ show cmd ++ " -> " ++ show n ++ - "\n\noutput: " ++ B.unpack (outputOnly result) + let args = maybe [] (\ x -> ["-p", show x]) port ++ [show dest, sshOpenRemoteCmd] + (code, out, err) <- readFile keypath >>= readProcessWithExitCode "ssh" args + case code of + ExitFailure n -> return . Left $ "Failure: " ++ showCommandForUser "ssh" args ++ " -> " ++ show n ++ + "\n\nstdout: " ++ out ++ "\n\nstderr: " ++ err _ -> return . Right $ () where - sshOpenCmd dest port keypath = - "cat " ++ keypath ++ " | " ++ "ssh " ++ (maybe "" ((++ "-p ") . show) port) ++ " " ++ show dest ++ " '" ++ sshOpenRemoteCmd ++ "'" sshOpenRemoteCmd = ("chmod g-w . && " ++ -- Ssh will not work if the permissions aren't just so "chmod o-rwx . && " ++ diff --git a/Extra/TIO.hs b/Extra/TIO.hs deleted file mode 100644 --- a/Extra/TIO.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} --- |A value of type TIO represents the state of the terminal I/O --- system. The 'bol' flag keeps track of whether we are at the --- beginning of line on the console. This is computed in terms of --- what we have sent to the console, but it should be remembered that --- the order that stdout and stderr are sent to the console may not be --- the same as the order in which they show up there. However, in --- practice this seems to work as one would hope. -module Extra.TIO - ( module Extra.CIO - -- * The TIO monad - , TIO - , runTIO - , tryTIO - --, liftTIO - ) where - -import Extra.CIO -import Prelude hiding (putStr, putChar, putStrLn) -import Control.Exception -import Control.Monad.RWS -import qualified System.IO as IO - -data TState - = TState { cursor :: Position -- ^ Is the console at beginning of line? - } deriving Show - -data Position - = BOL -- Beginning of line - | MOL -- Middle of line - | EOL -- End of line - deriving (Show, Eq) - -type TIOT = RWST TStyle () TState -type TIO = TIOT IO - --- |Perform a TIO monad task in the IO monad. -runTIO :: TStyle -> TIO a -> IO a -runTIO style action = (runRWST action) style initState >>= \ (a, _, _) -> return a - --- |Catch exceptions in a TIO action. ---tryTIO :: TIO a -> TIO (Either Exception a) -tryTIO task = - do state <- get - liftTIO (try' state) task - where - try' state task = - do result <- try task - case result of - Left e -> return (Left e, state, ()) - Right (a, s, _) -> return (Right a, s, ()) - -liftTIO :: (IO (a, TState, ()) -> IO (b, TState, ())) -> TIO a -> TIO b -liftTIO f = mapRWST f - --- |The initial output state - at the beginning of the line, no special handle --- state information, no repositories in the repository map. -initState :: TState -initState = TState {cursor = BOL} - --- |The TIO instance of CIO adds some features to the normal console --- output. By tracking the cursor position it is able to insert a --- prefix to each line, and to implement a "beginning of line" (BOL) --- function which only adds a newline when the cursor is not already --- at BOL. It also allows verbosity controlled output, where a verbosity --- level is stored in the monad state and output requests are given a --- verbosity which must be greater or equal to the monad's verbosity --- level for the output to appear. -instance CIO TIO where - hPutStr h s = - do style <- ask - state <- get - case (cursor state, break (== '\n') s) of - (_, ("", "")) -> return () - (BOL, ("", (_ : b))) -> prefix style >> newline >> hPutStr h b - (MOL, ("", (_ : b))) -> newline >> put (state {cursor = BOL}) >> hPutStr h b - (EOL, ("", (_ : b))) -> newline >> put (state {cursor = BOL}) >> hPutStr h b - (BOL, (a, b)) -> prefix style >> write a >> put (state {cursor = MOL}) >> hPutStr h b - (MOL, (a, b)) -> write a >> hPutStr h b - (EOL, (a, b)) -> newline >> prefix style >> write a >> put (state {cursor = MOL}) >> hPutStr h b - where - prefix style = liftIO (IO.hPutStr IO.stderr (hGetPrefix h style)) -- >> io (IO.hFlush h) - newline = liftIO (IO.hPutStr IO.stderr "\n") -- >> io (IO.hFlush IO.stderr) - write s = liftIO (IO.hPutStr IO.stderr s) -- >> io (IO.hFlush h) - -- | A "virtual" newline, this puts us into the EOL state. From - -- this state, a newline will be inserted before the next output, - -- unless that output itself begins with a newline. - hBOL _h = - do state <- get - put (state {cursor = if cursor state == BOL then BOL else EOL}) - -- |Return the "effective verbosity", or perhaps the effective - -- quietness. If this value is zero or less the output will be - -- complete. By convention, if it is one, the output will be brief. - -- If it is a two or more no output is generated. - ev v = - do style <- ask - return (verbosity style - v) - -- |Modify the current style for this action - setStyle styleFn = local styleFn - -- |Implementation of try for the TIO monad - tryCIO = tryTIO - -_test :: IO () -_test = - runTIO (defStyle {prefix = "% "}) - (putStr "hello\nworld\n" >> - bol >> -- No extra newline - putStr "(some text)" >> - putStr "(some more on same line)" >> -- This should be right after abc - bol >> - putStr "(newline)\n\n(after a blank line)" >> -- This should show up on a new line - bol) -- Newline before exit diff --git a/Extra/URI.hs b/Extra/URI.hs --- a/Extra/URI.hs +++ b/Extra/URI.hs @@ -89,6 +89,3 @@ (a : _) -> a goodURIs = takeWhile isJust moreURIs (badURIs, moreURIs) = span isNothing allURIs - -instance Ord URI where - compare a b = compare (uriToString id a "") (uriToString id b "") diff --git a/Test/QUnit.hs b/Test/QUnit.hs --- a/Test/QUnit.hs +++ b/Test/QUnit.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Test.QUnit