packages feed

sr-extra (empty) → 1.46.3

raw patch · 25 files changed

+1607/−0 lines, 25 filesdep +HUnitdep +QuickCheckdep +Unixutilssetup-changed

Dependencies added: HUnit, QuickCheck, Unixutils, base, bytestring, bzlib, containers, directory, filepath, mtl, network, network-uri, old-locale, old-time, pretty, process, pureMD5, random, regex-compat, time, unix, zlib

Files

+ COPYING view
@@ -0,0 +1,36 @@+This package was debianized by David Fox+<ddssff@gmail.com> on September 18, 2007.++Copyright (c) 2007, David Fox+Copyright (c) Jeremy Shaw 2007+Copyright (c) Stefan O'Rear 2006++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The names of contributors may not be used to endorse or promote+      products derived from this software without specific prior+      written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Extra/Bool.hs view
@@ -0,0 +1,7 @@+module Extra.Bool+    ( cond+    ) where++cond :: a -> a -> Bool -> a+cond t _ True = t+cond _ f False = f
+ Extra/CIO.hs view
@@ -0,0 +1,308 @@+-- |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  {-# DEPRECATED "Use System.Unix.QIO in Unixutils." #-}+    ( -- * 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
@@ -0,0 +1,20 @@+module Extra.Either where++import Data.Either (partitionEithers, rights)++isRight (Right _) = True+isRight (Left _) = False++isLeft = not . isRight++-- |Turn a list of eithers into an either of lists+concatEithers :: [Either a b] -> Either [a] [b]+concatEithers xs =+    case partitionEithers xs of +      ([], rs) -> Right rs+      (ls, _) -> Left ls++{-# DEPRECATED rightOnly "Use rights" #-}+rightOnly = rights+{-# DEPRECATED eitherFromList "Use concatEithers" #-}+eitherFromList = concatEithers
+ Extra/Exit.hs view
@@ -0,0 +1,15 @@+module Extra.Exit where++import Extra.HughesPJ+import System.Environment+import System.Exit+import System.IO+import Text.PrettyPrint.HughesPJ++-- |exitFailure with nicely formatted help text on stderr+exitWithHelp :: (String -> Doc) -- ^ generate help text, the argument is the result of getProgName+             -> IO a -- ^ no value is returned, this function always calls exitFailure+exitWithHelp helpText =+    do progName <- getProgName+       hPutStrLn stderr =<< renderWidth (helpText progName)+       exitFailure
+ Extra/Files.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |Some extra operations on files.  The functions here generally+-- return (Right ()) on success, Left [messages] on failure, and throw+-- an exception when a failure leaves things in an inconsistant state.+-- An example of an inconsistant state would be if we got a failure+-- when writing out a file, but were unable to restore the original+-- file to its original position.+module Extra.Files +    ( getSubDirectories+    , renameAlways+    , renameMissing+    , deleteMaybe+    , installFiles+    , writeAndZipFileWithBackup+    , writeAndZipFile+    , backupFile+    , writeFileIfMissing+    , maybeWriteFile		-- writeFileUnlessSame+    , createSymbolicLinkIfMissing+    , prepareSymbolicLink+    , forceRemoveLink+    , replaceFile+    ) where++import qualified Codec.Compression.GZip as GZip+import qualified Codec.Compression.BZip as BZip+import		 Control.Exception+import		 Control.Monad+import qualified Data.ByteString.Lazy as B+import		 Data.List+import		 Data.Maybe+import		 Extra.Misc+import		 System.Unix.Directory+import		 System.Directory+import		 System.IO.Error hiding (try, catch)+import		 System.Posix.Files++-- | Return the list of subdirectories, omitting . and .. and ignoring+-- symbolic links.+getSubDirectories :: FilePath -> IO [String]+getSubDirectories path =+    getDirectoryContents path >>=+    return . filter (not . (flip elem) [".", ".."]) >>=+    filterM isRealDirectory+    where+      isRealDirectory name = getSymbolicLinkStatus (path ++ "/" ++ name) >>= return . not . isSymbolicLink++-- |Atomically install a list of files.  Returns a list of what went+-- wrong on failure.  Will throw an error if it fails and is unable to+-- restore the original files to their original states.+installFiles :: [(FilePath, FilePath)] -> IO (Either [String] ())+installFiles pairs =+    do backedUp <- mapM (uncurry renameAlways) (zip originalFiles backupFiles)+       case lefts backedUp of+         [] -> +             do renamed <- mapM (uncurry renameAlways) (zip replacementFiles originalFiles)+                case lefts renamed of+                  [] -> return $ Right ()+                  _ ->+                      -- We failed after all the original files were+                      -- renamed and maybe some of the replacement+                      -- files were installed.  Move all the renamed+                      -- files back into place.+                      do restored <- mapM (uncurry renameAlways) (zip backupFiles originalFiles)+                         case lefts restored of+	                   -- We succeeded in failing.+                           [] -> return . Left . concat . lefts $ renamed+	                   -- Restore failed.  Throw an exception.+                           _ -> error ("installFiles: Couldn't restore original files after write failure:" +++                                       concat (map message (zip3 replacementFiles originalFiles renamed)) +++                                       concat (map message (zip3 originalFiles backupFiles restored)))+         _ ->+             -- We failed after renaming all original files, but+             -- before any of the replacement files were installed.+             -- Restore the backup for any missing original files.+             do restored <- mapM (uncurry renameMissing) (zip backupFiles originalFiles)+                case lefts restored of+	          -- We succeeded in failing.+                  [] -> return . Left . concat . lefts $ backedUp+		  -- Restore failed.  Throw an exception.+                  _ -> error ("installFiles: Couldn't restore original files after write failure: " +++                              concat (map message (zip3 originalFiles backupFiles backedUp)) +++                              concat (map message (zip3 backupFiles originalFiles restored)))+    where+      replacementFiles = map fst pairs+      originalFiles = map snd pairs+      backupFiles = map (++ "~") originalFiles+      message (path1, path2, Left problems) =+          "\n  " ++ path1 ++ " -> " ++ path2 ++ ": " ++ concat (intersperse ", " (map show problems))+      message (_, _, Right ()) = ""++lefts :: [Either a b] -> [a]+lefts xs = catMaybes $ map (either Just (const Nothing)) xs++-- |Change a file's name only if the new name doesn't exist.+renameMissing :: FilePath -> FilePath -> IO (Either [String] ())+renameMissing old new =+    do exists <- fileExist new+       case exists of+         True -> return $ Right ()+         False -> renameAlways old new++-- |Change a file's name, removing any existing file with the new name.+renameAlways :: FilePath -> FilePath -> IO (Either [String] ())+renameAlways old new =+    do deleted <- deleteMaybe new+       case deleted of+         Right () ->+             try (rename old new) >>=+             return . either (\ (e :: SomeException) -> Left ["Couldn't rename " ++ old ++ " -> " ++ new ++ ": " ++ show e]) (\ _ -> Right ())+         x -> return x++-- |Change a file's name if it exists.+renameMaybe :: FilePath -> FilePath -> IO (Either [String] ())+renameMaybe old new =+    do exists <- fileExist old+       case exists of+         False -> return $ Right ()+         True -> renameAlways old new++-- |Delete a file if it exists+deleteMaybe :: FilePath -> IO (Either [String] ())+deleteMaybe path =+    do exists <- fileExist path+       case exists of+         False -> return $ Right ()+         True ->+             do status <- getSymbolicLinkStatus path+		-- To do: should we remove the directory contents?+                let rm = if isDirectory status then removeDirectory else removeLink+                try (rm path) >>= return . either (\ (e :: SomeException) -> Left ["Couldn't remove " ++ path ++ ": " ++ show e]) (const . Right $ ())++-- |Create or update gzipped and bzip2-ed versions of a file.+zipFile :: FilePath -> IO (Either [String] ())+zipFile path =+    try (do forceRemoveLink gz+            forceRemoveLink bz2+            B.readFile path >>= B.writeFile gz . {- t1 . -} GZip.compress+            B.readFile path >>= B.writeFile bz2 . {- t2 . -} BZip.compress) >>=+    return . either (\ (e :: SomeException) -> Left ["Failure writing and zipping " ++ path, show e]) Right+    where+      gz = path ++ ".gz"+      bz2 = path ++ ".bz2"+      --t1 s = trace ("Size of " ++ gz ++ " text: " ++ show (L.length s)) s+      --t2 s = trace ("Size of " ++ bz2 ++ " text: " ++ show (L.length s)) s+      --writeMessage (command, output) =+      --    case exitCodeOnly output of+      --      (ExitFailure n : _) ->+      --          command ++ " -> " ++ show n ++ ":\n  " ++ L.unpack (stderrOnly output)+      --      _ -> ""++-- |like removeLink, but does not fail if link did not exist+forceRemoveLink :: FilePath -> IO ()+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] ())+writeAndZipFileWithBackup path text =+    backupFile path >>=+    either (\ e -> return (Left ["Failure renaming " ++ path ++ " -> " ++ path ++ "~: " ++ show e]))+           (\ _ -> try (B.writeFile path text) >>=+                   either (\ (e :: SomeException) ->+                               restoreBackup path >>=+                               either (\ e -> error ("Failed to restore backup: " ++ path ++ "~ -> " ++ path ++ ": " ++ show e))+                                      (\ _ -> return (Left ["Failure writing " ++ path ++ ": " ++ show e])))+                          (\ _ -> zipFile path))++-- | Write out three versions of a file, regular, gzipped, and bzip2ed.+-- This new version assumes the files are written to temporary locations,+-- so any existing file there can be removed.+writeAndZipFile :: FilePath -> B.ByteString -> IO (Either [String] ())+writeAndZipFile path text =+    deleteMaybe path >>=+    either (\ e -> return (Left ["Failure removing " ++ path ++ ": " ++ show e]))+           (\ _ -> try (B.writeFile path text) >>=+                   either (\ (e :: SomeException) -> return (Left ["Failure writing " ++ path ++ ": " ++ show e]))+                          (\ _ -> zipFile path))++-- Turn a file into a backup file if it exists.+backupFile :: FilePath -> IO (Either [String] ())+backupFile path = renameMaybe path (path ++ "~")++restoreBackup :: FilePath -> IO (Either [String] ())+restoreBackup path = renameMaybe (path ++ "~") path++-- | Like writeFile, but if the file already exists don't touch it.+-- Example: writeFileIfMissing True \"\/var\/lib\/dpkg\/status\" \"\"+writeFileIfMissing :: Bool -> FilePath -> String -> IO ()+writeFileIfMissing mkdirs path text =+    do+      exists <- doesFileExist path+      case exists of+        False ->+            do+              if mkdirs then+                  createDirectoryIfMissing True (parentPath path) else+                  return ()+              replaceFile path text+        True ->+            return ()++-- | Write a file if its content is different from the given text.+maybeWriteFile :: FilePath -> String -> IO ()+maybeWriteFile path text =+    try (readFile path) >>= maybeWrite+    where+      maybeWrite (Left (e :: IOException)) | isDoesNotExistError e = writeFile path text+      maybeWrite (Left e) = error ("maybeWriteFile: " ++ show e)+      maybeWrite (Right old) | old == text = return ()+      maybeWrite (Right _old) = +          --hPutStrLn stderr ("Old text: " ++ show old) >>+          --hPutStrLn stderr ("New text: " ++ show text) >>+          replaceFile path text++-- |Add-on for System.Posix.Files+createSymbolicLinkIfMissing :: String -> FilePath -> IO ()+createSymbolicLinkIfMissing text path =+    try (getSymbolicLinkStatus path) >>=+    either (\ (_ :: SomeException) -> createSymbolicLink text path) (\ _ -> return ())++prepareSymbolicLink :: FilePath -> FilePath -> IO ()+prepareSymbolicLink name path =+    checkExists >>= checkType >>= checkContent+    where+      checkExists = doesDirectoryExist path >>= orCreate+      checkType False = return False+      checkType True = getSymbolicLinkStatus path >>= return . isSymbolicLink >>= orReplace+      checkContent False = return ()+      checkContent True = readSymbolicLink path >>= return . (== name) >>= orReplace >> return ()+      orReplace True = return True+      orReplace False = do removeRecursiveSafely path; orCreate False+      orCreate True = return True+      orCreate False = do createSymbolicLink name path; return False++-- Replace a file's contents, accounting for the possibility that the+-- old contents of the file may still be being read.  Apparently there+-- is a race condition in the file system so we may get one or more+-- isAlreadyBusyError exceptions before the writeFile succeeds.+replaceFile :: FilePath -> String -> IO ()+replaceFile path text =+    --tries 100 10 f	-- There is now a fix for this problem, see ghc ticket 2122.+    f+    where+      f :: IO ()+      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.+--tries :: Int -> Int -> (IO a) -> IO (Either Exception a)+{-+tries _ 1 f = try f >>= either (return . Left) (return . Right)+tries usec count f = try f >>= either (\ (_ :: SomeException) -> usleep usec >> tries usec (count - 1) f) (return . Right)+-}
+ Extra/GPGSign.hs view
@@ -0,0 +1,72 @@+module Extra.GPGSign+    ( sign+    , PGPKey(..)+    , pgpSignFiles+    , pgpSignFile+    , cd+    ) where++import System.Process+import System.IO+import System.Exit+import Extra.Misc++_test :: PGPKey'' -> [FilePath] -> IO [FilePath]+_test key files =+    mapM (sign key) files++type PGPKey'' = String+++sign :: PGPKey'' -> FilePath -> IO FilePath+sign keyname path =+    do (_, _,err,pid) <- runInteractiveProcess cmd args workingDir env+       status <- waitForProcess pid+       case status of+         ExitSuccess -> return outputPath+         ExitFailure _ ->+             do gpgerr <- hGetContents err+                hPutStr stderr gpgerr+                exitWith status+       where+         cmd = "/usr/bin/gpg"+         args = [ "--batch"+                , "--yes"+                , "--default-key", keyname+                , "-o", outputPath+                , "--clearsign"+                , path+                ]+         outputPath = path ++ ".gpg"+         workingDir = Nothing -- Just (dirName path)+         env = Nothing++data PGPKey = Key String | Default deriving Show++pgpSignFiles :: FilePath -> PGPKey -> [FilePath] -> IO [Bool]+pgpSignFiles root key files = cd root $ mapM (pgpSignFile key) files++pgpSignFile :: PGPKey -> FilePath -> IO Bool+pgpSignFile keyname path =+    do (_, _,err,pid) <- runInteractiveProcess cmd args workingDir env+       status <- waitForProcess pid+       case status of+         ExitSuccess -> return True+         ExitFailure _code ->+             do gpgerr <- hGetContents err+                hPutStr stderr gpgerr+                return False+       where+         cmd = "/usr/bin/gpg"+         args = defaultKey +++             [ "--batch"+             , "--yes"+             , "-o", outputPath+             , "--armor"+             , "--detach-sign"+             , path+             ]+         defaultKey = case keyname of Key name -> ["--default-key", name]; Default -> []+         outputPath = path ++ ".gpg"+         workingDir = Nothing -- Just (dirName path)+         env = Nothing
+ Extra/HughesPJ.hs view
@@ -0,0 +1,11 @@+module Extra.HughesPJ where++import Data.Maybe+import Extra.Terminal+import Text.PrettyPrint.HughesPJ++-- |render a Doc using the current terminal width+renderWidth :: Doc -> IO String       +renderWidth doc =+    do columns <- return . fromMaybe 80 =<< getWidth+       return $ renderStyle (Style PageMode columns 1.0) doc
+ Extra/IO.hs view
@@ -0,0 +1,20 @@+module Extra.IO {-# DEPRECATED "CIO is deprecated" #-} where++import Extra.CIO+import qualified System.IO as IO+import Control.Exception (try)++-- |Use this module to call functions in the CIO module from the+-- regular IO monad.  This instance ignores all style and state+-- information.  The verbosity controlled output functions will ignore+-- any calls when v is greater than zero.  This allows you to call the+-- functions in the haskell-debian package from the regular IO monad.+-- +-- This is in a separate module from CIO so you don't accidentally do+-- a liftIO of some other CIO operation and get this instance.+instance CIO IO where+    hPutStr h s = IO.hPutStr h s+    hBOL h = IO.hPutStr h "\n"+    ev v = return (- v)+    setStyle _ f = f+    tryCIO = try
+ Extra/IOThread.hs view
@@ -0,0 +1,41 @@+-- |this module provides a simple mechanism for adding IO operations+-- to a queue and running them in a single thread. This is useful if+-- the IO operations have side-effects which could collide if run from+-- multiple threads. For example, creating an image thumbnail and+-- storing it on disk, running latex, etc.+module Extra.IOThread where++import Control.Concurrent (ThreadId, forkIO)+import Control.Concurrent.Chan (Chan,newChan, readChan, writeChan)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)+import Control.Exception+import Control.Monad (forever)++newtype IOThread a b = IOThread (Chan (a, MVar (Either SomeException b)))++-- |start the IO thread.+startIOThread :: (a -> IO b) -- ^ the IO function that does all the work+              -> IO (ThreadId, IOThread a b) -- ^ a ThreadId which can be used to kill the IOThread, and a handle that can be used to issue requests to the thread.+startIOThread f =+    do c <- newChan+       tid <- forkIO $ ioThread f c+       return (tid, IOThread c)+    where+      ioThread f c =+          forever $ do (a, mvar) <- readChan c+                       b <- try $ f a+                       putMVar mvar b++-- |issue a request to the IO thread and get back the result+-- if the thread function throws an exception 'ioRequest' will rethrow the exception.+ioRequest :: (IOThread a b) -- ^ handle to the IOThread+          -> a -- ^ argument to the function in the IOThread+          -> IO b -- ^ value returned by the function in the IOThread+ioRequest (IOThread chan) a =+    do resp <- newEmptyMVar +       writeChan chan (a, resp)+       e <- readMVar resp+       case e of+         (Right r) ->  return r+         (Left err) -> throwIO err+
+ Extra/List.hs view
@@ -0,0 +1,95 @@+module Extra.List+    ( consperse+    , surround+    , changePrefix+    , dropPrefix+    , cartesianProduct+    , wordsBy+    , empty+    , sortByMapped+    , sortByMappedM+    , partitionM+    , listIntersection+    , isSublistOf+    ) where++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+consperse s l = concat . intersperse s $ l++surround :: [a] -> [a] -> [[a]] -> [a]+-- ^ surround each element of a list - e.g. surround "(" ")" ["a", "b"] -> ["(a)(b)"]+surround prefix suffix items = concat $ map ((prefix ++) . (++ suffix)) items++-- |Replace the prefix of s, return Nothing if it doesn't match.+changePrefix :: (Eq a) => [a] -> [a] -> [a] -> Maybe [a]+changePrefix old new s = maybe Nothing (Just . (new ++)) (dropPrefix old s)++-- |Remove a prefix of s, return nothing if it doesn't match.+dropPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]+dropPrefix prefix s =+    case isPrefixOf prefix s of+      True -> Just (drop (length prefix) s)+      False -> Nothing++cartesianProduct :: [[a]] -> [[a]]+-- ^ cartesianProduct [[1,2,3], [4,5],[6]] -> [[1,4,6],[1,5,6],[2,4,6],[2,5,6],[3,4,6],[3,5,6]]+cartesianProduct [] = []+cartesianProduct [xs] = map (: []) xs+cartesianProduct (xs : yss) =+    distribute xs (cartesianProduct yss)+    where distribute xs yss = concat (map (\ x -> map (x :) yss) xs)++-- |FIXME: implement for a string+wordsBy :: Eq a => (a -> Bool) -> [a] -> [[a]]+wordsBy p s = +    case (break p s) of+      (s, []) -> [s]+      (h, t) -> h : wordsBy p (drop 1 t)++-- |Like maybe, but with empty vs. non-empty list+empty :: b -> ([a] -> b) -> [a] -> b+empty e _ [] = e+empty _ f l = f l++-- |Sort a list using the compare function on the list elements mapped+-- over f.  This is like "sortBy (\ a b -> compare (f a) (f b))"+-- except that f is applied O(n) times instead of O(n log n)+sortByMapped :: (a -> b) -> (b -> b -> Ordering) -> [a] -> [a]+sortByMapped f compare list =+    map fst sorted+    where+      sorted = sortBy (\ (_, x) (_, y) -> compare x y) pairs+      pairs = zip list (map f list)++-- |Monadic version of sortByMapped+sortByMappedM :: (a -> IO b) -> (b -> b -> Ordering) -> [a] -> IO [a]+sortByMappedM f compare list =+    do+      pairs <- mapM f list >>= return . (zip list)+      let sorted = sortBy (\ (_, x) (_, y) -> compare x y) pairs+      return (map fst sorted)++partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM p xs =+    foldM f ([], []) xs+    where f (a, b) x = p x >>= (\ flag -> return $ if flag then (x : a, b) else (a, x : b))++listIntersection :: Eq a => [[a]] -> [a]+listIntersection [] = []+listIntersection (first : rest) = foldr intersect first rest++isSublistOf :: Eq a => [a] -> [a] -> Maybe Int+isSublistOf sub lst =+    maybe Nothing (\ s -> Just (length s - length sub))+              (find (isSuffixOf sub) (inits lst))++{-+lookups :: (Eq a) => a -> [(a, b)] -> [b]+lookups a = map snd . filter ((a ==) . fst)+-}
+ Extra/Lock.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Extra.Lock+    ( withLock+    , awaitLock+    ) where++import Control.Exception+import Control.Monad.RWS+import Prelude hiding (catch)+import System.Directory+import System.IO+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 a+withLock path task =+    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 = 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 -> throw (lockedBy pid path)+               False -> breakLock+      processRunning [] = breakLock+      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.+          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.+--awaitLock :: (MonadIO m) => Int -> Int -> FilePath -> m a -> m (Either Exception a)+awaitLock tries usecs path task =+    attempt 0+    where +      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
@@ -0,0 +1,155 @@+module Extra.Misc+    (+    -- * String functions+      columns+    , justify+    -- * Tuple functions+    , mapSnd+    -- * FilePath functions+    , parentPath+    , canon+    -- * Map and Set functions+    , listMap+    , listDiff+    -- * System.Posix+    , checkSuperUser+    , md5sum+    , sameInode+    , sameMd5sum+    , tarDir+    -- * Processes+    -- , splitOutput+    -- * ByteString+    , cd+    -- * 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.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)+mapSnd f (a, b) = (a, f b)++-- Control file stuff++-- |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]]+columns rows =+    map (map pad . zip (widths ++ [0])) rows+    where+      widths = map (fromJust . listMax) . transpose . map (map length . init) $ rows+      listMax l = foldl (\ a b -> Just . maybe b (max b) $ a) Nothing l+      pad (width, field) = field ++ replicate (max 0 (width - length field)) ' '++-- |Group words into lines of length n or less.+justify :: String -> Int -> [[String]]+justify s n =+    foldr doWord [[]] (words s)+    where doWord w [] = [[w]]+	  doWord w (ws : etc) = +	      if length (concat (intersperse " " (w:ws))) <= n then+		 (w : ws) : etc else+		 [w] : ws : etc++-- |dirname+parentPath :: FilePath -> FilePath+parentPath path = fst (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]+listMap pairs =+    foldl insertPair Map.empty (reverse pairs)+    where insertPair m (k,a) = Map.insert k (a : (Map.findWithDefault [] k m)) m++-- Return the difference of two lists.  Order is not preserved.+listDiff :: Ord a => [a] -> [a] -> [a]+listDiff a b = Set.toList (Set.difference (Set.fromList a) (Set.fromList b))++-- | Weak attempt at canonicalizing a file path.+canon :: FilePath -> FilePath+canon path =+    let re = mkRegex "/" in+    let names = splitRegex re path in+    concat (intersperse "/" (merge names))+    where+      merge (".." : xs) = ".." : (merge xs)+      merge ("." : xs) = "." : (merge xs)+      merge (_ : ".." : xs) = (merge xs)+      merge (x : "." : xs) = (merge (x : xs))+      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 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+sameInode a b =+    do+      aStatus <- getFileStatus a+      bStatus <- getFileStatus b+      return (deviceID aStatus == deviceID bStatus && fileID aStatus == fileID bStatus)++-- | Predicate to decide if two files have the same md5 checksum.+sameMd5sum :: FilePath -> FilePath -> IO Bool+sameMd5sum a b =+    do+      asum <- md5sum a+      bsum <- md5sum b+      return (asum == bsum)++{-+splitOutput :: [Output B.ByteString] -> (B.ByteString, B.ByteString, [ExitCode])+splitOutput output = (B.concat (keepStdout output), B.concat (keepStderr output), keepResult 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++checkSuperUser :: IO Bool+checkSuperUser = getEffectiveUserID >>= return . (== 0)++-- | Given a tarball, return the name of the top directory.+tarDir :: FilePath -> IO (Maybe String)+tarDir path =+    readProcessWithExitCode "tar" ["tfz", path] "" >>= \ (code, out, _) ->+    case code of+      ExitSuccess -> return . dir . lines $ out+      _ -> return Nothing+    where+      dir [] = Nothing+      dir (file : _) = case wordsBy (== '/') file of+                         [] -> Nothing+                         ("" : _) -> Nothing+                         (s : _) -> Just s++cd :: FilePath -> IO a -> IO a+cd name m = +    bracket +        (do cwd <- getCurrentDirectory+            setCurrentDirectory name+            return cwd)+        (\oldwd -> do setCurrentDirectory oldwd)+        (const m)
+ Extra/Net.hs view
@@ -0,0 +1,20 @@+module Extra.Net+    ( webServerDirectoryContents+    ) where++import qualified Data.ByteString.Lazy.Char8 as L+import		 Data.Maybe+import		 Text.Regex++-- | Parse the text returned when a directory is listed by a web+-- server.  This is currently only known to work with Apache.+-- NOTE: there is a second copy of this function in+-- debian:Debian.URI. Please update both locations if you make+-- changes.+webServerDirectoryContents :: L.ByteString -> [String]+webServerDirectoryContents text =+    catMaybes . map (second . matchRegex re) . lines . L.unpack $ text+    where+      re = mkRegex "( <A HREF|<a href)=\"([^/][^\"]*)/\""+      second (Just [_, b]) = Just b+      second _ = Nothing
+ Extra/SSH.hs view
@@ -0,0 +1,114 @@+module Extra.SSH+    ( sshVerify+    , sshExportDeprecated+    , sshCopy+    ) where++import System.Cmd+import System.Directory+import System.Posix.User+import System.Environment+import System.Exit+import System.IO+import System.Process (readProcessWithExitCode, showCommandForUser)+-- |Set up access to destination (user\@host).+sshExportDeprecated :: String -> Maybe Int -> IO (Either String ())+sshExportDeprecated dest port =+    generatePublicKey >>=+    either (return . Left) (testAccess dest port) >>=+    either (return . Left) (openAccess dest port)++-- parseURI "ssh://dsf@server:22"+-- URI {uriScheme = "ssh:", uriAuthority = Just (URIAuth {uriUserInfo = "dsf@", uriRegName = "server", uriPort = ":22"}), uriPath = "", uriQuery = "", uriFragment = ""}++-- |Make sure there is a public key for the local account+generatePublicKey :: IO (Either String FilePath)+generatePublicKey =+    do user <- getEffectiveUserID+       home <- getUserEntryForID user >>= return . homeDirectory+       let cmd = "yes '' | ssh-keygen -t rsa 2>&1 >/dev/null"+       let keypath = home ++ "/.ssh/id_rsa.pub"+       exists <- doesFileExist keypath+       case exists of+         True -> return . Right $ keypath+         False ->+             do hPutStrLn stderr $ "generatePublicKey " ++ " -> " ++ keypath+                code <- system cmd+                case code of+                  ExitFailure n ->+                      return . Left $ "Failure: " ++ show cmd ++ " -> " ++ show n+                  _ -> return . Right $ keypath++-- |See if we already have access to the destination (user\@host).+sshVerify :: String -> Maybe Int -> IO Bool+sshVerify dest port =+    do result <- system (sshTestCmd dest port)+       return $ case result of+                  ExitSuccess -> True		-- We do+                  ExitFailure _ -> False	-- We do not+    where+      sshTestCmd dest port =+          ("ssh -o 'PreferredAuthentications hostbased,publickey' " +++           (maybe "" (("-p " ++) . show) port) ++ " " ++ show dest ++ " pwd > /dev/null && exit 0")++testAccess :: String -> Maybe Int -> FilePath -> IO (Either String (Maybe FilePath))+testAccess dest port keypath =+    do flag <- sshVerify dest port+       case flag of+         True -> return . Right $ Nothing+         False -> return . Right . Just $ keypath++-- |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 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+      sshOpenRemoteCmd =+          ("chmod g-w . && " ++				-- Ssh will not work if the permissions aren't just so+           "chmod o-rwx . && " +++           "mkdir -p .ssh && " +++           "chmod 700 .ssh && " +++           "cat >> .ssh/authorized_keys2 && " ++	-- Add the key to the authorized key list+           "chmod 600 .ssh/authorized_keys2")++-- This used to be main.+{-+test =+    getDest >>=+    either (return . Left) (uncurry sshExport) >>=+    either (error . show) (const . exitWith $ ExitSuccess)++-- |Get the destination account info from the command line+getDest :: IO (Either String (String, Maybe Int))+getDest =+    getArgs >>= checkArgs+    where checkArgs [dest] =+              return $ case parseURI ("ssh://" ++ dest) of+                         Just (URI {uriAuthority = Just (URIAuth {uriUserInfo = user, uriRegName = host, uriPort = ""})}) ->+                             Right (user ++ host, Nothing)+                         Just (URI {uriAuthority = Just (URIAuth {uriUserInfo = user, uriRegName = host, uriPort = port})}) ->+                             case reads (dropWhile (== ':') port) :: [(Int, String)] of+                               [] -> Left $ "Invalid destination: " ++ dest ++ " (" ++ port ++ ")"+                               ((n, _) : _) -> Right (user ++ host, Just n)+                         _ -> Left $ "Invalid destination: " ++ dest+          checkArgs args = return . Left $ "Usage: sshexport user@host"+-}++-- |Copy the ssh configuration from $HOME to the \/root directory of a+-- changeroot.+sshCopy :: FilePath -> IO ExitCode+sshCopy root =+    do exists <- doesDirectoryExist "~/.ssh"+       home <- getEnv "HOME"+       case exists of+         True -> system ("rsync -aHxSpDt --delete " ++ home ++ "/.ssh/ " ++ root ++ "/root/.ssh && " +++                         "chown -R root.root " ++ root ++ "/root/.ssh")+         False -> system "mkdir -p /root/.ssh"
+ Extra/Terminal.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- Copyright Stefan O'Rear 2006+-- Copyright Jeremy Shaw 2007+module Extra.Terminal where++import System.Posix.Env+import Foreign.C.Types++foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong++-- get the number of rows and columns using ioctl (0, TIOCGWINSZ, &w)+-- @see also: getWidth+getWinSize :: IO (Int,Int)+getWinSize = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size+                return (fromIntegral b, fromIntegral a)++-- get the number of colums.+-- First tries getWinSize, if that returns 0, then try the COLUMNS+-- shell variable.+getWidth :: IO (Maybe Int)+getWidth =+    do (cols, _) <- getWinSize+       case cols of+         0 -> return . fmap read =<< getEnv "COLUMNS"+         _ -> return (Just cols)
+ Extra/Time.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}+module Extra.Time+    ( formatDebianDate+    , myTimeDiffToString+    ) where++import Control.Exception+import Data.List+import Data.Time+#if MIN_VERSION_time(1,5,0)+import qualified System.Locale as Old (defaultTimeLocale)+import qualified System.Time as Old (formatTimeDiff, tdPicosec)+#else+import System.Locale as Old+import System.Time as Old+#endif+import Text.Printf++{- This function is so complicated because there seems to be no way+   to get the Data.Time to format seconds without the fractional part,+   which seems not to be allowed in the RFC822 format.+   The mysterious 'take 2' pulls in just the integral part.++   Note the getCurrentTime :: IO UTCTime, so this will always be in UTC time+   with the resulting string ending in "UTC".+ -}+++formatDebianDate t =+    prefix ++ seconds ++ suffix+        where prefix = formatTime defaultTimeLocale prefixFormat t+              seconds = take 2 $ formatTime defaultTimeLocale secondsFormat t+              suffix = formatTime defaultTimeLocale suffixFormat t+              prefixFormat = "%a, %d %b %Y %H:%M:"+              secondsFormat = "%S"+              suffixFormat = " %Z"+              format = "%a, %d %b %Y %H:%M:%S %Z"+              _test = assert (format == prefixFormat ++ secondsFormat ++ suffixFormat)++_test=+    do tz <- getCurrentTimeZone+       let ut = localTimeToUTC tz testtime+       return $ teststring == formatDebianDate ut+    where testtime = LocalTime {localDay=fromGregorian testyear testmonth testday,+                                localTimeOfDay=TimeOfDay{todHour=testhour,todMin=testminute,todSec=testsecond}}+          testyear = 2006+          testmonth = 12+          testday = 19+          testhour = 12+          testminute = 19+          testsecond = 15.29+          teststring = "Tue, 19 Dec 2006 17:19:15 UTC"++myTimeDiffToString diff =+    do+      case () of+        _ | isPrefixOf "00:00:0" s -> drop 7 s ++ printf ".%03d" ms ++ " s."+        _ | isPrefixOf "00:00:" s -> drop 6 s ++ printf ".%03d" ms ++ " s."+        _ | isPrefixOf "00:" s -> drop 3 s+        _ -> s+    where+      s = Old.formatTimeDiff Old.defaultTimeLocale "%T" diff+      ms = ps2ms ps+      ps2ms ps = quot (ps + 500000000) 1000000000+      ps = Old.tdPicosec diff
+ Extra/URI.hs view
@@ -0,0 +1,91 @@+-- |Make URI an instance of Read and Ord, and add functions to+-- manipulate the uriQuery.+module Extra.URI+    ( module Network.URI+    , relURI+    , setURIPort+    , parseURIQuery+    , modifyURIQuery+    , setURIQuery+    , setURIQueryAttr+    , deleteURIQueryAttr+    ) where++import Network.URI -- (URIAuth(..), URI(..), parseURI, uriToString, escapeURIString, isUnreserved, unEscapeString)+import Data.List(intersperse, groupBy, inits)+import Data.Maybe(isJust, isNothing, catMaybes)+import Control.Arrow(second)++-- |Create a relative URI with the given query.+relURI :: FilePath -> [(String, String)] -> URI+relURI path pairs = URI {uriScheme = "",+                   uriAuthority = Nothing,+                   uriPath = path,+                   uriQuery = formatURIQuery pairs,+                   uriFragment = ""}++-- |Set the port number in the URI authority, creating it if necessary.+setURIPort port uri =+    uri {uriAuthority = Just auth'}+    where+      auth' = auth {uriPort = port}+      auth = maybe nullAuth id (uriAuthority uri)+      nullAuth = URIAuth {uriUserInfo = "", uriRegName = "", uriPort = ""}++-- |Return the pairs in a URI's query+parseURIQuery :: URI -> [(String, String)]+parseURIQuery uri =+    case uriQuery uri of+      "" -> []+      '?' : attrs ->+          map (second (unEscapeString . tail) . break (== '='))+                  (filter (/= "&") (groupBy (\ a b -> a /= '&' && b /= '&') attrs))+      x -> error $ "Invalid URI query: " ++ x++-- |Modify a URI's query by applying a function to the pairs+modifyURIQuery :: ([(String, String)] -> [(String, String)]) -> URI -> URI+modifyURIQuery f uri = uri {uriQuery = formatURIQuery (f (parseURIQuery uri))}++setURIQuery :: [(String, String)] -> URI -> URI+setURIQuery pairs = modifyURIQuery (const pairs)++setURIQueryAttr :: String -> String -> URI -> URI+setURIQueryAttr name value uri =+    modifyURIQuery f uri+    where f pairs = (name, value) : filter ((/= name) . fst) pairs++deleteURIQueryAttr :: String -> URI -> URI+deleteURIQueryAttr name uri =+    modifyURIQuery f uri+    where f pairs = filter ((/= name) . fst) pairs++-- |Turn a list of attribute value pairs into a uriQuery.+formatURIQuery :: [(String, String)] -> String+formatURIQuery [] = ""+formatURIQuery attrs = '?' : concat (intersperse "&" (map (\ (a, b) -> a ++ "=" ++ escapeURIForQueryValue b) attrs))++-- |Escape a value so it can safely appear on the RHS of an element of+-- the URI query.  The isUnreserved predicate is the set of characters+-- that can appear in a URI which don't have any special meaning.+-- Everything else gets escaped.+escapeURIForQueryValue = escapeURIString isUnreserved++-- Make URI an instance of Read.  This will throw an error if no+-- prefix up to ten characters long of the argument string looks like+-- a URI.  If such a prefix is found, it will continue trying longer+-- and longer prefixes until the result no longer looks like a URI.+instance Read URI where+    readsPrec _ s =+        let allURIs = map parseURI (inits s) in+        -- If nothing in the first ten characters looks like a URI, give up+        case catMaybes (take 10 allURIs) of+          [] -> fail "read URI: no parse"+          -- Return the last element that still looks like a URI+          _ ->+              [(longestURI, drop (length badURIs + length goodURIs - 1) s)]+              where+                longestURI = case reverse (catMaybes goodURIs) of+                               [] -> error $ "Invalid URI: " ++ s+                               (a : _) -> a+                goodURIs = takeWhile isJust moreURIs+                (badURIs, moreURIs) = span isNothing allURIs
+ Extra/URIQuery.hs view
@@ -0,0 +1,39 @@+module Extra.URIQuery+    ( modify+    , del+    , put+    , copy+    ) where++import Data.List (partition)+import Data.Maybe (listToMaybe)+import Extra.URI++-- |Modify an individual URI query attributes.+modify :: String -> (Maybe String -> Maybe String) -> URI -> URI+modify a vf uri =+    let (vs, other) = partition ((== a) . fst) (parseURIQuery uri) in+    setURIQuery (case vf (listToMaybe (map snd vs)) of+                   Just v' -> (a, v') : other+                   Nothing -> other) uri++-- |Replace a query attribute with Nothing.+del :: String -> URI -> URI+del a uri = modify a (const Nothing) uri++-- |Replace a query attribute with something.+put :: String -> String -> URI -> URI +put a v uri = modify a (const (Just v)) uri++-- |Copy an attribute from one query to another+copy :: String -> URI -> URI -> URI+copy a src dst = modify a (const (lookup a (parseURIQuery src))) dst++-- Apply f to all of the URI's pairs+{-+modifyAll :: (String -> Maybe String -> Maybe String) -> URI -> URI+modifyAll f uri =+    foldr (\ (a, _) uri -> modify a (f a) uri) uri pairs+    where+      pairs = parseURIQuery uri+-}
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks simpleUserHooks
+ Test/QUnit.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Test.QUnit+-- Copyright   :  (c) Koen Claessen, John Hughes 2001, Jeremy Shaw 2008+-- License     :  BSD-style (see the file libraries\/base\/LICENSE)+-- +-- Maintainer  :  jeremy@n-heptane.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Some glue code for running QuickCheck tests using the HUnit framework.+--+-- This module provides an instance of Test.HUnit.Testable for+-- Test.QuickCheck.Property, which makes it trivial to use QuickCheck+-- properties in the HUnit framework:+--+-- @+--   import Test.HUnit+--   import Test.HUnit.Text+--   import Test.QuickCheck+--   import Test.QUnit+--+--   runTestTT $ (\"x \/= x\" ~: property (\x -> x /= x))+-- @+--+-- The QuickCheck Property will be run using+-- Test.QuickCheck.defaultConfig.  If you need to specific an+-- alternate config, then use 'testQuickCheck' like this:+--+-- @+--   runTestTT $ (\"x \/= x\" ~: testQuickCheck myConfig (\x -> x /= x))+-- @+-----------------------------------------------------------------------------+module Test.QUnit (testQuickCheck) where++import qualified Test.HUnit as HU+import qualified Test.QuickCheck as QC++-- |an instance of Test.HUnit.Testable for Test.QuickCheck.Property+--+-- Note: I did not add an instance:+--+-- instance (QC.Testable a) => (HU.Testable a)+--+-- Because it results in undeciable instances. For example, there is+-- an instance of 'Bool' for QC.Testable and HU.Testable already.+instance HU.Testable QC.Property where+    test qc = testQuickCheck QC.stdArgs qc++-- |turns the quickcheck test into an hunit test+--+-- Use this if you want to provide a custom 'Config' instead of+-- 'defaultConfig'.+testQuickCheck :: (QC.Testable a) => +           QC.Args  -- ^ quickcheck config+        -> a        -- ^ quickcheck property+        -> HU.Test+testQuickCheck args prop =+    HU.TestCase $+    do result <- QC.quickCheckWithResult args prop+       case result of+         QC.Success{} -> return ()+         QC.GaveUp{} -> let ntest = QC.numTests result in HU.assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.")+         QC.Failure{} -> let reason = QC.reason result in HU.assertFailure reason+         QC.NoExpectedFailure{} -> HU.assertFailure $ "No Expected Failure"
+ Test/QuickCheck/Properties.hs view
@@ -0,0 +1,9 @@+module Test.QuickCheck.Properties where++import Test.QuickCheck++isIdempotentBy :: (Arbitrary a, Eq a, Show a) => (a -> a) -> Gen a -> Property+isIdempotentBy f src = forAll src $ \a -> f a == f (f a)++isIdempotent :: (Arbitrary a, Eq a, Show a) => (a -> a) -> Property+isIdempotent f = isIdempotentBy f arbitrary
+ cbits/gwinsz.c view
@@ -0,0 +1,9 @@+#include <sys/ioctl.h>++unsigned long c_get_window_size(void) {+	struct winsize w;+	if (ioctl (0, TIOCGWINSZ, &w) >= 0)+		return (w.ws_row << 16) + w.ws_col;+	else+		return 0x190050;+}
+ cbits/gwinsz.h view
@@ -0,0 +1,1 @@+unsigned long c_get_window_size(void);
+ sr-extra.cabal view
@@ -0,0 +1,67 @@+Name:           sr-extra+Version:        1.46.3+License:        BSD3+License-File:	COPYING+Author:         David Fox+Category:       Unclassified+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+Synopsis:       A grab bag of modules.+Build-Type:     Simple+Cabal-Version:  >= 1.2+flag network-uri+ Description: Get Network.URI from the network-uri package+ Default: True++Library+  Build-Depends:+    base < 5,+    bytestring,+    bzlib,+    containers,+    directory,+    filepath,+    HUnit,+    mtl,+    old-locale,+    old-time,+    pretty,+    process,+    pureMD5,+    QuickCheck >= 2 && < 3,+    random,+    regex-compat,+    time >= 1.1,+    unix,+    Unixutils >= 1.51,+    zlib+  if flag(network-uri)+    Build-Depends: network-uri >= 2.6+  else+    Build-Depends: network >= 2.4+  ghc-options:	-O2 -W+  C-Sources:	     cbits/gwinsz.c+  Include-Dirs:        cbits+  Install-Includes:    gwinsz.h+  Exposed-modules:+    Extra.Bool,+    Extra.CIO,+    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