diff --git a/cbits/gwinsz.c b/cbits/gwinsz.c deleted file mode 100644 --- a/cbits/gwinsz.c +++ /dev/null @@ -1,9 +0,0 @@ -#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/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,11 +1,11 @@ Name: debian -Version: 3.96 +Version: 4.0.0 License: BSD3 License-File: debian/copyright Author: David Fox , Jeremy Shaw , Clifford Beshers Category: Debian -Maintainer: David Fox -Homepage: https://github.com/ddssff/debian-haskell +Maintainer: Clint Adams +Homepage: https://github.com/clinty/debian-haskell Build-Type: Simple Synopsis: Modules for working with the Debian package system Cabal-Version: >= 1.9 @@ -20,11 +20,6 @@ Description: Get Network.URI from the network-uri package Default: True -flag pretty-new - Description: pretty-1.1.2 includes the Text.PrettyPrint.HughesPJClass module from prettyclass - Default: True - Manual: True - Library Hs-Source-Dirs: src Build-Depends: @@ -33,11 +28,10 @@ bzlib, Cabal, containers, - directory, + directory >= 1.2.3.0, either, exceptions, filepath, - HaXml >= 1.20, hostname, HUnit, lens, @@ -45,6 +39,7 @@ mtl, old-locale, parsec >= 2 && <4, + pretty >= 1.1.2, process, process-extras >= 0.2.0, pureMD5, @@ -54,22 +49,18 @@ SHA, syb, template-haskell, + temporary, text, th-lift, th-orphans, time, unix, - Unixutils >= 1.52.4, utf8-string, zlib if flag(network-uri) Build-Depends: network-uri >= 2.6 else Build-Depends: network >= 2.4 && < 2.6 - if flag(pretty-new) - Build-Depends: pretty >= 1.1.2 - else - Build-Depends: pretty, prettyclass ghc-options: -Wall Exposed-modules: @@ -105,7 +96,6 @@ Debian.Version.Common, Debian.Version.String, Debian.Version.Text, - Debian.Report, Debian.TH, Debian.Time, Debian.URI, @@ -122,17 +112,6 @@ ghc-options: -threaded -W Extensions: ExistentialQuantification CPP -Executable debian-report - Hs-Source-Dirs: utils - Main-is: Report.hs - Build-Depends: base, debian, HaXml, unix - ghc-options: -threaded -W - C-Sources: cbits/gwinsz.c - Include-Dirs: cbits - Install-Includes: gwinsz.h - Extensions: ExistentialQuantification CPP - Build-Depends: pretty - Executable apt-get-build-depends Hs-Source-Dirs: utils Main-is: AptGetBuildDeps.hs @@ -144,13 +123,9 @@ Type: exitcode-stdio-1.0 Hs-Source-Dirs: Test Main-Is: Main.hs - Build-Depends: base, Cabal, debian, HUnit, parsec, regex-tdfa, text + Build-Depends: base, Cabal, debian, HUnit, parsec, pretty >= 1.1.2, regex-tdfa, text Other-Modules: Changes Control Dependencies Paths_debian Versions - if flag(pretty-new) - Build-Depends: pretty >= 1.1.2 - else - Build-Depends: pretty, prettyclass source-repository head type: git - location: https://github.com/ddssff/debian-haskell + location: https://github.com/clinty/debian-haskell diff --git a/debian/copyright b/debian/copyright --- a/debian/copyright +++ b/debian/copyright @@ -8,6 +8,7 @@ Copyright (c) 2007, David Fox Copyright (c) 2007, Jeremy Shaw +Copyright 2019 Clint Adams All rights reserved. diff --git a/src/Debian/Control/ByteString.hs b/src/Debian/Control/ByteString.hs --- a/src/Debian/Control/ByteString.hs +++ b/src/Debian/Control/ByteString.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses, PackageImports, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses, PackageImports, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} module Debian.Control.ByteString ( Control'(..) @@ -32,14 +32,13 @@ import Data.Word (Word8) import Data.List import qualified Data.ListLike as LL -import qualified Data.ListLike.String () +import qualified Data.ListLike.String as LL import Text.ParserCombinators.Parsec.Error import Text.ParserCombinators.Parsec.Pos -- Third Party Modules -import qualified Data.ByteString as W import qualified Data.ByteString.Char8 as C import Debian.Control.Common hiding (protectFieldText') @@ -130,15 +129,15 @@ protectFieldText = protectFieldText' asString = C.unpack -protectFieldText' :: (a ~ C.ByteString, LL.ListLike a Word8, ControlFunctions a) => a -> a +protectFieldText' :: (LL.StringLike a, LL.ListLike a Word8) => ControlFunctions a => a -> a protectFieldText' s = - case C.lines s of + case LL.lines s of [] -> LL.empty - (l : ls) -> dropWhileEnd (isSpace . chr . fromIntegral) $ C.unlines $ l : map protect ls + (l : ls) -> dropWhileEnd (isSpace . chr . fromIntegral) $ LL.unlines $ l : map protect ls where - dropWhileEnd :: (a ~ W.ByteString, LL.ListLike a Word8) => (Word8 -> Bool) -> a -> a - dropWhileEnd func = LL.reverse . W.dropWhile func . LL.reverse -- foldr (\x xs -> if func x && LL.null xs then LL.empty else LL.cons x xs) empty - protect :: (LL.ListLike a Word8) => a -> a + dropWhileEnd :: (LL.StringLike a, LL.ListLike a Word8) => (Word8 -> Bool) -> a -> a + dropWhileEnd func = LL.reverse . LL.dropWhile func . LL.reverse -- foldr (\x xs -> if func x && LL.null xs then LL.empty else LL.cons x xs) empty + protect :: (LL.StringLike a, LL.ListLike a Word8) => a -> a protect l = maybe LL.empty (\ c -> if isHorizSpace c then l else LL.cons (ord' ' ' :: Word8) l) (LL.find (const True :: Word8 -> Bool) l) -- isSpace' = isSpace . chr' isHorizSpace c = elem c (map ord' " \t") diff --git a/src/Debian/Deb.hs b/src/Debian/Deb.hs --- a/src/Debian/Deb.hs +++ b/src/Debian/Deb.hs @@ -4,16 +4,16 @@ import Control.Monad import Debian.Control.Common -import System.Directory (canonicalizePath) +import System.Directory (canonicalizePath, withCurrentDirectory) import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode) -import System.Unix.Directory (withTemporaryDirectory, withWorkingDirectory) +import System.IO.Temp (withSystemTempDirectory) fields :: (ControlFunctions a) => FilePath -> IO (Control' a) fields debFP = - withTemporaryDirectory ("fields.XXXXXX") $ \tmpdir -> + withSystemTempDirectory ("fields.XXXXXX") $ \tmpdir -> do debFP <- canonicalizePath debFP - withWorkingDirectory tmpdir $ + withCurrentDirectory tmpdir $ do (res, out, err) <- readProcessWithExitCode "ar" ["x",debFP,"control.tar.gz"] "" when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ show out ++ "\n" ++ show err ++ "\n" ++ show res) (res, out, err) <- readProcessWithExitCode "tar" ["xzf", "control.tar.gz", "./control"] "" diff --git a/src/Debian/Report.hs b/src/Debian/Report.hs deleted file mode 100644 --- a/src/Debian/Report.hs +++ /dev/null @@ -1,88 +0,0 @@ -module Debian.Report where - -import Data.Maybe -import qualified Data.Map as M -import Data.Text as Text (Text, unpack) -import Debian.Apt.Index (Fetcher, Compression(..), update, controlFromIndex') -import Debian.Control.Text -import Debian.Sources -import Debian.Version -import Text.XML.HaXml (CFilter, mkElem, cdata) -import Text.XML.HaXml.Posn -import Text.PrettyPrint (render) - --- * General Package Map Builders - --- |create a map of (package name, extracted field) from a list of index files --- --- NOTE: we could merge all the files into a single control and then --- run packageMap over that. We currently do it one control file at a --- time to avoid having all the control files loaded in memory at --- once. However, I am not sure that property is actually occuring --- anyway. So, this should be revisited. -makePackageMap :: (Paragraph -> a) -> (a -> a -> a) -> [(FilePath, Compression)] -> IO (M.Map Text a) -makePackageMap _ _ [] = return M.empty -makePackageMap extractValue resolveConflict ((path, compression):is) = - do r <- controlFromIndex' compression path - case r of - (Left e) -> error (show e) - (Right c) -> - do let pm = packageMap extractValue resolveConflict c - pms <- makePackageMap extractValue resolveConflict is - return $ M.unionWith resolveConflict pm pms - --- |create a map of (package name, max version) from a single control file -packageMap :: (Paragraph -> a) -> (a -> a -> a) -> Control' Text -> M.Map Text a -packageMap extractValue resolveConflict control = - M.fromListWith resolveConflict (map packageTuple (unControl control)) - where - packageTuple paragraph = (fromJust $ fieldValue "Package" paragraph, extractValue paragraph) - --- |extract the version number from a control paragraph -extractVersion :: Paragraph -> Maybe DebianVersion -extractVersion paragraph = fmap (parseDebianVersion' . unpack) $ fieldValue "Version" paragraph - --- * Trump Report - --- |compare two sources.list and find all the packages in the second that trump packages in the first --- see also: |trumpedMap| -trumped :: Fetcher -- ^ function for downloading package indexes - -> FilePath -- ^ cache directory to store index files in (must already exist) - -> String -- ^ binary architecture - -> [DebSource] -- ^ sources.list a - -> [DebSource] -- ^ sources.list b - -> IO (M.Map Text (DebianVersion, DebianVersion)) -- ^ a map of trumped package names to (version a, version b) -trumped fetcher cacheDir arch sourcesA sourcesB = - do indexesA <- update fetcher cacheDir arch (filter isDebSrc sourcesA) - pmA <- makePackageMap (fromJust . extractVersion) max (map fromJust indexesA) - indexesB <- update fetcher cacheDir arch (filter isDebSrc sourcesB) - pmB <- makePackageMap (fromJust . extractVersion) max (map fromJust indexesB) - return (trumpedMap pmA pmB) - where - isDebSrc :: DebSource -> Bool - isDebSrc ds = _sourceType ds == DebSrc - --- |calculate all the trumped packages -trumpedMap :: M.Map Text DebianVersion -- ^ package map a - -> M.Map Text DebianVersion -- ^ package map b - -> M.Map Text (DebianVersion, DebianVersion) -- ^ trumped packages (version a, version b) -trumpedMap pmA pmB = - M.foldrWithKey (checkTrumped pmB) M.empty pmA - where - checkTrumped pm package aVersion trumpedPM = - case M.lookup package pm of - (Just bVersion) - | bVersion > aVersion -> M.insert package (aVersion, bVersion) trumpedPM - _ -> trumpedPM - --- |create XML element and children from a trumped Map -trumpedXML :: M.Map Text (DebianVersion, DebianVersion) -> CFilter Posn -trumpedXML trumpedMap' = - mkElem "trumped" (map mkTrumpedPackage (M.toAscList trumpedMap' )) - where - mkTrumpedPackage (package, (oldVersion, newVersion)) = - mkElem "trumpedPackage" - [ mkElem "package" [ cdata (unpack package) ] - , mkElem "oldVersion" [ cdata (render . prettyDebianVersion $ oldVersion) ] - , mkElem "newVersion" [ cdata (render . prettyDebianVersion $ newVersion) ] - ] diff --git a/utils/Report.hs b/utils/Report.hs deleted file mode 100644 --- a/utils/Report.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables, TemplateHaskell #-} -module Main where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Control.Exception (try) -import Control.Monad -import Data.Maybe (fromMaybe) -import Debian.Apt.Methods -import Debian.Report -import Debian.Sources -import Debian.TH (here) -import Foreign.C.Types -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure) -import Text.XML.HaXml -import Text.XML.HaXml.Pretty (document) -import Text.XML.HaXml.Posn -import Text.PrettyPrint.HughesPJ -import System.IO -import System.Posix.Env - - --- * main - -main :: IO () -main = - do (sourcesAFP, sourcesBFP) <- parseArgs - let arch = "i386" -- not actually used for anything right now, could be when binary package list is enabled - cacheDir = "." -- FIXME: replace with tempdir later - sourcesA <- liftM (parseSourcesList [$here]) $ readFile sourcesAFP - sourcesB <- liftM (parseSourcesList [$here]) $ readFile sourcesBFP - trumpMap <- trumped (fetch emptyFetchCallbacks []) cacheDir arch sourcesA sourcesB - print (showXML "trump.xsl" (trumpedXML trumpMap)) - where - showXML :: String -> CFilter Posn -> Doc - showXML styleSheet = document . mkDocument styleSheet . cfilterToElem - -- cliff says this is broken with regards to cdata - cfilterToElem :: CFilter Posn -> Element Posn - cfilterToElem f = case f (CString False "" noPos) of - [CElem e _] -> xmlEscape stdXmlEscaper e - [] -> error "RSS produced no output" - _ -> error "RSS produced more than one output" - -- - mkDocument :: String -> Element Posn -> Document Posn - 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 [] - --- * command-line helper functions - -helpText :: String -> Doc -helpText progName = - (text "Usage:" <+> text progName <+> text "" <+> text ""$+$ - text [] $+$ - (fsep $ map text $ words $ "Find all the packages referenced by the second sources.list which trump packages find in the first sources.list.") - ) - -parseArgs :: IO (String, String) -parseArgs = - do args <- getArgs - case args of - [dista, distb] -> return (dista, distb) - _ -> exitWithHelp helpText - where - -- |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 - -- |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 - -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" - 0 -> either (\(_ :: IOError) -> Nothing) (fmap read) <$> try (getEnv "COLUMNS") - _ -> return (Just cols) - -