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.cabal b/Extra.cabal new file mode 100644 --- /dev/null +++ b/Extra.cabal @@ -0,0 +1,23 @@ +Name: Extra +Version: 1.29 +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://seereason.org/ +Build-Depends: base >= 3 && < 4, unix, regex-compat, time >= 1.1, Unixutils >= 1.10 , mtl, network, HaXml, pretty, directory, bytestring, process, containers, old-time, old-locale, QuickCheck, HUnit, random, filepath +Synopsis: A grab bag of modules. +ghc-options: -O2 -W +C-Sources: cbits/gwinsz.c +Include-Dirs: cbits +Install-Includes: gwinsz.h +Exposed-modules: + Extra.Bool, Extra.Either, Extra.Exit, Extra.Files, Extra.HaXml + Extra.GPGSign,Extra.List, Extra.HughesPJ, Extra.Lock, Extra.Misc, Extra.Net, Extra.SSH, + Extra.Time, Extra.Terminal, Extra.CIO, Extra.TIO, Extra.IO, Extra.URI, Test.QUnit +Build-Type: Simple + +-- For more complex build options see: +-- http://www.haskell.org/ghc/docs/latest/html/Cabal/ 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,296 @@ +-- |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. +module Extra.CIO + ( -- * The CIO class + CIO(..) + + -- * Style constructors and transformers + , TStyle(..) + , defStyle + , withStyle + + , setVerbosity + , addVerbosity + , setPrefix + , addPrefix + , appPrefix + , setPrefixes + , addPrefixes + , appPrefixes + , hGetPrefix + + -- * Output functions + , putStr + , ePutStr + , vPutStr + , vEPutStr + + , hPutChar + , putChar + , ePutChar + , vHPutChar + , vPutChar + , vEPutChar + + , hPutStrBl + , putStrBl + , ePutStrBl + , vHPutStrBl + , vPutStrBl + , vEPutStrBl + + , hPutStrLn + , putStrLn + , ePutStrLn + , vHPutStrLn + , vPutStrLn + , vEPutStrLn + + , bol + , eBOL + , vHBOL + , vBOL + , vEBOL + ) 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 Exception 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,32 @@ +module Extra.Either where + +lefts :: [Either a b] -> [a] +lefts xs = fst (partitionEithers xs) + +rights :: [Either a b] -> [b] +rights xs = snd (partitionEithers xs) + +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 + +-- |Return a pair of the lefts and the rights +partitionEithers :: [Either a b] -> ([a], [b]) +partitionEithers xs = + part ([], []) (reverse xs) + where + part (ls, rs) [] = (ls, rs) + part (ls, rs) (Left l : more) = part (l : ls, rs) more + part (ls, rs) (Right r : more) = part (ls, r : rs) more + +-- Deprecated +rightOnly = rights +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,250 @@ +-- |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 Control.Exception hiding (catch) +import Control.Monad +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List +import Data.Maybe +import Extra.Misc +import System.Unix.Directory +import System.Unix.Process +import System.Directory +import System.IO +import System.IO.Error hiding (try, catch) +import System.Posix.Files +import System.Posix.Unistd + +-- | 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 -> 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 -> 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 = + do let commands = ["gzip < '" ++ path ++ "' > '" ++ path ++ ".gz'", + "bzip2 < '" ++ path ++ "' > '" ++ path ++ ".bz2'"] + forceRemoveLink (path ++ ".gz") + forceRemoveLink (path ++ ".bz2") + results <- mapM (\ cmd -> lazyCommand cmd B.empty) commands + case filter (/= ExitSuccess) (concat (map exitCodeOnly results)) of + [] -> return $ Right () + _ -> return (Left ["Failure writing and zipping " ++ path ++ ": " ++ + concat (map writeMessage (zip commands results))]) + where + writeMessage (command, output) = + case exitCodeOnly output of + (ExitFailure n : _) -> + command ++ " -> " ++ show n ++ ":\n " ++ B.unpack (stderrOnly output) + _ -> "" + +-- |like removeLink, but does not fail if link did not exist +forceRemoveLink :: FilePath -> IO () +forceRemoveLink fp = removeLink fp `Prelude.catch` (\e -> unless (isDoesNotExistError e) (ioError e)) + +-- | 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 -> 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 -> 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 (IOException e)) | 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 (\ _ -> 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 `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 (const (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/HaXml.hs b/Extra/HaXml.hs new file mode 100644 --- /dev/null +++ b/Extra/HaXml.hs @@ -0,0 +1,33 @@ +module Extra.HaXml where + +import Text.PrettyPrint.HughesPJ +import Text.XML.HaXml +import Text.XML.HaXml.Pretty + +-- ** XML Helper functions (move) +-- | Render XML as a string. +-- MOVE: ?? +showXML :: String -> CFilter -> Doc +showXML styleSheet = document . mkDocument styleSheet . cfilterToElem + +-- MOVE: ?? +mkTxt :: String -> CFilter +mkTxt = cdata + +-- MOVE: ?? +-- cliff says this is broken with regards to cdata +cfilterToElem :: CFilter -> Element +cfilterToElem f = case f (CString False "") of + [CElem e] -> xmlEscape stdXmlEscaper e + [] -> error "RSS produced no output" + _ -> error "RSS produced more than one output" + +-- +-- MOVE: ?? +mkDocument :: String -> Element -> Document +mkDocument styleSheet elem = + let xmlDecl = XMLDecl "1.0" (Just (EncodingDecl "utf-8")) (Just True) + prolog = Prolog (Just xmlDecl) [] Nothing [PI ("xml-stylesheet","type=\"text/xsl\" href=\""++styleSheet++"\"")] + symTable = [] + in + Document prolog [] elem [] 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 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/List.hs b/Extra/List.hs new file mode 100644 --- /dev/null +++ b/Extra/List.hs @@ -0,0 +1,89 @@ +module Extra.List + ( consperse + , surround + , changePrefix + , dropPrefix + , cartesianProduct + , wordsBy + , empty + , sortByMapped + , sortByMappedM + , partitionM + , listIntersection + , isSublistOf + ) where + +import Control.Monad +import Data.List + +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)) diff --git a/Extra/Lock.hs b/Extra/Lock.hs new file mode 100644 --- /dev/null +++ b/Extra/Lock.hs @@ -0,0 +1,62 @@ +module Extra.Lock + ( withLock + , awaitLock + ) where + +import Control.Exception +import Control.Monad.RWS +import System.Directory +import System.IO +import System.IO.Error hiding (try) +import System.Posix.Files +import System.Posix.IO +import System.Posix.Unistd + +withLock :: (MonadIO m) => FilePath -> m a -> m (Either Exception a) +withLock path task = + liftIO checkLock >>= liftIO . takeLock >>= doTask task >>= liftIO . dropLock + where + -- Return True if file is locked by a running process, false otherwise + checkLock :: IO (Either Exception ()) + checkLock = try (readFile path) >>= either (return . checkReadError) (processRunning . lines) + checkReadError (IOException e) | isDoesNotExistError e = (Right ()) + checkReadError e = Left e + processRunning (pid : _) = + do exists <- doesDirectoryExist ("/proc/" ++ pid) + case exists of + True -> return (Left (lockedBy pid)) + False -> breakLock + processRunning [] = breakLock + lockedBy pid = IOException (mkIOError alreadyInUseErrorType ("Locked by " ++ pid) Nothing (Just path)) + breakLock = do try (removeFile path) >>= return . either checkBreakError (const (Right ())) + checkBreakError (IOException e) | isDoesNotExistError e = (Right ()) + checkBreakError e = Left e + takeLock :: Either Exception () -> IO (Either Exception ()) + takeLock (Right ()) = + -- Try to create the lock file in exclusive mode, if this + -- succeeds then we have a lock. Then write the process ID + -- into the lock and close. + try (openFd path ReadWrite (Just 0o600) (defaultFileFlags {exclusive = True, trunc = True})) >>= + either (return . Left) + (\ fd -> do h <- fdToHandle fd + processID >>= hPutStrLn h >> hClose h >> return (Right ())) + takeLock (Left e) = return (Left e) + doTask task (Right ()) = task >>= return . Right + doTask _ (Left e) = return (Left e) + dropLock (Right a) = try (removeFile path) >>= return . checkDrop a + dropLock (Left e) = return (Left e) + checkDrop a (Right ()) = Right a + checkDrop a (Left (IOException e)) | isDoesNotExistError e = Right a + checkDrop _ (Left e) = Left 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 = return (Left (ErrorCall "Too many failures")) + attempt n = withLock path task >>= either (\ _ -> liftIO (usleep usecs) >> attempt (n + 1)) (return . Right) + +processID :: IO String +processID = readSymbolicLink "/proc/self" diff --git a/Extra/Misc.hs b/Extra/Misc.hs new file mode 100644 --- /dev/null +++ b/Extra/Misc.hs @@ -0,0 +1,292 @@ +module Extra.Misc + (-- * List functions + -- * String functions + columns + , justify + -- * Tuple functions + , mapSnd + -- * FilePath functions + , parentPath + , canon + -- * Map and Set functions + , listMap + , listDiff + -- * Either functions + -- * System.IO functions + --ePut, + --ePutList, + -- * System.Posix + , checkSuperUser + -- removeRecursiveSafely, + , md5sum + , sameInode + , sameMd5sum + , tarDir + -- * Processes + , Extra.Misc.processOutput + , processOutput2 + , splitOutput + -- ByteString + , cd + -- Debugging + , read' + ) where + +import Control.Exception +import Control.Monad +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import Extra.List +import System.FilePath +import System.Unix.Process +import System.Directory +import System.Exit +import System.IO +import System.Posix.Files +import System.Posix.User (getEffectiveUserID) +import Text.Regex + +mapSnd :: (b -> c) -> (a, b) -> (a, c) +mapSnd f (a, b) = (a, f b) + +-- Control file stuff + +{- +mergeControls :: [Control] -> Control +mergeControls (Control p1 : Control p2 : etc) = mergeControls (Control (p1 ++ p2) : etc) +mergeControls [Control p1] = Control p1 +mergeControls [] = Control [] + +fieldValue :: String -> Paragraph -> Maybe String +fieldValue fieldName paragraph = + maybe Nothing value (lookupP fieldName paragraph) + where value (Field (_, value)) = (Just . stripWS) value + +hasField :: String -> String -> Paragraph -> Bool +hasField field value paragraph = + maybe False (== value) (fieldValue field paragraph) +-} + +-- |Pad strings so the columns line up. The argument and return value +-- elements are the rows of a table. Do not pad the rightmost column. +columns :: [[String]] -> [[String]] +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) + +{- +baseName :: FilePath -> String +baseName path = snd (splitFileName path) +-} + +-- |Turn a list of (k, a) pairs into a map from k -> [a]. The order of the elements in +-- the a list is preserved. +listMap :: (Ord k) => [(k, a)] -> Map.Map k [a] +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 [] = [] + +-- | Run md5sum on a file and return the resulting checksum as text. +md5sum :: FilePath -> IO (Either String String) +md5sum path = + do output <- lazyCommand cmd B.empty + let result = + case exitCodeOnly output of + [ExitFailure n] -> Left ("Error " ++ show n ++ " running '" ++ cmd ++ "'") + [ExitSuccess] -> + case listToMaybe . words . B.unpack . stdoutOnly $ output of + Nothing -> Left $ "Error in output of '" ++ cmd ++ "'" + Just checksum -> Right checksum + _ -> Left "Internal error 12" + return result + where + cmd = "md5sum " ++ path + +-- | 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) + +-- | Backwards compatibility functions. +processOutput :: String -> IO (Either Int String) +processOutput command = + do + output <- lazyCommand command B.empty + case exitCodeOnly output of + [ExitSuccess] -> return . Right . B.unpack . stdoutOnly $ output + [ExitFailure n] -> return . Left $ n + _ -> error "My.processOutput: Internal error 13" + +processOutput2 :: String -> IO (String, ExitCode) +processOutput2 command = + do + output <- lazyCommand command B.empty + case exitCodeOnly output of + [code] -> return ((B.unpack . stdoutOnly $ output), code) + _ -> error "My.processOutput2: Internal error 14" + +splitOutput :: [Output] -> (B.ByteString, B.ByteString, Maybe ExitCode) +splitOutput output = (stdoutOnly output, stderrOnly output, listToMaybe (exitCodeOnly output)) + +-- |A version of read with a more helpful error message. +read' s = + case reads s of + [] -> error $ "read - no parse: " ++ show s + ((x, s) : _) -> x + +{- +type DryRunFn = IO () -> (Bool, String) -> IO () + +(-?-) :: DryRunFn +-- ^ If this is a dry run (dryRun params is True) do *not* evaluate f, +-- but instead print a message. +(-?-) f (dryRun, "") = if dryRun then return () else f +(-?-) f (dryRun, msg) = + do + hPutStrLn stderr msg + if dryRun then return () else f +infixr 9 -?- +-} + +{- +(+/+) :: FilePath -> FilePath -> FilePath +(+/+) path1 "" = path1 +(+/+) "" path2 = path2 +(+/+) path1 path2 = + case (last path1, head path2) of + ('/', '/') -> path1 +/+ (tail path2) + (_, '/') -> path1 ++ path2 + ('/', _) -> path1 ++ path2 + (_, _) -> path1 ++ "/" ++ path2 +-} + +{- +-------------- From MissingH -------------- + +-- | Split the path into directory and file name +-- +-- Examples: +-- +-- \[Posix\] +-- +-- > splitFileName "/" == ("/", ".") +-- > splitFileName "/foo/bar.ext" == ("/foo", "bar.ext") +-- > splitFileName "bar.ext" == (".", "bar.ext") +-- > splitFileName "/foo/." == ("/foo", ".") +-- > splitFileName "/foo/.." == ("/foo", "..") +-- +-- \[Windows\] +-- +-- > splitFileName "\\" == ("\\", "") +-- > splitFileName "c:\\foo\\bar.ext" == ("c:\\foo", "bar.ext") +-- > splitFileName "bar.ext" == (".", "bar.ext") +-- > splitFileName "c:\\foo\\." == ("c:\\foo", ".") +-- > splitFileName "c:\\foo\\.." == ("c:\\foo", "..") +-- +-- The first case in the Windows examples returns an empty file name. +-- This is a special case because the \"\\\\\" path doesn\'t refer to +-- an object (file or directory) which resides within a directory. + +splitFileName :: FilePath -> (String, String) +splitFileName p = (reverse path1, reverse fname1) + where + (fname,path) = break isPathSeparator (reverse p) + path1 = case path of + "" -> "." + _ -> case dropWhile isPathSeparator path of + "" -> [pathSeparator] + p -> p + fname1 = case fname of + "" -> "." + _ -> fname + +-- | Checks whether the character is a valid path separator for the host +-- platform. The valid character is a 'pathSeparator' but since the Windows +-- operating system also accepts a slash (\"\/\") since DOS 2, the function +-- checks for it on this platform, too. +isPathSeparator :: Char -> Bool +isPathSeparator ch = + ch == '/' + +-- | Provides a platform-specific character used to separate directory levels in +-- a path string that reflects a hierarchical file system organization. The +-- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash +-- (@\"\\\"@) on the Windows operating system. +pathSeparator :: Char +pathSeparator = '/' +-} + + +checkSuperUser :: IO Bool +checkSuperUser = getEffectiveUserID >>= return . (== 0) + +-- | Given a tarball, return the name of the top directory. +tarDir :: FilePath -> IO (Maybe String) +tarDir path = + Extra.Misc.processOutput cmd >>= + return . either (const Nothing) (dir . lines) + where + cmd = "tar tfz '" ++ path ++ "'" + 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,17 @@ +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. +webServerDirectoryContents :: L.ByteString -> [String] +webServerDirectoryContents text = + catMaybes . map (second . matchRegex re) . lines . L.unpack $ text + where + re = mkRegex "( Maybe Int -> IO (Either String ()) +sshExport 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 + result <- lazyCommand cmd B.empty + case exitCodeOnly result of + (ExitFailure n : _) -> + return . Left $ "Failure: " ++ show cmd ++ " -> " ++ show n ++ + "\n\noutput: " ++ B.unpack (outputOnly result) + _ -> 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 +openAccess :: String -> Maybe Int -> Maybe FilePath -> IO (Either String ()) +openAccess _ _ Nothing = return . Right $ () +openAccess dest port (Just keypath) = + do hPutStrLn stderr $ "openAccess " ++ show dest ++ " " ++ show port ++ " " ++ show keypath + let cmd = sshOpenCmd dest port keypath + result <- lazyCommand cmd B.empty + case exitCodeOnly result of + (ExitFailure n : _) -> return . Left $ "Failure: " ++ show cmd ++ " -> " ++ show n ++ + "\n\noutput: " ++ B.unpack (outputOnly result) + _ -> return . Right $ () + where + sshOpenCmd dest port keypath = + "cat " ++ keypath ++ " | " ++ "ssh " ++ (maybe "" ((++ "-p ") . show) port) ++ " " ++ show dest ++ " '" ++ sshOpenRemoteCmd ++ "'" + sshOpenRemoteCmd = + ("chmod g-w . && " ++ -- Ssh will not work if the permissions aren't just so + "chmod o-rwx . && " ++ + "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/TIO.hs b/Extra/TIO.hs new file mode 100644 --- /dev/null +++ b/Extra/TIO.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TypeSynonymInstances #-} +module Extra.TIO + ( module Extra.CIO + -- * The TIO monad + , TIO + , runTIO + , tryTIO + --, liftTIO + ) where + +import Extra.CIO +import Prelude hiding (putStr, putChar, putStrLn) +import Control.Exception +import Control.Monad.RWS +import Control.Monad.Reader +import Control.Monad.Trans +import qualified System.IO as IO + +-- | This represents the state of the IO system. The 'bol' flag keeps +-- track of whether we are at the beginning of line on the console. +-- This is computed in terms of what we have sent to the console, but +-- it should be remembered that the order that stdout and stderr are +-- sent to the console may not be the same as the order in which they +-- show up there. However, in practice this seems to work as one +-- would hope. +data TState + = TState { cursor :: Position -- ^ Is the console at beginning of line? + } deriving Show + +data Position + = BOL -- Beginning of line + | MOL -- Middle of line + | EOL -- End of line + deriving (Show, Eq) + +type TIOT = RWST TStyle () TState +type TIO = TIOT IO + +-- |Perform a TIO monad task in the IO monad. +runTIO :: TStyle -> TIO a -> IO a +runTIO style action = (runRWST action) style initState >>= \ (a, _, _) -> return a + +-- |Catch exceptions in a TIO action. +tryTIO :: TIO a -> TIO (Either Exception a) +tryTIO task = + do state <- get + liftTIO (try' state) task + where + try' state task = + do result <- try task + case result of + Left e -> return (Left e, state, ()) + Right (a, s, _) -> return (Right a, s, ()) + +liftTIO :: (IO (a, TState, ()) -> IO (b, TState, ())) -> TIO a -> TIO b +liftTIO f = mapRWST f + +-- |The initial output state - at the beginning of the line, no special handle +-- state information, no repositories in the repository map. +initState :: TState +initState = TState {cursor = BOL} + +-- |The TIO instance of CIO adds some features to the normal console +-- output. By tracking the cursor position it is able to insert a +-- prefix to each line, and to implement a "beginning of line" (BOL) +-- function which only adds a newline when the cursor is not already +-- at BOL. It also allows verbosity controlled output, where a verbosity +-- level is stored in the monad state and output requests are given a +-- verbosity which must be greater or equal to the monad's verbosity +-- level for the output to appear. +instance CIO TIO where + hPutStr h s = + do style <- ask + state <- get + case (cursor state, break (== '\n') s) of + (_, ("", "")) -> return () + (BOL, ("", (_ : b))) -> prefix style >> newline >> hPutStr h b + (MOL, ("", (_ : b))) -> newline >> put (state {cursor = BOL}) >> hPutStr h b + (EOL, ("", (_ : b))) -> newline >> put (state {cursor = BOL}) >> hPutStr h b + (BOL, (a, b)) -> prefix style >> write a >> put (state {cursor = MOL}) >> hPutStr h b + (MOL, (a, b)) -> write a >> hPutStr h b + (EOL, (a, b)) -> newline >> prefix style >> write a >> put (state {cursor = MOL}) >> hPutStr h b + where + prefix style = liftIO (IO.hPutStr IO.stderr (hGetPrefix h style)) -- >> io (IO.hFlush h) + newline = liftIO (IO.hPutStr IO.stderr "\n") -- >> io (IO.hFlush IO.stderr) + write s = liftIO (IO.hPutStr IO.stderr s) -- >> io (IO.hFlush h) + -- | A "virtual" newline, this puts us into the EOL state. From + -- this state, a newline will be inserted before the next output, + -- unless that output itself begins with a newline. + hBOL h = + do state <- get + put (state {cursor = if cursor state == BOL then BOL else EOL}) + -- |Return the "effective verbosity", or perhaps the effective + -- quietness. If this value is zero or less the output will be + -- complete. By convention, if it is one, the output will be brief. + -- If it is a two or more no output is generated. + ev v = + do style <- ask + return (verbosity style - v) + -- |Modify the current style for this action + setStyle styleFn = local styleFn + -- |Implementation of try for the TIO monad + tryCIO = tryTIO + +_test :: IO () +_test = + runTIO (defStyle {prefix = "% "}) + (putStr "hello\nworld\n" >> + bol >> -- No extra newline + putStr "(some text)" >> + putStr "(some more on same line)" >> -- This should be right after abc + bol >> + putStr "(newline)\n\n(after a blank line)" >> -- This should show up on a new line + bol) -- Newline before exit diff --git a/Extra/Terminal.hs b/Extra/Terminal.hs new file mode 100644 --- /dev/null +++ b/Extra/Terminal.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- Copyright Stefan O'Rear 2006 +-- Copyright Jeremy Shaw 2007 +module Extra.Terminal where + +import Control.Monad +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,59 @@ +module Extra.Time + ( formatDebianDate + , myTimeDiffToString + ) where + +import Control.Exception +import Data.List +import Data.Time +import System.Locale +import System.Time +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 = formatTimeDiff defaultTimeLocale "%T" diff + ms = ps2ms ps + ps2ms ps = quot (ps + 500000000) 1000000000 + ps = 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,94 @@ +-- |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 (not . 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 + +instance Ord URI where + compare a b = compare (uriToString id a "") (uriToString id b "") 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 defaultUserHooks diff --git a/Test/QUnit.hs b/Test/QUnit.hs new file mode 100644 --- /dev/null +++ b/Test/QUnit.hs @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- | +-- 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 System.Random +import Test.HUnit as HU +import 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 Property where + test qc = testQuickCheck defaultConfig 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) => + Config -- ^ quickcheck config + -> a -- ^ quickcheck property + -> Test +testQuickCheck config property = + TestCase $ do rnd <- newStdGen + tests config (evaluate property) rnd 0 0 [] + +-- |modified version of the tests function from Test.QuickCheck +tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () +tests config gen rnd0 ntest nfail stamps + | ntest == configMaxTest config = return () + | nfail == configMaxFail config = assertFailure $ "Arguments exhausted after " ++ show ntest ++ " tests." + | otherwise = + do putStr (configEvery config ntest (arguments result)) + case ok result of + Nothing -> + tests config gen rnd1 ntest (nfail+1) stamps + Just True -> + tests config gen rnd1 (ntest+1) nfail (stamp result:stamps) + Just False -> + assertFailure $ ( "Falsifiable, after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) + where + result = generate (configSize config ntest) rnd2 gen + (rnd1,rnd2) = split rnd0 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);