packages feed

Extra (empty) → 1.29

raw patch · 24 files changed

+1765/−0 lines, 24 filesdep +HUnitdep +HaXmldep +QuickChecksetup-changed

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

Files

+ COPYING view
@@ -0,0 +1,36 @@+This package was debianized by David Fox+<ddssff@gmail.com> on September 18, 2007.++Copyright (c) 2007, David Fox+Copyright (c) Jeremy Shaw 2007+Copyright (c) Stefan O'Rear 2006++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The names of contributors may not be used to endorse or promote+      products derived from this software without specific prior+      written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Extra.cabal view
@@ -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 <david@seereason.com>+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/
+ Extra/Bool.hs view
@@ -0,0 +1,7 @@+module Extra.Bool+    ( cond+    ) where++cond :: a -> a -> Bool -> a+cond t _ True = t+cond _ f False = f
+ Extra/CIO.hs view
@@ -0,0 +1,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"
+ Extra/Either.hs view
@@ -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
+ Extra/Exit.hs view
@@ -0,0 +1,15 @@+module Extra.Exit where++import Extra.HughesPJ+import System.Environment+import System.Exit+import System.IO+import Text.PrettyPrint.HughesPJ++-- |exitFailure with nicely formatted help text on stderr+exitWithHelp :: (String -> Doc) -- ^ generate help text, the argument is the result of getProgName+             -> IO a -- ^ no value is returned, this function always calls exitFailure+exitWithHelp helpText =+    do progName <- getProgName+       hPutStrLn stderr =<< renderWidth (helpText progName)+       exitFailure
+ Extra/Files.hs view
@@ -0,0 +1,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)
+ Extra/GPGSign.hs view
@@ -0,0 +1,72 @@+module Extra.GPGSign+    ( sign+    , PGPKey(..)+    , pgpSignFiles+    , pgpSignFile+    , cd+    ) where++import System.Process+import System.IO+import System.Exit+import Extra.Misc++_test :: PGPKey'' -> [FilePath] -> IO [FilePath]+_test key files =+    mapM (sign key) files++type PGPKey'' = String+++sign :: PGPKey'' -> FilePath -> IO FilePath+sign keyname path =+    do (_, _,err,pid) <- runInteractiveProcess cmd args workingDir env+       status <- waitForProcess pid+       case status of+         ExitSuccess -> return outputPath+         ExitFailure _ ->+             do gpgerr <- hGetContents err+                hPutStr stderr gpgerr+                exitWith status+       where+         cmd = "/usr/bin/gpg"+         args = [ "--batch"+                , "--yes"+                , "--default-key", keyname+                , "-o", outputPath+                , "--clearsign"+                , path+                ]+         outputPath = path ++ ".gpg"+         workingDir = Nothing -- Just (dirName path)+         env = Nothing++data PGPKey = Key String | Default deriving Show++pgpSignFiles :: FilePath -> PGPKey -> [FilePath] -> IO [Bool]+pgpSignFiles root key files = cd root $ mapM (pgpSignFile key) files++pgpSignFile :: PGPKey -> FilePath -> IO Bool+pgpSignFile keyname path =+    do (_, _,err,pid) <- runInteractiveProcess cmd args workingDir env+       status <- waitForProcess pid+       case status of+         ExitSuccess -> return True+         ExitFailure _code ->+             do gpgerr <- hGetContents err+                hPutStr stderr gpgerr+                return False+       where+         cmd = "/usr/bin/gpg"+         args = defaultKey +++             [ "--batch"+             , "--yes"+             , "-o", outputPath+             , "--armor"+             , "--detach-sign"+             , path+             ]+         defaultKey = case keyname of Key name -> ["--default-key", name]; Default -> []+         outputPath = path ++ ".gpg"+         workingDir = Nothing -- Just (dirName path)+         env = Nothing
+ Extra/HaXml.hs view
@@ -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"++-- <?xml-stylesheet type="text/xsl" href="cdcatalog.xsl"?>+-- 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 []
+ Extra/HughesPJ.hs view
@@ -0,0 +1,11 @@+module Extra.HughesPJ where++import Data.Maybe+import Extra.Terminal+import Text.PrettyPrint.HughesPJ++-- |render a Doc using the current terminal width+renderWidth :: Doc -> IO String       +renderWidth doc =+    do columns <- return . fromMaybe 80 =<< getWidth+       return $ renderStyle (Style PageMode columns 1.0) doc
+ Extra/IO.hs view
@@ -0,0 +1,20 @@+module Extra.IO where++import Extra.CIO+import qualified System.IO as IO+import Control.Exception (try)++-- |Use this module to call functions in the CIO module from the+-- regular IO monad.  This instance ignores all style and state+-- information.  The verbosity controlled output functions will ignore+-- any calls when v is greater than zero.  This allows you to call the+-- functions in the haskell-debian package from the regular IO monad.+-- +-- This is in a separate module from CIO so you don't accidentally do+-- a liftIO of some other CIO operation and get this instance.+instance CIO IO where+    hPutStr h s = IO.hPutStr h s+    hBOL h = IO.hPutStr h "\n"+    ev v = return (- v)+    setStyle _ f = f+    tryCIO = try
+ Extra/List.hs view
@@ -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))
+ Extra/Lock.hs view
@@ -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"
+ Extra/Misc.hs view
@@ -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)
+ Extra/Net.hs view
@@ -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 "( <A HREF|<a href)=\"([^/][^\"]*)/\""+      second (Just [_, b]) = Just b+      second _ = Nothing
+ Extra/SSH.hs view
@@ -0,0 +1,119 @@+module Extra.SSH+    ( sshVerify+    , sshExport+    , sshCopy+    ) where++import Control.Monad(unless)+import System.Cmd+import System.Directory+import System.Posix.User+import System.Posix.Files+import System.Environment+import System.Exit+import System.IO+import Network.URI+import qualified Data.ByteString.Lazy.Char8 as B+import System.Unix.Process++-- |Set up access to destination (user\@host).+sshExport :: String -> 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"
+ Extra/TIO.hs view
@@ -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
+ Extra/Terminal.hs view
@@ -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)
+ Extra/Time.hs view
@@ -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
+ Extra/URI.hs view
@@ -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 "")
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks defaultUserHooks
+ Test/QUnit.hs view
@@ -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
+ cbits/gwinsz.c view
@@ -0,0 +1,9 @@+#include <sys/ioctl.h>++unsigned long c_get_window_size(void) {+	struct winsize w;+	if (ioctl (0, TIOCGWINSZ, &w) >= 0)+		return (w.ws_row << 16) + w.ws_col;+	else+		return 0x190050;+}
+ cbits/gwinsz.h view
@@ -0,0 +1,1 @@+unsigned long c_get_window_size(void);