diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,36 @@ +This package was debianized by David Fox + 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. diff --git a/Extra/Bool.hs b/Extra/Bool.hs new file mode 100644 --- /dev/null +++ b/Extra/Bool.hs @@ -0,0 +1,7 @@ +module Extra.Bool + ( cond + ) where + +cond :: a -> a -> Bool -> a +cond t _ True = t +cond _ f False = f diff --git a/Extra/CIO.hs b/Extra/CIO.hs new file mode 100644 --- /dev/null +++ b/Extra/CIO.hs @@ -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" diff --git a/Extra/Either.hs b/Extra/Either.hs new file mode 100644 --- /dev/null +++ b/Extra/Either.hs @@ -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 diff --git a/Extra/Exit.hs b/Extra/Exit.hs new file mode 100644 --- /dev/null +++ b/Extra/Exit.hs @@ -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 diff --git a/Extra/Files.hs b/Extra/Files.hs new file mode 100644 --- /dev/null +++ b/Extra/Files.hs @@ -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) +-} diff --git a/Extra/GPGSign.hs b/Extra/GPGSign.hs new file mode 100644 --- /dev/null +++ b/Extra/GPGSign.hs @@ -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 diff --git a/Extra/HughesPJ.hs b/Extra/HughesPJ.hs new file mode 100644 --- /dev/null +++ b/Extra/HughesPJ.hs @@ -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 diff --git a/Extra/IO.hs b/Extra/IO.hs new file mode 100644 --- /dev/null +++ b/Extra/IO.hs @@ -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 diff --git a/Extra/IOThread.hs b/Extra/IOThread.hs new file mode 100644 --- /dev/null +++ b/Extra/IOThread.hs @@ -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 + diff --git a/Extra/List.hs b/Extra/List.hs new file mode 100644 --- /dev/null +++ b/Extra/List.hs @@ -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) +-} diff --git a/Extra/Lock.hs b/Extra/Lock.hs new file mode 100644 --- /dev/null +++ b/Extra/Lock.hs @@ -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) diff --git a/Extra/Misc.hs b/Extra/Misc.hs new file mode 100644 --- /dev/null +++ b/Extra/Misc.hs @@ -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) diff --git a/Extra/Net.hs b/Extra/Net.hs new file mode 100644 --- /dev/null +++ b/Extra/Net.hs @@ -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 "( 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" diff --git a/Extra/Terminal.hs b/Extra/Terminal.hs new file mode 100644 --- /dev/null +++ b/Extra/Terminal.hs @@ -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) diff --git a/Extra/Time.hs b/Extra/Time.hs new file mode 100644 --- /dev/null +++ b/Extra/Time.hs @@ -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 diff --git a/Extra/URI.hs b/Extra/URI.hs new file mode 100644 --- /dev/null +++ b/Extra/URI.hs @@ -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 diff --git a/Extra/URIQuery.hs b/Extra/URIQuery.hs new file mode 100644 --- /dev/null +++ b/Extra/URIQuery.hs @@ -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 +-} diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks simpleUserHooks diff --git a/Test/QUnit.hs b/Test/QUnit.hs new file mode 100644 --- /dev/null +++ b/Test/QUnit.hs @@ -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" diff --git a/Test/QuickCheck/Properties.hs b/Test/QuickCheck/Properties.hs new file mode 100644 --- /dev/null +++ b/Test/QuickCheck/Properties.hs @@ -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 diff --git a/cbits/gwinsz.c b/cbits/gwinsz.c new file mode 100644 --- /dev/null +++ b/cbits/gwinsz.c @@ -0,0 +1,9 @@ +#include + +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; +} diff --git a/cbits/gwinsz.h b/cbits/gwinsz.h new file mode 100644 --- /dev/null +++ b/cbits/gwinsz.h @@ -0,0 +1,1 @@ +unsigned long c_get_window_size(void); diff --git a/sr-extra.cabal b/sr-extra.cabal new file mode 100644 --- /dev/null +++ b/sr-extra.cabal @@ -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 +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