diff --git a/Debian/Apt/Index.hs b/Debian/Apt/Index.hs --- a/Debian/Apt/Index.hs +++ b/Debian/Apt/Index.hs @@ -39,6 +39,7 @@ import System.FilePath (takeBaseName) --import qualified System.Unix.Misc as Misc import Text.ParserCombinators.Parsec.Error +import Text.PrettyPrint.Class (pretty) -- |Package indexes on the server are uncompressed or compressed with @@ -121,7 +122,7 @@ where baseURI = sourceUri debSource (release, sections) = - either (error $ "indexURIs: support not implemented for exact path: " ++ show debSource) id (sourceDist debSource) + either (error $ "indexURIs: support not implemented for exact path: " ++ show (pretty debSource)) id (sourceDist debSource) -- |return a tuple for the section -- - the URI to the uncompressed index file diff --git a/Debian/Control/String.hs b/Debian/Control/String.hs --- a/Debian/Control/String.hs +++ b/Debian/Control/String.hs @@ -29,17 +29,18 @@ import Text.ParserCombinators.Parsec import System.IO import Debian.Control.Common - --- |This may have bad performance issues -instance Show (Control' String) where - show (Control paragraph) = intercalate "\n" (map show paragraph) +import Text.PrettyPrint.Class (Pretty(pretty)) +import Text.PrettyPrint.HughesPJ (text, vcat, ($$)) -instance Show (Paragraph' String) where - show (Paragraph fields) = unlines (map show fields) +-- |This may have bad performance issues (why?) +instance Pretty (Control' String) where + pretty (Control paragraphs) = vcat (map (\ p -> pretty p $$ text "") paragraphs) +instance Pretty (Paragraph' String) where + pretty (Paragraph fields) = vcat (map pretty fields) -instance Show (Field' String) where - show (Field (name,value)) = name ++":"++ value - show (Comment text) = text +instance Pretty (Field' String) where + pretty (Field (name,value)) = text $ name ++":"++ value + pretty (Comment s) = text s type Field = Field' String type Control = Control' String diff --git a/Debian/Deb.hs b/Debian/Deb.hs --- a/Debian/Deb.hs +++ b/Debian/Deb.hs @@ -6,18 +6,19 @@ import Data.ByteString.Lazy (empty) import Debian.Control.Common import System.Exit (ExitCode(..)) +import System.Process (CmdSpec(RawCommand)) +import System.Process.Read (readProcessWithExitCode) import System.Unix.Directory (withTemporaryDirectory, withWorkingDirectory) import System.Unix.FilePath (realpath) -import System.Unix.Process (readProcessWithExitCode) fields :: (ControlFunctions a) => FilePath -> IO (Control' a) fields debFP = withTemporaryDirectory ("fields.XXXXXX") $ \tmpdir -> do debFP <- realpath debFP withWorkingDirectory tmpdir $ - do (res, out, err) <- readProcessWithExitCode "ar" ["x",debFP,"control.tar.gz"] id empty + do (res, out, err) <- readProcessWithExitCode "ar" ["x",debFP,"control.tar.gz"] empty when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ show out ++ "\n" ++ show err ++ "\n" ++ show res) - (res, out, err) <- readProcessWithExitCode "tar" ["xzf", "control.tar.gz", "./control"] id empty + (res, out, err) <- readProcessWithExitCode "tar" ["xzf", "control.tar.gz", "./control"] empty when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ show out ++ "\n" ++ show err ++ "\n" ++ show res) c <- parseControlFromFile "control" case c of diff --git a/Debian/Sources.hs b/Debian/Sources.hs --- a/Debian/Sources.hs +++ b/Debian/Sources.hs @@ -4,6 +4,8 @@ import Data.List (intercalate) import Debian.Release import Debian.URI +import Text.PrettyPrint.HughesPJ (text) +import Text.PrettyPrint.Class (Pretty(pretty)) data SourceType = Deb | DebSrc @@ -16,13 +18,13 @@ , sourceDist :: Either String (ReleaseName, [Section]) } deriving (Eq, Ord) -instance Show SourceType where - show Deb = "deb" - show DebSrc = "deb-src" +instance Pretty SourceType where + pretty Deb = text "deb" + pretty DebSrc = text "deb-src" -instance Show DebSource where - show (DebSource thetype theuri thedist) = - (show thetype) ++ " "++ uriToString id theuri " " ++ +instance Pretty DebSource where + pretty (DebSource thetype theuri thedist) = text $ + (show (pretty thetype)) ++ " "++ uriToString id theuri " " ++ (case thedist of Left exactPath -> escape exactPath Right (dist, sections) -> diff --git a/Debian/URI.hs b/Debian/URI.hs --- a/Debian/URI.hs +++ b/Debian/URI.hs @@ -10,13 +10,12 @@ import Control.Exception (SomeException, try) import qualified Data.ByteString.Lazy.Char8 as L +import Data.ByteString.UTF8 as B import qualified Data.ByteString as B import Data.Maybe (catMaybes) import Network.URI import System.Directory (getDirectoryContents) -import System.Exit (ExitCode(..)) -import System.Process (showCommandForUser) -import System.Unix.Process (readProcessWithExitCode) +import System.Process.Read (readProcessWithExitCode) -- import System.Unix.LazyProcess (collectStdout) -- import System.Unix.Progress (lazyCommandF) import Text.Regex (mkRegex, matchRegex) @@ -28,22 +27,7 @@ type URIString = String fileFromURI :: URI -> IO (Either SomeException L.ByteString) -fileFromURI uri = try $ - case (uriScheme uri, uriAuthority uri) of - ("file:", Nothing) -> L.readFile (uriPath uri) - -- ("ssh:", Just auth) -> cmdOutput ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " cat " ++ show (uriPath uri)) - ("ssh:", Just auth) -> - do let cmd = "ssh" - args = [uriUserInfo auth ++ uriRegName auth ++ uriPort auth, "cat", uriPath uri] - (code, out, _err) <- readProcessWithExitCode cmd args id L.empty - case code of - ExitFailure _ -> error (showCommandForUser cmd args ++ " -> " ++ show code) - _ -> return out - _ -> - do let cmd = "curl" - args = ["-s", "-g", uriToString' uri] - (_code, out, _err) <- readProcessWithExitCode cmd args id L.empty - return out +fileFromURI uri = fileFromURIStrict uri >>= either (return . Left) (return . Right . L.fromChunks . (: [])) fileFromURIStrict :: URI -> IO (Either SomeException B.ByteString) fileFromURIStrict uri = try $ @@ -53,21 +37,21 @@ ("ssh:", Just auth) -> do let cmd = "ssh" args = [uriUserInfo auth ++ uriRegName auth ++ uriPort auth, "cat", uriPath uri] - (_code, out, _err) <- readProcessWithExitCode cmd args id L.empty - return . B.concat . L.toChunks $ out + (_code, out, _err) <- readProcessWithExitCode cmd args B.empty + return out _ -> do let cmd = "curl" args = ["-s", "-g", uriToString' uri] - (_code, out, _err) <- readProcessWithExitCode cmd args id L.empty - return . B.concat . L.toChunks $ out + (_code, out, _err) <- readProcessWithExitCode cmd args B.empty + return out -- | Parse the text returned when a directory is listed by a web -- server. This is currently only known to work with Apache. -- NOTE: there is a second copy of this function in -- Extra:Extra.Net. Please update both locations if you make changes. -webServerDirectoryContents :: L.ByteString -> [String] +webServerDirectoryContents :: B.ByteString -> [String] webServerDirectoryContents text = - catMaybes . map (second . matchRegex re) . lines . L.unpack $ text + catMaybes . map (second . matchRegex re) . Prelude.lines . B.toString $ text where re = mkRegex "( do let cmd = "ssh" args = [uriUserInfo auth ++ uriRegName auth ++ uriPort auth, "ls", "-1", uriPath uri] - (_code, out, _err) <- readProcessWithExitCode cmd args id L.empty - return . lines . L.unpack $ out + (_code, out, _err) <- readProcessWithExitCode cmd args B.empty + return . Prelude.lines . B.toString $ out _ -> do let cmd = "curl" args = ["-s", "-g", uriToString' uri] - (_code, out, _err) <- readProcessWithExitCode cmd args id L.empty + (_code, out, _err) <- readProcessWithExitCode cmd args B.empty return . webServerDirectoryContents $ out diff --git a/Debian/Util/FakeChanges.hs b/Debian/Util/FakeChanges.hs --- a/Debian/Util/FakeChanges.hs +++ b/Debian/Util/FakeChanges.hs @@ -19,6 +19,7 @@ import Text.Regex.TDFA import Prelude hiding (catch, concat, foldr, all, mapM) import Network.BSD +import Text.PrettyPrint.Class (pretty) import Debian.Control import qualified Debian.Deb as Deb @@ -42,8 +43,7 @@ , tar :: Maybe FilePath , diff :: Maybe FilePath } - deriving Show - + fakeChanges :: [FilePath] -> IO (FilePath, String) fakeChanges fps = do files <- loadFiles fps @@ -78,7 +78,7 @@ )) , ("Files", "\n" ++ unlines fileLines) ] - return $ (concat [ source, "_", version, "_", binArch, ".changes"], show changes) + return $ (concat [ source, "_", version, "_", binArch, ".changes"], show (pretty changes)) -- let (invalid, binaries) = unzipEithers $ map debNameSplit debs {- when (not . null $ invalid) (throwDyn [MalformedDebFilename invalid]) @@ -102,9 +102,9 @@ | otherwise = case fieldValue "Version" (snd . fromJust $ dsc files) of (Just v) -> v - Nothing -> error $ show (dsc files) ++ " does not have a Version field :(" - + Nothing -> error $ "show (dsc files)" ++ " does not have a Version field :(" + getSource :: Files -> String getSource files = let dscSource = @@ -223,13 +223,13 @@ case res of (Left e) -> error $ "Error parsing " ++ dsc ++ "\n" ++ show e (Right (Control [p])) -> return (dsc, p) - (Right c) -> error $ dsc ++ " did not have exactly one paragraph: " ++ show c + (Right c) -> error $ dsc ++ " did not have exactly one paragraph: " ++ show (pretty c) loadDeb :: FilePath -> IO (FilePath, Paragraph) loadDeb deb = do res <- Deb.fields deb case res of (Control [p]) -> return (deb, p) - _ -> error $ deb ++ " did not have exactly one paragraph: " ++ show res + _ -> error $ deb ++ " did not have exactly one paragraph: " ++ show (pretty res) getUploader :: IO String diff --git a/Test/SourcesList.hs b/Test/SourcesList.hs --- a/Test/SourcesList.hs +++ b/Test/SourcesList.hs @@ -1,6 +1,7 @@ module Test.SourcesList where import Test.HUnit +import Text.PrettyPrint.Class (pretty) import Debian.Sources --import Data.Maybe @@ -21,7 +22,7 @@ testSourcesList :: Test testSourcesList = - test [ assertEqual "valid sources.list" validSourcesListExpected (unlines . map show . parseSourcesList $ validSourcesListStr) ] + test [ assertEqual "valid sources.list" validSourcesListExpected (unlines . map (show . pretty) . parseSourcesList $ validSourcesListStr) ] where validSourcesListStr = unlines $ [ " # A comment only line " @@ -44,16 +45,16 @@ testSourcesListParse :: Test testSourcesListParse = - test [ assertEqual "" text (concat . map (++ "\n") . map show . parseSourcesList $ text) ] + test [ assertEqual "" gutsy (concat . map (++ "\n") . map (show . pretty) . parseSourcesList $ gutsy) ] where - text = (concat ["deb http://us.archive.ubuntu.com/ubuntu/ gutsy main restricted universe multiverse\n", + gutsy = concat ["deb http://us.archive.ubuntu.com/ubuntu/ gutsy main restricted universe multiverse\n", "deb-src http://us.archive.ubuntu.com/ubuntu/ gutsy main restricted universe multiverse\n", "deb http://us.archive.ubuntu.com/ubuntu/ gutsy-updates main restricted universe multiverse\n", "deb-src http://us.archive.ubuntu.com/ubuntu/ gutsy-updates main restricted universe multiverse\n", "deb http://us.archive.ubuntu.com/ubuntu/ gutsy-backports main restricted universe multiverse\n", "deb-src http://us.archive.ubuntu.com/ubuntu/ gutsy-backports main restricted universe multiverse\n", "deb http://security.ubuntu.com/ubuntu/ gutsy-security main restricted universe multiverse\n", - "deb-src http://security.ubuntu.com/ubuntu/ gutsy-security main restricted universe multiverse\n"]) + "deb-src http://security.ubuntu.com/ubuntu/ gutsy-security main restricted universe multiverse\n"] sourcesListTests :: [Test] sourcesListTests = diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,5 +1,5 @@ Name: debian -Version: 3.64.1 +Version: 3.65 License: BSD3 License-File: debian/copyright Author: David Fox , Jeremy Shaw , Clifford Beshers @@ -34,7 +34,9 @@ old-locale, parsec >= 2 && <4, pretty, + pretty-class, process, + process-extras >= 0.4, pureMD5, regex-compat, regex-tdfa,