packages feed

Extra 1.42 → 1.45

raw patch · 12 files changed

+108/−645 lines, 12 filesdep +pureMD5dep ~Unixutilsdep ~networknew-uploader

Dependencies added: pureMD5

Dependency ranges changed: Unixutils, network

Files

Extra.cabal view
@@ -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 <david@seereason.com> 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:
− Extra/CIO.hs 
@@ -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"
Extra/Either.hs view
@@ -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
Extra/Files.hs view
@@ -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.
Extra/IO.hs view
@@ -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
Extra/List.hs view
@@ -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
Extra/Lock.hs view
@@ -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)
Extra/Misc.hs view
@@ -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
Extra/SSH.hs view
@@ -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 . && " ++
− Extra/TIO.hs 
@@ -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
Extra/URI.hs view
@@ -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 "")
Test/QUnit.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module      :  Test.QUnit