diff --git a/Debian/Apt/Dependencies.hs b/Debian/Apt/Dependencies.hs deleted file mode 100644 --- a/Debian/Apt/Dependencies.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS -fno-warn-missing-signatures #-} -module Debian.Apt.Dependencies -{- - ( solve - , State - , binaryDepends - , search - , bj' - , bt - , CSP(..) - ) -} where - --- test gutsyPackages "libc6" (\csp -> bt csp) - -import Control.Arrow (second) -import qualified Data.ByteString.Char8 as C -import Data.List as List (find, union) -import Data.Tree (Tree(rootLabel, Node)) -import Debian.Apt.Package (PackageNameMap, packageNameMap, lookupPackageByRel) -import Debian.Control.ByteString (ControlFunctions(stripWS, lookupP, parseControlFromFile), - Field'(Field, Comment), Control'(Control), Paragraph, Control) -import Debian.Relation (BinPkgName(..)) -import Debian.Relation.ByteString (ParseRelations(..), Relation(..), OrRelation, AndRelation, Relations, checkVersionReq) -import Debian.Version (DebianVersion, parseDebianVersion, prettyDebianVersion) -import Debian.Version.ByteString () -import Text.PrettyPrint (render) - --- * Basic CSP Types and Functions - -data Status - = Remaining AndRelation - | MissingDep Relation - | Complete - deriving (Eq) - -type State a = (Status, [a]) - -complete :: State a -> Bool -complete (Complete, _) = True -complete _ = False - -data CSP a - = CSP { pnm :: PackageNameMap a - , relations :: Relations - , depFunction :: (a -> Relations) - , conflicts :: a -> Relations - , packageVersion :: a -> (BinPkgName, DebianVersion) - } - --- * Test CSP - --- |TODO addProvides -- see DQL.Exec -controlCSP :: Control -> Relations -> (Paragraph -> Relations) -> CSP Paragraph -controlCSP (Control paragraphs) rels depF' = - CSP { pnm = packageNameMap getName paragraphs - , relations = rels - , depFunction = depF' - , conflicts = conflicts' - , packageVersion = packageVersionParagraph - } - where - getName :: Paragraph -> BinPkgName - getName p = case lookupP "Package" p of - Nothing -> error "Missing Package field" - Just (Field (_,n)) -> BinPkgName (C.unpack (stripWS n)) - Just (Comment _) -> error "controlCSP" - conflicts' :: Paragraph -> Relations - conflicts' p = - case lookupP "Conflicts" p of - Nothing -> [] - Just (Field (_, c)) -> either (error . show) id (parseRelations c) - Just (Comment _) -> error "controlCSP" - -testCSP :: FilePath -> (Paragraph -> Relations) -> String -> (CSP Paragraph -> IO a) -> IO a -testCSP controlFile depf relationStr cspf = - do c' <- parseControlFromFile controlFile - case c' of - Left e -> error (show e) - Right control@(Control _) -> - case parseRelations relationStr of - Left e -> error (show e) - Right r -> - cspf (controlCSP control r depf) - -depF :: Paragraph -> Relations -depF p = - let preDepends = - case lookupP "Pre-Depends" p of - Nothing -> [] - Just (Field (_,pd)) -> - either (error . show) id (parseRelations pd) - Just (Comment _) -> error "depF" - depends = - case lookupP "Depends" p of - Nothing -> [] - Just (Field (_,pd)) -> - either (error . show) id (parseRelations pd) - Just (Comment _) -> error "depF" - in - preDepends ++ depends - -sidPackages = "/var/lib/apt/lists/ftp.debian.org_debian_dists_unstable_main_binary-i386_Packages" -gutsyPackages = "/var/lib/apt/lists/mirror.anl.gov_pub_ubuntu_dists_gutsy_main_binary-i386_Packages" - -test controlFP rel labeler = - testCSP controlFP depF rel (mapM_ (\ (_,p) -> mapM_ (print . second (render . prettyDebianVersion) . packageVersionParagraph) p ) . take 1 . search labeler) - --- TODO: add better errors -packageVersionParagraph :: Paragraph -> (BinPkgName, DebianVersion) -packageVersionParagraph p = - case lookupP "Package" p of - Nothing -> error $ "Paragraph missing Package field" - (Just (Field (_, name))) -> - case lookupP "Version" p of - Nothing -> error $ "Paragraph missing Version field" - (Just (Field (_, str))) -> - case parseDebianVersion str of - Right ver -> (BinPkgName (C.unpack (stripWS name)), ver) - Left e -> error $ "packageVersionParagraph: " ++ show e - (Just (Comment _)) -> error "packageVersionParagraph" - (Just (Comment _)) -> error "packageVersionParagraph" - - - -conflict :: CSP p -> p -> p -> Bool -conflict csp p1 p2 = - let (name1, version1) = (packageVersion csp) p1 - (name2, version2) = (packageVersion csp) p2 - in - if name1 == name2 - then version1 /= version2 - else - any (conflict' (name1, version1)) (concat $ (conflicts csp) p2) || - any (conflict' (name2, version2)) (concat $ (conflicts csp) p1) - --- |JAS: deal with 'Provides' (can a package provide more than one package?) -conflict' :: (BinPkgName, DebianVersion) -> Relation -> Bool -conflict' (pName, pVersion) (Rel pkgName mVersionReq _) = - (pName == pkgName) && (checkVersionReq mVersionReq (Just pVersion)) - - - --- * Tree Helper Functions - -mkTree :: a -> [Tree a] -> Tree a -mkTree = Node - -label :: Tree a -> a -label = rootLabel - -initTree :: (a -> [a]) -> a -> Tree a -initTree f a = Node a (map (initTree f) (f a)) - -mapTree :: (a -> b) -> Tree a -> Tree b -mapTree = fmap - -foldTree :: (a -> [b] -> b) -> Tree a -> b -foldTree f (Node a ts) = f a (map (foldTree f) ts) - -zipTreesWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c -zipTreesWith f (Node a ts) (Node b us) = - Node (f a b) (zipWith (zipTreesWith f) ts us) - -prune :: (a -> Bool) -> Tree a -> Tree a -prune p = foldTree f - where f a ts = Node a (filter (not . p . label) ts) - -leaves :: Tree a -> [a] -leaves = foldTree f - where f leaf [] = [leaf] - f _ ts = concat ts - -inhTree :: (b -> a -> b) -> b -> Tree a -> Tree b -inhTree f b (Node a ts) = Node b' (map (inhTree f b') ts) - where b' = f b a - -distrTree :: (a -> [b]) -> b -> Tree a -> Tree b -distrTree f b (Node a ts) = Node b (zipWith (distrTree f) (f a) ts) - --- * mkSearchTree - --- TODO: might want to leave markers about what relation we are satisfying? -mkSearchTree :: forall a. CSP a -> Tree (State a) -mkSearchTree csp = - Node (Remaining (relations csp),[]) (andRelation ([],[]) (relations csp)) - where - andRelation :: ([a],AndRelation) -> AndRelation -> [Tree (State a)] - andRelation (candidates,[]) [] = [Node (Complete, candidates) []] - andRelation (candidates,remaining) [] = andRelation (candidates, []) remaining - andRelation (candidates, remaining) (x:xs) = - orRelation (candidates, xs ++ remaining) x - orRelation :: ([a],AndRelation) -> OrRelation -> [Tree (State a)] - orRelation acc x = - concat (fmap (relation acc) x) - relation :: ([a],AndRelation) -> Relation -> [Tree (State a)] - relation acc@(candidates,_) rel = - let packages = lookupPackageByRel (pnm csp) (packageVersion csp) rel in - case packages of - [] -> [Node (MissingDep rel, candidates) []] - _ -> map (package acc) packages - package :: ([a],AndRelation) -> a -> Tree (State a) - package (candidates, remaining) p = - if ((packageVersion csp) p) `elem` (map (packageVersion csp) candidates) - then if null remaining - then Node (Complete, candidates) [] - else Node (Remaining remaining, candidates) (andRelation (candidates, []) remaining) - else Node (Remaining remaining, (p : candidates)) (andRelation ((p : candidates), remaining) ((depFunction csp) p)) - - --- |earliestInconsistency does what it sounds like --- the 'reverse as' is because the vars are order high to low, but we --- want to find the lowest numbered (aka, eariest) inconsistency ?? --- -earliestInconsistency :: CSP a -> State a -> Maybe ((BinPkgName, DebianVersion), (BinPkgName, DebianVersion)) -earliestInconsistency _ (_,[]) = Nothing -earliestInconsistency _ (_,[_p]) = Nothing -earliestInconsistency csp (_,(p:ps)) = - case find ((conflict csp) p) (reverse ps) of - Nothing -> Nothing - (Just conflictingPackage) -> Just ((packageVersion csp) p, (packageVersion csp) conflictingPackage) - --- * Conflict Set - --- | conflicting packages and relations that require non-existant packages -type ConflictSet = ([(BinPkgName, DebianVersion)],[Relation]) - -isConflict :: ConflictSet -> Bool -isConflict ([],[]) = False -isConflict _ = True - -solutions :: Tree (State a, ConflictSet) -> [State a] -solutions = filter complete . map fst . leaves . prune (isConflict . snd) - -type Labeler a = CSP a -> Tree (State a) -> Tree (State a, ConflictSet) - -search :: Labeler a -> CSP a -> [State a] -search labeler csp = (solutions . (labeler csp) . mkSearchTree) csp - --- * Backtracking Labeler - -bt :: Labeler a -bt csp = mapTree f - where - f s@(status,_) = - case status of - (MissingDep rel) -> (s, ([], [rel])) - _ -> - (s, - case (earliestInconsistency csp) s of - Nothing -> ([],[]) - Just (a,b) -> ([a,b], [])) - --- * BackJumping Solver - -{-|bj - backjumping labeler - -If the node already has a conflict set, then leave it alone. - -Otherwise, the conflictset for the node is the combination of the -conflict sets of its direct children. --} -bj :: CSP p -> Tree (State p, ConflictSet) -> Tree (State p, ConflictSet) -bj csp = foldTree f - where f (s, cs) ts - | isConflict cs = mkTree (s, cs) ts --- | isConflict cs' = mkTree (s, cs') [] -- prevent space leak - | otherwise = mkTree (s, cs') ts - where cs' = - let set = combine csp (map label ts) [] in - set `seq` set -- prevent space leak - -unionCS :: [ConflictSet] -> ConflictSet -unionCS css = foldr (\(c1, m1) (c2, m2) -> ((c1 `union` c2), (m1 `union` m2))) ([],[]) css - -combine :: CSP p -> [(State p, ConflictSet)] -> [ConflictSet] -> ConflictSet -combine _ [] acc = unionCS acc -combine csp ((s,cs@(c,m)):ns) acc - | (not (lastvar `elem` c)) && null m = cs - | null c && null m = ([],[]) -- is this case ever used? - | otherwise = combine csp ns ((c, m):acc) - where lastvar = - let (_,(p:_)) = s in (packageVersion csp) p - - diff --git a/Debian/Apt/Index.hs b/Debian/Apt/Index.hs deleted file mode 100644 --- a/Debian/Apt/Index.hs +++ /dev/null @@ -1,332 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, OverloadedStrings, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -module Debian.Apt.Index - ( update - , Fetcher - , CheckSums(..) - , Compression(..) - , FileTuple - , Size - , controlFromIndex - , controlFromIndex' - , findContentsFiles - , findIndexes - , indexesInRelease - , tupleFromFilePath - ) where - -import Control.Monad -import qualified Codec.Compression.GZip as GZip -import qualified Codec.Compression.BZip as BZip -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.Digest.Pure.MD5 as MD5 -import qualified Data.Digest.Pure.SHA as SHA -import Data.Either (partitionEithers) -import Data.Function -import Data.List as List (null, intercalate, sortBy, isSuffixOf, isPrefixOf) -import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text as Text (Text, unpack, concat, lines, null, words) -import Data.Time -import Debian.Apt.Methods -import Debian.Control (formatControl) -import Debian.Control.ByteString -import Debian.Control.Common -import Debian.Control.Text (decodeControl) -import Debian.Release -import Debian.Sources -import Debian.URI -import System.Directory -import System.FilePath (()) -import System.Posix.Files -import System.FilePath (takeBaseName) ---import qualified System.Unix.Misc as Misc -import Text.ParserCombinators.Parsec.Error -import Text.PrettyPrint (render) -import Text.PrettyPrint.HughesPJClass (pPrint) -import Text.Read (readMaybe) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure, (<$>), (<*>)) -#endif - --- |Package indexes on the server are uncompressed or compressed with --- gzip or bzip2. We do not know what will exist on the server until we --- actually look. This type is used to mark the compression status of --- what was actually found. -data Compression - = BZ2 | GZ | Uncompressed - deriving (Read, Show, Eq, Ord, Enum, Bounded) - -data CheckSums - = CheckSums { md5sum :: Maybe String - , sha1 :: Maybe String - , sha256 :: Maybe String - } - deriving (Read, Show, Eq) - --- |function-type for a function that downloads a file --- The timestamp is optional. If the local file is as new or newer --- than the remote copy, the download may be skipped. --- --- A good choice might be a partially parameterized call to --- 'Debian.Apt.Methods.fetch' -type Fetcher = - URI -> -- remote URI - FilePath -> -- local file name - Maybe UTCTime -> -- optional time stamp for local file - IO Bool -- True on success, False on failure - --- |update - similar to apt-get update - --- downloads the index files associated with a sources.list. The --- downloaded index files will have the same basenames that apt-get uses --- in \/var\/lib\/apt\/lists. You can almost use this function instead of --- calling apt-get update. However there are a few key differences: --- 1. apt-get update also updates the binary cache files --- 2. apt-get update uses the partial directory and lock file in\ /var\/lib\/apt\/lists --- 3. apt-get update downloads the Release and Release.gpg files -update :: Fetcher -- ^ function that will do actually downloading - -> FilePath -- ^ download indexes to the directory (must already exist) - -> String -- ^ binary architecture - -> [DebSource] -- ^ sources.list - -> IO [Maybe (FilePath, Compression)] -- ^ (basename of index file, compression status) -update fetcher basePath arch sourcesList = - mapM (uncurry $ fetchIndex fetcher) (map (\(uri, fp, _) -> (uri, (basePath fp))) (concatMap (indexURIs arch) sourcesList)) - --- | download possibly compressed files --- NOTE: index uri must not include the .bz2 or .gz extension -fetchIndex :: Fetcher -- ^ function that will do the actual fetch - -> URI -- ^ remote URI of package index, without .bz2 or .gz extension - -> FilePath -- ^ name to save downloaded file as, without .bz2 or .gz extension - -> IO (Maybe (FilePath, Compression)) -- ^ (downloaded file name + extension, compression status) -fetchIndex fetcher uri localPath = - do let localPath' = localPath ++ ".bz2" - --lm <- getLastModified localPath' - res <- fetcher (uri { uriPath = (uriPath uri) ++ ".bz2" }) localPath' Nothing - if res - then return $ Just (localPath', BZ2) - else do let localPath' = localPath ++ ".gz" - lm <- getLastModified localPath' - res <- fetcher (uri { uriPath = (uriPath uri) ++ ".gz" }) localPath' lm - if res - then return $ Just (localPath', GZ) - else do lm <- getLastModified localPath - res <- fetcher (uri { uriPath = (uriPath uri) }) localPath lm - if res - then return (Just (localPath, Uncompressed)) - else return Nothing - --- |examine a DebSource line, and calculate for each section: --- - the URI to the uncompressed index file --- - the basename that apt-get would name the downloaded index --- FIXME: ExactPath dist will fail with error at runtime :( -indexURIs :: String -- ^ which binary architecture - -> DebSource -- ^ line from sources.list - -> [(URI, FilePath, DebSource)] -- ^ (remote uri, local name, deb source for just this section) -indexURIs arch debSource = - map (\ section -> let (uri, fp) = calcPath (sourceType debSource) arch baseURI release section - in (uri,fp, debSource { sourceDist = (Right (release, [section])) }) ) sections - where - baseURI = sourceUri debSource - (release, sections) = - either (error $ "indexURIs: support not implemented for exact path: " ++ render (pPrint debSource)) id (sourceDist debSource) - --- |return a tuple for the section --- - the URI to the uncompressed index file --- - the basename that apt-get uses for the downloaded index --- FIXME: support for Release and Release.gpg -calcPath :: SourceType -- ^ do we want Packages or Sources - -> String -- ^ The binary architecture to use for Packages - -> URI -- ^ base URI as it appears in sources.list - -> ReleaseName -- ^ the release (e.g., unstable, testing, stable, sid, etc) - -> Section -- ^ the section (main, contrib, non-free, etc) - -> (URI, [Char]) -- ^ (uri to index file, basename for the downloaded file) -calcPath srcType arch baseURI release section = - let indexPath = case srcType of - DebSrc -> "source/Sources" - Deb -> "binary-" ++ arch "Packages" - path = (uriPath baseURI) "dists" (releaseName' release) sectionName' section indexPath - in (baseURI { uriPath = path }, addPrefix . escapePath $ path) - where - addPrefix s = prefix scheme user' pass' reg port ++ {- "_" ++ -} s - prefix "http:" (Just user) Nothing (Just host) port = user ++ host ++ port - prefix "http:" _ _ (Just host) port = host ++ port - prefix "ftp:" _ _ (Just host) _ = host - prefix "file:" Nothing Nothing Nothing "" = "" - prefix "ssh:" (Just user) Nothing (Just host) port = user ++ host ++ port - prefix "ssh:" _ _ (Just host) port = host ++ port - prefix _ _ _ _ _ = error ("calcPath: unsupported uri: " ++ uriToString' baseURI) - user' = maybeOfString user - pass' = maybeOfString pass - (user, pass) = break (== ':') userpass - userpass = maybe "" uriUserInfo auth - reg = maybeOfString $ maybe "" uriRegName auth - port = maybe "" uriPort auth - scheme = uriScheme baseURI - auth = uriAuthority baseURI - --path = uriPath baseURI - - escapePath :: String -> String - escapePath s = intercalate "_" $ wordsBy (== '/') s - - maybeOfString :: String -> Maybe String - maybeOfString "" = Nothing - maybeOfString s = Just s - - 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) - --- |Parse a possibly compressed index file. -controlFromIndex :: Compression -> FilePath -> L.ByteString -> Either ParseError (Control' Text) -controlFromIndex GZ path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks . GZip.decompress $ s -controlFromIndex BZ2 path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks . BZip.decompress $ s -controlFromIndex Uncompressed path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks $ s - --- |parse an index possibly compressed file -controlFromIndex' :: Compression -> FilePath -> IO (Either ParseError (Control' Text)) -controlFromIndex' compression path = L.readFile path >>= return . controlFromIndex compression path - -type Size = Integer -type FileTuple = (CheckSums, Size, FilePath) - --- |A release file contains a list of indexes (Packages\/Sources). Each --- Package or Source index may appear multiple times because it may be --- compressed several different ways. This function will return an --- assoc list where the key is the name of the uncompressed package --- index name and the value is the list of (file, compression) which --- decompress to the key. -groupIndexes :: [FileTuple] -> [(FilePath, [(FileTuple, Compression)])] -groupIndexes indexFiles = - M.toList $ M.fromListWith combine $ map makeKV indexFiles - where - makeKV fileTuple@(_,_,fp) = - let (name, compressionMethod) = uncompressedName fp - in - (name, [(fileTuple, compressionMethod)]) - combine = (\x y -> sortBy (compare `on` snd) (x ++ y)) -{- - with t@(_,_,fp) m = - let (un, compression) = - in - M.insertWith --} - -{- -groupIndexes' :: String ->[FileTuple] -> [(FilePath, [(FileTuple, Compression)])] -groupIndexes' iType indexFiles = - M.toList (foldr (insertType iType) M.empty indexFiles) - where - insertType iType t@(_,_,fp) m = - case uncompressedName' iType fp of - Nothing -> m - (Just (un, compression)) -> - M.insertWith (\x y -> sortBy (compare `on` snd) (x ++ y)) un [(t, compression)] m --} - --- |The release file contains the checksums for the uncompressed --- package indexes, even if the uncompressed package indexes are not --- stored on the server. This function returns the list of files that --- actually exist. -filterExists :: FilePath -> (FilePath, [(FileTuple, Compression)]) -> IO (FilePath, [(FileTuple, Compression)]) -filterExists distDir (fp, alternatives) = - do e <- filterM ( \((_,_,fp),_) -> fileExist (distDir fp)) alternatives - -- when (null e) (error $ "None of these files exist: " ++ show alternatives) - return (fp, e) - -findIndexes :: FilePath -> String -> [FileTuple] -> IO [(FileTuple, Compression)] -findIndexes distDir iType controlFiles = - let indexes = groupIndexes controlFiles - in - do indexes' <- mapM (filterExists distDir) (filter (isType iType) indexes) - return $ map (head . snd) (filter (not . List.null . snd) indexes') - where - isType iType (fp, _) = iType `isSuffixOf` fp - -{- -findIndexes' :: FilePath -> String -> [FileTuple] -> IO [(FileTuple, Compression)] -findIndexes' distDir iType controlFiles = - let m = groupIndexes' iType controlFiles - in - do m' <- mapM (filterExists distDir) m - return $ map (head . snd) (filter (not . null . snd) m') --} - - -- insertType :: String -> (CheckSums, Integer, FilePath) -> M.Map FilePath ((CheckSums, Integer, FilePath), Compression) -> M.Map FilePath ((CheckSums, Integer, FilePath), Compression) - -{- -uncompressedName' :: String -> FilePath -> Maybe (FilePath, Compression) -uncompressedName' iType fp - | isSuffixOf iType fp = Just (fp, Uncompressed) - | isSuffixOf (iType ++".gz") fp = Just (reverse . (drop 3) . reverse $ fp, GZ) - | isSuffixOf (iType ++".bz2") fp = Just (reverse . (drop 4) . reverse $ fp, BZ2) - | otherwise = Nothing --} - -uncompressedName :: FilePath -> (FilePath, Compression) -uncompressedName fp - | isSuffixOf ".gz" fp = (reverse . (drop 3) . reverse $ fp, GZ) - | isSuffixOf ".bz2" fp = (reverse . (drop 4) . reverse $ fp, BZ2) - | otherwise = (fp, Uncompressed) - -indexesInRelease :: (FilePath -> Bool) - -> Control' Text -- ^ A release file - -> [(CheckSums, Integer, FilePath)] -- ^ -indexesInRelease filterp (Control [p]) = - -- In a release file we should find one or more of the fields - -- "SHA256", "SHA1", or "MD5Sum", each containing a list of triples - either error (filter (\(_,_,fp) -> filterp fp)) $ - msum [either Left (makeTuples makeSHA256) (maybe (Left "No SHA256 Field") makeTriples $ fieldValue "SHA256" p), - either Left (makeTuples makeSHA1) (maybe (Left "No SHA1 Field") makeTriples $ fieldValue "SHA1" p), - either Left (makeTuples makeMD5) (maybe (Left "No MD5Sum Field") makeTriples $ msum [fieldValue "MD5Sum" p, - fieldValue "Md5Sum" p, - fieldValue "MD5sum" p])] - where - makeSHA256 s = CheckSums {md5sum = Nothing, sha1 = Nothing, sha256 = Just s} - makeSHA1 s = CheckSums {md5sum = Nothing, sha1 = Just s, sha256 = Nothing} - makeMD5 s = CheckSums {md5sum = Just s, sha1 = Nothing, sha256 = Nothing} - - makeTuples :: (String -> CheckSums) -> [(Text, Text, Text)] -> Either String [(CheckSums, Integer, FilePath)] - makeTuples mk triples = - case partitionEithers (fmap (makeTuple mk) triples) of - ([], tuples) -> Right tuples - (s : _, _) -> Left s - - makeTuple :: (String -> CheckSums) -> (Text, Text, Text) -> Either String (CheckSums, Integer, FilePath) - makeTuple mk (sum, size, fp) = - (,,) <$> pure (mk (Text.unpack sum)) - <*> maybe (Left ("Invalid size field: " ++ show size)) Right (readMaybe (Text.unpack size)) - <*> pure (Text.unpack fp) - - makeTriples :: Text -> Either String [(Text, Text, Text)] - makeTriples t = case partitionEithers (map makeTriple (Text.lines t)) of - ([], xs) -> Right xs - (s : _, _) -> Left s - - makeTriple :: Text -> Either String (Text, Text, Text) - makeTriple t = case Text.words t of - [a, b, c] -> Right (a, b, c) - _ -> Left ("Invalid checksum line: " ++ show t) -indexesInRelease _ x = error $ "Invalid release file: " <> Text.unpack (Text.concat (formatControl x)) - --- |make a FileTuple for a file found on the local disk --- returns 'Nothing' if the file does not exist. -tupleFromFilePath :: FilePath -> FilePath -> IO (Maybe FileTuple) -tupleFromFilePath basePath fp = - do e <- fileExist (basePath fp) - if not e - then return Nothing - else do size <- getFileStatus (basePath fp) >>= return . fromIntegral . fileSize - md5 <- L.readFile (basePath fp) >>= return . show . MD5.md5 - sha1 <- L.readFile (basePath fp) >>= return . show . SHA.sha1 - sha256 <- L.readFile (basePath fp) >>= return . show . SHA.sha256 - return $ Just (CheckSums { md5sum = Just md5, sha1 = Just sha1, sha256 = Just sha256 }, size, fp) - --- |find the Contents-* files. These are not listed in the Release file -findContentsFiles :: (FilePath -> Bool) -> FilePath -> IO [FilePath] -findContentsFiles filterP distDir = - do files <- getDirectoryContents distDir - return $ filter filterP $ filter (isPrefixOf "Contents-" . takeBaseName) files diff --git a/Debian/Apt/Methods.hs b/Debian/Apt/Methods.hs deleted file mode 100644 --- a/Debian/Apt/Methods.hs +++ /dev/null @@ -1,486 +0,0 @@ -{-# LANGUAGE PackageImports #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-name-shadowing #-} --- |an interface for using the methods in /var/lib/apt/methods -module Debian.Apt.Methods - ( withMethodPath - , withMethodURI - , whichMethodPath - , openMethod - , closeMethod - , recvStatus - , sendCommand - , getLastModified - , simpleFetch - , fetch - , FetchCallbacks(..) - , emptyFetchCallbacks - , cliFetchCallbacks - , Command(..) - , Status(..) - , Message, Site, User, Password, Media, Drive, Header, ConfigItem - ) - where - -import Debian.Time -import Debian.URI - -import Control.Exception -import "mtl" Control.Monad.Error -import Data.Maybe -import Data.Time -import System.Directory -import System.Exit -import System.IO -import System.Posix.Files -import System.Process - -type MethodHandle = (Handle, Handle, Handle, ProcessHandle) - -capabilities, logMsg, status, uriStart, uriDone, uriFailure, generalFailure, authorizationRequired, mediaFailure, uriAcquire, configuration, authorizationCredentials, mediaChanged :: String -capabilities = "100" -logMsg = "101" -status = "102" -uriStart = "200" -uriDone = "201" -uriFailure = "400" -generalFailure = "401" -authorizationRequired = "402" -mediaFailure = "403" -uriAcquire = "600" -configuration = "601" -authorizationCredentials = "602" -mediaChanged = "603" - -type Message = String -type Site = String -type User = String -type Password = String -type Media = String -type Drive = String - -data Status - = Capabilities { version :: String, singleInstance :: Bool, preScan :: Bool, pipeline :: Bool, sendConfig :: Bool - , needsCleanup :: Bool, localOnly :: Bool } - | LogMsg Message - | Status URI Message - | URIStart { uri :: URI, size :: Maybe Integer, lastModified :: Maybe UTCTime, resumePoint :: Maybe Integer } - | URIDone { uri :: URI, size :: Maybe Integer, lastModified :: Maybe UTCTime, resumePoint :: Maybe Integer - , filename :: Maybe FilePath, hashes :: Hashes, imsHit :: Bool } - | URIFailure { uri :: URI, message :: Message } - | GeneralFailure Message - | AuthorizationRequired Site - | MediaFailure Media Drive - deriving (Show, Eq) - -data Hashes - = Hashes { md5 :: Maybe String - , sha1 :: Maybe String - , sha256 :: Maybe String - } - deriving (Show, Eq) - -emptyHashes = Hashes Nothing Nothing Nothing - -data Command - = URIAcquire URI FilePath (Maybe UTCTime) - | Configuration [ConfigItem] - | AuthorizationCredentials Site User Password - | MediaChanged Media (Maybe Bool) -- I don't really understand the Fail field, I am assuming it is 'Fail: true' - deriving (Show, Eq) - -type Header = (String, String) -type ConfigItem = (String, String) - -withMethodURI :: URI -> (MethodHandle -> IO a) -> IO a -withMethodURI uri f = - do mp <- liftM fromJust (whichMethodPath uri) - withMethodPath mp f - --- |withMethod - run |methodPath| bracketed with --- openMethod\/closeMethod. |f| gets the open handle. -withMethodPath :: FilePath -> (MethodHandle -> IO a) -> IO a -withMethodPath methodPath f = - bracket (openMethod methodPath) closeMethod $ f - --- |whichMethodBinary - find the method executable associated with a URI --- throws an exception on failure -whichMethodPath :: URI -> IO (Maybe FilePath) -whichMethodPath uri = - let scheme = init (uriScheme uri) - path = "/usr/lib/apt/methods/" ++ scheme - in - doesFileExist path >>= return . bool Nothing (Just path) - -{- -The flow of messages starts with the method sending out a -100 Capabilities and APT sending out a 601 Configuration. - -The flow is largely unsynchronized, but our function may have to -respond to things like authorization requests. Perhaps we do a -recvContents and then mapM_ over that ? Not all incoming messages -require a response, so... - --} - -parseStatus :: [String] -> Status -parseStatus [] = error "parseStatus" -parseStatus (code' : headers') = - parseStatus' (take 3 code') (map parseHeader headers') - where - parseStatus' code headers - | code == capabilities = - foldr updateCapability defaultCapabilities headers - where - updateCapability (a,v) c - | a == "Version" = c { version = v } - | a == "Single-Instance" = c { singleInstance = parseTrueFalse v } - | a == "Pre-Scan" = c { preScan = parseTrueFalse v } - | a == "Pipeline" = c { pipeline = parseTrueFalse v } - | a == "Send-Config" = c { sendConfig = parseTrueFalse v } - | a == "Needs-Cleanup" = c { needsCleanup = parseTrueFalse v } - | a == "Local-Only" = c { localOnly = parseTrueFalse v } - | otherwise = error $ "unknown capability: " ++ show (a,v) - defaultCapabilities = - Capabilities { version = "" - , singleInstance = False - , preScan = False - , pipeline = False - , sendConfig = False - , needsCleanup = False - , localOnly = False - } - parseStatus' code headers - | code == logMsg = - case headers of - [("Message", msg)] -> LogMsg msg - _ -> error "parseStatus'" - | code == status = - Status (fromJust $ parseURI $ fromJust $ lookup "URI" headers) (fromJust $ lookup "Message" headers) - | code == uriStart = - foldr updateUriStart (URIStart undefined Nothing Nothing Nothing) headers - where - updateUriStart (a,v) u - | a == "URI" = u { uri = fromJust $ parseURI v } - | a == "Size" = u { size = Just (read v) } - | a == "Last-Modified" = u { lastModified = parseTimeRFC822 v } -- if the date is unparseable, we silently truncate. Is that bad ? - | a == "Resume-Point" = u { resumePoint = Just (read v) } - updateUriStart _ _ = error "updateUriStart" - parseStatus' code headers - | code == uriDone = - foldr updateUriDone (URIDone undefined Nothing Nothing Nothing Nothing emptyHashes False) headers - where - updateUriDone (a,v) u - | a == "URI" = u { uri = fromJust $ parseURI v } - | a == "Size" = u { size = Just (read v) } - | a == "Last-Modified" = u { lastModified = parseTimeRFC822 v } -- if the date is unparseable, we silently truncate. Is that bad ? - | a == "Filename" = u { filename = Just v } - | a == "MD5Sum-Hash" = u { hashes = (hashes u) { md5 = Just v } } - | a == "MD5-Hash" = u { hashes = (hashes u) { md5 = Just v } } - | a == "SHA1-Hash" = u { hashes = (hashes u) { sha1 = Just v } } - | a == "SHA256-Hash" = u { hashes = (hashes u) { sha256 = Just v } } - | a == "Resume-Point" = u { resumePoint = Just (read v) } - | a == "IMS-Hit" && v == "true" = u { imsHit = True } - | otherwise = error $ "updateUriDone: unknown header: " ++ show (a,v) - parseStatus' code headers - | code == uriFailure = - URIFailure (fromJust $ parseURI $ fromJust $ lookup "URI" headers) (fromJust $ lookup "Message" headers) - | code == generalFailure = - GeneralFailure (fromJust $ lookup "Message" headers) - | code == authorizationRequired = - AuthorizationRequired (fromJust $ lookup "Site" headers) - | code == mediaFailure = - MediaFailure (fromJust $ lookup "Media" headers) (fromJust $ lookup "Drive" headers) - parseStatus' _ _ = error "parseStatus'" - -formatCommand :: Command -> [String] -formatCommand (URIAcquire uri filepath mLastModified) = - [ uriAcquire ++ " URI Acquire" - , "URI: " ++ uriToString' uri -- will this get credentials correct ? Or do we always pass those in seperately - , "FileName: " ++ filepath - ] ++ maybe [] (\lm -> ["Last-Modified: " ++ formatTimeRFC822 lm ]) mLastModified -formatCommand (Configuration configItems) = - (configuration ++ " Configuration") : (map formatConfigItem configItems) - where - formatConfigItem (a,v) = concat ["Config-Item: ", a, "=", v] -formatCommand (AuthorizationCredentials site user passwd) = - (authorizationCredentials ++ " Authorization Credentials") : - [ "Site: " ++ site - , "User: " ++ user - , "Password: " ++ passwd - ] -formatCommand (MediaChanged media mFail) = - [ mediaChanged ++ " Media Changed" - , "Media: " ++ media - ] ++ maybe [] (\b -> ["Fail: " ++ case b of True -> "true" ; False -> "false"]) mFail - - -parseTrueFalse :: String -> Bool -parseTrueFalse "true" = True -parseTrueFalse "false" = False -parseTrueFalse s = error $ "Invalid boolean string: " ++ s - - -recvStatus :: MethodHandle -> IO Status -recvStatus mh = liftM parseStatus $ recv mh - -sendCommand :: MethodHandle -> Command -> IO () -sendCommand mh cmd = sendMethod mh (formatCommand cmd) - - -parseHeader :: String -> Header -parseHeader str = - let (a, r) = span (/= ':') str - v = dropWhile (flip elem ": \t") r - in - (a, v) - -openMethod :: FilePath -> IO MethodHandle -openMethod methodBinary = - do - -- hPutStrLn stderr ("openMethod " ++ methodBinary) - runInteractiveCommand methodBinary - -- runInteractiveProcess methodBinary [] Nothing Nothing - -sendMethod :: MethodHandle -> [String] -> IO () -sendMethod (pIn, _pOut, _, _) strings = - do - -- hPutStrLn stderr "send:" - mapM_ put strings - hPutStrLn pIn "" - hFlush pIn - where - put line = - do - -- hPutStrLn stderr (" " ++ line) - hPutStrLn pIn line - -closeMethod :: MethodHandle -> IO ExitCode -closeMethod (pIn, pOut, pErr, handle) = - do - -- hPutStrLn stderr "closeMethod" - hClose pIn - hClose pOut - hClose pErr - waitForProcess handle - -recv :: MethodHandle -> IO [String] -recv (_pIn, pOut, _pErr, _pHandle) = - do - -- hPutStrLn stderr "recv:" - readTillEmptyLine pOut - where - readTillEmptyLine pOut = - do - line <- hGetLine pOut - case line of - "" -> return [] - line -> - do - -- hPutStrLn stderr (" " ++ line) - tail <- readTillEmptyLine pOut - return $ line : tail -{- -The flow of messages starts with the method sending out a -100 Capabilities and APT sending out a 601 Configuration. - -The flow is largely unsynchronized, but our function may have to -respond to things like authorization requests. Perhaps we do a -recvContents and then mapM_ over that ? Not all incoming messages -require a response. - -We probably also need to track state, for example, if we are -pipelining multiple downloads and want to show seperate progress bars -for each download. - -If someone wants to use fetch, they will need to provide methods to: - - 1. prompt for and provide authentication - 2. show progress - 3. show media change dialog - 4. Show log messages - 5. Show failures - 6. Send Configuration - -pipeline vs non-pipeline mode. -what if different methods are being used ? - -when pipelining, we probably don't want to have too many pipelines to -the same server. Perhaps there can be a limit, and for non-pipelinable -methods, we set the limit to 1. - -Each method can run in a seperate thread, since methods do not -interact with each other. In fact, each unique method+uri can be a -seperate thread. We can use a MVar to track the global max download -count. Perhaps we also want a per host throttle, since it is the host -connect that is likely to max out, not the access method. - -Plan: - -partition fetches by (host,method). -fork off threads for each (host, method). -Use MVar to throttle per host, and total connections - -We don't know if a method supports pipelining until we connect atleast -once. So if we have a non-pipelined method, we might want to start -multiple streams. On the other hand, for something like a CDROM, that -will just cause the system to thrash. - -cdrom, file, etc, don't have a host, so that is not a unique key then. -Pipelining on local methods is tricky, because it is hard to tell if -the local methods point to the same device or not. - -Even though we have multiple threads, the interactor can view the -incoming Stream as a single Stream because all the events are tagged -with the URI (i think). But, sending commands involves a fancy -router. We could include a reference to corresponding command for each -stream. - -For now, let's serialize the transfers, but allow pipeling for methods -that really allow pipelining. - --} - -data FetchCallbacks - = FetchCallbacks { logCB :: Message -> IO () - , statusCB :: URI -> Message -> IO () - , uriStartCB :: URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> IO () - , uriDoneCB :: URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> Maybe FilePath -> Hashes -> Bool -> IO () - , uriFailureCB :: URI -> Message -> IO () - , generalFailureCB :: Message -> IO () - , authorizationRequiredCB :: Site -> IO (Maybe (User, Password)) - , mediaFailureCB :: Media -> Drive -> IO () - , debugCB :: String -> IO () - } - -simpleFetch :: [ConfigItem] -> URI -> FilePath -> Maybe UTCTime -> IO Bool -simpleFetch = fetch cliFetchCallbacks - --- |fetch a single item, show console output --- see also: getLastModified -fetch :: FetchCallbacks -> [ConfigItem] -> URI -> FilePath -> Maybe UTCTime -> IO Bool -fetch cb configItems uri fp lastModified = - do withMethodURI uri $ \mh -> - do s <- recvStatus mh - debugCB cb ("<- " ++ show s) - sendCommand' mh (URIAcquire uri fp lastModified) - loop mh - where - sendCommand' mh c = - do mapM_ (debugCB cb . ("-> " ++)) (formatCommand c) - sendCommand mh c - loop mh = - do r <- recvStatus mh - case r of - Capabilities {} -> - do unless (null configItems) (sendCommand' mh (Configuration configItems)) - loop mh - LogMsg m -> - do logCB cb m - loop mh - Status uri m -> - do statusCB cb uri m - loop mh - URIStart uri size lastModified resumePoint -> - uriStartCB cb uri size lastModified resumePoint >> loop mh - URIDone uri size lastModified resumePoint filename hashes imsHit -> - uriDoneCB cb uri size lastModified resumePoint filename hashes imsHit >> return True - URIFailure uri message -> - uriFailureCB cb uri message >> return False - GeneralFailure m -> generalFailureCB cb m >> return False - AuthorizationRequired site -> - do mCredentials <- authorizationRequiredCB cb site - case mCredentials of - Nothing -> return False -- FIXME: do we need a force close option for closeMethod ? - Just (user, passwd) -> - do sendCommand' mh (AuthorizationCredentials site user passwd) - loop mh - MediaFailure media drive -> - do mediaFailureCB cb media drive - return False - --- |set of callbacks which do nothing. --- suitable for non-interactive usage. In the case authorization is --- required, no credentials will be supplied and the download should --- abort. -emptyFetchCallbacks = - FetchCallbacks { logCB = \ _m -> return () - , statusCB = \ _uri _m -> return () - , uriStartCB = \ _uri _size _lastModified _resumePoint -> return () - , uriDoneCB = \ _uri _size _lastModified _resumePoint _filename _hashes _imsHit -> return () - , uriFailureCB = \ _uri _message -> return () - , generalFailureCB = \ _m -> return () - , authorizationRequiredCB = \ _site -> return Nothing - , mediaFailureCB = \ _media _drive -> return () - , debugCB = \ _m -> return () - } - -cliFetchCallbacks = - emptyFetchCallbacks { statusCB = \uri m -> putStrLn $ uriToString' uri ++ " : " ++ m - , uriStartCB = \ uri _size lastModified _resumePoint -> putStrLn $ uriToString' uri ++ " started. " ++ show lastModified - , uriDoneCB = \uri _size _lastModified _resumePoint _filename _hashes imsHit -> putStrLn $ uriToString' uri ++ (if imsHit then " cached." else " downloaded.") - , uriFailureCB = \uri message -> hPutStrLn stderr $ "URI Failure: " ++ uriToString' uri ++ " : " ++ message - , generalFailureCB = \message -> hPutStrLn stderr $ "General Failure: " ++ message - , authorizationRequiredCB = \site -> - do putStrLn $ "Authorization Required for " ++ site - putStrLn "Username: " >> hFlush stdout - user <- getLine - putStrLn "Password: " >> hFlush stdout - passwd <- getLine -- TODO: write a getPasswd function which does not echo input - return (Just (user, passwd)) - , mediaFailureCB = \media drive -> hPutStrLn stderr $ "Media Failure: media=" ++ media ++" drive="++ drive - , debugCB = \m -> print m - } - -{- - FetchCallbacks { logCB = \m -> hPutStrLn stderr m - , statusCB = \uri m -> putStrLn (show uri ++" : "++ m) - , uriStartCB = \uri - } - -defaultAuthenticate site = - do putStrLn $ "Authorization Required for " ++ site - putStrLn "Username: " >> hFlush stdout - user <- getLine - putStrLn "Password: " >> hFlush stdout - passwd <- getLine -- TODO: write a getPasswd function which does not echo input - return (user, passwd) --} - -{- - let itemsByHost = groupOn (regName . fst) items - in - do totalQSem <- newQSem 16 -- max number of streams allowed for - forkIO - where - regName = fmap uriRegName . uriAuthority - withQSem :: QSem -> IO a -> IO a - withQSem qSem f = bracket (waitQSem qSem) (const $ signalQSem qSem) (const f) - -uris = map (fromJust . parseURI) [ "http://n-heptane.com/whee" - , "file:/one/two/three" - , "ssh://jeremy:aoeu@n-heptane.com" - , "cdrom:/one" - ] --} - --- * Misc Helper Functions - -bool :: a -> a -> Bool -> a -bool f _ False = f -bool _ t True = t - - -getLastModified :: FilePath -> IO (Maybe UTCTime) -getLastModified fp = - do e <- doesFileExist fp - if e - then getFileStatus fp >>= return . Just . epochTimeToUTCTime . modificationTime - else return Nothing - -{- -groupOn :: (Ord b) => (a -> b) -> [a] -> [[a]] -groupOn f = groupBy ((==) `on` f) . sortBy (compare `on` f) - -on :: (a -> a -> b) -> (c -> a) -> c -> c -> b -on f g x y = f (g x) (g y) --} diff --git a/Debian/Apt/Package.hs b/Debian/Apt/Package.hs deleted file mode 100644 --- a/Debian/Apt/Package.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- |Functions for dealing with source and binary packages in an abstract-way -module Debian.Apt.Package where - --- Standard GHC Modules - -import qualified Data.Map as Map - --- Local Modules - -import Debian.Version -import Debian.Relation - -type PackageNameMap a = Map.Map BinPkgName [a] - --- |'packageNameMap' creates a map from a package name to all the versions of that package --- NOTE: Provides are not included in the map --- NOTE: the sort order is random -- this is perhaps a bug --- see also: 'addProvides' -packageNameMap :: (a -> BinPkgName) -> [a] -> PackageNameMap a -packageNameMap getName packages = foldl (\m p -> Map.insertWith (++) (getName p) [p] m) Map.empty packages - --- |'addProvides' finds packages that Provide other packages and adds --- them to the PackageNameMap. They will be adde to the end of the --- list, so that real packages have 'higher priority' than virtual --- packages. --- NOTE: Does not check for duplication or multiple use -addProvides :: (p -> [BinPkgName]) -> [p] -> PackageNameMap p -> PackageNameMap p -addProvides providesf ps pnm = - let provides = findProvides providesf ps in - foldl (\m (packageName, package) -> Map.insertWith (flip (++)) packageName [package] m) pnm provides - --- |'findProvides' -findProvides :: forall p. (p -> [BinPkgName]) -> [p] -> [(BinPkgName, p)] -findProvides providesf packages = foldl addProvides' [] packages - where addProvides' :: [(BinPkgName, p)] -> p -> [(BinPkgName, p)] - addProvides' providesList package = - foldl (\pl pkgName -> (pkgName, package): pl) providesList (providesf package) - --- |'lookupPackageByRel' returns all the packages that satisfy the specified relation --- TODO: Add architecture check -lookupPackageByRel :: PackageNameMap a -> (a -> (BinPkgName, DebianVersion)) -> Relation -> [a] -lookupPackageByRel pm packageVersionF (Rel pkgName mVerReq _mArch) = - case Map.lookup pkgName pm of - Nothing -> [] - Just packages -> filter filterVer packages - where filterVer p = - case mVerReq of - Nothing -> True - Just _verReq -> - let (pName, pVersion) = packageVersionF p - in if pName /= pkgName - then False -- package is a virtual package, hence we can not do a version req - else checkVersionReq mVerReq (Just pVersion) diff --git a/Debian/Arch.hs b/Debian/Arch.hs deleted file mode 100644 --- a/Debian/Arch.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -module Debian.Arch - ( Arch(..) - , ArchOS(..) - , ArchCPU(..) - , prettyArch - , parseArch - ) where - -import Data.Data (Data) -import Data.Monoid ((<>)) -import Data.Typeable (Typeable) -import Text.PrettyPrint (Doc, text) - -data ArchOS = ArchOS String | ArchOSAny deriving (Eq, Ord, Read, Show, Data, Typeable) - -prettyOS :: ArchOS -> Doc -prettyOS (ArchOS s) = text s -prettyOS ArchOSAny = text "any" - -parseOS :: String -> ArchOS -parseOS "any" = ArchOSAny -parseOS s = ArchOS s - -data ArchCPU = ArchCPU String | ArchCPUAny deriving (Eq, Ord, Read, Show, Data, Typeable) - -prettyCPU :: ArchCPU -> Doc -prettyCPU (ArchCPU s) = text s -prettyCPU ArchCPUAny = text "any" - -parseCPU :: String -> ArchCPU -parseCPU "any" = ArchCPUAny -parseCPU s = ArchCPU s - -data Arch - = Source - | All - | Binary ArchOS ArchCPU - deriving (Eq, Ord, Read, Show, Data, Typeable) - -prettyArch :: Arch -> Doc -prettyArch Source = text "source" -prettyArch All = text "all" -prettyArch (Binary (ArchOS "linux") cpu) = prettyCPU cpu -prettyArch (Binary os cpu) = prettyOS os <> text "-" <> prettyCPU cpu - -parseArch :: String -> Arch -parseArch s = - case span (/= '-') s of - ("source", "") -> Source - ("all", "") -> All - (cpu, "") -> Binary (ArchOS "linux") (parseCPU cpu) - (os, '-' : cpu) -> Binary (parseOS os) (parseCPU cpu) - _ -> error "parseArch: internal error" diff --git a/Debian/Changes.hs b/Debian/Changes.hs deleted file mode 100644 --- a/Debian/Changes.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-missing-signatures #-} --- |Changelog and changes file support. -module Debian.Changes - ( ChangesFile(..) - , ChangedFileSpec(..) - , changesFileName - , ChangeLog(..) - , ChangeLogEntry(..) - , parseChangeLog - , parseEntries -- was parseLog - , parseEntry - , parseChanges - ) where - -import Data.Either (partitionEithers) -import Data.List (intercalate, intersperse) -import Data.Monoid ((<>)) -import Data.Text (Text, pack, unpack, strip) -import Debian.Arch (Arch, prettyArch) -import qualified Debian.Control.String as S -import Debian.Pretty (PP(..)) -import Debian.Release -import Debian.URI() -import Debian.Version -import System.Posix.Types -import Text.Regex.TDFA hiding (empty) -import Text.PrettyPrint (Doc, text, hcat, render) -import Text.PrettyPrint.HughesPJClass (Pretty(pPrint)) - --- |A file generated by dpkg-buildpackage describing the result of a --- package build -data ChangesFile = - Changes { changeDir :: FilePath -- ^ The full pathname of the directory holding the .changes file. - , changePackage :: String -- ^ The package name parsed from the .changes file name - , changeVersion :: DebianVersion -- ^ The version number parsed from the .changes file name - , changeRelease :: ReleaseName -- ^ The Distribution field of the .changes file - , changeArch :: Arch -- ^ The architecture parsed from the .changes file name - , changeInfo :: S.Paragraph' Text -- ^ The contents of the .changes file - , changeEntry :: ChangeLogEntry -- ^ The value of the Changes field of the .changes file - , changeFiles :: [ChangedFileSpec] -- ^ The parsed value of the Files attribute - } deriving (Eq, Read, Show) - --- |An entry in the list of files generated by the build. -data ChangedFileSpec = - ChangedFileSpec { changedFileMD5sum :: String - , changedFileSHA1sum :: String - , changedFileSHA256sum :: String - , changedFileSize :: FileOffset - , changedFileSection :: SubSection - , changedFilePriority :: String - , changedFileName :: FilePath - } deriving (Eq, Read, Show) - --- |A changelog is a series of ChangeLogEntries -data ChangeLogEntry = - Entry { logPackage :: String -- FIXME: Should be a SrcPkgName - , logVersion :: DebianVersion - , logDists :: [ReleaseName] - , logUrgency :: String - , logComments :: String - , logWho :: String - , logDate :: String - } - | WhiteSpace String -- ^ The parser here never returns this - deriving (Eq, Read, Show) - -newtype ChangeLog = ChangeLog [ChangeLogEntry] deriving (Eq, Read, Show) - -{- -instance Show ChangesFile where - show = changesFileName --} - -changesFileName :: ChangesFile -> String -changesFileName = render . pPrint . PP - -instance Pretty (PP ChangesFile) where - pPrint (PP changes) = text (changePackage changes ++ "_") <> prettyDebianVersion (changeVersion changes) <> text "_" <> prettyArch (changeArch changes) <> text ".changes" - -instance Pretty (PP ChangedFileSpec) where - pPrint (PP file) = - text (changedFileMD5sum file <> " " <> - show (changedFileSize file) <> " " <> - sectionName (changedFileSection file) <> " " <> - changedFilePriority file <> " " <> - changedFileName file) - -instance Pretty (PP ChangeLogEntry) where - pPrint (PP (Entry package ver dists urgency details who date)) = - hcat [ text package <> text " (" <> prettyDebianVersion ver <> text (") " <> intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency) - , text "\n\n" - , text " " <> text (strip' details) - , text "\n\n" - , text (" -- " <> who <> " " <> date) - , text "\n" ] - pPrint (PP (WhiteSpace _)) = error "instance Pretty ChangeLogEntry" - -instance Pretty (PP [ChangeLogEntry]) where - pPrint = hcat . intersperse (text "\n") . map (pPrint . PP) . unPP - -strip' = unpack . strip . pack - -instance Pretty (PP ChangeLog) where - pPrint (PP (ChangeLog xs)) = hcat (intersperse (text "\n") (map (pPrint . PP) xs)) - --- |Show just the top line of a changelog entry (for debugging output.) -_showHeader :: ChangeLogEntry -> Doc -_showHeader (Entry package ver dists urgency _ _ _) = - text (package <> " (") <> prettyDebianVersion ver <> text (") " <> intercalate " " (map releaseName' dists) <> "; urgency=" <> urgency <> "...") -_showHeader (WhiteSpace _) = error "_showHeader" - -{- -format is a series of entries like this: - - package (version) distribution(s); urgency=urgency - [optional blank line(s), stripped] - * change details - more change details - [blank line(s), included in output of dpkg-parsechangelog] - * even more change details - [optional blank line(s), stripped] - -- maintainer name [two spaces] date - -package and version are the source package name and version number. - -distribution(s) lists the distributions where this version should be -installed when it is uploaded - it is copied to the Distribution field -in the .changes file. See Distribution, Section 5.6.14. - -urgency is the value for the Urgency field in the .changes file for -the upload (see Urgency, Section 5.6.17). It is not possible to -specify an urgency containing commas; commas are used to separate -keyword=value settings in the dpkg changelog format (though there is -currently only one useful keyword, urgency). - -The change details may in fact be any series of lines starting with at -least two spaces, but conventionally each change starts with an -asterisk and a separating space and continuation lines are indented so -as to bring them in line with the start of the text above. Blank lines -may be used here to separate groups of changes, if desired. - -If this upload resolves bugs recorded in the Bug Tracking System -(BTS), they may be automatically closed on the inclusion of this -package into the Debian archive by including the string: closes: -Bug#nnnnn in the change details.[16] This information is conveyed via -the Closes field in the .changes file (see Closes, Section 5.6.22). - -The maintainer name and email address used in the changelog should be -the details of the person uploading this version. They are not -necessarily those of the usual package maintainer. The information -here will be copied to the Changed-By field in the .changes file (see -Changed-By, Section 5.6.4), and then later used to send an -acknowledgement when the upload has been installed. - -The date must be in RFC822 format[17]; it must include the time zone -specified numerically, with the time zone name or abbreviation -optionally present as a comment in parentheses. - -The first "title" line with the package name must start at the left -hand margin. The "trailer" line with the maintainer and date details -must be preceded by exactly one space. The maintainer details and the -date must be separated by exactly two spaces. - -The entire changelog must be encoded in UTF-8. --} - --- | Parse the entries of a debian changelog and verify they are all --- valid. -parseChangeLog :: String -> Either [[String]] ChangeLog -parseChangeLog s = - case partitionEithers (parseEntries s) of - ([], xs) -> Right (ChangeLog xs) - (ss, _) -> Left ss - --- |Parse a Debian Changelog and return a lazy list of entries -parseEntries :: String -> [Either [String] ChangeLogEntry] -parseEntries "" = [] -parseEntries text = - case parseEntry text of - Left messages -> [Left messages] - Right (entry, text') -> Right entry : parseEntries text' - --- |Parse a single changelog entry, returning the entry and the remaining text. -parseEntry :: String -> Either [String] (ChangeLogEntry, String) -parseEntry text = - case text =~ entryRE :: MatchResult String of - x | mrSubList x == [] -> Left ["Parse error in " ++ show text] - MR {mrAfter = after, mrSubList = [_, name, ver, dists, urgency, _, details, _, _, who, _, date, _]} -> - Right (Entry name - (parseDebianVersion' ver) - (map parseReleaseName . words $ dists) - urgency - (" " ++ unpack (strip (pack details)) ++ "\n") - (take (length who - 2) who) - date, - after) - MR {mrBefore = _before, mrMatch = _matched, mrAfter = after, mrSubList = matches} -> - Left ["Internal error\n after=" ++ show after ++ "\n " ++ show (length matches) ++ " matches: " ++ show matches] - -entryRE = bol ++ blankLines ++ headerRE ++ changeDetails ++ signature ++ blankLines -changeDetails = "((\n| \n| -\n|([^ ]| [^--]| -[^--])[^\n]*\n)*)" -signature = " -- ([ ]*([^ ]+ )* )([^\n]*)\n" - --- |Parse the changelog information that shows up in the .changes --- file, i.e. a changelog entry with no signature. -parseChanges :: Text -> Maybe ChangeLogEntry -parseChanges text = - case unpack text =~ changesRE :: MatchResult String of - MR {mrSubList = []} -> Nothing - MR {mrSubList = [_, name, ver, dists, urgency, _, details]} -> - Just $ Entry name - (parseDebianVersion' ver) - (map parseReleaseName . words $ dists) - urgency - details - "" "" - MR {mrSubList = x} -> error $ "Unexpected match: " ++ show x - where - changesRE = bol ++ blankLines ++ optWhite ++ headerRE ++ "(.*)$" - -headerRE = - package ++ ver ++ dists ++ urgency - where - package = "([^ \t(]*)" ++ optWhite - ver = "\\(([^)]*)\\)" ++ optWhite - dists = "([^;]*);" ++ optWhite - urgency = "urgency=([^\n]*)\n" ++ blankLines - -blankLines = blankLine ++ "*" -blankLine = "(" ++ optWhite ++ "\n)" -optWhite = "[ \t]*" -bol = "^" - --- This can be used for tests -_s1 = unlines - ["haskell-regex-compat (0.92-3+seereason1~jaunty4) jaunty-seereason; urgency=low", - "", - " [ Joachim Breitner ]", - " * Adjust priority according to override file", - " * Depend on hscolour (Closes: #550769)", - "", - " [ Marco Túlio Gontijo e Silva ]", - " * debian/control: Use more sintetic name for Vcs-Darcs.", - " * Built from sid apt pool", - " * Build dependency changes:", - " cpphs: 1.9-1+seereason1~jaunty5 -> 1.9-1+seereason1~jaunty6", - " ghc6: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", - " ghc6-doc: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", - " ghc6-prof: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", - " haddock: 2.4.2-3+seereason3~jaunty1 -> 6.12.1-0+seereason1~jaunty1", - " haskell-devscripts: 0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1", - " haskell-regex-base-doc: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", - " haskell-regex-posix-doc: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", - " libghc6-regex-base-dev: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", - " libghc6-regex-base-prof: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", - " libghc6-regex-posix-dev: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", - " libghc6-regex-posix-prof: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", - "", - " -- SeeReason Autobuilder Fri, 25 Dec 2009 01:55:37 -0800", - "", - "haskell-regex-compat (0.92-3) unstable; urgency=low", - "", - " [ Joachim Breitner ]", - " * Adjust priority according to override file", - " * Depend on hscolour (Closes: #550769)", - "", - " [ Marco Túlio Gontijo e Silva ]", - " * debian/control: Use more sintetic name for Vcs-Darcs.", - "", - " -- Joachim Breitner Mon, 20 Jul 2009 13:05:35 +0200", - "", - "haskell-regex-compat (0.92-2) unstable; urgency=low", - "", - " * Adopt package for the Debian Haskell Group", - " * Fix \"FTBFS with new dpkg-dev\" by adding comma to debian/control", - " (Closes: #536473)", - "", - " -- Joachim Breitner Mon, 20 Jul 2009 12:05:40 +0200", - "", - "haskell-regex-compat (0.92-1.1) unstable; urgency=low", - "", - " * Rebuild for GHC 6.10.", - " * NMU with permission of the author.", - "", - " -- John Goerzen Mon, 16 Mar 2009 10:12:04 -0500", - "", - "haskell-regex-compat (0.92-1) unstable; urgency=low", - "", - " * New upstream release", - " * debian/control:", - " - Bump Standards-Version. No changes needed.", - "", - " -- Arjan Oosting Sun, 18 Jan 2009 00:05:02 +0100", - "", - "haskell-regex-compat (0.91-1) unstable; urgency=low", - "", - " * Take over package from Ian, as I already maintain haskell-regex-base,", - " and move Ian to the Uploaders field.", - " * Packaging complete redone (based on my haskell-regex-base package).", - "", - " -- Arjan Oosting Sat, 19 Jan 2008 16:48:39 +0100", - "", - "haskell-regex-compat (0.71.0.1-1) unstable; urgency=low", - " ", - " * Initial release (used to be part of ghc6).", - " * Using \"Generic Haskell cabal library packaging files v9\".", - " ", - " -- Ian Lynagh (wibble) Wed, 21 Nov 2007 01:26:57 +0000"] diff --git a/Debian/Control.hs b/Debian/Control.hs deleted file mode 100644 --- a/Debian/Control.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- |A module for working with Debian control files -module Debian.Control - ( -- * Types - Control'(..) - , Paragraph'(..) - , Field'(..) - , Control - , Paragraph - , Field - , ControlParser - , ControlFunctions(..) - -- * Control File Parser - , pControl - -- * Helper Functions - , mergeControls - , fieldValue - , removeField - , prependFields - , appendFields - , renameField - , modifyField - , raiseFields - , packParagraph - , packField - , formatControl - , formatParagraph - , formatField - -- * Policy classes and functions - , P.HasDebianControl(..) - , P.ControlFileError(..) - , P.parseDebianControlFromFile - , P.validateDebianControl - , P.unsafeDebianControl - , P.debianSourceParagraph - , P.debianBinaryParagraphs - , P.debianPackageParagraphs - , P.debianPackageNames - , P.debianSourcePackageName - , P.debianBinaryPackageNames - , P.debianRelations - , P.debianBuildDeps - , P.debianBuildDepsIndep - ) where - ---import Control.Monad ---import Data.List ---import Text.ParserCombinators.Parsec ---import System.IO -import Debian.Control.Common -import Debian.Control.String -import Data.List -import Data.Text as T (Text, pack, concat) -import qualified Debian.Control.Builder () -import qualified Debian.Control.Text as T -import qualified Debian.Control.TextLazy as TL -import qualified Debian.Control.ByteString as B () -import qualified Debian.Control.Policy as P -import qualified Debian.Control.String as S - -packParagraph :: S.Paragraph -> T.Paragraph -packParagraph (S.Paragraph s) = T.Paragraph (map packField s) - -packField :: Field' String -> Field' Text -packField (S.Field (name, value)) = T.Field (T.pack name, T.pack value) -packField (S.Comment s) = T.Comment (T.pack s) - -formatControl :: Control' Text -> [Text] -formatControl (T.Control paragraphs) = intersperse (T.pack "\n") . map formatParagraph $ paragraphs - -formatParagraph :: Paragraph' Text -> Text -formatParagraph (T.Paragraph fields) = T.concat . map formatField $ fields - -formatField :: Field' Text -> Text -formatField (T.Field (name, value)) = T.concat [name, T.pack ":", value, T.pack "\n"] -formatField (T.Comment s) = s diff --git a/Debian/Control/Builder.hs b/Debian/Control/Builder.hs deleted file mode 100644 --- a/Debian/Control/Builder.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} -module Debian.Control.Builder - ( -- * Types - Control'(..) - , Paragraph'(..) - , Field'(..) - , Control - , Paragraph - , Field - -- , ControlParser - , ControlFunctions(..) - -- * Control File Parser - -- , pControl - -- * Helper Functions - , mergeControls - , fieldValue - , removeField - , prependFields - , appendFields - , renameField - , modifyField - , raiseFields - , decodeControl - , decodeParagraph - , decodeField - ) where - -import qualified Data.ByteString.Char8 as B -import Data.Char (toLower, chr) -import Data.List (find) -import qualified Data.ListLike as LL -import Data.ListLike.Text.Builder () -import qualified Data.Text as T (pack, unpack, map, reverse) -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder (Builder, fromLazyText, fromText, toLazyText) -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) ---import Data.Text.IO as T (readFile) -import qualified Debian.Control.ByteString as B ---import Text.Parsec.Error (ParseError) ---import Text.Parsec.Text (Parser) ---import Text.Parsec.Prim (runP) -import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, asString), - Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment), - mergeControls, fieldValue, removeField, prependFields, appendFields, - renameField, modifyField, raiseFields, protectFieldText') - --- | @parseFromFile p filePath@ runs a string parser @p@ on the --- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError' --- ('Left') or a value of type @a@ ('Right'). --- --- > main = do{ result <- parseFromFile numbers "digits.txt" --- > ; case result of --- > Left err -> print err --- > Right xs -> print (sum xs) --- > } -{- -parseFromFile :: Parser a -> String -> IO (Either ParseError a) -parseFromFile p fname - = do input <- T.readFile fname `E.catch` (\ (_ :: E.SomeException) -> B.readFile fname >>= return . decode) - return (runP p () fname input) --} - -type Field = Field' Builder -type Control = Control' Builder -type Paragraph = Paragraph' Builder - -decodeControl :: B.Control -> Control -decodeControl (B.Control paragraphs) = Control (map decodeParagraph paragraphs) - -decodeParagraph :: B.Paragraph -> Paragraph -decodeParagraph (B.Paragraph s) = B.Paragraph (map decodeField s) - -decodeField :: Field' B.ByteString -> Field' Builder -decodeField (B.Field (name, value)) = Field (decode name, decode value) -decodeField (B.Comment s) = Comment (decode s) - -decode :: B.ByteString -> Builder -decode = fromText . decodeUtf8With (\ _ w -> fmap (chr . fromIntegral) w) - --- * ControlFunctions - -instance ControlFunctions Builder where - parseControlFromFile filepath = - -- The ByteString parser is far more efficient than the Text - -- parser. By calling decodeControl we tell the compiler to - -- use it instead. - parseControlFromFile filepath >>= return . either Left (Right . decodeControl) - parseControlFromHandle sourceName handle = - parseControlFromHandle sourceName handle >>= return . either Left (Right . decodeControl) - parseControl sourceName c = - -- Warning: This is very slow, it does a utf8 round trip - either Left (Right . decodeControl) (parseControl sourceName (encodeUtf8 (toStrict (toLazyText c)))) - lookupP fieldName (Paragraph paragraph) = - find (hasFieldName (map toLower fieldName)) paragraph - where hasFieldName :: String -> Field' Builder -> Bool - hasFieldName name (Field (fieldName',_)) = name == LL.map toLower (LL.toString fieldName') - hasFieldName _ _ = False - stripWS = dropAround (`elem` (" \t" :: String)) - -- T.strip would also strip newlines - protectFieldText = protectFieldText' - asString = LL.toString - -dropAround p = LL.dropWhile p . LL.dropWhileEnd p - --- * Control File Parser -{- --- type ControlParser = GenParser T.Text -type ControlParser a = Parsec T.Text () a - --- |A parser for debian control file. This parser handles control files --- that end without a newline as well as ones that have several blank --- lines at the end. It is very liberal and does not attempt validate --- the fields in any way. All trailing, leading, and folded whitespace --- is preserved in the field values. See 'stripWS'. -pControl :: ControlParser Control -pControl = - do many $ char '\n' - sepEndBy pParagraph pBlanks >>= return . Control - -pParagraph :: ControlParser Paragraph -pParagraph = many1 (pComment <|> pField) >>= return . Paragraph - --- |We are liberal in that we allow *any* field to have folded white --- space, even though the specific restricts that to a few fields. -pField :: ControlParser Field -pField = - do c1 <- noneOf "#\n" - fieldName <- many1 $ noneOf ":\n" - char ':' - fieldValue <- many fcharfws - (char '\n' >> return ()) <|> eof - return $ Field (T.cons c1 (T.pack fieldName), T.pack fieldValue) - -pComment :: ControlParser Field -pComment = - do char '#' - text <- many (satisfy (not . ((==) '\n'))) - char '\n' - return $ Comment (T.pack ("#" <> text <> "\n")) - -fcharfws :: ControlParser Char -fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') - -fchar :: ControlParser Char -fchar = satisfy (/='\n') - -_fws :: ControlParser T.Text -_fws = - try $ do char '\n' - ws <- many1 (char ' ') - c <- many1 (satisfy (not . ((==) '\n'))) - return $ T.cons '\n' (T.pack ws <> T.pack c) - --- |We go with the assumption that 'blank lines' mean lines that --- consist of entirely of zero or more whitespace characters. -pBlanks :: ControlParser T.Text -pBlanks = - do s <- many1 (oneOf " \n") - return . T.pack $ s --} diff --git a/Debian/Control/ByteString.hs b/Debian/Control/ByteString.hs deleted file mode 100644 --- a/Debian/Control/ByteString.hs +++ /dev/null @@ -1,289 +0,0 @@ -{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses, PackageImports, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -module Debian.Control.ByteString - ( Control'(..) - , Paragraph'(..) - , Field'(..) - , Control - , Paragraph - , Field - , ControlFunctions(..) - -- * Helper Functions - , mergeControls - , fieldValue - , removeField - , prependFields - , appendFields - , renameField - , modifyField - , raiseFields - ) where - --- Standard GHC modules - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative(..)) -#endif -import Control.Applicative (Alternative(..)) -import qualified Control.Exception as E -import "mtl" Control.Monad.State - -import Data.Char(toLower, isSpace, chr, ord) -import Data.Word (Word8) -import Data.List -import qualified Data.ListLike as LL -import qualified Data.ListLike.String as LL - -import Text.ParserCombinators.Parsec.Error -import Text.ParserCombinators.Parsec.Pos - --- Third Party Modules - -import qualified Data.ByteString.Char8 as C - -import Debian.Control.Common hiding (protectFieldText') - --- Local Modules - --- import ByteStreamParser - --- * Types -{- -newtype Control = Control [Paragraph] -newtype Paragraph = Paragraph [Field] -newtype Field = Field (C.ByteString, C.ByteString) --} - -type Control = Control' C.ByteString -type Paragraph = Paragraph' C.ByteString -type Field = Field' C.ByteString --- * Control Parser - -type ControlParser a = Parser C.ByteString a - -pKey :: ControlParser C.ByteString -pKey = notEmpty $ pTakeWhile (\c -> (c /= ':') && (c /= '\n')) - -pValue :: ControlParser C.ByteString -pValue = Parser $ \bs -> - let newlines = C.elemIndices '\n' bs - rest = dropWhile continuedAfter newlines ++ [C.length bs] - continuedAfter i = bs `safeIndex` (i+1) `elem` map Just " \t#" - (text, bs') = C.splitAt (head rest) bs - in Ok (text, bs') - -pField :: ControlParser Field -pField = - do k <- pKey - _ <- pChar ':' - v <- pValue --- pChar '\n' - (pChar '\n' >> return ()) <|> pEOF - return (Field (k,v)) - -pComment :: ControlParser Field -pComment = Parser $ \bs -> - let newlines = C.elemIndices '\n' bs - linestarts = 0 : map (+1) newlines - rest = dropWhile commentAt linestarts ++ [C.length bs] - commentAt i = bs `safeIndex` i == Just '#' - (text, bs') = C.splitAt (head rest) bs - in if C.null text - then Empty - else Ok (Comment text, bs') - -pParagraph :: ControlParser Paragraph -pParagraph = - do f <- pMany1 (pComment <|> pField) - pSkipMany (pChar '\n') - return (Paragraph f) - -pControl :: ControlParser Control -pControl = - do pSkipMany (pChar '\n') - c <- pMany pParagraph - return (Control c) - - --- parseControlFromFile :: FilePath -> IO (Either String Control) - -instance ControlFunctions C.ByteString where - parseControlFromFile fp = - do c <- C.readFile fp - case parse pControl c of - Nothing -> return (Left (newErrorMessage (Message ("Failed to parse " ++ fp)) (newPos fp 0 0))) - (Just (cntl,_)) -> return (Right cntl) - parseControlFromHandle sourceName handle = - E.try (C.hGetContents handle) >>= - either (\ (e :: E.SomeException) -> error ("parseControlFromHandle ByteString: Failure parsing " ++ sourceName ++ ": " ++ show e)) (return . parseControl sourceName) - parseControl sourceName c = - do case parse pControl c of - Nothing -> Left (newErrorMessage (Message ("Failed to parse " ++ sourceName)) (newPos sourceName 0 0)) - Just (cntl,_) -> Right cntl - lookupP fieldName (Paragraph fields) = - let pFieldName = C.pack (map toLower fieldName) in - find (\ (Field (fieldName',_)) -> C.map toLower fieldName' == pFieldName) fields - -- NOTE: probably inefficient - stripWS = C.reverse . strip . C.reverse . strip - where strip = C.dropWhile (flip elem " \t") - protectFieldText = protectFieldText' - asString = C.unpack - -protectFieldText' :: (LL.StringLike a, LL.ListLike a Word8) => ControlFunctions a => a -> a -protectFieldText' s = - case LL.lines s of - [] -> LL.empty - (l : ls) -> dropWhileEnd (isSpace . chr . fromIntegral) $ LL.unlines $ l : map protect ls - where - 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") - ord' = fromIntegral . ord - -- chr' = chr . fromIntegral - -{- -main = - do [fp] <- getArgs - C.readFile fp >>= \c -> maybe (putStrLn "failed.") (print . length . fst) (parse pControl c) --} --- * Helper Functions - -safeIndex :: C.ByteString -> Int -> Maybe Char -bs `safeIndex` i = if i < C.length bs then Just (bs `C.index` i) else Nothing - --- * Parser - -data Result a - = Ok a - | Fail - | Empty - deriving Show - --- m2r :: Maybe a -> Result a --- m2r (Just a) = Ok a --- m2r Nothing = Empty - -r2m :: Result a -> Maybe a -r2m (Ok a) = Just a -r2m _ = Nothing - -newtype Parser state a = Parser { unParser :: (state -> Result (a, state)) } - -instance Functor (Parser state) where - fmap f m = - Parser $ \ state -> - let r = (unParser m) state in - case r of - Ok (a,state') -> Ok (f a,state') - Empty -> Empty - Fail -> Fail - -instance Applicative (Parser state) where - pure = return - (<*>) = ap - -instance Alternative (Parser state) where - empty = - Parser $ \state -> - (unParser mzero) state - (<|>) = mplus - -instance Monad (Parser state) where - return a = Parser (\s -> Ok (a,s)) - m >>= f = - Parser $ \state -> - let r = (unParser m) state in - case r of - Ok (a,state') -> - case unParser (f a) $ state' of - Empty -> Fail - o -> o - Empty -> Empty - Fail -> Fail - -instance MonadPlus (Parser state) where - mzero = Parser (const Empty) - mplus (Parser p1) (Parser p2) = - Parser (\s -> case p1 s of - Empty -> p2 s - o -> o - ) - --- Parser (\s -> maybe (p2 s) (Just) (p1 s)) - - -_pSucceed :: a -> Parser state a -_pSucceed = return - -_pFail :: Parser state a -_pFail = Parser (const Empty) - - -satisfy :: (Char -> Bool) -> Parser C.ByteString Char -satisfy f = - Parser $ \bs -> - if C.null bs - then Empty - else let (s,ss) = (C.head bs, C.tail bs) in - if (f s) - then Ok (s,ss) - else Empty - -pChar :: Char -> Parser C.ByteString Char -pChar c = satisfy ((==) c) - - -_try :: Parser state a -> Parser state a -_try (Parser p) = - Parser $ \bs -> case (p bs) of - Fail -> Empty - o -> o - -pEOF :: Parser C.ByteString () -pEOF = - Parser $ \bs -> if C.null bs then Ok ((),bs) else Empty - -pTakeWhile :: (Char -> Bool) -> Parser C.ByteString C.ByteString -pTakeWhile f = - Parser $ \bs -> Ok (C.span f bs) - -_pSkipWhile :: (Char -> Bool) -> Parser C.ByteString () -_pSkipWhile p = - Parser $ \bs -> Ok ((), C.dropWhile p bs) - -pMany :: Parser st a -> Parser st [a] -pMany p - = scan id - where - scan f = do x <- p - scan (\tail -> f (x:tail)) - <|> return (f []) - -notEmpty :: Parser st C.ByteString -> Parser st C.ByteString -notEmpty (Parser p) = - Parser $ \s -> case p s of - o@(Ok (a, _s)) -> - if C.null a - then Empty - else o - x -> x - -pMany1 :: Parser st a -> Parser st [a] -pMany1 p = - do x <- p - xs <- pMany p - return (x:xs) - -pSkipMany :: Parser st a -> Parser st () -pSkipMany p = scan - where - scan = (p >> scan) <|> return () - -_pSkipMany1 :: Parser st a -> Parser st () -_pSkipMany1 p = p >> pSkipMany p - -parse :: Parser state a -> state -> Maybe (a, state) -parse p s = r2m ((unParser p) s) diff --git a/Debian/Control/Common.hs b/Debian/Control/Common.hs deleted file mode 100644 --- a/Debian/Control/Common.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, UndecidableInstances #-} -module Debian.Control.Common - ( -- * Types - Control'(..) - , Paragraph'(..) - , Field'(..) - , ControlFunctions(..) - , mergeControls - , fieldValue - , removeField - , prependFields - , appendFields - , renameField - , modifyField - , raiseFields - , parseControlFromCmd - , md5sumField - , protectFieldText' - ) - where - -import Control.Monad (msum) -import Data.Char (isSpace) -import Data.List as List (dropWhileEnd, partition, intersperse) -import Data.ListLike as LL (ListLike, cons, dropWhileEnd, empty, find, null, singleton) -import Data.ListLike.String as LL (StringLike, lines, unlines) -import Data.Monoid ((<>)) -import Debian.Pretty (PP(..)) -import System.Exit (ExitCode(ExitSuccess, ExitFailure)) -import System.IO (Handle) -import System.Process (runInteractiveCommand, waitForProcess) -import Text.ParserCombinators.Parsec (ParseError) -import Text.PrettyPrint (Doc, text, hcat) -import Text.PrettyPrint.HughesPJClass (Pretty(pPrint)) - -newtype Control' a - = Control { unControl :: [Paragraph' a] } deriving (Eq, Ord, Read, Show) - -newtype Paragraph' a - = Paragraph [Field' a] - deriving (Eq, Ord, Read, Show) - --- |NOTE: we do not strip the leading or trailing whitespace in the --- name or value -data Field' a - = Field (a, a) - | Comment a -- ^ Lines beginning with # - deriving (Eq, Ord, Read, Show) - -class ControlFunctions a where - -- |'parseControlFromFile' @filepath@ is a simple wrapper function - -- that parses @filepath@ using 'pControl' - parseControlFromFile :: FilePath -> IO (Either ParseError (Control' a)) - -- |'parseControlFromHandle' @sourceName@ @handle@ - @sourceName@ is only used for error reporting - parseControlFromHandle :: String -> Handle -> IO (Either ParseError (Control' a)) - -- |'parseControlFromString' @sourceName@ @text@ - @sourceName@ is only used for error reporting - parseControl :: String -> a -> (Either ParseError (Control' a)) - -- | 'lookupP' @fieldName paragraph@ looks up a 'Field' in a 'Paragraph'. - -- @N.B.@ trailing and leading whitespace is /not/ stripped. - lookupP :: String -> (Paragraph' a) -> Maybe (Field' a) - -- |Strip the trailing and leading space and tab characters from a - -- string. Folded whitespace is /not/ unfolded. This should probably - -- be moved to someplace more general purpose. - stripWS :: a -> a - -- |Protect field value text so the parser doesn't split it into - -- multiple fields or paragraphs. This must modify all field text - -- to enforce two conditions: (1) All lines other than the initial - -- one must begin with a space or a tab, and (2) the trailing - -- white space must not contain newlines. This is called before - -- pretty printing to prevent the parser from misinterpreting - -- field text as multiple fields or paragraphs. - protectFieldText :: a -> a - asString :: a -> String - --- | This can usually be used as the implementation of protectFieldText -protectFieldText' :: forall a. (StringLike a, ListLike a Char) => ControlFunctions a => a -> a -protectFieldText' s = - let trimmedLines :: [a] - trimmedLines = map (LL.dropWhileEnd isSpace :: a -> a) $ (LL.lines s :: [a]) - strippedLines :: [a] - strippedLines = List.dropWhileEnd LL.null trimmedLines in - -- Split the text into lines, drop trailing whitespace from each - -- line, and drop trailing blank lines. - case strippedLines of - [] -> empty - (l : ls) -> - let -- The first line is indented one space - l' = {-LL.cons ' '-} l - -- Null lines are replaced by a single '.' If any line - -- is unindented, all will get an additional space of - -- indentation. - ls' = case all indented ls of - True -> map (\ x -> if LL.null x then (LL.cons ' ' $ singleton '.') else x) ls - False -> map (LL.cons ' ') $ map (\ x -> if LL.null x then (singleton '.') else x) ls in - LL.dropWhileEnd isSpace (LL.unlines (l' : ls')) - where - indented l = maybe True isSpace (LL.find (const True) l) - --- | This may have bad performance issues (dsf: Whoever wrote this --- comment should have explained why.) -instance (ControlFunctions a, Pretty (PP a)) => Pretty (Control' a) where - pPrint = ppControl -instance (ControlFunctions a, Pretty (PP a)) => Pretty (Paragraph' a) where - pPrint = ppParagraph - -instance (ControlFunctions a, Pretty (PP a)) => Pretty (Field' a) where - pPrint = ppField - -ppControl :: (ControlFunctions a, Pretty (PP a)) => Control' a -> Doc -ppControl (Control paragraph) = - hcat (intersperse (text "\n") (map ppParagraph paragraph)) - -ppParagraph :: (ControlFunctions a, Pretty (PP a)) => Paragraph' a -> Doc -ppParagraph (Paragraph fields) = - hcat (map (\ x -> ppField x <> text "\n") fields) - -ppField :: (ControlFunctions a, Pretty (PP a)) => Field' a -> Doc -ppField (Field (n,v)) = pPrint (PP n) <> text ":" <> pPrint (PP (protectFieldText v)) -ppField (Comment c) = pPrint (PP c) - -mergeControls :: [Control' a] -> Control' a -mergeControls controls = - Control (concatMap unControl controls) - -fieldValue :: (ControlFunctions a) => String -> Paragraph' a -> Maybe a -fieldValue fieldName paragraph = - case lookupP fieldName paragraph of - Just (Field (_, val)) -> Just $ stripWS val - _ -> Nothing - -removeField :: (Eq a) => a -> Paragraph' a -> Paragraph' a -removeField toRemove (Paragraph fields) = - Paragraph (filter remove fields) - where - remove (Field (name,_)) = name == toRemove - remove (Comment _) = False - -prependFields :: [Field' a] -> Paragraph' a -> Paragraph' a -prependFields newfields (Paragraph fields) = Paragraph (newfields ++ fields) - -appendFields :: [Field' a] -> Paragraph' a -> Paragraph' a -appendFields newfields (Paragraph fields) = Paragraph (fields ++ newfields) - -renameField :: (Eq a) => a -> a -> Paragraph' a -> Paragraph' a -renameField oldname newname (Paragraph fields) = - Paragraph (map rename fields) - where - rename (Field (name, value)) | name == oldname = Field (newname, value) - rename field = field - -modifyField :: (Eq a) => a -> (a -> a) -> Paragraph' a -> Paragraph' a -modifyField name f (Paragraph fields) = - Paragraph (map modify fields) - where - modify (Field (name', value)) | name' == name = Field (name, f value) - modify field = field - --- | Move selected fields to the beginning of a paragraph. -raiseFields :: (Eq a) => (a -> Bool) -> Paragraph' a -> Paragraph' a -raiseFields f (Paragraph fields) = - let (a, b) = partition f' fields in Paragraph (a ++ b) - where f' (Field (name, _)) = f name - f' (Comment _) = False - --- | Run a command and parse its output as a control file. -parseControlFromCmd :: ControlFunctions a => String -> IO (Either String (Control' a)) -parseControlFromCmd cmd = - do - (_, outh, _, handle) <- runInteractiveCommand cmd - result <- parseControlFromHandle cmd outh - either (return . Left . show) (finish handle) result - where - finish handle control = - do - exitCode <- waitForProcess handle - case exitCode of - ExitSuccess -> return $ Right control - ExitFailure n -> return $ Left ("Failure: " ++ cmd ++ " -> " ++ show n) - --- |look up the md5sum file in a paragraph --- Tries several different variations: --- MD5Sum: --- Md5Sum: --- MD5sum: -md5sumField :: (ControlFunctions a) => Paragraph' a -> Maybe a -md5sumField p = msum [fieldValue "MD5Sum" p, fieldValue "Md5Sum" p, fieldValue "MD5sum" p] diff --git a/Debian/Control/Policy.hs b/Debian/Control/Policy.hs deleted file mode 100644 --- a/Debian/Control/Policy.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-} -{-# OPTIONS_GHC -Wall #-} --- | Access to things that Debian policy says should be in a valid --- control file. The pure functions will not throw ControlFileError --- if they are operating on a DebianControl value returned by --- validateDebianControl. However, they might if they are created --- using unsafeDebianControl. -module Debian.Control.Policy - ( -- * Validated debian control file type - DebianControl(unDebianControl) - , validateDebianControl - , unsafeDebianControl - , parseDebianControlFromFile - , parseDebianControl - , ControlFileError(..) - -- * Class of things that contain one DebianControl value - , HasDebianControl(debianControl) - -- * Pure functions that operate on validated control files - , debianSourceParagraph - , debianBinaryParagraphs - , debianPackageParagraphs - , debianPackageNames - , debianSourcePackageName - , debianBinaryPackageNames - , debianRelations - , debianBuildDeps - , debianBuildDepsIndep - ) where - -import Control.Exception (Exception, throw) -import Control.Monad.Catch (MonadCatch, try) -import Data.List (intercalate) -import Data.Text (Text) -import Data.Typeable (Typeable) -import Data.ListLike (toList) -import Debian.Control.Common (Control'(..), Paragraph'(..), Field'(..), fieldValue, ControlFunctions(parseControlFromFile, parseControl)) -import Debian.Control.Text () -import Debian.Loc (__LOC__) -import Debian.Pretty (prettyShow) -import Debian.Relation (SrcPkgName(..), BinPkgName(..), Relations, parseRelations) -import Debian.Relation.Text () -import Language.Haskell.TH (Loc(..)) -import Prelude hiding (ioError) --- import qualified Debug.ShowPlease as Please -import Text.Parsec.Error (ParseError) - --- | Opaque (constructor not exported) type to hold a validated Debian --- Control File -data DebianControl = DebianControl {unDebianControl :: Control' Text} - -instance Show DebianControl where - show c = "(parseDebianControl \"\" " ++ show (prettyShow (unDebianControl c)) ++ ")" - --- | Validate and return a control file in an opaque wrapper. May --- throw a ControlFileError. Currently we only verify that it has a --- Source field in the first paragraph and one or more subsequent --- paragraphs each with a Package field, and no syntax errors in the --- build dependencies (though they may be absent.) -validateDebianControl :: MonadCatch m => Control' Text -> m (Either ControlFileError DebianControl) -validateDebianControl ctl = - try (do _ <- return $ debianPackageNames (DebianControl ctl) - _ <- return $ debianBuildDeps (DebianControl ctl) - _ <- return $ debianBuildDepsIndep (DebianControl ctl) - return ()) >>= - return . either Left (\ _ -> Right $ DebianControl ctl) - -unsafeDebianControl :: Control' Text -> DebianControl -unsafeDebianControl = DebianControl - -parseDebianControl :: MonadCatch m => String -> Text -> m (Either ControlFileError DebianControl) -parseDebianControl sourceName s = either (return . Left . ParseControlError [$__LOC__]) validateDebianControl (parseControl sourceName s) - -parseDebianControlFromFile :: FilePath -> IO (Either ControlFileError DebianControl) -parseDebianControlFromFile controlPath = - try (parseControlFromFile controlPath) >>= - either (return . Left . IOError [$__LOC__]) - (either (return . Left . ParseControlError [$__LOC__]) validateDebianControl) - --- | Class of things that contain a validated Debian control file. -class Show a => HasDebianControl a where - debianControl :: a -> DebianControl - -instance HasDebianControl DebianControl where - debianControl = id - -class HasControl a where - control :: a -> Control' Text - -instance HasControl (Control' Text) where - control = id - -instance HasControl DebianControl where - control = unDebianControl - --- | Errors that control files might throw, with source file name and --- line number generated by template haskell. -data ControlFileError - = NoParagraphs {locs :: [Loc]} - | NoBinaryParagraphs {locs :: [Loc], ctl :: String} - | MissingField {locs :: [Loc], field :: String} - | ParseRelationsError {locs :: [Loc], parseError :: ParseError} - | ParseControlError {locs :: [Loc], parseError :: ParseError} - | IOError {locs :: [Loc], ioError :: IOError} - deriving Typeable - -instance Show ControlFileError where - show (NoParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoParagraphs" - show (NoBinaryParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoBinaryParagraphs" - show (MissingField {..}) = intercalate ", " (map showLoc locs) ++ ": MissingField " ++ show field - show (ParseRelationsError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseRelationsError " ++ show parseError - show (ParseControlError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseControlError " ++ show parseError - show (IOError {..}) = intercalate ", " (map showLoc locs) ++ ": IOError " ++ show ioError - -showLoc :: Loc -> String -showLoc x = show (loc_filename x) ++ "(line " ++ show (fst (loc_start x)) ++ ", column " ++ show (snd (loc_start x)) ++ ")" - --- instance Please.Show ControlFileError where --- show (IOError e) = "(IOError " ++ Please.show e ++ ")" --- show (ParseRelationsError e) = "(ParseRelationsError " ++ Please.show e ++ ")" --- show (ParseControlError e) = "(ParseControlError " ++ Please.show e ++ ")" --- show x = show x - -instance Exception ControlFileError - -instance Eq ControlFileError where - _ == _ = False - -debianPackageParagraphs :: HasDebianControl a => a -> (Paragraph' Text, [Paragraph' Text]) -debianPackageParagraphs ctl = - case removeCommentParagraphs ctl of - DebianControl (Control [_]) -> throw $ NoBinaryParagraphs [$__LOC__] (show ctl) - DebianControl (Control []) -> throw $ NoParagraphs [$__LOC__] - DebianControl (Control (sourceParagraph : binParagraphs)) -> (sourceParagraph, binParagraphs) - --- | Comment paragraphs are rare, but they happen. -removeCommentParagraphs :: HasDebianControl a => a -> DebianControl -removeCommentParagraphs c = - DebianControl (Control (filter (not . isCommentParagraph) (unControl (unDebianControl (debianControl c))))) - where - isCommentParagraph (Paragraph fields) = all isCommentField fields - isCommentField (Comment _) = True - isCommentField _ = False - -debianSourceParagraph :: HasDebianControl a => a -> Paragraph' Text -debianSourceParagraph = fst . debianPackageParagraphs - -debianBinaryParagraphs :: HasDebianControl a => a -> [Paragraph' Text] -debianBinaryParagraphs = snd . debianPackageParagraphs - -debianPackageNames :: HasDebianControl a => a -> (SrcPkgName, [BinPkgName]) -debianPackageNames c = - let (srcParagraph, binParagraphs) = debianPackageParagraphs c in - (mapFieldValue (SrcPkgName . toList) "Source" srcParagraph, map (mapFieldValue (BinPkgName . toList) "Package") binParagraphs) - -debianSourcePackageName :: HasDebianControl a => a -> SrcPkgName -debianSourcePackageName = fst . debianPackageNames - -debianBinaryPackageNames :: HasDebianControl a => a -> [BinPkgName] -debianBinaryPackageNames = snd . debianPackageNames - -debianBuildDepsIndep :: HasDebianControl a => a -> Maybe Relations -debianBuildDepsIndep ctl = either throw id $ debianRelations "Build-Depends-Indep" (debianControl ctl) - -debianBuildDeps :: HasDebianControl a => a -> Maybe Relations -debianBuildDeps ctl = either throw id $ debianRelations "Build-Depends" (debianControl ctl) - --- | Version of fieldValue that may throw a ControlFileError. We only --- use this internally on fields that we already validated. -fieldValue' :: ControlFunctions text => String -> Paragraph' text -> text -fieldValue' fieldName paragraph = maybe (throw $ MissingField [$__LOC__] fieldName) id $ fieldValue fieldName paragraph - --- | This could access fields we haven't validated, so --- it can return an error. Additionally, the field might --- be absent, in which case it returns Nothing. -debianRelations :: HasDebianControl a => String -> a -> Either ControlFileError (Maybe Relations) -debianRelations fieldName ctl = maybe (Right Nothing) (either (Left . ParseRelationsError [$__LOC__]) (Right . Just) . parseRelations) $ fieldValue fieldName (debianSourceParagraph ctl) - --- | Apply a function to the text from a named field in a control file paragraph. -mapFieldValue :: (Text -> a) -> String -> Paragraph' Text -> a -mapFieldValue f fieldName paragraph = f $ fieldValue' fieldName paragraph diff --git a/Debian/Control/String.hs b/Debian/Control/String.hs deleted file mode 100644 --- a/Debian/Control/String.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} -module Debian.Control.String - ( -- * Types - Control'(..) - , Paragraph'(..) - , Field'(..) - , Control - , Paragraph - , Field - , ControlParser - , ControlFunctions(..) - -- * Control File Parser - , pControl - -- * Helper Functions - , mergeControls - , fieldValue - , removeField - , prependFields - , appendFields - , renameField - , modifyField - , raiseFields - ) where - -import qualified Control.Exception as E -import Data.Char (toLower) -import Data.List (find) -import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, protectFieldText, asString), - Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment), - mergeControls, fieldValue, removeField, prependFields, appendFields, - renameField, modifyField, raiseFields, protectFieldText') -import System.IO (hGetContents) -import Text.ParserCombinators.Parsec (CharParser, parse, parseFromFile, sepEndBy, satisfy, oneOf, string, lookAhead, try, many, many1, (<|>), noneOf, char, eof) - -type Field = Field' String -type Control = Control' String -type Paragraph = Paragraph' String - --- * ControlFunctions - -instance ControlFunctions String where - parseControlFromFile filepath = - parseFromFile pControl filepath - parseControlFromHandle sourceName handle = - E.try (hGetContents handle) >>= - either (\ (e :: E.SomeException) -> error ("parseControlFromHandle String: Failure parsing " ++ sourceName ++ ": " ++ show e)) (return . parseControl sourceName) - parseControl sourceName c = - parse pControl sourceName c - lookupP fieldName (Paragraph paragraph) = - find (hasFieldName (map toLower fieldName)) paragraph - where hasFieldName name (Field (fieldName',_)) = name == map toLower fieldName' - hasFieldName _ _ = False - stripWS = reverse . strip . reverse . strip - where strip = dropWhile (flip elem " \t") - protectFieldText = protectFieldText' - asString = id - --- * Control File Parser - -type ControlParser a = CharParser () a - --- |A parser for debian control file. This parser handles control files --- that end without a newline as well as ones that have several blank --- lines at the end. It is very liberal and does not attempt validate --- the fields in any way. All trailing, leading, and folded whitespace --- is preserved in the field values. See 'stripWS'. -pControl :: ControlParser Control -pControl = - do many $ char '\n' - sepEndBy pParagraph pBlanks >>= return . Control - -pParagraph :: ControlParser Paragraph -pParagraph = many1 (pComment <|> pField) >>= return . Paragraph - --- |We are liberal in that we allow *any* field to have folded white --- space, even though the specific restricts that to a few fields. -pField :: ControlParser Field -pField = - do c1 <- noneOf "#\n" - fieldName <- many1 $ noneOf ":\n" - char ':' - fieldValue <- many fcharfws - (char '\n' >> return ()) <|> eof - return $ Field (c1 : fieldName, fieldValue) - -pComment :: ControlParser Field -pComment = - do char '#' - text <- many (satisfy (not . ((==) '\n'))) - char '\n' - return $ Comment ("#" ++ text ++ "\n") - -fcharfws :: ControlParser Char -fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') - -fchar :: ControlParser Char -fchar = satisfy (/='\n') - -_fws :: ControlParser String -_fws = - try $ do char '\n' - ws <- many1 (char ' ') - c <- many1 (satisfy (not . ((==) '\n'))) - return $ '\n' : (ws ++ c) - --- |We go with the assumption that 'blank lines' mean lines that --- consist of entirely of zero or more whitespace characters. -pBlanks :: ControlParser String -pBlanks = many1 (oneOf " \n") diff --git a/Debian/Control/Text.hs b/Debian/Control/Text.hs deleted file mode 100644 --- a/Debian/Control/Text.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} -module Debian.Control.Text - ( -- * Types - Control'(..) - , Paragraph'(..) - , Field'(..) - , Control - , Paragraph - , Field - -- , ControlParser - , ControlFunctions(..) - -- * Control File Parser - -- , pControl - -- * Helper Functions - , mergeControls - , fieldValue - , removeField - , prependFields - , appendFields - , renameField - , modifyField - , raiseFields - , decodeControl - , decodeParagraph - , decodeField - ) where - -import qualified Data.ByteString.Char8 as B -import Data.Char (toLower, chr) -import Data.List (find) -import qualified Data.Text as T (Text, pack, unpack, map, dropAround, reverse) -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) ---import Data.Text.IO as T (readFile) -import qualified Debian.Control.ByteString as B ---import Text.Parsec.Error (ParseError) ---import Text.Parsec.Text (Parser) ---import Text.Parsec.Prim (runP) -import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, asString), - Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment), - mergeControls, fieldValue, removeField, prependFields, appendFields, - renameField, modifyField, raiseFields, protectFieldText') - --- | @parseFromFile p filePath@ runs a string parser @p@ on the --- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError' --- ('Left') or a value of type @a@ ('Right'). --- --- > main = do{ result <- parseFromFile numbers "digits.txt" --- > ; case result of --- > Left err -> print err --- > Right xs -> print (sum xs) --- > } -{- -parseFromFile :: Parser a -> String -> IO (Either ParseError a) -parseFromFile p fname - = do input <- T.readFile fname `E.catch` (\ (_ :: E.SomeException) -> B.readFile fname >>= return . decode) - return (runP p () fname input) --} - -type Field = Field' T.Text -type Control = Control' T.Text -type Paragraph = Paragraph' T.Text - -decodeControl :: B.Control -> Control -decodeControl (B.Control paragraphs) = Control (map decodeParagraph paragraphs) - -decodeParagraph :: B.Paragraph -> Paragraph -decodeParagraph (B.Paragraph s) = B.Paragraph (map decodeField s) - -decodeField :: Field' B.ByteString -> Field' T.Text -decodeField (B.Field (name, value)) = Field (decode name, decode value) -decodeField (B.Comment s) = Comment (decode s) - -decode :: B.ByteString -> T.Text -decode = decodeUtf8With (\ _ w -> fmap (chr . fromIntegral) w) - --- * ControlFunctions - -instance ControlFunctions T.Text where - parseControlFromFile filepath = - -- The ByteString parser is far more efficient than the Text - -- parser. By calling decodeControl we tell the compiler to - -- use it instead. - parseControlFromFile filepath >>= return . either Left (Right . decodeControl) - parseControlFromHandle sourceName handle = - parseControlFromHandle sourceName handle >>= return . either Left (Right . decodeControl) - parseControl sourceName c = - -- Warning: This is very slow, it does a utf8 round trip - either Left (Right . decodeControl) (parseControl sourceName (encodeUtf8 c)) - lookupP fieldName (Paragraph paragraph) = - find (hasFieldName (map toLower fieldName)) paragraph - where hasFieldName :: String -> Field' T.Text -> Bool - hasFieldName name (Field (fieldName',_)) = T.pack name == T.map toLower fieldName' - hasFieldName _ _ = False - stripWS = T.dropAround (`elem` (" \t" :: String)) - -- T.strip would also strip newlines - protectFieldText = protectFieldText' - asString = T.unpack - --- * Control File Parser -{- --- type ControlParser = GenParser T.Text -type ControlParser a = Parsec T.Text () a - --- |A parser for debian control file. This parser handles control files --- that end without a newline as well as ones that have several blank --- lines at the end. It is very liberal and does not attempt validate --- the fields in any way. All trailing, leading, and folded whitespace --- is preserved in the field values. See 'stripWS'. -pControl :: ControlParser Control -pControl = - do many $ char '\n' - sepEndBy pParagraph pBlanks >>= return . Control - -pParagraph :: ControlParser Paragraph -pParagraph = many1 (pComment <|> pField) >>= return . Paragraph - --- |We are liberal in that we allow *any* field to have folded white --- space, even though the specific restricts that to a few fields. -pField :: ControlParser Field -pField = - do c1 <- noneOf "#\n" - fieldName <- many1 $ noneOf ":\n" - char ':' - fieldValue <- many fcharfws - (char '\n' >> return ()) <|> eof - return $ Field (T.cons c1 (T.pack fieldName), T.pack fieldValue) - -pComment :: ControlParser Field -pComment = - do char '#' - text <- many (satisfy (not . ((==) '\n'))) - char '\n' - return $ Comment (T.pack ("#" <> text <> "\n")) - -fcharfws :: ControlParser Char -fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') - -fchar :: ControlParser Char -fchar = satisfy (/='\n') - -_fws :: ControlParser T.Text -_fws = - try $ do char '\n' - ws <- many1 (char ' ') - c <- many1 (satisfy (not . ((==) '\n'))) - return $ T.cons '\n' (T.pack ws <> T.pack c) - --- |We go with the assumption that 'blank lines' mean lines that --- consist of entirely of zero or more whitespace characters. -pBlanks :: ControlParser T.Text -pBlanks = - do s <- many1 (oneOf " \n") - return . T.pack $ s --} diff --git a/Debian/Control/TextLazy.hs b/Debian/Control/TextLazy.hs deleted file mode 100644 --- a/Debian/Control/TextLazy.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} -module Debian.Control.TextLazy - ( -- * Types - Control'(..) - , Paragraph'(..) - , Field'(..) - , Control - , Paragraph - , Field - -- , ControlParser - , ControlFunctions(..) - -- * Control File Parser - -- , pControl - -- * Helper Functions - , mergeControls - , fieldValue - , removeField - , prependFields - , appendFields - , renameField - , modifyField - , raiseFields - , decodeControl - , decodeParagraph - , decodeField - ) where - -import qualified Data.ByteString.Char8 as B -import Data.Char (toLower, chr) -import Data.List (find) -import qualified Data.Text.Lazy as T (Text, pack, unpack, map, dropAround, reverse, fromStrict, toStrict) -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) ---import Data.Text.IO as T (readFile) -import qualified Debian.Control.ByteString as B ---import Text.Parsec.Error (ParseError) ---import Text.Parsec.Text (Parser) ---import Text.Parsec.Prim (runP) -import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, asString), - Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment), - mergeControls, fieldValue, removeField, prependFields, appendFields, - renameField, modifyField, raiseFields, protectFieldText') - --- | @parseFromFile p filePath@ runs a string parser @p@ on the --- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError' --- ('Left') or a value of type @a@ ('Right'). --- --- > main = do{ result <- parseFromFile numbers "digits.txt" --- > ; case result of --- > Left err -> print err --- > Right xs -> print (sum xs) --- > } -{- -parseFromFile :: Parser a -> String -> IO (Either ParseError a) -parseFromFile p fname - = do input <- T.readFile fname `E.catch` (\ (_ :: E.SomeException) -> B.readFile fname >>= return . decode) - return (runP p () fname input) --} - -type Field = Field' T.Text -type Control = Control' T.Text -type Paragraph = Paragraph' T.Text - -decodeControl :: B.Control -> Control -decodeControl (B.Control paragraphs) = Control (map decodeParagraph paragraphs) - -decodeParagraph :: B.Paragraph -> Paragraph -decodeParagraph (B.Paragraph s) = B.Paragraph (map decodeField s) - -decodeField :: Field' B.ByteString -> Field' T.Text -decodeField (B.Field (name, value)) = Field (decode name, decode value) -decodeField (B.Comment s) = Comment (decode s) - -decode :: B.ByteString -> T.Text -decode = T.fromStrict . decodeUtf8With (\ _ w -> fmap (chr . fromIntegral) w) - --- * ControlFunctions - -instance ControlFunctions T.Text where - parseControlFromFile filepath = - -- The ByteString parser is far more efficient than the Text - -- parser. By calling decodeControl we tell the compiler to - -- use it instead. - parseControlFromFile filepath >>= return . either Left (Right . decodeControl) - parseControlFromHandle sourceName handle = - parseControlFromHandle sourceName handle >>= return . either Left (Right . decodeControl) - parseControl sourceName c = - -- Warning: This is very slow, it does a utf8 round trip - either Left (Right . decodeControl) (parseControl sourceName (encodeUtf8 (T.toStrict c))) - lookupP fieldName (Paragraph paragraph) = - find (hasFieldName (map toLower fieldName)) paragraph - where hasFieldName :: String -> Field' T.Text -> Bool - hasFieldName name (Field (fieldName',_)) = T.pack name == T.map toLower fieldName' - hasFieldName _ _ = False - stripWS = T.dropAround (`elem` (" \t" :: String)) - -- T.strip would also strip newlines - protectFieldText = protectFieldText' - asString = T.unpack - --- * Control File Parser -{- --- type ControlParser = GenParser T.Text -type ControlParser a = Parsec T.Text () a - --- |A parser for debian control file. This parser handles control files --- that end without a newline as well as ones that have several blank --- lines at the end. It is very liberal and does not attempt validate --- the fields in any way. All trailing, leading, and folded whitespace --- is preserved in the field values. See 'stripWS'. -pControl :: ControlParser Control -pControl = - do many $ char '\n' - sepEndBy pParagraph pBlanks >>= return . Control - -pParagraph :: ControlParser Paragraph -pParagraph = many1 (pComment <|> pField) >>= return . Paragraph - --- |We are liberal in that we allow *any* field to have folded white --- space, even though the specific restricts that to a few fields. -pField :: ControlParser Field -pField = - do c1 <- noneOf "#\n" - fieldName <- many1 $ noneOf ":\n" - char ':' - fieldValue <- many fcharfws - (char '\n' >> return ()) <|> eof - return $ Field (T.cons c1 (T.pack fieldName), T.pack fieldValue) - -pComment :: ControlParser Field -pComment = - do char '#' - text <- many (satisfy (not . ((==) '\n'))) - char '\n' - return $ Comment (T.pack ("#" <> text <> "\n")) - -fcharfws :: ControlParser Char -fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') - -fchar :: ControlParser Char -fchar = satisfy (/='\n') - -_fws :: ControlParser T.Text -_fws = - try $ do char '\n' - ws <- many1 (char ' ') - c <- many1 (satisfy (not . ((==) '\n'))) - return $ T.cons '\n' (T.pack ws <> T.pack c) - --- |We go with the assumption that 'blank lines' mean lines that --- consist of entirely of zero or more whitespace characters. -pBlanks :: ControlParser T.Text -pBlanks = - do s <- many1 (oneOf " \n") - return . T.pack $ s --} diff --git a/Debian/Deb.hs b/Debian/Deb.hs deleted file mode 100644 --- a/Debian/Deb.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -module Debian.Deb where - -import Control.Monad - -import Debian.Control.Common -import System.Directory (canonicalizePath) -import System.Exit (ExitCode(..)) -import System.Process (readProcessWithExitCode) -import System.Unix.Directory (withTemporaryDirectory, withWorkingDirectory) - -fields :: (ControlFunctions a) => FilePath -> IO (Control' a) -fields debFP = - withTemporaryDirectory ("fields.XXXXXX") $ \tmpdir -> - do debFP <- canonicalizePath debFP - withWorkingDirectory 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"] "" - when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ show out ++ "\n" ++ show err ++ "\n" ++ show res) - c <- parseControlFromFile "control" - case c of - Left e -> error (show e) - (Right c) -> return c -- I don't think we need seq because parsec will force everything from the file diff --git a/Debian/Extra/Files.hs b/Debian/Extra/Files.hs deleted file mode 100644 --- a/Debian/Extra/Files.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE PackageImports #-} --- |Domain independent functions used by the haskell-debian package. -module Debian.Extra.Files - ( withTemporaryFile - ) where - -import "mtl" Control.Monad.Trans (MonadIO, liftIO) -import System.Directory (getTemporaryDirectory, removeFile) -import System.IO (hPutStr, hClose, openBinaryTempFile) - -withTemporaryFile :: MonadIO m - => (FilePath -> m a) -- ^ The function we want to pass a FilePath to - -> String -- ^ The text that the file should contain - -> m a -- ^ The function's return value -withTemporaryFile f text = - do path <- liftIO writeTemporaryFile - result <- f path - liftIO $ removeFile path - return result - where - writeTemporaryFile = - do dir <- getTemporaryDirectory - (path, h) <- openBinaryTempFile dir "wtf.tmp" - hPutStr h text - hClose h - return path - --- Example: write the path of the temporary file and its contents into /tmp/result: --- test = --- withTemporaryFile f "Some text\n" --- where f path = readFile path >>= return . (("Contents of " ++ path ++ ":\n") ++) >>= writeFile "/tmp/result" diff --git a/Debian/GenBuildDeps.hs b/Debian/GenBuildDeps.hs deleted file mode 100644 --- a/Debian/GenBuildDeps.hs +++ /dev/null @@ -1,330 +0,0 @@ -{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-} -{-# LANGUAGE NoDisambiguateRecordFields, NoRecordWildCards #-} --- |Figure out the dependency relation between debianized source --- directories. The code to actually solve these dependency relations --- for a particular set of binary packages is in Debian.Repo.Dependency. -module Debian.GenBuildDeps - ( DepInfo(..) - , sourceName' - , relations' - , binaryNames' - -- * Preparing dependency info - , buildDependencies - , RelaxInfo - , relaxDeps - -- * Using dependency info - , BuildableInfo(..) - , ReadyTarget(..) - , buildable - , compareSource - -- * Obsolete? - , orderSource - , genDeps - , failPackage - , getSourceOrder - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Control.Exception (throw) -import Control.Monad (filterM, foldM) -import Control.Monad.State (evalState, get, modify, State) -import Data.Graph (Graph, Edge, Vertex, buildG, topSort, reachable, transposeG, edges, scc) -import Data.List as List (elemIndex, find, map, nub, partition, tails) -import Data.Map as Map (empty, findWithDefault, fromList, insert, Map, lookup) -import Data.Maybe -import Data.Set as Set (fromList, intersection, null, Set) -import Data.Tree as Tree (Tree(Node, rootLabel, subForest)) -import Debian.Control (parseControlFromFile) -import Debian.Control.Policy (HasDebianControl, DebianControl, ControlFileError(..), validateDebianControl, debianSourcePackageName, debianBinaryPackageNames, debianBuildDeps, debianBuildDepsIndep) -import Debian.Loc (__LOC__) -import Debian.Relation -import Debian.Relation.Text () --- import Debug.Trace (trace) -import System.Directory (getDirectoryContents, doesFileExist) - --- | This type describes the build dependencies of a source package. -data DepInfo = DepInfo { - sourceName :: SrcPkgName -- ^ source package name - , relations :: Relations -- ^ dependency relations - , binaryNames :: [BinPkgName] -- ^ binary dependency names (is this a function of relations?) - , depSet :: Set.Set BinPkgName -- ^ Set containing all binary package names mentioned in relations - , binSet :: Set.Set BinPkgName -- ^ Set containing binaryNames - } deriving Show - -instance Eq DepInfo where - a == b = (sourceName a == sourceName b) && - Set.fromList (map Set.fromList (relations a)) == Set.fromList (map Set.fromList (relations b)) && - Set.fromList (binaryNames a) == Set.fromList (binaryNames b) - --- |Return the dependency info for a source package with the given dependency relaxation. --- |According to debian policy, only the first paragraph in debian\/control can be a source package --- -buildDependencies :: HasDebianControl control => control -> DepInfo -buildDependencies control = do - let rels = concat [fromMaybe [] (debianBuildDeps control), - fromMaybe [] (debianBuildDepsIndep control)] - bins = debianBinaryPackageNames control - DepInfo { sourceName = debianSourcePackageName control - , relations = rels - , binaryNames = bins - , depSet = Set.fromList (List.map (\(Rel x _ _) -> x) (concat rels)) - , binSet = Set.fromList bins } - --- | source package name -sourceName' :: HasDebianControl control => control -> SrcPkgName -sourceName' control = debianSourcePackageName control - --- | dependency relations -relations' :: HasDebianControl control => control -> Relations -relations' control = concat [fromMaybe [] (debianBuildDeps control), - fromMaybe [] (debianBuildDepsIndep control)] - --- | binary dependency names (is this a function of relations?) -binaryNames' :: HasDebianControl control => control -> [BinPkgName] -binaryNames' control = debianBinaryPackageNames control - --- |Specifies build dependencies that should be ignored during the build --- decision. If the pair is (BINARY, Nothing) it means the binary package --- BINARY should always be ignored when deciding whether to build. If the --- pair is (BINARY, Just SOURCE) it means that binary package BINARY should --- be ignored when deiciding whether to build package SOURCE. -newtype OldRelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)] deriving Show - --- | Given a source package name and a binary package name, return --- False if the binary package should be ignored hwen deciding whether --- to build the source package. This is used to prevent build --- dependency cycles from triggering unnecessary rebuilds. (This is a --- replacement for the RelaxInfo type, which we temporarily rename --- OldRelaxInfo.) -type RelaxInfo = SrcPkgName -> BinPkgName -> Bool - --- |Remove any dependencies that are designated \"relaxed\" by relaxInfo. -relaxDeps :: RelaxInfo -> [DepInfo] -> [DepInfo] -relaxDeps relaxInfo deps = - List.map relaxDep deps - where - relaxDep :: DepInfo -> DepInfo - relaxDep info = info {relations = filteredDependencies} - where - -- Discard any dependencies not on the filtered package name list. If - -- this results in an empty list in an or-dep the entire dependency can - -- be discarded. - filteredDependencies :: Relations - filteredDependencies = filter (/= []) (List.map (filter keepDep) (relations info)) - keepDep :: Relation -> Bool - keepDep (Rel name _ _) = not (relaxInfo (sourceName info) name) - -data ReadyTarget a - = ReadyTarget { ready :: a - -- ^ Some target whose build dependencies are all satisfied - , waiting :: [a] - -- ^ The targets that are waiting for the ready target - , other :: [a] - -- ^ The rest of the targets that need to be built - } - -data BuildableInfo a - = BuildableInfo - { readyTargets :: [ReadyTarget a] - , allBlocked :: [a] } - | CycleInfo - { depPairs :: [(a, a)] } - --- | Given an ordering function representing the dependencies on a --- list of packages, return a ReadyTarget triple: One ready package, --- the packages that depend on the ready package directly or --- indirectly, and all the other packages. -buildable :: forall a. (a -> DepInfo) -> [a] -> BuildableInfo a -buildable relax packages = - -- Find all packages which can't reach any other packages in the - -- graph of the "has build dependency" relation on the - -- yet-to-be-built packages - case partition (\ x -> reachable hasDep x == [x]) verts of - -- None of the packages are buildable, return information - -- about how to break this build dependency cycle. - ([], _) -> CycleInfo {depPairs = List.map ofEdge $ head $ (allCycles hasDep)} - -- We have some buildable packages, return them along with - -- the list of packages each one directly blocks - (allReady, blocked) -> - BuildableInfo { readyTargets = List.map (makeReady blocked allReady) allReady - , allBlocked = List.map ofVertex blocked } - where - makeReady :: [Vertex] -> [Vertex] -> Vertex -> ReadyTarget a - makeReady blocked ready thisReady = - let otherReady = filter (/= thisReady) ready - (directlyBlocked, otherBlocked) = partition (\ x -> elem x (reachable isDep thisReady)) blocked in - ReadyTarget { ready = ofVertex thisReady - , waiting = List.map ofVertex directlyBlocked - , other = List.map ofVertex (otherReady ++ otherBlocked) } - --allDeps x = (ofVertex x, List.map ofVertex (filter (/= x) (reachable hasDep x))) - isDep :: Graph - isDep = transposeG hasDep - hasDep :: Graph - hasDep = buildG (0, length packages - 1) hasDepEdges - - hasDepEdges :: [(Int, Int)] - hasDepEdges = -#if 0 - nub (foldr f [] (tails vertPairs)) - where f :: [(Int, DepInfo)] -> [(Int, Int)] -> [(Int, Int)] - f [] es = es - f (x : xs) es = catMaybes (List.map (toEdge x) xs) ++ es - toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> Maybe Edge - toEdge (xv, xa) (yv, ya) = - case compareSource xa ya of - EQ -> Nothing - LT -> Just (yv, xv) - GT -> Just (xv, yv) -#else - nub (evalState (foldM f [] (tails vertPairs)) Map.empty) - where f :: [(Int, Int)] -> [(Int, DepInfo)] -> State (Map.Map (Int, Int) Ordering) [(Int, Int)] - f es [] = return es - f es (x : xs) = mapM (toEdge x) xs >>= \es' -> return (catMaybes es' ++ es) - toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> State (Map.Map (Int, Int) Ordering) (Maybe Edge) - toEdge (xv, xa) (yv, ya) = do - mp <- get - r <- case Map.lookup (xv, yv) mp of - Just r' -> return r' - Nothing -> do - let r' = compareSource xa ya - -- trace ("compareSource " ++ show (unSrcPkgName $ sourceName xa) ++ " " ++ show (unSrcPkgName $ sourceName ya) ++ " -> " ++ show r') (return ()) - modify (Map.insert (xv, yv) r') - return r' - case r of - EQ -> return Nothing - LT -> return $ Just (yv, xv) - GT -> return $ Just (xv, yv) -#endif - ofEdge :: Edge -> (a, a) - ofEdge (a, b) = (ofVertex a, ofVertex b) - ofVertex :: Int -> a - ofVertex n = fromJust (Map.findWithDefault Nothing n (Map.fromList (zip [0..] (map Just packages)))) - verts :: [Int] - verts = map fst vertPairs - vertPairs :: [(Int, DepInfo)] - vertPairs = zip [0..] $ map relax packages - --- | Find a cycle in a graph that involves -allCycles :: Graph -> [[Edge]] -allCycles g = - -- Every cycle is confined to an SCC (strongly connected component). - -- Every node in an SCC is part of some cycle. - concatMap sccCycles (scc g) - where - -- Find all the cycles in an SCC - sccCycles :: Tree Vertex -> [[Edge]] - sccCycles t = mapMaybe addBackEdge (treePaths t) - - addBackEdge :: [Vertex] -> Maybe [Edge] - addBackEdge path@(root : _) = - let back = (last path, root) in - if elem back (edges g) then Just (pathEdges (path ++ [root])) else Nothing - --- | All the paths from root to a leaf -treePaths :: Tree a -> [[a]] -treePaths (Node {rootLabel = r, subForest = []}) = [[r]] -treePaths (Node {rootLabel = r, subForest = ts}) = map (r :) (concatMap treePaths ts) - -pathEdges :: [a] -> [(a, a)] -pathEdges (v1 : v2 : vs) = (v1, v2) : pathEdges (v2 : vs) -pathEdges _ = [] - --- | Remove any packages which can't be built given that a package has failed. -failPackage :: Eq a => (a -> a -> Ordering) -> a -> [a] -> ([a], [a]) -failPackage cmp failed packages = - let graph = buildGraph cmp packages in - let root = elemIndex failed packages in - let victims = maybe [] (map (fromJust . vertex) . reachable graph) root in - partition (\ x -> not . elem x $ victims) packages - where - vertex n = Map.findWithDefault Nothing n vertexMap - vertexMap = Map.fromList (zip [0..] (map Just packages)) - --- | Given a list of packages, sort them according to their apparant --- build dependencies so that the first element doesn't depend on any --- of the other packages. -orderSource :: (a -> a -> Ordering) -> [a] -> [a] -orderSource cmp packages = - map (fromJust . vertex) (topSort graph) - where - graph = buildGraph cmp packages - vertex n = Map.findWithDefault Nothing n vertexMap - vertexMap = Map.fromList (zip [0..] (map Just packages)) - --- | Build a graph with the list of packages as its nodes and the --- build dependencies as its edges. -buildGraph :: (a -> a -> Ordering) -> [a] -> Graph -buildGraph cmp packages = - let es = someEdges (zip packages [0..]) in - buildG (0, length packages - 1) es - where - someEdges [] = [] - someEdges (a : etc) = aEdges a etc ++ someEdges etc - aEdges (ap, an) etc = - concat (map (\ (bp, bn) -> - case cmp ap bp of - LT -> [(an, bn)] - GT -> [(bn, an)] - EQ -> []) etc) - --- |This is a nice start. It ignores circular build depends and takes --- a pretty simplistic approach to 'or' build depends. However, I --- think this should work pretty nicely in practice. -compareSource :: DepInfo -> DepInfo -> Ordering -compareSource p1 p2 -#if 0 - | any (\rel -> isJust (find (checkPackageNameReq rel) (binaryNames p2))) (concat (relations p1)) = GT - | any (\rel -> isJust (find (checkPackageNameReq rel) (binaryNames p1))) (concat (relations p2)) = LT - | otherwise = EQ - where - checkPackageNameReq :: Relation -> BinPkgName -> Bool - checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName -#else - | not (Set.null (Set.intersection (depSet p1) (binSet p2))) = GT - | not (Set.null (Set.intersection (depSet p2) (binSet p1))) = LT - | otherwise = EQ -#endif - -compareSource' :: HasDebianControl control => control -> control -> Ordering -compareSource' control1 control2 - | any (\rel -> isJust (find (checkPackageNameReq rel) bins2)) (concat depends1) = GT - | any (\rel -> isJust (find (checkPackageNameReq rel) bins1)) (concat depends2) = LT - | otherwise = EQ - where - bins1 = binaryNames' control1 - bins2 = binaryNames' control2 - depends1 = relations' control1 - depends2 = relations' control2 - checkPackageNameReq :: Relation -> BinPkgName -> Bool - checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName - --- |Return the dependency info for a list of control files. -genDeps :: [FilePath] -> IO [DebianControl] -genDeps controlFiles = do - orderSource compareSource' <$> mapM genDep' controlFiles - where - -- Parse the control file and extract the build dependencies - genDep' controlPath = parseControlFromFile controlPath >>= - either (\ x -> throw (ParseRelationsError [$__LOC__] x)) - (\ x -> validateDebianControl x {- `mapExn` (pushLoc $__LOC__) -} >>= either throw return) - --- pushLoc :: Loc -> ControlFileError -> ControlFileError --- pushLoc loc e = e {locs = loc : locs e} - --- |One example of how to tie the below functions together. In this --- case 'fp' is the path to a directory that contains a bunch of --- checked out source packages. The code will automatically look for --- debian\/control. It returns a list with the packages in the --- order they should be built. -getSourceOrder :: FilePath -> IO [SrcPkgName] -getSourceOrder fp = - findControlFiles fp >>= genDeps >>= return . map sourceName' - where - -- Return a list of the files that look like debian\/control. - findControlFiles :: FilePath -> IO [FilePath] - findControlFiles root = - getDirectoryContents root >>= - mapM (\ x -> return $ root ++ "/" ++ x ++ "/debian/control") >>= - filterM doesFileExist diff --git a/Debian/Loc.hs b/Debian/Loc.hs deleted file mode 100644 --- a/Debian/Loc.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-} -module Debian.Loc - ( __LOC__ - , mapExn - ) where - -import Control.Applicative ((<$>), (<*>), pure) -import Control.Exception (Exception, throw) -import Control.Monad.Catch (MonadCatch, catch) -import Language.Haskell.TH - -__LOC__ :: Q Exp -__LOC__ = location >>= \ x -> - recConE 'Loc [ (,) <$> (pure 'loc_filename) <*> litE (stringL (loc_filename x)) - , (,) <$> (pure 'loc_package) <*> litE (stringL (loc_package x)) - , (,) <$> (pure 'loc_module) <*> litE (stringL (loc_module x)) - , (,) <$> (pure 'loc_start) <*> [|($(litE (integerL (fromIntegral (fst (loc_start x))))), - $(litE (integerL (fromIntegral (snd (loc_start x)))))) :: (Int, Int)|] - , (,) <$> (pure 'loc_end) <*> [|($(litE (integerL (fromIntegral (fst (loc_end x))))), - $(litE (integerL (fromIntegral (snd (loc_end x)))))) :: (Int, Int)|] ] - -mapExn :: forall e m a. (MonadCatch m, Exception e) => m a -> (e -> e) -> m a -mapExn task f = task `catch` (\ (e :: e) -> throw (f e)) diff --git a/Debian/Pretty.hs b/Debian/Pretty.hs deleted file mode 100644 --- a/Debian/Pretty.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | A constructor we can wrap around values to avoid any built in --- Pretty instance - for example, instance Pretty [a]. --- --- * display is now prettyShow --- * display' is now prettyText --- * ppDisplay is now ppShow --- * ppDisplay' is now ppText -{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-} -module Debian.Pretty - ( PP(PP, unPP) - , prettyShow - , prettyText - , ppPrint - , ppShow - , ppText - ) where - -import Data.Text (Text, unpack, pack) -import Text.PrettyPrint.HughesPJClass (Doc, Pretty(pPrint), text, empty, prettyShow) - --- | This type is wrapped around values before we pretty print them so --- we can write our own Pretty instances for common types without --- polluting the name space of clients of this package with instances --- they don't want. -newtype PP a = PP {unPP :: a} deriving (Functor) - -instance Pretty (PP Text) where - pPrint = text . unpack . unPP - -instance Pretty (PP String) where - pPrint = text . unPP - -instance Pretty (PP a) => Pretty (PP (Maybe a)) where - pPrint = maybe empty ppPrint . unPP - -prettyText :: Pretty a => a -> Text -prettyText = pack . prettyShow - -ppPrint :: Pretty (PP a) => a -> Doc -ppPrint = pPrint . PP - -ppShow :: Pretty (PP a) => a -> String -ppShow = prettyShow . PP - -ppText :: Pretty (PP a) => a -> Text -ppText = pack . prettyShow . PP diff --git a/Debian/Relation.hs b/Debian/Relation.hs deleted file mode 100644 --- a/Debian/Relation.hs +++ /dev/null @@ -1,25 +0,0 @@ --- |A module for working with debian relationships -module Debian.Relation - ( -- * Types - PkgName(..) - , SrcPkgName(..) - , BinPkgName(..) - , Relations - , AndRelation - , OrRelation - , Relation(..) - , ArchitectureReq(..) - , Arch(..) - , ArchOS(..) - , ArchCPU(..) - , VersionReq(..) - -- * Helper Functions - , checkVersionReq - -- * Relation Parser - , RelParser - , ParseRelations(..) - ) where - -import Debian.Arch (Arch(..), ArchOS(..), ArchCPU(..)) -import Debian.Relation.Common (SrcPkgName(..), BinPkgName(..), PkgName(pkgNameFromString)) -import Debian.Relation.String diff --git a/Debian/Relation/ByteString.hs b/Debian/Relation/ByteString.hs deleted file mode 100644 --- a/Debian/Relation/ByteString.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} --- |A module for working with debian relationships -module Debian.Relation.ByteString - ( -- * Types - AndRelation - , OrRelation - , Relations - , Relation(..) - , ArchitectureReq(..) - , VersionReq(..) - -- * Helper Functions - , checkVersionReq - -- * Relation Parser - , RelParser - , ParseRelations(..) - ) where - -import qualified Data.ByteString.Char8 as C - --- Local Modules - ---import Debian.Relation.Common -import Debian.Relation.String ---import Debian.Version - --- * ParseRelations - --- For now we just wrap the string version -instance ParseRelations C.ByteString where - parseRelations byteStr = parseRelations (C.unpack byteStr) diff --git a/Debian/Relation/Common.hs b/Debian/Relation/Common.hs deleted file mode 100644 --- a/Debian/Relation/Common.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-} -module Debian.Relation.Common where - --- Standard GHC Modules - -import Data.Data (Data) -import Data.List as List (map, intersperse) -import Data.Monoid (mconcat, (<>)) -import Data.Function -import Data.Set as Set (Set, toList) -import Data.Typeable (Typeable) -import Debian.Arch (Arch, prettyArch) -import Debian.Pretty (PP(..)) -import Prelude hiding (map) -import Text.ParserCombinators.Parsec -import Text.PrettyPrint (Doc, text, empty) -import Text.PrettyPrint.HughesPJClass (Pretty(pPrint)) - --- Local Modules - -import Debian.Version - --- Datatype for relations - -type Relations = AndRelation -type AndRelation = [OrRelation] -type OrRelation = [Relation] - -data Relation = Rel BinPkgName (Maybe VersionReq) (Maybe ArchitectureReq) deriving (Eq, Read, Show) - -newtype SrcPkgName = SrcPkgName {unSrcPkgName :: String} deriving (Read, Show, Eq, Ord, Data, Typeable) -newtype BinPkgName = BinPkgName {unBinPkgName :: String} deriving (Read, Show, Eq, Ord, Data, Typeable) - -class Pretty (PP a) => PkgName a where - pkgNameFromString :: String -> a - -instance PkgName BinPkgName where - pkgNameFromString = BinPkgName - -instance PkgName SrcPkgName where - pkgNameFromString = SrcPkgName - -class ParseRelations a where - -- |'parseRelations' parse a debian relation (i.e. the value of a - -- Depends field). Return a parsec error or a value of type - -- 'Relations' - parseRelations :: a -> Either ParseError Relations - --- | This needs to be indented for use in a control file: intercalate "\n " . lines . show -prettyRelations :: [[Relation]] -> Doc -prettyRelations xss = mconcat . intersperse (text "\n, ") . List.map prettyOrRelation $ xss - -prettyOrRelation :: [Relation] -> Doc -prettyOrRelation xs = mconcat . intersperse (text " | ") . List.map prettyRelation $ xs - -prettyRelation :: Relation -> Doc -prettyRelation (Rel name ver arch) = - pPrint (PP name) <> maybe empty prettyVersionReq ver <> maybe empty prettyArchitectureReq arch - -instance Ord Relation where - compare (Rel pkgName1 mVerReq1 _mArch1) (Rel pkgName2 mVerReq2 _mArch2) = - case compare pkgName1 pkgName2 of - LT -> LT - GT -> GT - EQ -> compare mVerReq1 mVerReq2 - -data ArchitectureReq - = ArchOnly (Set Arch) - | ArchExcept (Set Arch) - deriving (Eq, Ord, Read, Show) - -prettyArchitectureReq :: ArchitectureReq -> Doc -prettyArchitectureReq (ArchOnly arch) = text " [" <> mconcat (List.map prettyArch (toList arch)) <> text "]" -prettyArchitectureReq (ArchExcept arch) = text " [" <> mconcat (List.map ((text "!") <>) (List.map prettyArch (toList arch))) <> text "]" - -data VersionReq - = SLT DebianVersion - | LTE DebianVersion - | EEQ DebianVersion - | GRE DebianVersion - | SGR DebianVersion - deriving (Eq, Read, Show) - -prettyVersionReq :: VersionReq -> Doc -prettyVersionReq (SLT v) = text " (<< " <> prettyDebianVersion v <> text ")" -prettyVersionReq (LTE v) = text " (<= " <> prettyDebianVersion v <> text ")" -prettyVersionReq (EEQ v) = text " (= " <> prettyDebianVersion v <> text ")" -prettyVersionReq (GRE v) = text " (>= " <> prettyDebianVersion v <> text ")" -prettyVersionReq (SGR v) = text " (>> " <> prettyDebianVersion v <> text ")" - --- |The sort order is based on version number first, then on the kind of --- relation, sorting in the order <<, <= , ==, >= , >> -instance Ord VersionReq where - compare = compare `on` extr - where extr (SLT v) = (v,0 :: Int) - extr (LTE v) = (v,1 :: Int) - extr (EEQ v) = (v,2 :: Int) - extr (GRE v) = (v,3 :: Int) - extr (SGR v) = (v,4 :: Int) - --- |Check if a version number satisfies a version requirement. -checkVersionReq :: Maybe VersionReq -> Maybe DebianVersion -> Bool -checkVersionReq Nothing _ = True -checkVersionReq _ Nothing = False -checkVersionReq (Just (SLT v1)) (Just v2) = v2 < v1 -checkVersionReq (Just (LTE v1)) (Just v2) = v2 <= v1 -checkVersionReq (Just (EEQ v1)) (Just v2) = v2 == v1 -checkVersionReq (Just (GRE v1)) (Just v2) = v2 >= v1 -checkVersionReq (Just (SGR v1)) (Just v2) = v2 > v1 - -instance Pretty (PP BinPkgName) where - pPrint = text . unBinPkgName . unPP - -instance Pretty (PP SrcPkgName) where - pPrint = text . unSrcPkgName . unPP - --- | Wrap `PP` around type synonyms that might overlap with the --- `Pretty [a]` instance. -instance Pretty (PP Relations) where - pPrint = prettyRelations . unPP - -instance Pretty (PP OrRelation) where - pPrint = prettyOrRelation . unPP - -instance Pretty (PP Relation) where - pPrint = prettyRelation . unPP - -instance Pretty (PP VersionReq) where - pPrint = prettyVersionReq . unPP - -instance Pretty (PP ArchitectureReq) where - pPrint = prettyArchitectureReq . unPP diff --git a/Debian/Relation/String.hs b/Debian/Relation/String.hs deleted file mode 100644 --- a/Debian/Relation/String.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE FlexibleInstances, PackageImports, TypeSynonymInstances #-} -{-# OPTIONS -fno-warn-unused-do-bind -fno-warn-orphans #-} --- |A module for working with debian relationships -module Debian.Relation.String - ( -- * Types - AndRelation - , OrRelation - , Relations - , Relation(..) - , ArchitectureReq(..) - , VersionReq(..) - -- * Helper Functions - , checkVersionReq - -- * Relation Parser - , RelParser - , ParseRelations(..) - , pRelations - ) where - --- Standard GHC Modules - -import "mtl" Control.Monad.Identity (Identity) -import Data.Set (fromList) -import Text.ParserCombinators.Parsec -import Text.Parsec.Prim (ParsecT) - --- Local Modules - -import Debian.Arch (Arch, parseArch) -import Debian.Relation.Common -import Debian.Version - --- * ParseRelations - -instance ParseRelations String where - parseRelations str = - let str' = scrub str in - case parse pRelations str' str' of - Right relations -> Right (filter (/= []) relations) - x -> x - where - scrub = unlines . filter (not . comment) . lines - comment s = case dropWhile (`elem` " \t") s of - ('#' : _) -> True - _ -> False - --- * Relation Parser - -type RelParser a = CharParser () a - --- "Correct" dependency lists are separated by commas, but sometimes they --- are omitted and it is possible to parse relations without them. -pRelations :: RelParser Relations -pRelations = do -- rel <- sepBy pOrRelation (char ',') - rel <- many pOrRelation - eof - return rel - -pOrRelation :: RelParser OrRelation -pOrRelation = do skipMany (char ',' <|> whiteChar) - rel <- sepBy1 pRelation (char '|') - skipMany (char ',' <|> whiteChar) - return rel - -whiteChar :: ParsecT String u Identity Char -whiteChar = oneOf [' ','\t','\n'] - -pRelation :: RelParser Relation -pRelation = - do skipMany whiteChar - pkgName <- many1 (noneOf [' ',',','|','\t','\n','(']) - skipMany whiteChar - mVerReq <- pMaybeVerReq - skipMany whiteChar - mArch <- pMaybeArch - return $ Rel (BinPkgName pkgName) mVerReq mArch - -pMaybeVerReq :: RelParser (Maybe VersionReq) -pMaybeVerReq = - do char '(' - skipMany whiteChar - op <- pVerReq - skipMany whiteChar - ver <- many1 (noneOf [' ',')','\t','\n']) - skipMany whiteChar - char ')' - return $ Just (op (parseDebianVersion' ver)) - <|> - do return $ Nothing - -pVerReq :: ParsecT [Char] u Identity (DebianVersion -> VersionReq) -pVerReq = - do char '<' - (do char '<' <|> char ' ' <|> char '\t' - return $ SLT - <|> - do char '=' - return $ LTE) - <|> - do string "=" - return $ EEQ - <|> - do char '>' - (do char '=' - return $ GRE - <|> - do char '>' <|> char ' ' <|> char '\t' - return $ SGR) - -pMaybeArch :: RelParser (Maybe ArchitectureReq) -pMaybeArch = - do char '[' - (do archs <- pArchExcept - char ']' - skipMany whiteChar - return (Just (ArchExcept (fromList . map parseArchExcept $ archs))) - <|> - do archs <- pArchOnly - char ']' - skipMany whiteChar - return (Just (ArchOnly (fromList . map parseArch $ archs))) - ) - <|> - return Nothing - --- Some packages (e.g. coreutils) have architecture specs like [!i386 --- !hppa], even though this doesn't really make sense: once you have --- one !, anything else you include must also be (implicitly) a !. -pArchExcept :: RelParser [String] -pArchExcept = sepBy (char '!' >> many1 (noneOf [']',' '])) (skipMany1 whiteChar) - -pArchOnly :: RelParser [String] -pArchOnly = sepBy (many1 (noneOf [']',' '])) (skipMany1 whiteChar) - --- | Ignore the ! if it is present, we already know this list has at --- least one, and the rest are implicit. -parseArchExcept :: String -> Arch -parseArchExcept ('!' : s) = parseArch s -parseArchExcept s = parseArch s diff --git a/Debian/Relation/Text.hs b/Debian/Relation/Text.hs deleted file mode 100644 --- a/Debian/Relation/Text.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} --- |A module for working with debian relationships -module Debian.Relation.Text - ( -- * Types - AndRelation - , OrRelation - , Relations - , Relation(..) - , ArchitectureReq(..) - , VersionReq(..) - -- * Helper Functions - , checkVersionReq - -- * Relation Parser - , RelParser - , ParseRelations(..) - ) where - -import qualified Data.Text as T - --- Local Modules - ---import Debian.Relation.Common -import Debian.Relation.String ---import Debian.Version - --- * ParseRelations - --- For now we just wrap the string version -instance ParseRelations T.Text where - parseRelations text = parseRelations (T.unpack text) diff --git a/Debian/Release.hs b/Debian/Release.hs deleted file mode 100644 --- a/Debian/Release.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Debian.Release - ( ReleaseName(..) - , parseReleaseName - , releaseName' - , Section(..) - , SubSection(..) - , sectionName - , sectionName' - , sectionNameOfSubSection - , parseSection - , parseSection' - ) where - -import Data.Data (Data) -import Data.Typeable (Typeable) -import Network.URI (unEscapeString, escapeURIString, isAllowedInURI) - --- |A distribution (aka release) name. This type is expected to refer --- to a subdirectory of the dists directory which is at the top level --- of a repository. -data ReleaseName = ReleaseName { relName :: String } deriving (Eq, Ord, Read, Show, Data, Typeable) - -parseReleaseName :: String -> ReleaseName -parseReleaseName name = ReleaseName {relName = unEscapeString name} - -releaseName' :: ReleaseName -> String -releaseName' (ReleaseName {relName = s}) = escapeURIString isAllowedInURI s - --- |A section of a repository such as main, contrib, non-free, --- restricted. The indexes for a section are located below the --- distribution directory. -newtype Section = Section String deriving (Read, Show, Eq, Ord) - --- |A package's subsection is only evident in its control information, --- packages from different subsections all reside in the same index. -data SubSection = SubSection { section :: Section, subSectionName :: String } deriving (Read, Show, Eq, Ord) - -sectionName :: SubSection -> String -sectionName (SubSection (Section "main") y) = y -sectionName (SubSection x y) = sectionName' x ++ "/" ++ y - -sectionName' :: Section -> String -sectionName' (Section s) = escapeURIString isAllowedInURI s - -sectionNameOfSubSection :: SubSection -> String -sectionNameOfSubSection = sectionName' . section - --- |Parse the value that appears in the @Section@ field of a .changes file. --- (Does this need to be unesacped?) -parseSection :: String -> SubSection -parseSection s = - case span (/= '/') s of - (x, "") -> SubSection (Section "main") x - ("main", y) -> SubSection (Section "main") y - (x, y) -> SubSection (Section x) (tail y) - -parseSection' :: String -> Section -parseSection' name = - Section (unEscapeString name) diff --git a/Debian/Report.hs b/Debian/Report.hs deleted file mode 100644 --- a/Debian/Report.hs +++ /dev/null @@ -1,87 +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 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/Debian/Sources.hs b/Debian/Sources.hs deleted file mode 100644 --- a/Debian/Sources.hs +++ /dev/null @@ -1,323 +0,0 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -module Debian.Sources - {- ( SourceType(..) - , SourceOption(..) - , SourceOp(..) - , DebSource(..) - , parseSourceLine - , parseSourceLine' - , parseSourcesList - ) -} where - -import Data.Maybe (fromJust) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Debian.Pretty (PP(..)) -import Debian.Release -import Network.URI (URI, uriToString, parseURI, unEscapeString, escapeURIString, isAllowedInURI) -import Test.HUnit -import Text.ParserCombinators.Parsec -import Text.PrettyPrint (hcat, punctuate, render, text) -import Text.PrettyPrint.HughesPJClass (Pretty(pPrint)) - -data SourceType - = Deb | DebSrc - deriving (Eq, Ord, Show) - --- arch --- lang --- target --- pdiffs --- by-hash --- allow-insecure=no --- allow-weak=no --- allow-downgrade-to-insecure=no --- trusted=no --- signed-by --- check-valid-until --- valid-until-min --- valid-until-max -data SourceOption - = SourceOption String SourceOp [String] - deriving (Eq, Ord, Show) - -data SourceOp = OpSet | OpAdd | OpDel deriving (Eq, Ord, Show) - -instance Pretty SourceOp where - pPrint OpSet = text "=" - pPrint OpAdd = text "+=" - pPrint OpDel = text "-=" - -data DebSource - = DebSource - { sourceType :: SourceType - , sourceOptions :: [SourceOption] - , sourceUri :: URI - , sourceDist :: Either String (ReleaseName, [Section]) - } deriving (Eq, Ord, Show) - -instance Pretty SourceType where - pPrint Deb = text "deb" - pPrint DebSrc = text "deb-src" - -instance Pretty SourceOption where - pPrint (SourceOption k op vs) = text k <> pPrint op <> hcat (punctuate (text ",") (map text vs)) - -instance Pretty DebSource where - pPrint (DebSource thetype theoptions theuri thedist) = - hcat (punctuate (text " ") - ([pPrint thetype] ++ - (case theoptions of - [] -> [] - _ -> [text "[" <> hcat (punctuate (text ", ") (map pPrint theoptions)) <> text "]"]) ++ - [text (uriToString id theuri "")] ++ - case thedist of - Left exactPath -> [text (escapeURIString isAllowedInURI exactPath)] - Right (dist, sections) -> - map text (releaseName' dist : map sectionName' sections))) - -instance Pretty (PP [DebSource]) where - pPrint = hcat . map (\ x -> pPrint x <> text "\n") . unPP - --- |This is a name given to a combination of parts of one or more --- releases that can be specified by a sources.list file. -type SliceName = ReleaseName --- data SliceName = SliceName { sliceName :: String } deriving (Eq, Ord, Show) - -{- - -deb uri distribution [component1] [componenent2] [...] - -The URI for the deb type must specify the base of the Debian -distribution, from which APT will find the information it needs. - -distribution can specify an exact path, in which case the components -must be omitted and distribution must end with a slash (/). - -If distribution does not specify an exact path, at least one component -must be present. - -Distribution may also contain a variable, $(ARCH), which expands to -the Debian architecture (i386, m68k, powerpc, ...) used on the -system. - -The rest of the line can be marked as a comment by using a #. - -Additional Notes: - - + Lines can begin with leading white space. - - + If the dist ends with slash (/), then it must be an absolute path - and it is an error to specify components after it. - --} - --- |quoteWords - similar to words, but with special handling of --- double-quotes and brackets. --- --- The handling double quotes and [] is supposed to match: --- apt-0.6.44.2\/apt-pkg\/contrib\/strutl.cc:ParseQuoteWord() --- --- The behaviour can be defined as: --- --- Break the string into space seperated words ignoring spaces that --- appear between \"\" or []. Strip trailing and leading white space --- around words. Strip out double quotes, but leave the square --- brackets intact. -quoteWords :: String -> [String] -quoteWords [] = [] -quoteWords s = quoteWords' (dropWhile (==' ') s) - where - quoteWords' :: String -> [String] - quoteWords' [] = [] - quoteWords' str = - case break (flip elem (" [\"" :: String)) str of - ([],[]) -> [] - (w, []) -> [w] - (w, (' ':rest)) -> w : (quoteWords' (dropWhile (==' ') rest)) - (w, ('"':rest)) -> - case break (== '"') rest of - (w',('"':rest)) -> - case quoteWords' rest of - [] -> [w ++ w'] - (w'':ws) -> ((w ++ w' ++ w''): ws) - (_w',[]) -> error ("quoteWords: missing \" in the string: " ++ s) - _ -> error ("the impossible happened in SourcesList.quoteWords") - (w, ('[':rest)) -> - case break (== ']') rest of - (w',(']':rest)) -> - case quoteWords' rest of - [] -> [w ++ "[" ++ w' ++ "]"] - (w'':ws) -> ((w ++ "[" ++ w' ++ "]" ++ w''): ws) - (_w',[]) -> error ("quoteWords: missing ] in the string: " ++ s) - _ -> error ("the impossible happened in SourcesList.quoteWords") - _ -> error ("the impossible happened in SourcesList.quoteWords") - -stripLine :: String -> String -stripLine = takeWhile (/= '#') . dropWhile (== ' ') - -sourceLines :: String -> [String] -sourceLines = filter (not . null) . map stripLine . lines - --- |parseSourceLine -- parses a source line --- the argument must be a non-empty, valid source line with comments stripped --- see: 'sourceLines' -parseSourceLine :: String -> DebSource -parseSourceLine str = either error id (parseSourceLine' str) -{- - case quoteWords str of - (theTypeStr : theUriStr : theDistStr : sectionStrs) -> - let sections = map parseSection' sectionStrs - theType = case unEscapeString theTypeStr of - "deb" -> Deb - "deb-src" -> DebSrc - o -> error ("parseSourceLine: invalid type " ++ o ++ " in line:\n" ++ str) - theUri = case parseURI theUriStr of - Nothing -> error ("parseSourceLine: invalid uri " ++ theUriStr ++ " in the line:\n" ++ str) - Just u -> u - theDist = unEscapeString theDistStr - in - case last theDist of - '/' -> if null sections - then DebSource { sourceType = theType, sourceOptions = [], sourceUri = theUri, sourceDist = Left theDist } - else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str) - _ -> if null sections - then error ("parseSourceLine: Dist is not an exact path, so at least one section is required on the line:\n" ++ str) - else DebSource { sourceType = theType, sourceOptions = [], sourceUri = theUri, sourceDist = Right (parseReleaseName theDist, sections) } - _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str) --} - -parseOptions :: String -> Either ParseError [SourceOption] -parseOptions s = parse pOptions s s - -pOptions :: CharParser () [SourceOption] -pOptions = do _ <- char '[' - skipMany (oneOf [' ','\t']) - opts <- sepBy1 pOption (char ',') - skipMany (oneOf [' ','\t']) - _ <- char ']' - return opts - -pOption :: CharParser () SourceOption -pOption = do skipMany (oneOf [' ','\t']) - key <- many1 (noneOf ['+','-','=',' ','\t']) - skipMany (oneOf [' ','\t']) - op <- pOp - skipMany (oneOf [' ','\t']) - values <- sepBy1 (many1 (noneOf [',',']',' ','\t'])) (char ',') - skipMany (oneOf [' ','\t']) - return $ SourceOption key op values - -pOp :: CharParser () SourceOp -pOp = do (char '+' >> char '=' >> return OpAdd) - <|> - (char '-' >> char '=' >> return OpDel) - <|> - (char '=' >> return OpSet) - -parseSourceLine' :: String -> Either String DebSource -parseSourceLine' str = - case quoteWords str of - theTypeStr : theOptionStr@('[' : _) : theURIStr : theDistStr : sectionStrs -> - either - (Left . show) - (\opts -> go theTypeStr opts theURIStr theDistStr sectionStrs) - (parseOptions theOptionStr) - theTypeStr : theURIStr : theDistStr : sectionStrs -> - go theTypeStr [] theURIStr theDistStr sectionStrs - _ -> Left ("parseSourceLine: invalid line in sources.list:\n" ++ str) - where - go theTypeStr theOptions theURIStr theDistStr sectionStrs = - let sections = map parseSection' sectionStrs - theType = case unEscapeString theTypeStr of - "deb" -> Right Deb - "deb-src" -> Right DebSrc - s -> Left ("parseSourceLine: invalid type " ++ s ++ " in line:\n" ++ str) - theURI = case parseURI theURIStr of - Nothing -> Left ("parseSourceLine: invalid uri " ++ theURIStr ++ " in the line:\n" ++ str) - Just u -> Right u - theDist = unEscapeString theDistStr - in - case (last theDist, theType, theURI) of - ('/', Right typ, Right uri) -> if null sections - then Right $ DebSource { sourceType = typ, sourceOptions = theOptions, sourceUri = uri, sourceDist = Left theDist } - else Left ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str) - (_, Right typ, Right uri) -> if null sections - then Left ("parseSourceLine: Dist is not an exact path, so at least one section is required on the line:\n" ++ str) - else Right $ DebSource { sourceType = typ, sourceOptions = theOptions, sourceUri = uri, sourceDist = Right ((parseReleaseName theDist), sections) } - (_, Left msg, _) -> Left msg - (_, _, Left msg) -> Left msg - -parseSourcesList :: String -> [DebSource] -parseSourcesList = map parseSourceLine . sourceLines - --- * Unit Tests - --- TODO: add test cases that test for unterminated double-quote or bracket -testQuoteWords :: Test -testQuoteWords = - test [ assertEqual "Space seperate words, no quoting" ["hello", "world","!"] (quoteWords " hello world ! ") - , assertEqual "Space seperate words, double quotes" ["hello world","!"] (quoteWords " hel\"lo world\" ! ") - , assertEqual "Space seperate words, square brackets" ["hel[lo worl]d","!"] (quoteWords " hel[lo worl]d ! ") - , assertEqual "Space seperate words, square-bracket at end" ["hel[lo world]"] (quoteWords " hel[lo world]") - , assertEqual "Space seperate words, double quote at end" ["hello world"] (quoteWords " hel\"lo world\"") - , assertEqual "Space seperate words, square-bracket at beginning" ["[hello wo]rld","!"] (quoteWords "[hello wo]rld !") - , assertEqual "Space seperate words, double quote at beginning" ["hello world","!"] (quoteWords "\"hello wor\"ld !") - ] - -testSourcesList :: Test -testSourcesList = - test [ assertEqual "parse and pretty sources.list" validSourcesListExpected (render . pPrint . PP . parseSourcesList $ validSourcesListStr) ] - -testSourcesList2 :: Test -testSourcesList2 = - test [ assertEqual "pretty sources.list" validSourcesListExpected (render . pPrint . PP $ validSourcesList) ] - -validSourcesListStr :: String -validSourcesListStr = - unlines $ [ " # A comment only line " - , " deb ftp://ftp.debian.org/debian unstable main contrib non-free # typical deb line" - , " deb-src ftp://ftp.debian.org/debian unstable main contrib non-free # typical deb-src line" - , "" - , "# comment line" - , "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ # exact path" - , "deb [trusted=yes] http://ftp.debian.org/whee \"space dist\" main" - , "deb [trusted=yes] http://ftp.debian.org/whee dist space%20section" - ] - -validSourcesList :: [DebSource] -validSourcesList = - [DebSource {sourceType = Deb, sourceOptions = [], sourceUri = fromJust (parseURI "ftp://ftp.debian.org/debian"), sourceDist = Right (ReleaseName {relName = "unstable"},[Section "main",Section "contrib",Section "non-free"])}, - DebSource {sourceType = DebSrc, sourceOptions = [], sourceUri = fromJust (parseURI "ftp://ftp.debian.org/debian"), sourceDist = Right (ReleaseName {relName = "unstable"},[Section "main",Section "contrib",Section "non-free"])}, - DebSource {sourceType = Deb, sourceOptions = [], sourceUri = fromJust (parseURI "http://pkg-kde.alioth.debian.org/kde-3.5.0/"), sourceDist = Left "./"}, - DebSource {sourceType = Deb, sourceOptions = [SourceOption "trusted" OpSet ["yes"]], sourceUri = fromJust (parseURI "http://ftp.debian.org/whee"), sourceDist = Right (ReleaseName {relName = "space dist"},[Section "main"])}, - DebSource {sourceType = Deb, sourceOptions = [SourceOption "trusted" OpSet ["yes"]], sourceUri = fromJust (parseURI "http://ftp.debian.org/whee"), sourceDist = Right (ReleaseName {relName = "dist"},[Section "space section"])}] - -validSourcesListExpected :: String -validSourcesListExpected = - unlines $ [ "deb ftp://ftp.debian.org/debian unstable main contrib non-free" - , "deb-src ftp://ftp.debian.org/debian unstable main contrib non-free" - , "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./" - , "deb [trusted=yes] http://ftp.debian.org/whee space%20dist main" - , "deb [trusted=yes] http://ftp.debian.org/whee dist space%20section" - ] -_invalidSourcesListStr1 :: Text -_invalidSourcesListStr1 = "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ main contrib non-free # exact path with sections" - -testSourcesListParse :: Test -testSourcesListParse = - test [ assertEqual "" gutsy (concat . map (<> "\n") . map (render . pPrint) . parseSourcesList $ gutsy) ] - where - 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"] - -sourcesListTests :: Test -sourcesListTests = - TestList [ testQuoteWords, testSourcesList, testSourcesList2, testSourcesListParse ] diff --git a/Debian/Time.hs b/Debian/Time.hs deleted file mode 100644 --- a/Debian/Time.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE CPP #-} -module Debian.Time where - -import Data.Time -#if !MIN_VERSION_time(1,5,0) -import System.Locale (defaultTimeLocale) -#endif -import Data.Time.Clock.POSIX -import System.Posix.Types - --- * Time Helper Functions - -rfc822DateFormat' :: String -rfc822DateFormat' = "%a, %d %b %Y %T %z" - -epochTimeToUTCTime :: EpochTime -> UTCTime -epochTimeToUTCTime = posixSecondsToUTCTime . fromIntegral . fromEnum - -formatTimeRFC822 :: (FormatTime t) => t -> String -formatTimeRFC822 = formatTime defaultTimeLocale rfc822DateFormat' - -parseTimeRFC822 :: (ParseTime t) => String -> Maybe t -parseTimeRFC822 = parseTime defaultTimeLocale rfc822DateFormat' - -getCurrentLocalRFC822Time :: IO String -getCurrentLocalRFC822Time = getCurrentTime >>= utcToLocalZonedTime >>= return . formatTime defaultTimeLocale rfc822DateFormat' - diff --git a/Debian/URI.hs b/Debian/URI.hs deleted file mode 100644 --- a/Debian/URI.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE CPP, PackageImports #-} -{-# OPTIONS -Wall -fno-warn-orphans #-} - -module Debian.URI - ( module Network.URI - , URI' - , toURI' - , fromURI' - , readURI' - , uriToString' - , fileFromURI - , fileFromURIStrict - , dirFromURI - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Control.Exception (SomeException, throw, try) -import Data.ByteString.Lazy.UTF8 as L -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Maybe (catMaybes, fromJust) -import Data.Text as T (unpack) -import Data.Text.Encoding (decodeUtf8) -import Network.URI (URI(..), URIAuth(..), parseURI, uriToString) -import System.Directory (getDirectoryContents) -import System.Exit (ExitCode(..)) --- import System.Process.ByteString (readProcessWithExitCode) -import System.Process (CreateProcess, proc) -import System.Process.Common (showCreateProcessForUser) -import System.Process.ByteString.Lazy (readCreateProcessWithExitCode) -import Text.Regex (mkRegex, matchRegex) - --- | A wrapper around a String containing a known parsable URI. Not --- absolutely safe, because you could say read "URI' \"bogus string\"" --- :: URI'. But enough to save me from myself. -newtype URI' = URI' String deriving (Read, Show, Eq, Ord) - -readURI' :: String -> Maybe URI' -readURI' s = maybe Nothing (const (Just (URI' s))) (parseURI s) - -fromURI' :: URI' -> URI -fromURI' (URI' s) = fromJust (parseURI s) - --- | Using the bogus Show instance of URI here. If it ever gets fixed --- this will stop working. Worth noting that show will obscure any --- password info embedded in the URI, so that's nice. -toURI' :: URI -> URI' -toURI' = URI' . show - -uriToString' :: URI -> String -uriToString' uri = uriToString id uri "" - -fileFromURI :: URI -> IO (Either SomeException L.ByteString) -fileFromURI uri = fileFromURIStrict uri - -fileFromURIStrict :: URI -> IO (Either SomeException L.ByteString) -fileFromURIStrict uri = try $ - case (uriScheme uri, uriAuthority uri) of - ("file:", Nothing) -> L.readFile (uriPath uri) - -- ("ssh:", Just auth) -> cmdOutputStrict ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " cat " ++ show (uriPath uri)) - ("ssh:", Just auth) -> - run (proc "ssh" [uriUserInfo auth ++ uriRegName auth ++ uriPort auth, "cat", uriPath uri]) - _ -> - run (proc "curl" ["-s", "-g", uriToString' uri]) - --- | 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 text = - catMaybes . map (second . matchRegex re) . Prelude.lines . L.toString $ text - where - re = mkRegex "( IO (Either SomeException [String]) -dirFromURI uri = try $ - case (uriScheme uri, uriAuthority uri) of - ("file:", Nothing) -> getDirectoryContents (uriPath uri) - ("ssh:", Just auth) -> - (Prelude.lines . L.toString) <$> - run (proc "ssh" [uriUserInfo auth ++ uriRegName auth ++ uriPort auth, "ls", "-1", uriPath uri]) - _ -> - webServerDirectoryContents <$> - run (proc "curl" ["-s", "-g", uriToString' uri]) - -run :: CreateProcess -> IO L.ByteString -run cp = do - (code, out, err) <- readCreateProcessWithExitCode cp L.empty - case code of - ExitSuccess -> return out - ExitFailure _ -> throw (userError (show code ++ "\n" ++ - " command: " ++ showCreateProcessForUser cp ++ "\n" ++ - " stderr: " ++ unpack (decodeUtf8 (L.toStrict err)) ++ "\n" ++ - " stdout: " ++ unpack (decodeUtf8 (L.toStrict out)))) diff --git a/Debian/UTF8.hs b/Debian/UTF8.hs deleted file mode 100644 --- a/Debian/UTF8.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE CPP #-} --- | There are old index files that have funky characters like 'ø' --- that are not properly UTF8 encoded. As far as I can tell, these --- files are otherwise plain ascii, so just naivelyinsert the --- character into the output stream. -module Debian.UTF8 - ( decode - , readFile - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import qualified Data.ByteString.Char8 as B (concat) -import qualified Data.ByteString.Lazy.Char8 as L (ByteString, readFile, toChunks) -import Data.Char (chr) -import Data.Text as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Word (Word8) -import Prelude hiding (readFile) - -decode :: L.ByteString -> T.Text -decode b = decodeUtf8With e (B.concat (L.toChunks b)) - where - e :: String -> Maybe Word8 -> Maybe Char - e _description w = fmap (chr . fromIntegral) w - -readFile :: FilePath -> IO T.Text -readFile path = decode <$> L.readFile path diff --git a/Debian/Util/FakeChanges.hs b/Debian/Util/FakeChanges.hs deleted file mode 100644 --- a/Debian/Util/FakeChanges.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} -module Debian.Util.FakeChanges (fakeChanges) where - ---import Control.Arrow -import Control.Exception -import Control.Monad hiding (mapM) -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Data (Data, Typeable) -import Data.Digest.Pure.SHA as SHA -import Data.Foldable (concat, all, foldr) -import Data.List as List (intercalate, nub, partition, isSuffixOf) -import Data.Maybe -import Debian.Pretty (prettyShow) -import Data.Traversable -import Debian.Control -import qualified Debian.Deb as Deb -import Debian.Time -import Network.BSD (getHostName) -import Prelude hiding (concat, foldr, all, mapM, sum) -import System.Environment -import System.FilePath -import System.Posix.Files -import Text.Regex.TDFA - -data Error - = NoDebs - | TooManyDscs [FilePath] - | TooManyTars [FilePath] - | TooManyDiffs [FilePath] - | UnknownFiles [FilePath] - | MalformedDebFilename [FilePath] - | VersionMismatch [Maybe String] - deriving (Read, Show, Eq, Typeable, Data) - -data Files - = Files { dsc :: Maybe (FilePath, Paragraph) - , debs :: [(FilePath, Paragraph)] - , tar :: Maybe FilePath - , diff :: Maybe FilePath - } - -fakeChanges :: [FilePath] -> IO (FilePath, String) -fakeChanges fps = - do files <- loadFiles fps - let version = getVersion files - source = getSource files - maintainer = getMaintainer files - arches = getArches files - binArch = getBinArch files - dist = "unstable" - urgency = "low" - (invalid, binaries) = unzipEithers $ map (debNameSplit . fst) (debs files) - when (not . null $ invalid) (error $ "Some .deb names are invalid: " ++ show invalid) - uploader <- getUploader - date <- getCurrentLocalRFC822Time - fileLines <- mapM mkFileLine fps - let changes = Control $ return . Paragraph $ map Field - [ ("Format"," 1.7") - , ("Date", ' ' : date) - , ("Source", ' ' : source) - , ("Binary", ' ' : (intercalate " " $ map (\(n,_,_) -> n) binaries)) - , ("Architecture", ' ' : intercalate " " arches) - , ("Version", ' ' : version) - , ("Distribution", ' ' : dist) - , ("Urgency", ' ' : urgency) - , ("Maintainer", ' ' : maintainer) - , ("Changed-By", ' ' : uploader) - , ("Description", "\n Simulated description") - , ("Changes", "\n" ++ unlines (map (' ':) [ source ++ " (" ++ version ++") " ++ dist ++ "; urgency=" ++ urgency - , "." - , " * Simulated changes" - ] - )) - , ("Files", "\n" ++ unlines fileLines) - ] - return $ (concat [ source, "_", version, "_", binArch, ".changes"], prettyShow changes) --- let (invalid, binaries) = unzipEithers $ map debNameSplit debs -{- - when (not . null $ invalid) (throwDyn [MalformedDebFilename invalid]) - version <- getVersion dsc debs - putStrLn version - source <- getSource dsc debs - putStrLn source --} --- TODO: seems like this could be more aggressive about ensure the --- versions make sense. Except with packages like libc, the versions --- don't make sense. Maybe we want a flag that disables version check --- ? -getVersion :: Files -> String -getVersion files - | isNothing (dsc files) = - let versions = map (fieldValue "Version" . snd) (debs files) - in - if (all isJust versions) && (length (nub versions) == 1) - then fromJust (head versions) - else error (show [VersionMismatch (nub versions)]) - | otherwise = - case fieldValue "Version" (snd . fromJust $ dsc files) of - (Just v) -> v - Nothing -> error $ "show (dsc files)" ++ " does not have a Version field :(" - - -getSource :: Files -> String -getSource files = - let dscSource = - case (dsc files) of - Nothing -> [] - (Just (fp, p)) -> - case fieldValue "Source" p of - (Just v) -> [v] - Nothing -> error $ fp ++ " does not have a Source field :(" - debSources = map debSource (debs files) - srcs = nub (dscSource ++ debSources) - in - if (singleton srcs) - then (head srcs) - else error $ "Could not determine source." - where - debSource (deb,p) = - case (fieldValue "Source" p) of - (Just v) -> v - Nothing -> - case fieldValue "Package" p of - (Just v) -> v - Nothing -> error $ "Could not find Source or Package field in " ++ deb - - - -getMaintainer :: Files -> String -getMaintainer files - | isJust (dsc files) = - let (fp, p) = fromJust (dsc files) - in - case fieldValue "Maintainer" p of - Nothing -> error $ fp ++ " is missing the Maintainer field." - (Just v) -> v - | otherwise = - let maintainers = catMaybes $ map (fieldValue "Maintainer" . snd) (debs files) - maintainer = nub maintainers - in - if singleton maintainer - then head maintainer - else error $ "Could not uniquely determine the maintainer: " ++ show maintainer - -getArches :: Files -> [String] -getArches files = - let debArchs = map (fieldValue "Architecture" . snd) (debs files) - tarArch = fmap (const "source") (tar files) - diffArch = fmap (const "source") (diff files) - in - nub $ catMaybes (tarArch : diffArch : debArchs) - - -getBinArch :: Files -> String -getBinArch files = - let binArch = nub $ mapMaybe (fieldValue "Architecture" . snd) (debs files) - in - if singleton binArch - then head binArch - else case (filter (/= "all") binArch) of - [b] -> b - _ -> error $ "Could not uniquely determine binary architecture: " ++ show binArch - -mkFileLine :: FilePath -> IO String -mkFileLine fp - | ".deb" `isSuffixOf` fp = - do sum <- L.readFile fp >>= return . show . sha256 - size <- liftM fileSize $ getFileStatus fp - (Control (p:_)) <- Deb.fields fp - return $ concat [ " ", sum, " ", show size, " ", fromMaybe "unknown" (fieldValue "Section" p), " " - , fromMaybe "optional" (fieldValue "Priority" p), " ", (takeBaseName fp) - ] - | otherwise = - do sum <- L.readFile fp >>= return . show . sha256 - size <- liftM fileSize $ getFileStatus fp - return $ concat [ " ", sum, " ", show size, " ", "unknown", " " - , "optional"," ", (takeBaseName fp) - ] - --- more implementations can be found at: --- http://www.google.com/codesearch?hl=en&lr=&q=%22%5BEither+a+b%5D+-%3E+%28%5Ba%5D%2C%5Bb%5D%29%22&btnG=Search -unzipEithers :: [Either a b] -> ([a],[b]) -unzipEithers = foldr unzipEither ([],[]) - where - unzipEither (Left l) ~(ls, rs) = (l:ls, rs) - unzipEither (Right r) ~(ls, rs) = (ls, r:rs) - --- move to different library -debNameSplit :: String -> Either FilePath (String, String, String) -debNameSplit fp = - case (takeFileName fp) =~ "^(.*)_(.*)_(.*).deb$" of - [[_, name, version, arch]] -> Right (name, version, arch) - _ -> Left fp - - -loadFiles :: [FilePath] -> IO Files -loadFiles files = - let (dscs', files'') = partition (isSuffixOf ".dsc") files' - (debs', files') = partition (isSuffixOf ".deb") files - (tars', files''') = partition (isSuffixOf ".tar.gz") files'' - (diffs', rest) = partition (isSuffixOf ".diff.gz") files''' - errors = concat [ if (length debs' < 1) then [NoDebs] else [] - , if (length dscs' > 1) then [TooManyDscs dscs'] else [] - , if (length tars' > 1) then [TooManyTars tars'] else [] - , if (length diffs' > 1) then [TooManyDiffs diffs'] else [] - , if (length rest > 0) then [UnknownFiles rest] else [] - ] - in - do when (not . null $ errors) (error $ show errors) - dsc' <- mapM loadDsc (listToMaybe dscs') - debs'' <- mapM loadDeb debs' - return $ Files { dsc = dsc', debs = debs'', tar = listToMaybe tars', diff = listToMaybe diffs' } - -- if (not . null $ errors) then throwDyn errors else return (debs, listToMaybe dscs, listToMaybe tars, listToMaybe diffs) - where - loadDsc :: FilePath -> IO (FilePath, Paragraph) - loadDsc dsc' = - do res <- parseControlFromFile dsc' - 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: " ++ prettyShow 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: " ++ prettyShow res - - -getUploader :: IO String -getUploader = - do debFullName <- - do dfn <- try (getEnv "DEBFULLNAME") - case dfn of - (Right n) -> return n - (Left (_ :: SomeException)) -> - do dfn' <-try (getEnv "USER") - case dfn' of - (Right n) -> return n - (Left (_ :: SomeException)) -> error $ "Could not determine user name, neither DEBFULLNAME nor USER enviroment variables were set." - emailAddr <- - do eml <- try (getEnv "DEBEMAIL") - case eml of - (Right e) -> return e - (Left (_ :: SomeException)) -> - do eml' <- try (getEnv "EMAIL") - case eml' of - (Right e) -> return e - (Left (_ :: SomeException)) -> getHostName -- FIXME: this is not a FQDN - return $ debFullName ++ " <" ++ emailAddr ++ ">" - --- * Utils - -singleton :: [a] -> Bool -singleton [_] = True -singleton _ = False diff --git a/Debian/Version.hs b/Debian/Version.hs deleted file mode 100644 --- a/Debian/Version.hs +++ /dev/null @@ -1,16 +0,0 @@ --- |A module for parsing, comparing, and (eventually) modifying debian version --- numbers. -module Debian.Version - (DebianVersion -- |Exported abstract because the internal representation is likely to change - , prettyDebianVersion - , parseDebianVersion - , parseDebianVersion' - , epoch - , version - , revision - , buildDebianVersion - , evr - ) where - -import Debian.Version.Common -import Debian.Version.String () diff --git a/Debian/Version/ByteString.hs b/Debian/Version/ByteString.hs deleted file mode 100644 --- a/Debian/Version/ByteString.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module Debian.Version.ByteString - ( ParseDebianVersion(..) - ) where - -import Text.ParserCombinators.Parsec - -import qualified Data.ByteString.Char8 as C - -import Debian.Version.Common -import Debian.Version.Internal - -instance ParseDebianVersion C.ByteString where - parseDebianVersion byteStr = - let str = C.unpack byteStr in - case parse parseDV str str of - Left e -> Left e - Right dv -> Right (DebianVersion str dv) diff --git a/Debian/Version/Common.hs b/Debian/Version/Common.hs deleted file mode 100644 --- a/Debian/Version/Common.hs +++ /dev/null @@ -1,185 +0,0 @@ --- |A module for parsing, comparing, and (eventually) modifying debian version --- numbers. -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS -fno-warn-orphans -fno-warn-unused-do-bind #-} -module Debian.Version.Common - ( DebianVersion -- |Exported abstract because the internal representation is likely to change - , prettyDebianVersion - , ParseDebianVersion(..) - , parseDebianVersion' - , evr -- DebianVersion -> (Maybe Int, String, Maybe String) - , epoch - , version - , revision - , buildDebianVersion - , parseDV - ) where - -import Data.Char (ord, isDigit, isAlpha) -import Debian.Pretty (PP(..)) -import Debian.Version.Internal -import Text.ParserCombinators.Parsec -import Text.Regex -import Text.PrettyPrint (Doc, render) -import Text.PrettyPrint.HughesPJClass (Pretty(pPrint), text) - -prettyDebianVersion :: DebianVersion -> Doc -prettyDebianVersion (DebianVersion s _) = text s - -instance Pretty (PP DebianVersion) where - pPrint = prettyDebianVersion . unPP - -instance Eq DebianVersion where - (DebianVersion _ v1) == (DebianVersion _ v2) = v1 == v2 - -instance Ord DebianVersion where - compare (DebianVersion _ v1) (DebianVersion _ v2) = compare v1 v2 - -instance Show DebianVersion where - show v = "(Debian.Version.parseDebianVersion (" ++ show (render (prettyDebianVersion v)) ++ " :: String))" - --- make ~ less than everything, and everything else higher that letters -order :: Char -> Int -order c - | isDigit c = 0 - | isAlpha c = ord c - | c == '~' = -1 - | otherwise = (ord c) + 256 - --- |We have to do this wackiness because ~ is less than the empty string -compareNonNumeric :: [Char] -> [Char] -> Ordering -compareNonNumeric "" "" = EQ -compareNonNumeric "" ('~':_cs) = GT -compareNonNumeric ('~':_cs) "" = LT -compareNonNumeric "" _ = LT -compareNonNumeric _ "" = GT -compareNonNumeric (c1:cs1) (c2:cs2) = - if (order c1) == (order c2) - then compareNonNumeric cs1 cs2 - else compare (order c1) (order c2) - -instance Eq NonNumeric where - (NonNumeric s1 n1) == (NonNumeric s2 n2) = - case compareNonNumeric s1 s2 of - EQ -> n1 == n2 - _o -> False - -instance Ord NonNumeric where - compare (NonNumeric s1 n1) (NonNumeric s2 n2) = - case compareNonNumeric s1 s2 of - EQ -> compare n1 n2 - o -> o - -instance Eq Numeric where - (Numeric n1 mnn1) == (Numeric n2 mnn2) = - case compare n1 n2 of - EQ -> case compareMaybeNonNumeric mnn1 mnn2 of - EQ -> True - _ -> False - _ -> False - -compareMaybeNonNumeric :: Maybe NonNumeric -> Maybe NonNumeric -> Ordering -compareMaybeNonNumeric mnn1 mnn2 = - case (mnn1, mnn2) of - (Nothing, Nothing) -> EQ - (Just (NonNumeric nn _), Nothing) -> compareNonNumeric nn "" - (Nothing, Just (NonNumeric nn _)) -> compareNonNumeric "" nn - (Just nn1, Just nn2) -> compare nn1 nn2 - -instance Ord Numeric where - compare (Numeric n1 mnn1) (Numeric n2 mnn2) = - case compare n1 n2 of - EQ -> compareMaybeNonNumeric mnn1 mnn2 - o -> o - --- * Parser - -class ParseDebianVersion a where - parseDebianVersion :: a-> Either ParseError DebianVersion --- |Convert a string to a debian version number. May throw an --- exception if the string is unparsable -- but I am not sure if that --- can currently happen. Are there any invalid version strings? --- Perhaps ones with underscore, or something? - -parseDebianVersion' :: ParseDebianVersion string => string -> DebianVersion -parseDebianVersion' str = either (\e -> error (show e)) id (parseDebianVersion str) - -{- -showNN :: NonNumeric -> String -showNN (NonNumeric s n) = s ++ showN n - -showN :: Found Numeric -> String -showN (Found (Numeric n nn)) = show n ++ maybe "" showNN nn -showN (Simulated _) = "" --} - -parseDV :: CharParser () (Found Int, NonNumeric, Found NonNumeric) -parseDV = - do skipMany $ oneOf " \t" - e <- parseEpoch - upstreamVersion <- parseNonNumeric True True - debianRevision <- option (Simulated (NonNumeric "" (Simulated (Numeric 0 Nothing)))) (char '-' >> parseNonNumeric True False >>= return . Found) - return (e, upstreamVersion, debianRevision) - -parseEpoch :: CharParser () (Found Int) -parseEpoch = - option (Simulated 0) (try (many1 digit >>= \d -> char ':' >> return (Found (read d)))) - - -parseNonNumeric :: Bool -> Bool -> CharParser () NonNumeric -parseNonNumeric zeroOk upstream = - do nn <- (if zeroOk then many else many1) ((noneOf "-0123456789") <|> (if upstream then upstreamDash else pzero)) - n <- parseNumeric upstream - return $ NonNumeric nn n - where - upstreamDash :: CharParser () Char - upstreamDash = try $ do char '-' - lookAhead $ (many (noneOf "- \n\t") >> char '-') - return '-' - -parseNumeric :: Bool -> CharParser () (Found Numeric) -parseNumeric upstream = - do n <- many1 (satisfy isDigit) - nn <- option Nothing (parseNonNumeric False upstream >>= return . Just) - return $ Found (Numeric (read n) nn) - <|> - return (Simulated (Numeric 0 Nothing)) - -{- -compareTest :: String -> String -> Ordering -compareTest str1 str2 = - let v1 = either (error . show) id $ parse parseDV str1 str1 - v2 = either (error . show) id $ parse parseDV str2 str2 - in - compare v1 v2 --} - --- |Split a DebianVersion into its three components: epoch, version, --- revision. It is not safe to use the parsed version number for --- this because you will lose information, such as leading zeros. -evr :: DebianVersion -> (Maybe Int, String, Maybe String) -evr (DebianVersion s _) = - let re = mkRegex "^(([0-9]+):)?(([^-]*)|((.*)-([^-]*)))$" in - -- ( ) ( ( )) - -- ( e ) ( v ) (v2) ( r ) - case matchRegex re s of - Just ["", _, _, v, "", _, _] -> (Nothing, v, Nothing) - Just ["", _, _, _, _, v, r] -> (Nothing, v, Just r) - Just [_, e, _, v, "", _, _] -> (Just (read e), v, Nothing) - Just [_, e, _, _, _, v, r] -> (Just (read e), v, Just r) - -- I really don't think this can happen. - _ -> error ("Invalid Debian Version String: " ++ s) - -epoch :: DebianVersion -> Maybe Int -epoch v = case evr v of (x, _, _) -> x -version :: DebianVersion -> String -version v = case evr v of (_, x, _) -> x -revision :: DebianVersion -> Maybe String -revision v = case evr v of (_, _, x) -> x - --- Build a Debian version number from epoch, version, revision -buildDebianVersion :: Maybe Int -> String -> Maybe String -> DebianVersion -buildDebianVersion e v r = - either (error . show) (DebianVersion str) $ parse parseDV str str - where - str = (maybe "" (\ n -> show n ++ ":") e ++ v ++ maybe "" (\ s -> "-" ++ s) r) diff --git a/Debian/Version/Internal.hs b/Debian/Version/Internal.hs deleted file mode 100644 --- a/Debian/Version/Internal.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} -module Debian.Version.Internal - ( DebianVersion(..) - , Numeric(..) - , NonNumeric(..) - , Found(..) - ) where - -import Data.Data (Data) -import Data.Typeable (Typeable) - --- Currently we store the original version string in the data-type so --- that we can faithfully reproduce it quickly. Currently we do not --- have any way to modify a version number -- so this works fine. May --- have to change later. -data DebianVersion - = DebianVersion String (Found Int, NonNumeric, Found NonNumeric) deriving (Data, Typeable) - -data NonNumeric - = NonNumeric String (Found Numeric) - deriving (Show, Data, Typeable) - -data Numeric - = Numeric Int (Maybe NonNumeric) - deriving (Show, Data, Typeable) - -data Found a - = Found { unFound :: a } - | Simulated { unFound :: a } - deriving (Show, Data, Typeable) - -instance (Eq a) => Eq (Found a) where - f1 == f2 = (unFound f1) == (unFound f2) - -instance (Ord a) => Ord (Found a) where - compare f1 f2 = compare (unFound f1) (unFound f2) diff --git a/Debian/Version/String.hs b/Debian/Version/String.hs deleted file mode 100644 --- a/Debian/Version/String.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -{-# OPTIONS -fno-warn-orphans #-} -module Debian.Version.String - ( ParseDebianVersion(..) - ) where - -import Text.ParserCombinators.Parsec - -import Data.List (stripPrefix) -import Debian.Version.Common -import Debian.Version.Internal - -instance ParseDebianVersion String where - parseDebianVersion str = - case parse parseDV str str of - Left e -> Left e - Right dv -> Right (DebianVersion str dv) - -instance Read DebianVersion where - readsPrec _ s = - case stripPrefix "Debian.Version.parseDebianVersion " s of - Just s' -> case reads s' :: [(String, String)] of - []-> [] - (v, s'') : _ -> [(parseDebianVersion' v, s'')] - Nothing -> [] diff --git a/Debian/Version/Text.hs b/Debian/Version/Text.hs deleted file mode 100644 --- a/Debian/Version/Text.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module Debian.Version.Text - ( ParseDebianVersion(..) - ) where - -import Text.ParserCombinators.Parsec - -import qualified Data.Text as T - -import Debian.Version.Common -import Debian.Version.Internal - -instance ParseDebianVersion T.Text where - parseDebianVersion text = - let str = T.unpack text in - case parse parseDV str str of - Left e -> Left e - Right dv -> Right (DebianVersion str dv) diff --git a/Test/Changes.hs b/Test/Changes.hs --- a/Test/Changes.hs +++ b/Test/Changes.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving, TemplateHaskell #-} {-# OPTIONS -fno-warn-missing-signatures -fno-warn-orphans #-} module Changes where import Debian.Changes +import Debian.Codename (Codename, parseCodename) import Debian.Pretty (PP(..)) -import Debian.Release (ReleaseName(ReleaseName, relName)) import Debian.Version (parseDebianVersion, parseDebianVersion') +import Debian.TH (here) +import Distribution.Pretty (pretty) import Test.HUnit import Text.PrettyPrint (render) -import Text.PrettyPrint.HughesPJClass (pPrint) s3 = unlines ["name (version) dist; urgency=urgency", @@ -157,17 +158,17 @@ " -- Marco Túlio Gontijo e Silva Wed, 11 Mar 2009 18:58:06 -0300", ""] -test5 = TestCase (assertEqual "haskell-regex-compat changelog 1" s1 (render . pPrint . PP . either (const (error "parse")) id . parseChangeLog $ s1)) +test5 = TestCase (assertEqual "haskell-regex-compat changelog 1" s1 (render . pretty . PP . either (const (error "parse")) id . parseChangeLog $ s1)) test3 = TestCase (assertEqual "haskell-regex-compat changelog 2" expected (parseEntries s3)) - where expected = [Right (Entry {logPackage = "name", logVersion = parseDebianVersion' "version", logDists = [ReleaseName {relName = "dist"}], logUrgency = "urgency", logComments = " * details\n", logWho = "David Fox ", logDate = "Wed, 21 Nov 2007 01:26:57 +0000"})] + where expected = [Right (Entry {logPackage = "name", logVersion = parseDebianVersion' "version", logDists = [parseCodename "dist"], logUrgency = "urgency", logComments = " * details\n", logWho = "David Fox ", logDate = "Wed, 21 Nov 2007 01:26:57 +0000"})] test4 = TestCase (assertEqual "haskell-regex-compat changelog 3" expected (parseEntries s4)) where expected = [Right (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-3+seereason1~jaunty4", - logDists = [ReleaseName {relName = "jaunty-seereason"}], + logDists = [parseCodename "jaunty-seereason"], logUrgency = "low", logComments = " [ Joachim Breitner ]\n * Adjust priority according to override file\n * Depend on hscolour (Closes: #550769)\n\n [ Marco T\250lio Gontijo e Silva ]\n", logWho = "David Fox ", @@ -175,33 +176,33 @@ test1 = TestCase (assertEqual "haskell-regex-compat changelog 4" expected (either (const (error "parse")) id (parseChangeLog s1))) - where expected = ChangeLog [(Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-3+seereason1~jaunty4", logDists = [ReleaseName {relName = "jaunty-seereason"}], logUrgency = "low", logComments = " [ Joachim Breitner ]\n * Adjust priority according to override file\n * Depend on hscolour (Closes: #550769)\n\n [ Marco T\250lio Gontijo e Silva ]\n * debian/control: Use more sintetic name for Vcs-Darcs.\n * Built from sid apt pool\n * Build dependency changes:\n cpphs: 1.9-1+seereason1~jaunty5 -> 1.9-1+seereason1~jaunty6\n ghc6: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n ghc6-doc: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n ghc6-prof: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n haddock: 2.4.2-3+seereason3~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n haskell-devscripts: 0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1\n haskell-regex-base-doc: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1\n haskell-regex-posix-doc: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2\n libghc6-regex-base-dev: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1\n libghc6-regex-base-prof: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1\n libghc6-regex-posix-dev: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2\n libghc6-regex-posix-prof: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2\n", logWho = "SeeReason Autobuilder ", logDate = "Fri, 25 Dec 2009 01:55:37 -0800"}), - (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-3", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " [ Joachim Breitner ]\n * Adjust priority according to override file\n * Depend on hscolour (Closes: #550769)\n\n [ Marco T\250lio Gontijo e Silva ]\n * debian/control: Use more sintetic name for Vcs-Darcs.\n", logWho = "Joachim Breitner ", logDate = "Mon, 20 Jul 2009 13:05:35 +0200"}), - (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-2", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " * Adopt package for the Debian Haskell Group\n * Fix \"FTBFS with new dpkg-dev\" by adding comma to debian/control\n (Closes: #536473)\n", logWho = "Joachim Breitner ", logDate = "Mon, 20 Jul 2009 12:05:40 +0200"}), - (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-1.1", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " * Rebuild for GHC 6.10.\n * NMU with permission of the author.\n", logWho = "John Goerzen ", logDate = "Mon, 16 Mar 2009 10:12:04 -0500"}), - (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-1", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " * New upstream release\n * debian/control:\n - Bump Standards-Version. No changes needed.\n", logWho = "Arjan Oosting ", logDate = "Sun, 18 Jan 2009 00:05:02 +0100"}), - (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.91-1", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " * Take over package from Ian, as I already maintain haskell-regex-base,\n and move Ian to the Uploaders field.\n * Packaging complete redone (based on my haskell-regex-base package).\n", logWho = "Arjan Oosting ", logDate = "Sat, 19 Jan 2008 16:48:39 +0100"}), - (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.71.0.1-1", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " * Initial release (used to be part of ghc6).\n * Using \"Generic Haskell cabal library packaging files v9\".\n", logWho = "Ian Lynagh (wibble) ", logDate = "Wed, 21 Nov 2007 01:26:57 +0000"})] + where expected = ChangeLog [(Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-3+seereason1~jaunty4", logDists = [parseCodename "jaunty-seereason"], logUrgency = "low", logComments = " [ Joachim Breitner ]\n * Adjust priority according to override file\n * Depend on hscolour (Closes: #550769)\n\n [ Marco T\250lio Gontijo e Silva ]\n * debian/control: Use more sintetic name for Vcs-Darcs.\n * Built from sid apt pool\n * Build dependency changes:\n cpphs: 1.9-1+seereason1~jaunty5 -> 1.9-1+seereason1~jaunty6\n ghc6: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n ghc6-doc: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n ghc6-prof: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n haddock: 2.4.2-3+seereason3~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n haskell-devscripts: 0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1\n haskell-regex-base-doc: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1\n haskell-regex-posix-doc: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2\n libghc6-regex-base-dev: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1\n libghc6-regex-base-prof: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1\n libghc6-regex-posix-dev: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2\n libghc6-regex-posix-prof: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2\n", logWho = "SeeReason Autobuilder ", logDate = "Fri, 25 Dec 2009 01:55:37 -0800"}), + (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-3", logDists = [parseCodename "unstable"], logUrgency = "low", logComments = " [ Joachim Breitner ]\n * Adjust priority according to override file\n * Depend on hscolour (Closes: #550769)\n\n [ Marco T\250lio Gontijo e Silva ]\n * debian/control: Use more sintetic name for Vcs-Darcs.\n", logWho = "Joachim Breitner ", logDate = "Mon, 20 Jul 2009 13:05:35 +0200"}), + (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-2", logDists = [parseCodename "unstable"], logUrgency = "low", logComments = " * Adopt package for the Debian Haskell Group\n * Fix \"FTBFS with new dpkg-dev\" by adding comma to debian/control\n (Closes: #536473)\n", logWho = "Joachim Breitner ", logDate = "Mon, 20 Jul 2009 12:05:40 +0200"}), + (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-1.1", logDists = [parseCodename "unstable"], logUrgency = "low", logComments = " * Rebuild for GHC 6.10.\n * NMU with permission of the author.\n", logWho = "John Goerzen ", logDate = "Mon, 16 Mar 2009 10:12:04 -0500"}), + (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.92-1", logDists = [parseCodename "unstable"], logUrgency = "low", logComments = " * New upstream release\n * debian/control:\n - Bump Standards-Version. No changes needed.\n", logWho = "Arjan Oosting ", logDate = "Sun, 18 Jan 2009 00:05:02 +0100"}), + (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.91-1", logDists = [parseCodename "unstable"], logUrgency = "low", logComments = " * Take over package from Ian, as I already maintain haskell-regex-base,\n and move Ian to the Uploaders field.\n * Packaging complete redone (based on my haskell-regex-base package).\n", logWho = "Arjan Oosting ", logDate = "Sat, 19 Jan 2008 16:48:39 +0100"}), + (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion' "0.71.0.1-1", logDists = [parseCodename "unstable"], logUrgency = "low", logComments = " * Initial release (used to be part of ghc6).\n * Using \"Generic Haskell cabal library packaging files v9\".\n", logWho = "Ian Lynagh (wibble) ", logDate = "Wed, 21 Nov 2007 01:26:57 +0000"})] test2 = TestCase (assertEqual "haskell-regex-compat changelog" expected (parseEntries s2)) where expected = [Right (Entry {logPackage = "haskell-haskeline", logVersion = parseDebianVersion' "0.6.1.6-1+seereason1~jaunty6", - logDists = [ReleaseName {relName = "jaunty-seereason"}], + logDists = [parseCodename "jaunty-seereason"], logUrgency = "low", logComments = " * New upstream version.\n * Remove extensible-exceptions patch, since ghc6 now ships it.\n * debian/control:\n - Use versioned Build-Depends.\n - Use unversioned Recommends for ghc6-doc in libghc6-terminfo-doc.\n - Use haskell Section.\n - Use new Standards-Version: 3.8.1.\n - Use DM-Upload-Allowed: yes.\n - Use haskell:Recommends and haskell:Suggests.\n - Don't use shlibs:Depends for -prof.\n - Split dependencies in more than one line.\n * Built from sid apt pool\n * Build dependency changes:\n ghc6: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n ghc6-doc: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n ghc6-prof: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n haddock: 2.4.2-3+seereason3~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n haskell-devscripts: 0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1\n libghc6-mtl-dev: 1.1.0.2-7+seereason3~jaunty7 -> 1.1.0.2-7+seereason3~jaunty8\n libghc6-mtl-doc: 1.1.0.2-7+seereason3~jaunty7 -> 1.1.0.2-7+seereason3~jaunty8\n libghc6-mtl-prof: 1.1.0.2-7+seereason3~jaunty7 -> 1.1.0.2-7+seereason3~jaunty8\n libghc6-terminfo-dev: 0.3.0.2-2+seereason1~jaunty5 -> 0.3.0.2-2+seereason1~jaunty6\n libghc6-terminfo-doc: 0.3.0.2-2+seereason1~jaunty5 -> 0.3.0.2-2+seereason1~jaunty6\n libghc6-terminfo-prof: 0.3.0.2-2+seereason1~jaunty5 -> 0.3.0.2-2+seereason1~jaunty6\n libghc6-utf8-string-dev: 0.3.5-1+seereason3~jaunty7 -> 0.3.5-1++1+seereason1~jaunty1\n libghc6-utf8-string-doc: 0.3.5-1+seereason3~jaunty7 -> 0.3.5-1++1+seereason1~jaunty1\n libghc6-utf8-string-prof: 0.3.5-1+seereason3~jaunty7 -> 0.3.5-1++1+seereason1~jaunty1\n", logWho = "SeeReason Autobuilder ", logDate = "Fri, 25 Dec 2009 13:48:18 -0800"}), Right (Entry {logPackage = "haskell-haskeline", logVersion = parseDebianVersion' "0.6.1.6-1", - logDists = [ReleaseName {relName = "unstable"}], + logDists = [parseCodename "unstable"], logUrgency = "low", logComments = " * New upstream version.\n * Remove extensible-exceptions patch, since ghc6 now ships it.\n * debian/control:\n - Use versioned Build-Depends.\n - Use unversioned Recommends for ghc6-doc in libghc6-terminfo-doc.\n - Use haskell Section.\n - Use new Standards-Version: 3.8.1.\n - Use DM-Upload-Allowed: yes.\n - Use haskell:Recommends and haskell:Suggests.\n - Don't use shlibs:Depends for -prof.\n - Split dependencies in more than one line.\n", logWho = "Marco T\250lio Gontijo e Silva ", logDate = "Tue, 02 Jun 2009 10:18:27 -0300"}), Right (Entry {logPackage = "haskell-haskeline", logVersion = parseDebianVersion' "0.6.1.3-1", - logDists = [ReleaseName {relName = "unstable"}], + logDists = [parseCodename "unstable"], logUrgency = "low", logComments = " * Initial Debian package. (Closes: #496961)\n", logWho = "Marco T\250lio Gontijo e Silva ", diff --git a/Test/Control.hs b/Test/Control.hs --- a/Test/Control.hs +++ b/Test/Control.hs @@ -12,9 +12,10 @@ import Debian.Pretty (prettyShow) import Debian.Relation import Debian.Version (parseDebianVersion, parseDebianVersion') +import Distribution.Pretty (pretty) import Paths_debian (version) import Text.Parsec.Error (ParseError) -import Text.PrettyPrint.HughesPJClass (Doc, text, pPrint) +import Text.PrettyPrint.HughesPJClass (Doc, text) import Text.Regex.TDFA ((=~), MatchResult(..)) #if !MIN_VERSION_pretty(1,1,2) @@ -38,14 +39,14 @@ -- inter-paragraph newlines, or missing terminating newlines, would be -- good. controlTests = - [ TestCase (assertEqual "pretty1" (pPrint control) (either (error "parser failed") pPrint (parseControl "debian/control" sample))) - , TestCase (assertEqual "pretty2" (text sample) (pPrint control)) - , TestCase (assertEqual "pretty3" (text (head paragraphs <> "\n")) (pPrint (head (unControl control)))) + [ TestCase (assertEqual "pretty1" (pretty control) (either (error "parser failed") pretty (parseControl "debian/control" sample))) + , TestCase (assertEqual "pretty2" (text sample) (pretty control)) + , TestCase (assertEqual "pretty3" (text (head paragraphs <> "\n")) (pretty (head (unControl control)))) -- The Pretty class instances are distinct implementations from -- those in Debian.Control.PrettyPrint. Not sure why, there is a -- terse note about performance concerns. - , TestCase (assertEqual "pretty4" (text sample) (pPrint control)) - , TestCase (assertEqual "pretty5" (text (head paragraphs <> "\n")) (pPrint (head (unControl control)))) + , TestCase (assertEqual "pretty4" (text sample) (pretty control)) + , TestCase (assertEqual "pretty5" (text (head paragraphs <> "\n")) (pretty (head (unControl control)))) , TestCase (validateDebianControl control >>= \ vc -> assertEqual "policy1" (Right (unsafeDebianControl control)) vc) -- validate control file , TestCase (validateDebianControl control >>= \ vc -> assertEqual "policy2" (Right (Just builddeps)) (either Left (debianRelations "Build-Depends") vc)) -- parse build deps , TestCase (validateDebianControl control >>= \ vc -> assertEqual "policy3" (Right Nothing) (either Left (debianRelations "Foo") vc)) -- absent field diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,24 @@ +haskell-debian (3.95) unstable; urgency=medium + + * Clean up error handling and monad transformers. + * Move source code into src subdirectory to avoid build problems on case + insensitive HFS partitions. + * Move Debian.Except module to Extra.Except in sr-extra package. + + -- David Fox Tue, 12 Feb 2019 16:38:30 -0800 + +haskell-debian (3.94) unstable; urgency=medium + + * Additions to Debian.URI. + + -- David Fox Sat, 02 Feb 2019 08:18:12 -0800 + +haskell-debian (3.93.6) unstable; urgency=medium + + * Throw a UserError when dirFromURI gets 404 Not Found + + -- David Fox Fri, 25 Jan 2019 12:12:56 -0800 + haskell-debian (3.93.5) unstable; urgency=medium * Restore import of <$> for older versions of base. diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,5 +1,5 @@ Name: debian -Version: 3.93.5 +Version: 3.95 License: BSD3 License-File: debian/copyright Author: David Fox , Jeremy Shaw , Clifford Beshers @@ -26,18 +26,21 @@ Manual: True Library - Hs-Source-Dirs: . + Hs-Source-Dirs: src Build-Depends: base >= 4 && < 5, bytestring, bzlib, + Cabal, containers, directory, either, exceptions, filepath, HaXml >= 1.20, + hostname, HUnit, + lens, ListLike >= 4.3.5, mtl, old-locale, @@ -45,18 +48,22 @@ process, process-extras >= 0.2.0, pureMD5, + QuickCheck, regex-compat, regex-tdfa, SHA, + syb, template-haskell, text, + th-lift, + th-orphans, time, unix, Unixutils >= 1.52.4, utf8-string, zlib if flag(network-uri) - Build-Depends: network >= 2.6, network-uri >= 2.6 + Build-Depends: network-uri >= 2.6 else Build-Depends: network >= 2.4 && < 2.6 if flag(pretty-new) @@ -64,7 +71,7 @@ else Build-Depends: pretty, prettyclass - ghc-options: -Wall -O2 + ghc-options: -Wall Exposed-modules: Debian.Apt.Dependencies, Debian.Apt.Index, @@ -72,6 +79,7 @@ Debian.Apt.Package, Debian.Arch, Debian.Changes, + Debian.Codename, Debian.Control, Debian.Control.Common, Debian.Control.Builder @@ -98,10 +106,12 @@ Debian.Version.String, Debian.Version.Text, Debian.Report, + Debian.TH, Debian.Time, Debian.URI, Debian.UTF8, - Debian.Util.FakeChanges + Debian.Util.FakeChanges, + Debian.VendorURI other-modules: Debian.Version.Internal @@ -109,14 +119,14 @@ Hs-Source-Dirs: utils Main-is: FakeChanges.hs Build-Depends: base, debian, directory, filepath - ghc-options: -threaded -W -O2 + 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 -O2 + ghc-options: -threaded -W C-Sources: cbits/gwinsz.c Include-Dirs: cbits Install-Includes: gwinsz.h @@ -127,14 +137,15 @@ Hs-Source-Dirs: utils Main-is: AptGetBuildDeps.hs Build-Depends: base, debian, process - ghc-options: -threaded -W -O2 + ghc-options: -threaded -W Extensions: ExistentialQuantification CPP Test-Suite debian-tests Type: exitcode-stdio-1.0 Hs-Source-Dirs: Test Main-Is: Main.hs - Build-Depends: base, debian, HUnit, parsec, regex-tdfa, text + Build-Depends: base, Cabal, debian, HUnit, parsec, regex-tdfa, text + Other-Modules: Changes Control Dependencies Paths_debian Versions if flag(pretty-new) Build-Depends: pretty >= 1.1.2 else diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,24 @@ +haskell-debian (3.95) unstable; urgency=medium + + * Clean up error handling and monad transformers. + * Move source code into src subdirectory to avoid build problems on case + insensitive HFS partitions. + * Move Debian.Except module to Extra.Except in sr-extra package. + + -- David Fox Tue, 12 Feb 2019 16:38:30 -0800 + +haskell-debian (3.94) unstable; urgency=medium + + * Additions to Debian.URI. + + -- David Fox Sat, 02 Feb 2019 08:18:12 -0800 + +haskell-debian (3.93.6) unstable; urgency=medium + + * Throw a UserError when dirFromURI gets 404 Not Found + + -- David Fox Fri, 25 Jan 2019 12:12:56 -0800 + haskell-debian (3.93.5) unstable; urgency=medium * Restore import of <$> for older versions of base. diff --git a/src/Debian/Apt/Dependencies.hs b/src/Debian/Apt/Dependencies.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Apt/Dependencies.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -fno-warn-missing-signatures #-} +module Debian.Apt.Dependencies +{- + ( solve + , State + , binaryDepends + , search + , bj' + , bt + , CSP(..) + ) -} where + +-- test gutsyPackages "libc6" (\csp -> bt csp) + +import Control.Arrow (second) +import qualified Data.ByteString.Char8 as C +import Data.List as List (find, union) +import Data.Tree (Tree(rootLabel, Node)) +import Debian.Apt.Package (PackageNameMap, packageNameMap, lookupPackageByRel) +import Debian.Control.ByteString (ControlFunctions(stripWS, lookupP, parseControlFromFile), + Field'(Field, Comment), Control'(Control), Paragraph, Control) +import Debian.Relation (BinPkgName(..)) +import Debian.Relation.ByteString (ParseRelations(..), Relation(..), OrRelation, AndRelation, Relations, checkVersionReq) +import Debian.Version (DebianVersion, parseDebianVersion, prettyDebianVersion) +import Debian.Version.ByteString () +import Text.PrettyPrint (render) + +-- * Basic CSP Types and Functions + +data Status + = Remaining AndRelation + | MissingDep Relation + | Complete + deriving (Eq) + +type State a = (Status, [a]) + +complete :: State a -> Bool +complete (Complete, _) = True +complete _ = False + +data CSP a + = CSP { pnm :: PackageNameMap a + , relations :: Relations + , depFunction :: (a -> Relations) + , conflicts :: a -> Relations + , packageVersion :: a -> (BinPkgName, DebianVersion) + } + +-- * Test CSP + +-- |TODO addProvides -- see DQL.Exec +controlCSP :: Control -> Relations -> (Paragraph -> Relations) -> CSP Paragraph +controlCSP (Control paragraphs) rels depF' = + CSP { pnm = packageNameMap getName paragraphs + , relations = rels + , depFunction = depF' + , conflicts = conflicts' + , packageVersion = packageVersionParagraph + } + where + getName :: Paragraph -> BinPkgName + getName p = case lookupP "Package" p of + Nothing -> error "Missing Package field" + Just (Field (_,n)) -> BinPkgName (C.unpack (stripWS n)) + Just (Comment _) -> error "controlCSP" + conflicts' :: Paragraph -> Relations + conflicts' p = + case lookupP "Conflicts" p of + Nothing -> [] + Just (Field (_, c)) -> either (error . show) id (parseRelations c) + Just (Comment _) -> error "controlCSP" + +testCSP :: FilePath -> (Paragraph -> Relations) -> String -> (CSP Paragraph -> IO a) -> IO a +testCSP controlFile depf relationStr cspf = + do c' <- parseControlFromFile controlFile + case c' of + Left e -> error (show e) + Right control@(Control _) -> + case parseRelations relationStr of + Left e -> error (show e) + Right r -> + cspf (controlCSP control r depf) + +depF :: Paragraph -> Relations +depF p = + let preDepends = + case lookupP "Pre-Depends" p of + Nothing -> [] + Just (Field (_,pd)) -> + either (error . show) id (parseRelations pd) + Just (Comment _) -> error "depF" + depends = + case lookupP "Depends" p of + Nothing -> [] + Just (Field (_,pd)) -> + either (error . show) id (parseRelations pd) + Just (Comment _) -> error "depF" + in + preDepends ++ depends + +sidPackages = "/var/lib/apt/lists/ftp.debian.org_debian_dists_unstable_main_binary-i386_Packages" +gutsyPackages = "/var/lib/apt/lists/mirror.anl.gov_pub_ubuntu_dists_gutsy_main_binary-i386_Packages" + +test controlFP rel labeler = + testCSP controlFP depF rel (mapM_ (\ (_,p) -> mapM_ (print . second (render . prettyDebianVersion) . packageVersionParagraph) p ) . take 1 . search labeler) + +-- TODO: add better errors +packageVersionParagraph :: Paragraph -> (BinPkgName, DebianVersion) +packageVersionParagraph p = + case lookupP "Package" p of + Nothing -> error $ "Paragraph missing Package field" + (Just (Field (_, name))) -> + case lookupP "Version" p of + Nothing -> error $ "Paragraph missing Version field" + (Just (Field (_, str))) -> + case parseDebianVersion str of + Right ver -> (BinPkgName (C.unpack (stripWS name)), ver) + Left e -> error $ "packageVersionParagraph: " ++ show e + (Just (Comment _)) -> error "packageVersionParagraph" + (Just (Comment _)) -> error "packageVersionParagraph" + + + +conflict :: CSP p -> p -> p -> Bool +conflict csp p1 p2 = + let (name1, version1) = (packageVersion csp) p1 + (name2, version2) = (packageVersion csp) p2 + in + if name1 == name2 + then version1 /= version2 + else + any (conflict' (name1, version1)) (concat $ (conflicts csp) p2) || + any (conflict' (name2, version2)) (concat $ (conflicts csp) p1) + +-- |JAS: deal with 'Provides' (can a package provide more than one package?) +conflict' :: (BinPkgName, DebianVersion) -> Relation -> Bool +conflict' (pName, pVersion) (Rel pkgName mVersionReq _) = + (pName == pkgName) && (checkVersionReq mVersionReq (Just pVersion)) + + + +-- * Tree Helper Functions + +mkTree :: a -> [Tree a] -> Tree a +mkTree = Node + +label :: Tree a -> a +label = rootLabel + +initTree :: (a -> [a]) -> a -> Tree a +initTree f a = Node a (map (initTree f) (f a)) + +mapTree :: (a -> b) -> Tree a -> Tree b +mapTree = fmap + +foldTree :: (a -> [b] -> b) -> Tree a -> b +foldTree f (Node a ts) = f a (map (foldTree f) ts) + +zipTreesWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c +zipTreesWith f (Node a ts) (Node b us) = + Node (f a b) (zipWith (zipTreesWith f) ts us) + +prune :: (a -> Bool) -> Tree a -> Tree a +prune p = foldTree f + where f a ts = Node a (filter (not . p . label) ts) + +leaves :: Tree a -> [a] +leaves = foldTree f + where f leaf [] = [leaf] + f _ ts = concat ts + +inhTree :: (b -> a -> b) -> b -> Tree a -> Tree b +inhTree f b (Node a ts) = Node b' (map (inhTree f b') ts) + where b' = f b a + +distrTree :: (a -> [b]) -> b -> Tree a -> Tree b +distrTree f b (Node a ts) = Node b (zipWith (distrTree f) (f a) ts) + +-- * mkSearchTree + +-- TODO: might want to leave markers about what relation we are satisfying? +mkSearchTree :: forall a. CSP a -> Tree (State a) +mkSearchTree csp = + Node (Remaining (relations csp),[]) (andRelation ([],[]) (relations csp)) + where + andRelation :: ([a],AndRelation) -> AndRelation -> [Tree (State a)] + andRelation (candidates,[]) [] = [Node (Complete, candidates) []] + andRelation (candidates,remaining) [] = andRelation (candidates, []) remaining + andRelation (candidates, remaining) (x:xs) = + orRelation (candidates, xs ++ remaining) x + orRelation :: ([a],AndRelation) -> OrRelation -> [Tree (State a)] + orRelation acc x = + concat (fmap (relation acc) x) + relation :: ([a],AndRelation) -> Relation -> [Tree (State a)] + relation acc@(candidates,_) rel = + let packages = lookupPackageByRel (pnm csp) (packageVersion csp) rel in + case packages of + [] -> [Node (MissingDep rel, candidates) []] + _ -> map (package acc) packages + package :: ([a],AndRelation) -> a -> Tree (State a) + package (candidates, remaining) p = + if ((packageVersion csp) p) `elem` (map (packageVersion csp) candidates) + then if null remaining + then Node (Complete, candidates) [] + else Node (Remaining remaining, candidates) (andRelation (candidates, []) remaining) + else Node (Remaining remaining, (p : candidates)) (andRelation ((p : candidates), remaining) ((depFunction csp) p)) + + +-- |earliestInconsistency does what it sounds like +-- the 'reverse as' is because the vars are order high to low, but we +-- want to find the lowest numbered (aka, eariest) inconsistency ?? +-- +earliestInconsistency :: CSP a -> State a -> Maybe ((BinPkgName, DebianVersion), (BinPkgName, DebianVersion)) +earliestInconsistency _ (_,[]) = Nothing +earliestInconsistency _ (_,[_p]) = Nothing +earliestInconsistency csp (_,(p:ps)) = + case find ((conflict csp) p) (reverse ps) of + Nothing -> Nothing + (Just conflictingPackage) -> Just ((packageVersion csp) p, (packageVersion csp) conflictingPackage) + +-- * Conflict Set + +-- | conflicting packages and relations that require non-existant packages +type ConflictSet = ([(BinPkgName, DebianVersion)],[Relation]) + +isConflict :: ConflictSet -> Bool +isConflict ([],[]) = False +isConflict _ = True + +solutions :: Tree (State a, ConflictSet) -> [State a] +solutions = filter complete . map fst . leaves . prune (isConflict . snd) + +type Labeler a = CSP a -> Tree (State a) -> Tree (State a, ConflictSet) + +search :: Labeler a -> CSP a -> [State a] +search labeler csp = (solutions . (labeler csp) . mkSearchTree) csp + +-- * Backtracking Labeler + +bt :: Labeler a +bt csp = mapTree f + where + f s@(status,_) = + case status of + (MissingDep rel) -> (s, ([], [rel])) + _ -> + (s, + case (earliestInconsistency csp) s of + Nothing -> ([],[]) + Just (a,b) -> ([a,b], [])) + +-- * BackJumping Solver + +{-|bj - backjumping labeler + +If the node already has a conflict set, then leave it alone. + +Otherwise, the conflictset for the node is the combination of the +conflict sets of its direct children. +-} +bj :: CSP p -> Tree (State p, ConflictSet) -> Tree (State p, ConflictSet) +bj csp = foldTree f + where f (s, cs) ts + | isConflict cs = mkTree (s, cs) ts +-- | isConflict cs' = mkTree (s, cs') [] -- prevent space leak + | otherwise = mkTree (s, cs') ts + where cs' = + let set = combine csp (map label ts) [] in + set `seq` set -- prevent space leak + +unionCS :: [ConflictSet] -> ConflictSet +unionCS css = foldr (\(c1, m1) (c2, m2) -> ((c1 `union` c2), (m1 `union` m2))) ([],[]) css + +combine :: CSP p -> [(State p, ConflictSet)] -> [ConflictSet] -> ConflictSet +combine _ [] acc = unionCS acc +combine csp ((s,cs@(c,m)):ns) acc + | (not (lastvar `elem` c)) && null m = cs + | null c && null m = ([],[]) -- is this case ever used? + | otherwise = combine csp ns ((c, m):acc) + where lastvar = + let (_,(p:_)) = s in (packageVersion csp) p + + diff --git a/src/Debian/Apt/Index.hs b/src/Debian/Apt/Index.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Apt/Index.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, OverloadedStrings, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} +module Debian.Apt.Index + ( update + , Fetcher + , CheckSums(..) + , Compression(..) + , FileTuple + , Size + , controlFromIndex + , controlFromIndex' + , findContentsFiles + , findIndexes + , indexesInRelease + , tupleFromFilePath + ) where + +import qualified Codec.Compression.GZip as GZip +import qualified Codec.Compression.BZip as BZip +import Control.Lens (over, to, view) +import Control.Monad +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Digest.Pure.MD5 as MD5 +import qualified Data.Digest.Pure.SHA as SHA +import Data.Either (partitionEithers) +import Data.Function +import Data.List as List (null, intercalate, sortBy, isSuffixOf, isPrefixOf) +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text as Text (Text, unpack, concat, lines, words) +import Data.Time +import Debian.Apt.Methods +import Debian.Codename (Codename, codename) +import Debian.Control (formatControl) +import Debian.Control.ByteString +--import Debian.Control.Common +import Debian.Control.Text (decodeControl) +import Debian.Release +import Debian.Sources +import Debian.URI (uriPathLens, uriToString') +import Debian.VendorURI (VendorURI, vendorURI) +import Network.URI +import System.Directory +import System.FilePath (()) +import System.Posix.Files +import System.FilePath (takeBaseName) +--import qualified System.Unix.Misc as Misc +import Text.ParserCombinators.Parsec.Error +import Text.PrettyPrint (render) +import Distribution.Pretty (pretty) +import Text.Read (readMaybe) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure, (<$>), (<*>)) +#endif + +-- |Package indexes on the server are uncompressed or compressed with +-- gzip or bzip2. We do not know what will exist on the server until we +-- actually look. This type is used to mark the compression status of +-- what was actually found. +data Compression + = BZ2 | GZ | Uncompressed + deriving (Read, Show, Eq, Ord, Enum, Bounded) + +data CheckSums + = CheckSums { md5sum :: Maybe String + , sha1 :: Maybe String + , sha256 :: Maybe String + } + deriving (Read, Show, Eq) + +-- |function-type for a function that downloads a file +-- The timestamp is optional. If the local file is as new or newer +-- than the remote copy, the download may be skipped. +-- +-- A good choice might be a partially parameterized call to +-- 'Debian.Apt.Methods.fetch' +type Fetcher = + URI -> -- remote URI + FilePath -> -- local file name + Maybe UTCTime -> -- optional time stamp for local file + IO Bool -- True on success, False on failure + +-- |update - similar to apt-get update + +-- downloads the index files associated with a sources.list. The +-- downloaded index files will have the same basenames that apt-get uses +-- in \/var\/lib\/apt\/lists. You can almost use this function instead of +-- calling apt-get update. However there are a few key differences: +-- 1. apt-get update also updates the binary cache files +-- 2. apt-get update uses the partial directory and lock file in\ /var\/lib\/apt\/lists +-- 3. apt-get update downloads the Release and Release.gpg files +update :: Fetcher -- ^ function that will do actually downloading + -> FilePath -- ^ download indexes to the directory (must already exist) + -> String -- ^ binary architecture + -> [DebSource] -- ^ sources.list + -> IO [Maybe (FilePath, Compression)] -- ^ (basename of index file, compression status) +update fetcher basePath arch sourcesList = + mapM (uncurry $ fetchIndex fetcher) (map (\(uri, fp, _) -> (uri, (basePath fp))) (concatMap (indexURIs arch) sourcesList)) + +-- | download possibly compressed files +-- NOTE: index uri must not include the .bz2 or .gz extension +fetchIndex :: Fetcher -- ^ function that will do the actual fetch + -> URI -- ^ remote URI of package index, without .bz2 or .gz extension + -> FilePath -- ^ name to save downloaded file as, without .bz2 or .gz extension + -> IO (Maybe (FilePath, Compression)) -- ^ (downloaded file name + extension, compression status) +fetchIndex fetcher uri localPath = + do let localPath' = localPath ++ ".bz2" + --lm <- getLastModified localPath' + res <- fetcher (uri { uriPath = (uriPath uri) ++ ".bz2" }) localPath' Nothing + if res + then return $ Just (localPath', BZ2) + else do let localPath' = localPath ++ ".gz" + lm <- getLastModified localPath' + res <- fetcher (uri { uriPath = (uriPath uri) ++ ".gz" }) localPath' lm + if res + then return $ Just (localPath', GZ) + else do lm <- getLastModified localPath + res <- fetcher (uri { uriPath = (uriPath uri) }) localPath lm + if res + then return (Just (localPath, Uncompressed)) + else return Nothing + +-- |examine a DebSource line, and calculate for each section: +-- - the URI to the uncompressed index file +-- - the basename that apt-get would name the downloaded index +-- FIXME: ExactPath dist will fail with error at runtime :( +indexURIs :: String -- ^ which binary architecture + -> DebSource -- ^ line from sources.list + -> [(URI, FilePath, DebSource)] -- ^ (remote uri, local name, deb source for just this section) +indexURIs arch debSource = + map (\ section -> let (uri, fp) = calcPath (view sourceType debSource) arch baseURI release section + in (uri,fp, debSource { _sourceDist = (Right (release, [section])) }) ) sections + where + baseURI = view sourceUri debSource + (release, sections) = + either (error $ "indexURIs: support not implemented for exact path: " ++ render (pretty debSource)) id (view sourceDist debSource) + +-- |return a tuple for the section +-- - the URI to the uncompressed index file +-- - the basename that apt-get uses for the downloaded index +-- FIXME: support for Release and Release.gpg +calcPath :: SourceType -- ^ do we want Packages or Sources + -> String -- ^ The binary architecture to use for Packages + -> VendorURI -- ^ base URI as it appears in sources.list + -> Codename -- ^ the release (e.g., unstable, testing, stable, sid, etc) + -> Section -- ^ the section (main, contrib, non-free, etc) + -> (URI, [Char]) -- ^ (uri to index file, basename for the downloaded file) +calcPath srcType arch baseURI release section = + let indexPath = case srcType of + DebSrc -> "source/Sources" + Deb -> "binary-" ++ arch "Packages" + uri' = over uriPathLens (\path -> path "dists" codename release sectionName' section indexPath) (view vendorURI baseURI) + path = view uriPathLens uri' + in (uri', addPrefix (escapePath path)) + where + addPrefix s = prefix scheme user' pass' reg port ++ {- "_" ++ -} s + prefix "http:" (Just user) Nothing (Just host) port = user ++ host ++ port + prefix "http:" _ _ (Just host) port = host ++ port + prefix "ftp:" _ _ (Just host) _ = host + prefix "file:" Nothing Nothing Nothing "" = "" + prefix "ssh:" (Just user) Nothing (Just host) port = user ++ host ++ port + prefix "ssh:" _ _ (Just host) port = host ++ port + prefix _ _ _ _ _ = error ("calcPath: unsupported uri: " ++ view (vendorURI . to uriToString') baseURI) + user' = maybeOfString user + pass' = maybeOfString pass + (user, pass) = break (== ':') userpass + userpass = maybe "" uriUserInfo auth + reg = maybeOfString $ maybe "" uriRegName auth + port = maybe "" uriPort auth + scheme = view (vendorURI . to uriScheme) baseURI + auth = view (vendorURI . to uriAuthority) baseURI + --path = uriPath baseURI + + escapePath :: String -> String + escapePath s = intercalate "_" $ wordsBy (== '/') s + + maybeOfString :: String -> Maybe String + maybeOfString "" = Nothing + maybeOfString s = Just s + + 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) + +-- |Parse a possibly compressed index file. +controlFromIndex :: Compression -> FilePath -> L.ByteString -> Either ParseError (Control' Text) +controlFromIndex GZ path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks . GZip.decompress $ s +controlFromIndex BZ2 path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks . BZip.decompress $ s +controlFromIndex Uncompressed path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks $ s + +-- |parse an index possibly compressed file +controlFromIndex' :: Compression -> FilePath -> IO (Either ParseError (Control' Text)) +controlFromIndex' compression path = L.readFile path >>= return . controlFromIndex compression path + +type Size = Integer +type FileTuple = (CheckSums, Size, FilePath) + +-- |A release file contains a list of indexes (Packages\/Sources). Each +-- Package or Source index may appear multiple times because it may be +-- compressed several different ways. This function will return an +-- assoc list where the key is the name of the uncompressed package +-- index name and the value is the list of (file, compression) which +-- decompress to the key. +groupIndexes :: [FileTuple] -> [(FilePath, [(FileTuple, Compression)])] +groupIndexes indexFiles = + M.toList $ M.fromListWith combine $ map makeKV indexFiles + where + makeKV fileTuple@(_,_,fp) = + let (name, compressionMethod) = uncompressedName fp + in + (name, [(fileTuple, compressionMethod)]) + combine = (\x y -> sortBy (compare `on` snd) (x ++ y)) +{- + with t@(_,_,fp) m = + let (un, compression) = + in + M.insertWith +-} + +{- +groupIndexes' :: String ->[FileTuple] -> [(FilePath, [(FileTuple, Compression)])] +groupIndexes' iType indexFiles = + M.toList (foldr (insertType iType) M.empty indexFiles) + where + insertType iType t@(_,_,fp) m = + case uncompressedName' iType fp of + Nothing -> m + (Just (un, compression)) -> + M.insertWith (\x y -> sortBy (compare `on` snd) (x ++ y)) un [(t, compression)] m +-} + +-- |The release file contains the checksums for the uncompressed +-- package indexes, even if the uncompressed package indexes are not +-- stored on the server. This function returns the list of files that +-- actually exist. +filterExists :: FilePath -> (FilePath, [(FileTuple, Compression)]) -> IO (FilePath, [(FileTuple, Compression)]) +filterExists distDir (fp, alternatives) = + do e <- filterM ( \((_,_,fp),_) -> fileExist (distDir fp)) alternatives + -- when (null e) (error $ "None of these files exist: " ++ show alternatives) + return (fp, e) + +findIndexes :: FilePath -> String -> [FileTuple] -> IO [(FileTuple, Compression)] +findIndexes distDir iType controlFiles = + let indexes = groupIndexes controlFiles + in + do indexes' <- mapM (filterExists distDir) (filter (isType iType) indexes) + return $ map (head . snd) (filter (not . List.null . snd) indexes') + where + isType iType (fp, _) = iType `isSuffixOf` fp + +{- +findIndexes' :: FilePath -> String -> [FileTuple] -> IO [(FileTuple, Compression)] +findIndexes' distDir iType controlFiles = + let m = groupIndexes' iType controlFiles + in + do m' <- mapM (filterExists distDir) m + return $ map (head . snd) (filter (not . null . snd) m') +-} + + -- insertType :: String -> (CheckSums, Integer, FilePath) -> M.Map FilePath ((CheckSums, Integer, FilePath), Compression) -> M.Map FilePath ((CheckSums, Integer, FilePath), Compression) + +{- +uncompressedName' :: String -> FilePath -> Maybe (FilePath, Compression) +uncompressedName' iType fp + | isSuffixOf iType fp = Just (fp, Uncompressed) + | isSuffixOf (iType ++".gz") fp = Just (reverse . (drop 3) . reverse $ fp, GZ) + | isSuffixOf (iType ++".bz2") fp = Just (reverse . (drop 4) . reverse $ fp, BZ2) + | otherwise = Nothing +-} + +uncompressedName :: FilePath -> (FilePath, Compression) +uncompressedName fp + | isSuffixOf ".gz" fp = (reverse . (drop 3) . reverse $ fp, GZ) + | isSuffixOf ".bz2" fp = (reverse . (drop 4) . reverse $ fp, BZ2) + | otherwise = (fp, Uncompressed) + +indexesInRelease :: (FilePath -> Bool) + -> Control' Text -- ^ A release file + -> [(CheckSums, Integer, FilePath)] -- ^ +indexesInRelease filterp (Control [p]) = + -- In a release file we should find one or more of the fields + -- "SHA256", "SHA1", or "MD5Sum", each containing a list of triples + either error (filter (\(_,_,fp) -> filterp fp)) $ + msum [either Left (makeTuples makeSHA256) (maybe (Left "No SHA256 Field") makeTriples $ fieldValue "SHA256" p), + either Left (makeTuples makeSHA1) (maybe (Left "No SHA1 Field") makeTriples $ fieldValue "SHA1" p), + either Left (makeTuples makeMD5) (maybe (Left "No MD5Sum Field") makeTriples $ msum [fieldValue "MD5Sum" p, + fieldValue "Md5Sum" p, + fieldValue "MD5sum" p])] + where + makeSHA256 s = CheckSums {md5sum = Nothing, sha1 = Nothing, sha256 = Just s} + makeSHA1 s = CheckSums {md5sum = Nothing, sha1 = Just s, sha256 = Nothing} + makeMD5 s = CheckSums {md5sum = Just s, sha1 = Nothing, sha256 = Nothing} + + makeTuples :: (String -> CheckSums) -> [(Text, Text, Text)] -> Either String [(CheckSums, Integer, FilePath)] + makeTuples mk triples = + case partitionEithers (fmap (makeTuple mk) triples) of + ([], tuples) -> Right tuples + (s : _, _) -> Left s + + makeTuple :: (String -> CheckSums) -> (Text, Text, Text) -> Either String (CheckSums, Integer, FilePath) + makeTuple mk (sum, size, fp) = + (,,) <$> pure (mk (Text.unpack sum)) + <*> maybe (Left ("Invalid size field: " ++ show size)) Right (readMaybe (Text.unpack size)) + <*> pure (Text.unpack fp) + + makeTriples :: Text -> Either String [(Text, Text, Text)] + makeTriples t = case partitionEithers (map makeTriple (Text.lines t)) of + ([], xs) -> Right xs + (s : _, _) -> Left s + + makeTriple :: Text -> Either String (Text, Text, Text) + makeTriple t = case Text.words t of + [a, b, c] -> Right (a, b, c) + _ -> Left ("Invalid checksum line: " ++ show t) +indexesInRelease _ x = error $ "Invalid release file: " <> Text.unpack (Text.concat (formatControl x)) + +-- |make a FileTuple for a file found on the local disk +-- returns 'Nothing' if the file does not exist. +tupleFromFilePath :: FilePath -> FilePath -> IO (Maybe FileTuple) +tupleFromFilePath basePath fp = + do e <- fileExist (basePath fp) + if not e + then return Nothing + else do size <- getFileStatus (basePath fp) >>= return . fromIntegral . fileSize + md5 <- L.readFile (basePath fp) >>= return . show . MD5.md5 + sha1 <- L.readFile (basePath fp) >>= return . show . SHA.sha1 + sha256 <- L.readFile (basePath fp) >>= return . show . SHA.sha256 + return $ Just (CheckSums { md5sum = Just md5, sha1 = Just sha1, sha256 = Just sha256 }, size, fp) + +-- |find the Contents-* files. These are not listed in the Release file +findContentsFiles :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +findContentsFiles filterP distDir = + do files <- getDirectoryContents distDir + return $ filter filterP $ filter (isPrefixOf "Contents-" . takeBaseName) files diff --git a/src/Debian/Apt/Methods.hs b/src/Debian/Apt/Methods.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Apt/Methods.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-name-shadowing #-} +-- |an interface for using the methods in /var/lib/apt/methods +module Debian.Apt.Methods + ( withMethodPath + , withMethodURI + , whichMethodPath + , openMethod + , closeMethod + , recvStatus + , sendCommand + , getLastModified + , simpleFetch + , fetch + , FetchCallbacks(..) + , emptyFetchCallbacks + , cliFetchCallbacks + , Command(..) + , Status(..) + , Message, Site, User, Password, Media, Drive, Header, ConfigItem + ) + where + +import Debian.Time +import Debian.URI (URI(..), parseURI, uriToString') + +import Control.Exception +import Control.Monad.Except +import Data.Maybe +import Data.Time +import System.Directory +import System.Exit +import System.IO +import System.Posix.Files +import System.Process + +type MethodHandle = (Handle, Handle, Handle, ProcessHandle) + +capabilities, logMsg, status, uriStart, uriDone, uriFailure, generalFailure, authorizationRequired, mediaFailure, uriAcquire, configuration, authorizationCredentials, mediaChanged :: String +capabilities = "100" +logMsg = "101" +status = "102" +uriStart = "200" +uriDone = "201" +uriFailure = "400" +generalFailure = "401" +authorizationRequired = "402" +mediaFailure = "403" +uriAcquire = "600" +configuration = "601" +authorizationCredentials = "602" +mediaChanged = "603" + +type Message = String +type Site = String +type User = String +type Password = String +type Media = String +type Drive = String + +data Status + = Capabilities { version :: String, singleInstance :: Bool, preScan :: Bool, pipeline :: Bool, sendConfig :: Bool + , needsCleanup :: Bool, localOnly :: Bool } + | LogMsg Message + | Status URI Message + | URIStart { uri :: URI, size :: Maybe Integer, lastModified :: Maybe UTCTime, resumePoint :: Maybe Integer } + | URIDone { uri :: URI, size :: Maybe Integer, lastModified :: Maybe UTCTime, resumePoint :: Maybe Integer + , filename :: Maybe FilePath, hashes :: Hashes, imsHit :: Bool } + | URIFailure { uri :: URI, message :: Message } + | GeneralFailure Message + | AuthorizationRequired Site + | MediaFailure Media Drive + deriving (Show, Eq) + +data Hashes + = Hashes { md5 :: Maybe String + , sha1 :: Maybe String + , sha256 :: Maybe String + } + deriving (Show, Eq) + +emptyHashes = Hashes Nothing Nothing Nothing + +data Command + = URIAcquire URI FilePath (Maybe UTCTime) + | Configuration [ConfigItem] + | AuthorizationCredentials Site User Password + | MediaChanged Media (Maybe Bool) -- I don't really understand the Fail field, I am assuming it is 'Fail: true' + deriving (Show, Eq) + +type Header = (String, String) +type ConfigItem = (String, String) + +withMethodURI :: URI -> (MethodHandle -> IO a) -> IO a +withMethodURI uri f = + do mp <- liftM fromJust (whichMethodPath uri) + withMethodPath mp f + +-- |withMethod - run |methodPath| bracketed with +-- openMethod\/closeMethod. |f| gets the open handle. +withMethodPath :: FilePath -> (MethodHandle -> IO a) -> IO a +withMethodPath methodPath f = + bracket (openMethod methodPath) closeMethod $ f + +-- |whichMethodBinary - find the method executable associated with a URI +-- throws an exception on failure +whichMethodPath :: URI -> IO (Maybe FilePath) +whichMethodPath uri = + let scheme = init (uriScheme uri) + path = "/usr/lib/apt/methods/" ++ scheme + in + doesFileExist path >>= return . bool Nothing (Just path) + +{- +The flow of messages starts with the method sending out a +100 Capabilities and APT sending out a 601 Configuration. + +The flow is largely unsynchronized, but our function may have to +respond to things like authorization requests. Perhaps we do a +recvContents and then mapM_ over that ? Not all incoming messages +require a response, so... + +-} + +parseStatus :: [String] -> Status +parseStatus [] = error "parseStatus" +parseStatus (code' : headers') = + parseStatus' (take 3 code') (map parseHeader headers') + where + parseStatus' code headers + | code == capabilities = + foldr updateCapability defaultCapabilities headers + where + updateCapability (a,v) c + | a == "Version" = c { version = v } + | a == "Single-Instance" = c { singleInstance = parseTrueFalse v } + | a == "Pre-Scan" = c { preScan = parseTrueFalse v } + | a == "Pipeline" = c { pipeline = parseTrueFalse v } + | a == "Send-Config" = c { sendConfig = parseTrueFalse v } + | a == "Needs-Cleanup" = c { needsCleanup = parseTrueFalse v } + | a == "Local-Only" = c { localOnly = parseTrueFalse v } + | otherwise = error $ "unknown capability: " ++ show (a,v) + defaultCapabilities = + Capabilities { version = "" + , singleInstance = False + , preScan = False + , pipeline = False + , sendConfig = False + , needsCleanup = False + , localOnly = False + } + parseStatus' code headers + | code == logMsg = + case headers of + [("Message", msg)] -> LogMsg msg + _ -> error "parseStatus'" + | code == status = + Status (fromJust $ parseURI $ fromJust $ lookup "URI" headers) (fromJust $ lookup "Message" headers) + | code == uriStart = + foldr updateUriStart (URIStart undefined Nothing Nothing Nothing) headers + where + updateUriStart (a,v) u + | a == "URI" = u { uri = fromJust $ parseURI v } + | a == "Size" = u { size = Just (read v) } + | a == "Last-Modified" = u { lastModified = parseTimeRFC822 v } -- if the date is unparseable, we silently truncate. Is that bad ? + | a == "Resume-Point" = u { resumePoint = Just (read v) } + updateUriStart _ _ = error "updateUriStart" + parseStatus' code headers + | code == uriDone = + foldr updateUriDone (URIDone undefined Nothing Nothing Nothing Nothing emptyHashes False) headers + where + updateUriDone (a,v) u + | a == "URI" = u { uri = fromJust $ parseURI v } + | a == "Size" = u { size = Just (read v) } + | a == "Last-Modified" = u { lastModified = parseTimeRFC822 v } -- if the date is unparseable, we silently truncate. Is that bad ? + | a == "Filename" = u { filename = Just v } + | a == "MD5Sum-Hash" = u { hashes = (hashes u) { md5 = Just v } } + | a == "MD5-Hash" = u { hashes = (hashes u) { md5 = Just v } } + | a == "SHA1-Hash" = u { hashes = (hashes u) { sha1 = Just v } } + | a == "SHA256-Hash" = u { hashes = (hashes u) { sha256 = Just v } } + | a == "Resume-Point" = u { resumePoint = Just (read v) } + | a == "IMS-Hit" && v == "true" = u { imsHit = True } + | otherwise = error $ "updateUriDone: unknown header: " ++ show (a,v) + parseStatus' code headers + | code == uriFailure = + URIFailure (fromJust $ parseURI $ fromJust $ lookup "URI" headers) (fromJust $ lookup "Message" headers) + | code == generalFailure = + GeneralFailure (fromJust $ lookup "Message" headers) + | code == authorizationRequired = + AuthorizationRequired (fromJust $ lookup "Site" headers) + | code == mediaFailure = + MediaFailure (fromJust $ lookup "Media" headers) (fromJust $ lookup "Drive" headers) + parseStatus' _ _ = error "parseStatus'" + +formatCommand :: Command -> [String] +formatCommand (URIAcquire uri filepath mLastModified) = + [ uriAcquire ++ " URI Acquire" + , "URI: " ++ uriToString' uri -- will this get credentials correct ? Or do we always pass those in seperately + , "FileName: " ++ filepath + ] ++ maybe [] (\lm -> ["Last-Modified: " ++ formatTimeRFC822 lm ]) mLastModified +formatCommand (Configuration configItems) = + (configuration ++ " Configuration") : (map formatConfigItem configItems) + where + formatConfigItem (a,v) = concat ["Config-Item: ", a, "=", v] +formatCommand (AuthorizationCredentials site user passwd) = + (authorizationCredentials ++ " Authorization Credentials") : + [ "Site: " ++ site + , "User: " ++ user + , "Password: " ++ passwd + ] +formatCommand (MediaChanged media mFail) = + [ mediaChanged ++ " Media Changed" + , "Media: " ++ media + ] ++ maybe [] (\b -> ["Fail: " ++ case b of True -> "true" ; False -> "false"]) mFail + + +parseTrueFalse :: String -> Bool +parseTrueFalse "true" = True +parseTrueFalse "false" = False +parseTrueFalse s = error $ "Invalid boolean string: " ++ s + + +recvStatus :: MethodHandle -> IO Status +recvStatus mh = liftM parseStatus $ recv mh + +sendCommand :: MethodHandle -> Command -> IO () +sendCommand mh cmd = sendMethod mh (formatCommand cmd) + + +parseHeader :: String -> Header +parseHeader str = + let (a, r) = span (/= ':') str + v = dropWhile (flip elem ": \t") r + in + (a, v) + +openMethod :: FilePath -> IO MethodHandle +openMethod methodBinary = + do + -- hPutStrLn stderr ("openMethod " ++ methodBinary) + runInteractiveCommand methodBinary + -- runInteractiveProcess methodBinary [] Nothing Nothing + +sendMethod :: MethodHandle -> [String] -> IO () +sendMethod (pIn, _pOut, _, _) strings = + do + -- hPutStrLn stderr "send:" + mapM_ put strings + hPutStrLn pIn "" + hFlush pIn + where + put line = + do + -- hPutStrLn stderr (" " ++ line) + hPutStrLn pIn line + +closeMethod :: MethodHandle -> IO ExitCode +closeMethod (pIn, pOut, pErr, handle) = + do + -- hPutStrLn stderr "closeMethod" + hClose pIn + hClose pOut + hClose pErr + waitForProcess handle + +recv :: MethodHandle -> IO [String] +recv (_pIn, pOut, _pErr, _pHandle) = + do + -- hPutStrLn stderr "recv:" + readTillEmptyLine pOut + where + readTillEmptyLine pOut = + do + line <- hGetLine pOut + case line of + "" -> return [] + line -> + do + -- hPutStrLn stderr (" " ++ line) + tail <- readTillEmptyLine pOut + return $ line : tail +{- +The flow of messages starts with the method sending out a +100 Capabilities and APT sending out a 601 Configuration. + +The flow is largely unsynchronized, but our function may have to +respond to things like authorization requests. Perhaps we do a +recvContents and then mapM_ over that ? Not all incoming messages +require a response. + +We probably also need to track state, for example, if we are +pipelining multiple downloads and want to show seperate progress bars +for each download. + +If someone wants to use fetch, they will need to provide methods to: + + 1. prompt for and provide authentication + 2. show progress + 3. show media change dialog + 4. Show log messages + 5. Show failures + 6. Send Configuration + +pipeline vs non-pipeline mode. +what if different methods are being used ? + +when pipelining, we probably don't want to have too many pipelines to +the same server. Perhaps there can be a limit, and for non-pipelinable +methods, we set the limit to 1. + +Each method can run in a seperate thread, since methods do not +interact with each other. In fact, each unique method+uri can be a +seperate thread. We can use a MVar to track the global max download +count. Perhaps we also want a per host throttle, since it is the host +connect that is likely to max out, not the access method. + +Plan: + +partition fetches by (host,method). +fork off threads for each (host, method). +Use MVar to throttle per host, and total connections + +We don't know if a method supports pipelining until we connect atleast +once. So if we have a non-pipelined method, we might want to start +multiple streams. On the other hand, for something like a CDROM, that +will just cause the system to thrash. + +cdrom, file, etc, don't have a host, so that is not a unique key then. +Pipelining on local methods is tricky, because it is hard to tell if +the local methods point to the same device or not. + +Even though we have multiple threads, the interactor can view the +incoming Stream as a single Stream because all the events are tagged +with the URI (i think). But, sending commands involves a fancy +router. We could include a reference to corresponding command for each +stream. + +For now, let's serialize the transfers, but allow pipeling for methods +that really allow pipelining. + +-} + +data FetchCallbacks + = FetchCallbacks { logCB :: Message -> IO () + , statusCB :: URI -> Message -> IO () + , uriStartCB :: URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> IO () + , uriDoneCB :: URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> Maybe FilePath -> Hashes -> Bool -> IO () + , uriFailureCB :: URI -> Message -> IO () + , generalFailureCB :: Message -> IO () + , authorizationRequiredCB :: Site -> IO (Maybe (User, Password)) + , mediaFailureCB :: Media -> Drive -> IO () + , debugCB :: String -> IO () + } + +simpleFetch :: [ConfigItem] -> URI -> FilePath -> Maybe UTCTime -> IO Bool +simpleFetch = fetch cliFetchCallbacks + +-- |fetch a single item, show console output +-- see also: getLastModified +fetch :: FetchCallbacks -> [ConfigItem] -> URI -> FilePath -> Maybe UTCTime -> IO Bool +fetch cb configItems uri fp lastModified = + do withMethodURI uri $ \mh -> + do s <- recvStatus mh + debugCB cb ("<- " ++ show s) + sendCommand' mh (URIAcquire uri fp lastModified) + loop mh + where + sendCommand' mh c = + do mapM_ (debugCB cb . ("-> " ++)) (formatCommand c) + sendCommand mh c + loop mh = + do r <- recvStatus mh + case r of + Capabilities {} -> + do unless (null configItems) (sendCommand' mh (Configuration configItems)) + loop mh + LogMsg m -> + do logCB cb m + loop mh + Status uri m -> + do statusCB cb uri m + loop mh + URIStart uri size lastModified resumePoint -> + uriStartCB cb uri size lastModified resumePoint >> loop mh + URIDone uri size lastModified resumePoint filename hashes imsHit -> + uriDoneCB cb uri size lastModified resumePoint filename hashes imsHit >> return True + URIFailure uri message -> + uriFailureCB cb uri message >> return False + GeneralFailure m -> generalFailureCB cb m >> return False + AuthorizationRequired site -> + do mCredentials <- authorizationRequiredCB cb site + case mCredentials of + Nothing -> return False -- FIXME: do we need a force close option for closeMethod ? + Just (user, passwd) -> + do sendCommand' mh (AuthorizationCredentials site user passwd) + loop mh + MediaFailure media drive -> + do mediaFailureCB cb media drive + return False + +-- |set of callbacks which do nothing. +-- suitable for non-interactive usage. In the case authorization is +-- required, no credentials will be supplied and the download should +-- abort. +emptyFetchCallbacks = + FetchCallbacks { logCB = \ _m -> return () + , statusCB = \ _uri _m -> return () + , uriStartCB = \ _uri _size _lastModified _resumePoint -> return () + , uriDoneCB = \ _uri _size _lastModified _resumePoint _filename _hashes _imsHit -> return () + , uriFailureCB = \ _uri _message -> return () + , generalFailureCB = \ _m -> return () + , authorizationRequiredCB = \ _site -> return Nothing + , mediaFailureCB = \ _media _drive -> return () + , debugCB = \ _m -> return () + } + +cliFetchCallbacks = + emptyFetchCallbacks { statusCB = \uri m -> putStrLn $ uriToString' uri ++ " : " ++ m + , uriStartCB = \ uri _size lastModified _resumePoint -> putStrLn $ uriToString' uri ++ " started. " ++ show lastModified + , uriDoneCB = \uri _size _lastModified _resumePoint _filename _hashes imsHit -> putStrLn $ uriToString' uri ++ (if imsHit then " cached." else " downloaded.") + , uriFailureCB = \uri message -> hPutStrLn stderr $ "URI Failure: " ++ uriToString' uri ++ " : " ++ message + , generalFailureCB = \message -> hPutStrLn stderr $ "General Failure: " ++ message + , authorizationRequiredCB = \site -> + do putStrLn $ "Authorization Required for " ++ site + putStrLn "Username: " >> hFlush stdout + user <- getLine + putStrLn "Password: " >> hFlush stdout + passwd <- getLine -- TODO: write a getPasswd function which does not echo input + return (Just (user, passwd)) + , mediaFailureCB = \media drive -> hPutStrLn stderr $ "Media Failure: media=" ++ media ++" drive="++ drive + , debugCB = \m -> print m + } + +{- + FetchCallbacks { logCB = \m -> hPutStrLn stderr m + , statusCB = \uri m -> putStrLn (show uri ++" : "++ m) + , uriStartCB = \uri + } + +defaultAuthenticate site = + do putStrLn $ "Authorization Required for " ++ site + putStrLn "Username: " >> hFlush stdout + user <- getLine + putStrLn "Password: " >> hFlush stdout + passwd <- getLine -- TODO: write a getPasswd function which does not echo input + return (user, passwd) +-} + +{- + let itemsByHost = groupOn (regName . fst) items + in + do totalQSem <- newQSem 16 -- max number of streams allowed for + forkIO + where + regName = fmap uriRegName . uriAuthority + withQSem :: QSem -> IO a -> IO a + withQSem qSem f = bracket (waitQSem qSem) (const $ signalQSem qSem) (const f) + +uris = map (fromJust . parseURI) [ "http://n-heptane.com/whee" + , "file:/one/two/three" + , "ssh://jeremy:aoeu@n-heptane.com" + , "cdrom:/one" + ] +-} + +-- * Misc Helper Functions + +bool :: a -> a -> Bool -> a +bool f _ False = f +bool _ t True = t + + +getLastModified :: FilePath -> IO (Maybe UTCTime) +getLastModified fp = + do e <- doesFileExist fp + if e + then getFileStatus fp >>= return . Just . epochTimeToUTCTime . modificationTime + else return Nothing + +{- +groupOn :: (Ord b) => (a -> b) -> [a] -> [[a]] +groupOn f = groupBy ((==) `on` f) . sortBy (compare `on` f) + +on :: (a -> a -> b) -> (c -> a) -> c -> c -> b +on f g x y = f (g x) (g y) +-} diff --git a/src/Debian/Apt/Package.hs b/src/Debian/Apt/Package.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Apt/Package.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- |Functions for dealing with source and binary packages in an abstract-way +module Debian.Apt.Package where + +-- Standard GHC Modules + +import qualified Data.Map as Map + +-- Local Modules + +import Debian.Version +import Debian.Relation + +type PackageNameMap a = Map.Map BinPkgName [a] + +-- |'packageNameMap' creates a map from a package name to all the versions of that package +-- NOTE: Provides are not included in the map +-- NOTE: the sort order is random -- this is perhaps a bug +-- see also: 'addProvides' +packageNameMap :: (a -> BinPkgName) -> [a] -> PackageNameMap a +packageNameMap getName packages = foldl (\m p -> Map.insertWith (++) (getName p) [p] m) Map.empty packages + +-- |'addProvides' finds packages that Provide other packages and adds +-- them to the PackageNameMap. They will be adde to the end of the +-- list, so that real packages have 'higher priority' than virtual +-- packages. +-- NOTE: Does not check for duplication or multiple use +addProvides :: (p -> [BinPkgName]) -> [p] -> PackageNameMap p -> PackageNameMap p +addProvides providesf ps pnm = + let provides = findProvides providesf ps in + foldl (\m (packageName, package) -> Map.insertWith (flip (++)) packageName [package] m) pnm provides + +-- |'findProvides' +findProvides :: forall p. (p -> [BinPkgName]) -> [p] -> [(BinPkgName, p)] +findProvides providesf packages = foldl addProvides' [] packages + where addProvides' :: [(BinPkgName, p)] -> p -> [(BinPkgName, p)] + addProvides' providesList package = + foldl (\pl pkgName -> (pkgName, package): pl) providesList (providesf package) + +-- |'lookupPackageByRel' returns all the packages that satisfy the specified relation +-- TODO: Add architecture check +lookupPackageByRel :: PackageNameMap a -> (a -> (BinPkgName, DebianVersion)) -> Relation -> [a] +lookupPackageByRel pm packageVersionF (Rel pkgName mVerReq _mArch) = + case Map.lookup pkgName pm of + Nothing -> [] + Just packages -> filter filterVer packages + where filterVer p = + case mVerReq of + Nothing -> True + Just _verReq -> + let (pName, pVersion) = packageVersionF p + in if pName /= pkgName + then False -- package is a virtual package, hence we can not do a version req + else checkVersionReq mVerReq (Just pVersion) diff --git a/src/Debian/Arch.hs b/src/Debian/Arch.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Arch.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +module Debian.Arch + ( Arch(..) + , ArchOS(..) + , ArchCPU(..) + , prettyArch + , parseArch + ) where + +import Data.Data (Data) +import Data.Monoid ((<>)) +import Data.Typeable (Typeable) +import Text.PrettyPrint (Doc, text) + +data ArchOS = ArchOS String | ArchOSAny deriving (Eq, Ord, Read, Show, Data, Typeable) + +prettyOS :: ArchOS -> Doc +prettyOS (ArchOS s) = text s +prettyOS ArchOSAny = text "any" + +parseOS :: String -> ArchOS +parseOS "any" = ArchOSAny +parseOS s = ArchOS s + +data ArchCPU = ArchCPU String | ArchCPUAny deriving (Eq, Ord, Read, Show, Data, Typeable) + +prettyCPU :: ArchCPU -> Doc +prettyCPU (ArchCPU s) = text s +prettyCPU ArchCPUAny = text "any" + +parseCPU :: String -> ArchCPU +parseCPU "any" = ArchCPUAny +parseCPU s = ArchCPU s + +data Arch + = Source + | All + | Binary ArchOS ArchCPU + deriving (Eq, Ord, Read, Show, Data, Typeable) + +prettyArch :: Arch -> Doc +prettyArch Source = text "source" +prettyArch All = text "all" +prettyArch (Binary (ArchOS "linux") cpu) = prettyCPU cpu +prettyArch (Binary os cpu) = prettyOS os <> text "-" <> prettyCPU cpu + +parseArch :: String -> Arch +parseArch s = + case span (/= '-') s of + ("source", "") -> Source + ("all", "") -> All + (cpu, "") -> Binary (ArchOS "linux") (parseCPU cpu) + (os, '-' : cpu) -> Binary (parseOS os) (parseCPU cpu) + _ -> error "parseArch: internal error" diff --git a/src/Debian/Changes.hs b/src/Debian/Changes.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Changes.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-missing-signatures #-} +-- |Changelog and changes file support. +module Debian.Changes + ( ChangesFile(..) + , ChangedFileSpec(..) + , changesFileName + , ChangeLog(..) + , ChangeLogEntry(..) + , parseChangeLog + , parseEntries -- was parseLog + , parseEntry + , parseChanges + ) where + +import Data.Either (partitionEithers) +import Data.List (intercalate, intersperse) +import Data.Monoid ((<>)) +import Data.Text (Text, pack, unpack, strip) +import Debian.Arch (Arch, prettyArch) +import Debian.Codename (Codename, codename, parseCodename) +import qualified Debian.Control.String as S +import Debian.Pretty (PP(..)) +import Debian.Release +import Debian.Version +import System.Posix.Types +import Text.Regex.TDFA hiding (empty) +import Text.PrettyPrint (Doc, text, hcat, render) +import Distribution.Pretty (Pretty(pretty)) + +-- |A file generated by dpkg-buildpackage describing the result of a +-- package build +data ChangesFile = + Changes { changeDir :: FilePath -- ^ The full pathname of the directory holding the .changes file. + , changePackage :: String -- ^ The package name parsed from the .changes file name + , changeVersion :: DebianVersion -- ^ The version number parsed from the .changes file name + , changeRelease :: Codename -- ^ The Distribution field of the .changes file + , changeArch :: Arch -- ^ The architecture parsed from the .changes file name + , changeInfo :: S.Paragraph' Text -- ^ The contents of the .changes file + , changeEntry :: ChangeLogEntry -- ^ The value of the Changes field of the .changes file + , changeFiles :: [ChangedFileSpec] -- ^ The parsed value of the Files attribute + } deriving (Eq, Read, Show) + +-- |An entry in the list of files generated by the build. +data ChangedFileSpec = + ChangedFileSpec { changedFileMD5sum :: String + , changedFileSHA1sum :: String + , changedFileSHA256sum :: String + , changedFileSize :: FileOffset + , changedFileSection :: SubSection + , changedFilePriority :: String + , changedFileName :: FilePath + } deriving (Eq, Read, Show) + +-- |A changelog is a series of ChangeLogEntries +data ChangeLogEntry = + Entry { logPackage :: String -- FIXME: Should be a SrcPkgName + , logVersion :: DebianVersion + , logDists :: [Codename] + , logUrgency :: String + , logComments :: String + , logWho :: String + , logDate :: String + } + | WhiteSpace String -- ^ The parser here never returns this + deriving (Eq, Read, Show) + +newtype ChangeLog = ChangeLog [ChangeLogEntry] deriving (Eq, Read, Show) + +{- +instance Show ChangesFile where + show = changesFileName +-} + +changesFileName :: ChangesFile -> String +changesFileName = render . pretty . PP + +instance Pretty (PP ChangesFile) where + pretty (PP changes) = text (changePackage changes ++ "_") <> prettyDebianVersion (changeVersion changes) <> text "_" <> prettyArch (changeArch changes) <> text ".changes" + +instance Pretty (PP ChangedFileSpec) where + pretty (PP file) = + text (changedFileMD5sum file <> " " <> + show (changedFileSize file) <> " " <> + sectionName (changedFileSection file) <> " " <> + changedFilePriority file <> " " <> + changedFileName file) + +instance Pretty (PP ChangeLogEntry) where + pretty (PP (Entry package ver dists urgency details who date)) = + hcat [ text package <> text " (" <> prettyDebianVersion ver <> text (") " <> intercalate " " (map codename dists) ++ "; urgency=" ++ urgency) + , text "\n\n" + , text " " <> text (strip' details) + , text "\n\n" + , text (" -- " <> who <> " " <> date) + , text "\n" ] + pretty (PP (WhiteSpace _)) = error "instance Pretty ChangeLogEntry" + +instance Pretty (PP [ChangeLogEntry]) where + pretty = hcat . intersperse (text "\n") . map (pretty . PP) . unPP + +strip' = unpack . strip . pack + +instance Pretty (PP ChangeLog) where + pretty (PP (ChangeLog xs)) = hcat (intersperse (text "\n") (map (pretty . PP) xs)) + +-- |Show just the top line of a changelog entry (for debugging output.) +_showHeader :: ChangeLogEntry -> Doc +_showHeader (Entry package ver dists urgency _ _ _) = + text (package <> " (") <> prettyDebianVersion ver <> text (") " <> intercalate " " (map codename dists) <> "; urgency=" <> urgency <> "...") +_showHeader (WhiteSpace _) = error "_showHeader" + +{- +format is a series of entries like this: + + package (version) distribution(s); urgency=urgency + [optional blank line(s), stripped] + * change details + more change details + [blank line(s), included in output of dpkg-parsechangelog] + * even more change details + [optional blank line(s), stripped] + -- maintainer name [two spaces] date + +package and version are the source package name and version number. + +distribution(s) lists the distributions where this version should be +installed when it is uploaded - it is copied to the Distribution field +in the .changes file. See Distribution, Section 5.6.14. + +urgency is the value for the Urgency field in the .changes file for +the upload (see Urgency, Section 5.6.17). It is not possible to +specify an urgency containing commas; commas are used to separate +keyword=value settings in the dpkg changelog format (though there is +currently only one useful keyword, urgency). + +The change details may in fact be any series of lines starting with at +least two spaces, but conventionally each change starts with an +asterisk and a separating space and continuation lines are indented so +as to bring them in line with the start of the text above. Blank lines +may be used here to separate groups of changes, if desired. + +If this upload resolves bugs recorded in the Bug Tracking System +(BTS), they may be automatically closed on the inclusion of this +package into the Debian archive by including the string: closes: +Bug#nnnnn in the change details.[16] This information is conveyed via +the Closes field in the .changes file (see Closes, Section 5.6.22). + +The maintainer name and email address used in the changelog should be +the details of the person uploading this version. They are not +necessarily those of the usual package maintainer. The information +here will be copied to the Changed-By field in the .changes file (see +Changed-By, Section 5.6.4), and then later used to send an +acknowledgement when the upload has been installed. + +The date must be in RFC822 format[17]; it must include the time zone +specified numerically, with the time zone name or abbreviation +optionally present as a comment in parentheses. + +The first "title" line with the package name must start at the left +hand margin. The "trailer" line with the maintainer and date details +must be preceded by exactly one space. The maintainer details and the +date must be separated by exactly two spaces. + +The entire changelog must be encoded in UTF-8. +-} + +-- | Parse the entries of a debian changelog and verify they are all +-- valid. +parseChangeLog :: String -> Either [[String]] ChangeLog +parseChangeLog s = + case partitionEithers (parseEntries s) of + ([], xs) -> Right (ChangeLog xs) + (ss, _) -> Left ss + +-- |Parse a Debian Changelog and return a lazy list of entries +parseEntries :: String -> [Either [String] ChangeLogEntry] +parseEntries "" = [] +parseEntries text = + case parseEntry text of + Left messages -> [Left messages] + Right (entry, text') -> Right entry : parseEntries text' + +-- |Parse a single changelog entry, returning the entry and the remaining text. +parseEntry :: String -> Either [String] (ChangeLogEntry, String) +parseEntry text = + case text =~ entryRE :: MatchResult String of + x | mrSubList x == [] -> Left ["Parse error in " ++ show text] + MR {mrAfter = after, mrSubList = [_, name, ver, dists, urgency, _, details, _, _, who, _, date, _]} -> + Right (Entry name + (parseDebianVersion' ver) + (map parseCodename . words $ dists) + urgency + (" " ++ unpack (strip (pack details)) ++ "\n") + (take (length who - 2) who) + date, + after) + MR {mrBefore = _before, mrMatch = _matched, mrAfter = after, mrSubList = matches} -> + Left ["Internal error\n after=" ++ show after ++ "\n " ++ show (length matches) ++ " matches: " ++ show matches] + +entryRE = bol ++ blankLines ++ headerRE ++ changeDetails ++ signature ++ blankLines +changeDetails = "((\n| \n| -\n|([^ ]| [^--]| -[^--])[^\n]*\n)*)" +signature = " -- ([ ]*([^ ]+ )* )([^\n]*)\n" + +-- |Parse the changelog information that shows up in the .changes +-- file, i.e. a changelog entry with no signature. +parseChanges :: Text -> Maybe ChangeLogEntry +parseChanges text = + case unpack text =~ changesRE :: MatchResult String of + MR {mrSubList = []} -> Nothing + MR {mrSubList = [_, name, ver, dists, urgency, _, details]} -> + Just $ Entry name + (parseDebianVersion' ver) + (map parseCodename . words $ dists) + urgency + details + "" "" + MR {mrSubList = x} -> error $ "Unexpected match: " ++ show x + where + changesRE = bol ++ blankLines ++ optWhite ++ headerRE ++ "(.*)$" + +headerRE = + package ++ ver ++ dists ++ urgency + where + package = "([^ \t(]*)" ++ optWhite + ver = "\\(([^)]*)\\)" ++ optWhite + dists = "([^;]*);" ++ optWhite + urgency = "urgency=([^\n]*)\n" ++ blankLines + +blankLines = blankLine ++ "*" +blankLine = "(" ++ optWhite ++ "\n)" +optWhite = "[ \t]*" +bol = "^" + +-- This can be used for tests +_s1 = unlines + ["haskell-regex-compat (0.92-3+seereason1~jaunty4) jaunty-seereason; urgency=low", + "", + " [ Joachim Breitner ]", + " * Adjust priority according to override file", + " * Depend on hscolour (Closes: #550769)", + "", + " [ Marco Túlio Gontijo e Silva ]", + " * debian/control: Use more sintetic name for Vcs-Darcs.", + " * Built from sid apt pool", + " * Build dependency changes:", + " cpphs: 1.9-1+seereason1~jaunty5 -> 1.9-1+seereason1~jaunty6", + " ghc6: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " ghc6-doc: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " ghc6-prof: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " haddock: 2.4.2-3+seereason3~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " haskell-devscripts: 0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1", + " haskell-regex-base-doc: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", + " haskell-regex-posix-doc: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", + " libghc6-regex-base-dev: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", + " libghc6-regex-base-prof: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", + " libghc6-regex-posix-dev: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", + " libghc6-regex-posix-prof: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", + "", + " -- SeeReason Autobuilder Fri, 25 Dec 2009 01:55:37 -0800", + "", + "haskell-regex-compat (0.92-3) unstable; urgency=low", + "", + " [ Joachim Breitner ]", + " * Adjust priority according to override file", + " * Depend on hscolour (Closes: #550769)", + "", + " [ Marco Túlio Gontijo e Silva ]", + " * debian/control: Use more sintetic name for Vcs-Darcs.", + "", + " -- Joachim Breitner Mon, 20 Jul 2009 13:05:35 +0200", + "", + "haskell-regex-compat (0.92-2) unstable; urgency=low", + "", + " * Adopt package for the Debian Haskell Group", + " * Fix \"FTBFS with new dpkg-dev\" by adding comma to debian/control", + " (Closes: #536473)", + "", + " -- Joachim Breitner Mon, 20 Jul 2009 12:05:40 +0200", + "", + "haskell-regex-compat (0.92-1.1) unstable; urgency=low", + "", + " * Rebuild for GHC 6.10.", + " * NMU with permission of the author.", + "", + " -- John Goerzen Mon, 16 Mar 2009 10:12:04 -0500", + "", + "haskell-regex-compat (0.92-1) unstable; urgency=low", + "", + " * New upstream release", + " * debian/control:", + " - Bump Standards-Version. No changes needed.", + "", + " -- Arjan Oosting Sun, 18 Jan 2009 00:05:02 +0100", + "", + "haskell-regex-compat (0.91-1) unstable; urgency=low", + "", + " * Take over package from Ian, as I already maintain haskell-regex-base,", + " and move Ian to the Uploaders field.", + " * Packaging complete redone (based on my haskell-regex-base package).", + "", + " -- Arjan Oosting Sat, 19 Jan 2008 16:48:39 +0100", + "", + "haskell-regex-compat (0.71.0.1-1) unstable; urgency=low", + " ", + " * Initial release (used to be part of ghc6).", + " * Using \"Generic Haskell cabal library packaging files v9\".", + " ", + " -- Ian Lynagh (wibble) Wed, 21 Nov 2007 01:26:57 +0000"] diff --git a/src/Debian/Codename.hs b/src/Debian/Codename.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Codename.hs @@ -0,0 +1,27 @@ +-- | https://wiki.debian.org/DebianRepository/Format#Codename + +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} + +module Debian.Codename + ( Codename(..) + , codename + , parseCodename + ) where + +import Data.Data (Data, Typeable) +import Debian.TH ({-instance Pretty Loc-}) +import Network.URI (unEscapeString, escapeURIString, isAllowedInURI) +--import Text.PrettyPrint.HughesPJClass as PP (Pretty(pPrint), text) +import Text.PrettyPrint (text) +import Distribution.Pretty + +data Codename = Codename String deriving (Eq, Ord, Read, Show, Data, Typeable) + +parseCodename :: String -> Codename +parseCodename = Codename . unEscapeString + +codename :: Codename -> String +codename (Codename s) = escapeURIString isAllowedInURI s + +instance Pretty Codename where + pretty (Codename s) = text s diff --git a/src/Debian/Control.hs b/src/Debian/Control.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Control.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +-- |A module for working with Debian control files +module Debian.Control + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + , ControlParser + , ControlFunctions(..) + -- * Control File Parser + , pControl + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + , packParagraph + , packField + , formatControl + , formatParagraph + , formatField + -- * Policy classes and functions + , P.HasDebianControl(..) + , P.ControlFileError(..) + , P.parseDebianControlFromFile + , P.validateDebianControl + , P.unsafeDebianControl + , P.debianSourceParagraph + , P.debianBinaryParagraphs + , P.debianPackageParagraphs + , P.debianPackageNames + , P.debianSourcePackageName + , P.debianBinaryPackageNames + , P.debianRelations + , P.debianBuildDeps + , P.debianBuildDepsIndep + ) where + +--import Control.Monad +--import Data.List +--import Text.ParserCombinators.Parsec +--import System.IO +import Debian.Control.Common +import Debian.Control.String +import Data.List +import Data.Text as T (Text, pack, concat) +import qualified Debian.Control.Builder () +import qualified Debian.Control.Text as T +--import qualified Debian.Control.TextLazy as TL +import qualified Debian.Control.ByteString as B () +import qualified Debian.Control.Policy as P +import qualified Debian.Control.String as S + +packParagraph :: S.Paragraph -> T.Paragraph +packParagraph (S.Paragraph s) = T.Paragraph (map packField s) + +packField :: Field' String -> Field' Text +packField (S.Field (name, value)) = T.Field (T.pack name, T.pack value) +packField (S.Comment s) = T.Comment (T.pack s) + +formatControl :: Control' Text -> [Text] +formatControl (T.Control paragraphs) = intersperse (T.pack "\n") . map formatParagraph $ paragraphs + +formatParagraph :: Paragraph' Text -> Text +formatParagraph (T.Paragraph fields) = T.concat . map formatField $ fields + +formatField :: Field' Text -> Text +formatField (T.Field (name, value)) = T.concat [name, T.pack ":", value, T.pack "\n"] +formatField (T.Comment s) = s diff --git a/src/Debian/Control/Builder.hs b/src/Debian/Control/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Control/Builder.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} +module Debian.Control.Builder + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + -- , ControlParser + , ControlFunctions(..) + -- * Control File Parser + -- , pControl + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + , decodeControl + , decodeParagraph + , decodeField + ) where + +import qualified Data.ByteString.Char8 as B +import Data.Char (toLower, chr) +import Data.List (find) +import qualified Data.ListLike as LL +import Data.ListLike.Text.Builder () +--import qualified Data.Text as T (pack, unpack, map, reverse) +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (Builder, {-fromLazyText,-} fromText, toLazyText) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +--import Data.Text.IO as T (readFile) +import qualified Debian.Control.ByteString as B +--import Text.Parsec.Error (ParseError) +--import Text.Parsec.Text (Parser) +--import Text.Parsec.Prim (runP) +import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, asString), + Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment), + mergeControls, fieldValue, removeField, prependFields, appendFields, + renameField, modifyField, raiseFields, protectFieldText') + +-- | @parseFromFile p filePath@ runs a string parser @p@ on the +-- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError' +-- ('Left') or a value of type @a@ ('Right'). +-- +-- > main = do{ result <- parseFromFile numbers "digits.txt" +-- > ; case result of +-- > Left err -> print err +-- > Right xs -> print (sum xs) +-- > } +{- +parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile p fname + = do input <- T.readFile fname `E.catch` (\ (_ :: E.SomeException) -> B.readFile fname >>= return . decode) + return (runP p () fname input) +-} + +type Field = Field' Builder +type Control = Control' Builder +type Paragraph = Paragraph' Builder + +decodeControl :: B.Control -> Control +decodeControl (B.Control paragraphs) = Control (map decodeParagraph paragraphs) + +decodeParagraph :: B.Paragraph -> Paragraph +decodeParagraph (B.Paragraph s) = B.Paragraph (map decodeField s) + +decodeField :: Field' B.ByteString -> Field' Builder +decodeField (B.Field (name, value)) = Field (decode name, decode value) +decodeField (B.Comment s) = Comment (decode s) + +decode :: B.ByteString -> Builder +decode = fromText . decodeUtf8With (\ _ w -> fmap (chr . fromIntegral) w) + +-- * ControlFunctions + +instance ControlFunctions Builder where + parseControlFromFile filepath = + -- The ByteString parser is far more efficient than the Text + -- parser. By calling decodeControl we tell the compiler to + -- use it instead. + parseControlFromFile filepath >>= return . either Left (Right . decodeControl) + parseControlFromHandle sourceName handle = + parseControlFromHandle sourceName handle >>= return . either Left (Right . decodeControl) + parseControl sourceName c = + -- Warning: This is very slow, it does a utf8 round trip + either Left (Right . decodeControl) (parseControl sourceName (encodeUtf8 (toStrict (toLazyText c)))) + lookupP fieldName (Paragraph paragraph) = + find (hasFieldName (map toLower fieldName)) paragraph + where hasFieldName :: String -> Field' Builder -> Bool + hasFieldName name (Field (fieldName',_)) = name == LL.map toLower (LL.toString fieldName') + hasFieldName _ _ = False + stripWS = dropAround (`elem` (" \t" :: String)) + -- T.strip would also strip newlines + protectFieldText = protectFieldText' + asString = LL.toString + +dropAround :: LL.ListLike c item => (item -> Bool) -> c -> c +dropAround p = LL.dropWhile p . LL.dropWhileEnd p + +-- * Control File Parser +{- +-- type ControlParser = GenParser T.Text +type ControlParser a = Parsec T.Text () a + +-- |A parser for debian control file. This parser handles control files +-- that end without a newline as well as ones that have several blank +-- lines at the end. It is very liberal and does not attempt validate +-- the fields in any way. All trailing, leading, and folded whitespace +-- is preserved in the field values. See 'stripWS'. +pControl :: ControlParser Control +pControl = + do many $ char '\n' + sepEndBy pParagraph pBlanks >>= return . Control + +pParagraph :: ControlParser Paragraph +pParagraph = many1 (pComment <|> pField) >>= return . Paragraph + +-- |We are liberal in that we allow *any* field to have folded white +-- space, even though the specific restricts that to a few fields. +pField :: ControlParser Field +pField = + do c1 <- noneOf "#\n" + fieldName <- many1 $ noneOf ":\n" + char ':' + fieldValue <- many fcharfws + (char '\n' >> return ()) <|> eof + return $ Field (T.cons c1 (T.pack fieldName), T.pack fieldValue) + +pComment :: ControlParser Field +pComment = + do char '#' + text <- many (satisfy (not . ((==) '\n'))) + char '\n' + return $ Comment (T.pack ("#" <> text <> "\n")) + +fcharfws :: ControlParser Char +fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') + +fchar :: ControlParser Char +fchar = satisfy (/='\n') + +_fws :: ControlParser T.Text +_fws = + try $ do char '\n' + ws <- many1 (char ' ') + c <- many1 (satisfy (not . ((==) '\n'))) + return $ T.cons '\n' (T.pack ws <> T.pack c) + +-- |We go with the assumption that 'blank lines' mean lines that +-- consist of entirely of zero or more whitespace characters. +pBlanks :: ControlParser T.Text +pBlanks = + do s <- many1 (oneOf " \n") + return . T.pack $ s +-} diff --git a/src/Debian/Control/ByteString.hs b/src/Debian/Control/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Control/ByteString.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses, PackageImports, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} +module Debian.Control.ByteString + ( Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + , ControlFunctions(..) + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + ) where + +-- Standard GHC modules + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative(..)) +#endif +import Control.Applicative (Alternative(..)) +import qualified Control.Exception as E +import "mtl" Control.Monad.State + +import Data.Char(toLower, isSpace, chr, ord) +import Data.Word (Word8) +import Data.List +import qualified Data.ListLike as LL +import qualified Data.ListLike.String as LL + +import Text.ParserCombinators.Parsec.Error +import Text.ParserCombinators.Parsec.Pos + +-- Third Party Modules + +import qualified Data.ByteString.Char8 as C + +import Debian.Control.Common hiding (protectFieldText') + +-- Local Modules + +-- import ByteStreamParser + +-- * Types +{- +newtype Control = Control [Paragraph] +newtype Paragraph = Paragraph [Field] +newtype Field = Field (C.ByteString, C.ByteString) +-} + +type Control = Control' C.ByteString +type Paragraph = Paragraph' C.ByteString +type Field = Field' C.ByteString +-- * Control Parser + +type ControlParser a = Parser C.ByteString a + +pKey :: ControlParser C.ByteString +pKey = notEmpty $ pTakeWhile (\c -> (c /= ':') && (c /= '\n')) + +pValue :: ControlParser C.ByteString +pValue = Parser $ \bs -> + let newlines = C.elemIndices '\n' bs + rest = dropWhile continuedAfter newlines ++ [C.length bs] + continuedAfter i = bs `safeIndex` (i+1) `elem` map Just " \t#" + (text, bs') = C.splitAt (head rest) bs + in Ok (text, bs') + +pField :: ControlParser Field +pField = + do k <- pKey + _ <- pChar ':' + v <- pValue +-- pChar '\n' + (pChar '\n' >> return ()) <|> pEOF + return (Field (k,v)) + +pComment :: ControlParser Field +pComment = Parser $ \bs -> + let newlines = C.elemIndices '\n' bs + linestarts = 0 : map (+1) newlines + rest = dropWhile commentAt linestarts ++ [C.length bs] + commentAt i = bs `safeIndex` i == Just '#' + (text, bs') = C.splitAt (head rest) bs + in if C.null text + then Empty + else Ok (Comment text, bs') + +pParagraph :: ControlParser Paragraph +pParagraph = + do f <- pMany1 (pComment <|> pField) + pSkipMany (pChar '\n') + return (Paragraph f) + +pControl :: ControlParser Control +pControl = + do pSkipMany (pChar '\n') + c <- pMany pParagraph + return (Control c) + + +-- parseControlFromFile :: FilePath -> IO (Either String Control) + +instance ControlFunctions C.ByteString where + parseControlFromFile fp = + do c <- C.readFile fp + case parse pControl c of + Nothing -> return (Left (newErrorMessage (Message ("Failed to parse " ++ fp)) (newPos fp 0 0))) + (Just (cntl,_)) -> return (Right cntl) + parseControlFromHandle sourceName handle = + E.try (C.hGetContents handle) >>= + either (\ (e :: E.SomeException) -> error ("parseControlFromHandle ByteString: Failure parsing " ++ sourceName ++ ": " ++ show e)) (return . parseControl sourceName) + parseControl sourceName c = + do case parse pControl c of + Nothing -> Left (newErrorMessage (Message ("Failed to parse " ++ sourceName)) (newPos sourceName 0 0)) + Just (cntl,_) -> Right cntl + lookupP fieldName (Paragraph fields) = + let pFieldName = C.pack (map toLower fieldName) in + find (\ (Field (fieldName',_)) -> C.map toLower fieldName' == pFieldName) fields + -- NOTE: probably inefficient + stripWS = C.reverse . strip . C.reverse . strip + where strip = C.dropWhile (flip elem [' ', '\t']) + protectFieldText = protectFieldText' + asString = C.unpack + +protectFieldText' :: (LL.StringLike a, LL.ListLike a Word8) => ControlFunctions a => a -> a +protectFieldText' s = + case LL.lines s of + [] -> LL.empty + (l : ls) -> dropWhileEnd (isSpace . chr . fromIntegral) $ LL.unlines $ l : map protect ls + where + 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") + ord' = fromIntegral . ord + -- chr' = chr . fromIntegral + +{- +main = + do [fp] <- getArgs + C.readFile fp >>= \c -> maybe (putStrLn "failed.") (print . length . fst) (parse pControl c) +-} +-- * Helper Functions + +safeIndex :: C.ByteString -> Int -> Maybe Char +bs `safeIndex` i = if i < C.length bs then Just (bs `C.index` i) else Nothing + +-- * Parser + +data Result a + = Ok a + | Fail + | Empty + deriving Show + +-- m2r :: Maybe a -> Result a +-- m2r (Just a) = Ok a +-- m2r Nothing = Empty + +r2m :: Result a -> Maybe a +r2m (Ok a) = Just a +r2m _ = Nothing + +newtype Parser state a = Parser { unParser :: (state -> Result (a, state)) } + +instance Functor (Parser state) where + fmap f m = + Parser $ \ state -> + let r = (unParser m) state in + case r of + Ok (a,state') -> Ok (f a,state') + Empty -> Empty + Fail -> Fail + +instance Applicative (Parser state) where + pure = return + (<*>) = ap + +instance Alternative (Parser state) where + empty = + Parser $ \state -> + (unParser mzero) state + (<|>) = mplus + +instance Monad (Parser state) where + return a = Parser (\s -> Ok (a,s)) + m >>= f = + Parser $ \state -> + let r = (unParser m) state in + case r of + Ok (a,state') -> + case unParser (f a) $ state' of + Empty -> Fail + o -> o + Empty -> Empty + Fail -> Fail + +instance MonadPlus (Parser state) where + mzero = Parser (const Empty) + mplus (Parser p1) (Parser p2) = + Parser (\s -> case p1 s of + Empty -> p2 s + o -> o + ) + +-- Parser (\s -> maybe (p2 s) (Just) (p1 s)) + + +_pSucceed :: a -> Parser state a +_pSucceed = return + +_pFail :: Parser state a +_pFail = Parser (const Empty) + + +satisfy :: (Char -> Bool) -> Parser C.ByteString Char +satisfy f = + Parser $ \bs -> + if C.null bs + then Empty + else let (s,ss) = (C.head bs, C.tail bs) in + if (f s) + then Ok (s,ss) + else Empty + +pChar :: Char -> Parser C.ByteString Char +pChar c = satisfy ((==) c) + + +_try :: Parser state a -> Parser state a +_try (Parser p) = + Parser $ \bs -> case (p bs) of + Fail -> Empty + o -> o + +pEOF :: Parser C.ByteString () +pEOF = + Parser $ \bs -> if C.null bs then Ok ((),bs) else Empty + +pTakeWhile :: (Char -> Bool) -> Parser C.ByteString C.ByteString +pTakeWhile f = + Parser $ \bs -> Ok (C.span f bs) + +_pSkipWhile :: (Char -> Bool) -> Parser C.ByteString () +_pSkipWhile p = + Parser $ \bs -> Ok ((), C.dropWhile p bs) + +pMany :: Parser st a -> Parser st [a] +pMany p + = scan id + where + scan f = do x <- p + scan (\tail -> f (x:tail)) + <|> return (f []) + +notEmpty :: Parser st C.ByteString -> Parser st C.ByteString +notEmpty (Parser p) = + Parser $ \s -> case p s of + o@(Ok (a, _s)) -> + if C.null a + then Empty + else o + x -> x + +pMany1 :: Parser st a -> Parser st [a] +pMany1 p = + do x <- p + xs <- pMany p + return (x:xs) + +pSkipMany :: Parser st a -> Parser st () +pSkipMany p = scan + where + scan = (p >> scan) <|> return () + +_pSkipMany1 :: Parser st a -> Parser st () +_pSkipMany1 p = p >> pSkipMany p + +parse :: Parser state a -> state -> Maybe (a, state) +parse p s = r2m ((unParser p) s) diff --git a/src/Debian/Control/Common.hs b/src/Debian/Control/Common.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Control/Common.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, UndecidableInstances #-} +module Debian.Control.Common + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , ControlFunctions(..) + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + , parseControlFromCmd + , md5sumField + , protectFieldText' + ) + where + +import Control.Monad (msum) +import Data.Char (isSpace) +import Data.List as List (dropWhileEnd, partition, intersperse) +import Data.ListLike as LL (ListLike, cons, dropWhileEnd, empty, find, null, singleton) +import Data.ListLike.String as LL (StringLike, lines, unlines) +import Data.Monoid ((<>)) +import Debian.Pretty (PP(..)) +import System.Exit (ExitCode(ExitSuccess, ExitFailure)) +import System.IO (Handle) +import System.Process (runInteractiveCommand, waitForProcess) +import Text.ParserCombinators.Parsec (ParseError) +import Text.PrettyPrint (Doc, text, hcat) +import Distribution.Pretty (Pretty(pretty)) + +newtype Control' a + = Control { unControl :: [Paragraph' a] } deriving (Eq, Ord, Read, Show) + +newtype Paragraph' a + = Paragraph [Field' a] + deriving (Eq, Ord, Read, Show) + +-- |NOTE: we do not strip the leading or trailing whitespace in the +-- name or value +data Field' a + = Field (a, a) + | Comment a -- ^ Lines beginning with # + deriving (Eq, Ord, Read, Show) + +class ControlFunctions a where + -- |'parseControlFromFile' @filepath@ is a simple wrapper function + -- that parses @filepath@ using 'pControl' + parseControlFromFile :: FilePath -> IO (Either ParseError (Control' a)) + -- |'parseControlFromHandle' @sourceName@ @handle@ - @sourceName@ is only used for error reporting + parseControlFromHandle :: String -> Handle -> IO (Either ParseError (Control' a)) + -- |'parseControlFromString' @sourceName@ @text@ - @sourceName@ is only used for error reporting + parseControl :: String -> a -> (Either ParseError (Control' a)) + -- | 'lookupP' @fieldName paragraph@ looks up a 'Field' in a 'Paragraph'. + -- @N.B.@ trailing and leading whitespace is /not/ stripped. + lookupP :: String -> (Paragraph' a) -> Maybe (Field' a) + -- |Strip the trailing and leading space and tab characters from a + -- string. Folded whitespace is /not/ unfolded. This should probably + -- be moved to someplace more general purpose. + stripWS :: a -> a + -- |Protect field value text so the parser doesn't split it into + -- multiple fields or paragraphs. This must modify all field text + -- to enforce two conditions: (1) All lines other than the initial + -- one must begin with a space or a tab, and (2) the trailing + -- white space must not contain newlines. This is called before + -- pretty printing to prevent the parser from misinterpreting + -- field text as multiple fields or paragraphs. + protectFieldText :: a -> a + asString :: a -> String + +-- | This can usually be used as the implementation of protectFieldText +protectFieldText' :: forall a. (StringLike a, ListLike a Char) => ControlFunctions a => a -> a +protectFieldText' s = + let trimmedLines :: [a] + trimmedLines = map (LL.dropWhileEnd isSpace :: a -> a) $ (LL.lines s :: [a]) + strippedLines :: [a] + strippedLines = List.dropWhileEnd LL.null trimmedLines in + -- Split the text into lines, drop trailing whitespace from each + -- line, and drop trailing blank lines. + case strippedLines of + [] -> empty + (l : ls) -> + let -- The first line is indented one space + l' = {-LL.cons ' '-} l + -- Null lines are replaced by a single '.' If any line + -- is unindented, all will get an additional space of + -- indentation. + ls' = case all indented ls of + True -> map (\ x -> if LL.null x then (LL.cons ' ' $ singleton '.') else x) ls + False -> map (LL.cons ' ') $ map (\ x -> if LL.null x then (singleton '.') else x) ls in + LL.dropWhileEnd isSpace (LL.unlines (l' : ls')) + where + indented l = maybe True isSpace (LL.find (const True) l) + +-- | This may have bad performance issues (dsf: Whoever wrote this +-- comment should have explained why.) +instance (ControlFunctions a, Pretty (PP a)) => Pretty (Control' a) where + pretty = ppControl +instance (ControlFunctions a, Pretty (PP a)) => Pretty (Paragraph' a) where + pretty = ppParagraph + +instance (ControlFunctions a, Pretty (PP a)) => Pretty (Field' a) where + pretty = ppField + +ppControl :: (ControlFunctions a, Pretty (PP a)) => Control' a -> Doc +ppControl (Control paragraph) = + hcat (intersperse (text "\n") (map ppParagraph paragraph)) + +ppParagraph :: (ControlFunctions a, Pretty (PP a)) => Paragraph' a -> Doc +ppParagraph (Paragraph fields) = + hcat (map (\ x -> ppField x <> text "\n") fields) + +ppField :: (ControlFunctions a, Pretty (PP a)) => Field' a -> Doc +ppField (Field (n,v)) = pretty (PP n) <> text ":" <> pretty (PP (protectFieldText v)) +ppField (Comment c) = pretty (PP c) + +mergeControls :: [Control' a] -> Control' a +mergeControls controls = + Control (concatMap unControl controls) + +fieldValue :: (ControlFunctions a) => String -> Paragraph' a -> Maybe a +fieldValue fieldName paragraph = + case lookupP fieldName paragraph of + Just (Field (_, val)) -> Just $ stripWS val + _ -> Nothing + +removeField :: (Eq a) => a -> Paragraph' a -> Paragraph' a +removeField toRemove (Paragraph fields) = + Paragraph (filter remove fields) + where + remove (Field (name,_)) = name == toRemove + remove (Comment _) = False + +prependFields :: [Field' a] -> Paragraph' a -> Paragraph' a +prependFields newfields (Paragraph fields) = Paragraph (newfields ++ fields) + +appendFields :: [Field' a] -> Paragraph' a -> Paragraph' a +appendFields newfields (Paragraph fields) = Paragraph (fields ++ newfields) + +renameField :: (Eq a) => a -> a -> Paragraph' a -> Paragraph' a +renameField oldname newname (Paragraph fields) = + Paragraph (map rename fields) + where + rename (Field (name, value)) | name == oldname = Field (newname, value) + rename field = field + +modifyField :: (Eq a) => a -> (a -> a) -> Paragraph' a -> Paragraph' a +modifyField name f (Paragraph fields) = + Paragraph (map modify fields) + where + modify (Field (name', value)) | name' == name = Field (name, f value) + modify field = field + +-- | Move selected fields to the beginning of a paragraph. +raiseFields :: (Eq a) => (a -> Bool) -> Paragraph' a -> Paragraph' a +raiseFields f (Paragraph fields) = + let (a, b) = partition f' fields in Paragraph (a ++ b) + where f' (Field (name, _)) = f name + f' (Comment _) = False + +-- | Run a command and parse its output as a control file. +parseControlFromCmd :: ControlFunctions a => String -> IO (Either String (Control' a)) +parseControlFromCmd cmd = + do + (_, outh, _, handle) <- runInteractiveCommand cmd + result <- parseControlFromHandle cmd outh + either (return . Left . show) (finish handle) result + where + finish handle control = + do + exitCode <- waitForProcess handle + case exitCode of + ExitSuccess -> return $ Right control + ExitFailure n -> return $ Left ("Failure: " ++ cmd ++ " -> " ++ show n) + +-- |look up the md5sum file in a paragraph +-- Tries several different variations: +-- MD5Sum: +-- Md5Sum: +-- MD5sum: +md5sumField :: (ControlFunctions a) => Paragraph' a -> Maybe a +md5sumField p = msum [fieldValue "MD5Sum" p, fieldValue "Md5Sum" p, fieldValue "MD5sum" p] diff --git a/src/Debian/Control/Policy.hs b/src/Debian/Control/Policy.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Control/Policy.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} +-- | Access to things that Debian policy says should be in a valid +-- control file. The pure functions will not throw ControlFileError +-- if they are operating on a DebianControl value returned by +-- validateDebianControl. However, they might if they are created +-- using unsafeDebianControl. +module Debian.Control.Policy + ( -- * Validated debian control file type + DebianControl(unDebianControl) + , validateDebianControl + , unsafeDebianControl + , parseDebianControlFromFile + , parseDebianControl + , ControlFileError(..) + -- * Class of things that contain one DebianControl value + , HasDebianControl(debianControl) + -- * Pure functions that operate on validated control files + , debianSourceParagraph + , debianBinaryParagraphs + , debianPackageParagraphs + , debianPackageNames + , debianSourcePackageName + , debianBinaryPackageNames + , debianRelations + , debianBuildDeps + , debianBuildDepsIndep + ) where + +import Control.Exception (Exception, throw) +import Control.Monad.Catch (MonadCatch, try) +import Data.List (intercalate) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.ListLike (toList) +import Debian.Control.Common (Control'(..), Paragraph'(..), Field'(..), fieldValue, ControlFunctions(parseControlFromFile, parseControl)) +import Debian.Control.Text () +import Debian.Loc (__LOC__) +import Debian.Pretty (prettyShow) +import Debian.Relation (SrcPkgName(..), BinPkgName(..), Relations, parseRelations) +import Debian.Relation.Text () +import Language.Haskell.TH (Loc(..)) +import Prelude hiding (ioError) +-- import qualified Debug.ShowPlease as Please +import Text.Parsec.Error (ParseError) + +-- | Opaque (constructor not exported) type to hold a validated Debian +-- Control File +data DebianControl = DebianControl {unDebianControl :: Control' Text} + +instance Show DebianControl where + show c = "(parseDebianControl \"\" " ++ show (prettyShow (unDebianControl c)) ++ ")" + +-- | Validate and return a control file in an opaque wrapper. May +-- throw a ControlFileError. Currently we only verify that it has a +-- Source field in the first paragraph and one or more subsequent +-- paragraphs each with a Package field, and no syntax errors in the +-- build dependencies (though they may be absent.) +validateDebianControl :: MonadCatch m => Control' Text -> m (Either ControlFileError DebianControl) +validateDebianControl ctl = + try (do _ <- return $ debianPackageNames (DebianControl ctl) + _ <- return $ debianBuildDeps (DebianControl ctl) + _ <- return $ debianBuildDepsIndep (DebianControl ctl) + return ()) >>= + return . either Left (\ _ -> Right $ DebianControl ctl) + +unsafeDebianControl :: Control' Text -> DebianControl +unsafeDebianControl = DebianControl + +parseDebianControl :: MonadCatch m => String -> Text -> m (Either ControlFileError DebianControl) +parseDebianControl sourceName s = either (return . Left . ParseControlError [$__LOC__]) validateDebianControl (parseControl sourceName s) + +parseDebianControlFromFile :: FilePath -> IO (Either ControlFileError DebianControl) +parseDebianControlFromFile controlPath = + try (parseControlFromFile controlPath) >>= + either (return . Left . IOError [$__LOC__]) + (either (return . Left . ParseControlError [$__LOC__]) validateDebianControl) + +-- | Class of things that contain a validated Debian control file. +class Show a => HasDebianControl a where + debianControl :: a -> DebianControl + +instance HasDebianControl DebianControl where + debianControl = id + +class HasControl a where + control :: a -> Control' Text + +instance HasControl (Control' Text) where + control = id + +instance HasControl DebianControl where + control = unDebianControl + +-- | Errors that control files might throw, with source file name and +-- line number generated by template haskell. +data ControlFileError + = NoParagraphs {locs :: [Loc]} + | NoBinaryParagraphs {locs :: [Loc], ctl :: String} + | MissingField {locs :: [Loc], field :: String} + | ParseRelationsError {locs :: [Loc], parseError :: ParseError} + | ParseControlError {locs :: [Loc], parseError :: ParseError} + | IOError {locs :: [Loc], ioError :: IOError} + deriving Typeable + +instance Show ControlFileError where + show (NoParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoParagraphs" + show (NoBinaryParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoBinaryParagraphs" + show (MissingField {..}) = intercalate ", " (map showLoc locs) ++ ": MissingField " ++ show field + show (ParseRelationsError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseRelationsError " ++ show parseError + show (ParseControlError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseControlError " ++ show parseError + show (IOError {..}) = intercalate ", " (map showLoc locs) ++ ": IOError " ++ show ioError + +showLoc :: Loc -> String +showLoc x = show (loc_filename x) ++ "(line " ++ show (fst (loc_start x)) ++ ", column " ++ show (snd (loc_start x)) ++ ")" + +-- instance Please.Show ControlFileError where +-- show (IOError e) = "(IOError " ++ Please.show e ++ ")" +-- show (ParseRelationsError e) = "(ParseRelationsError " ++ Please.show e ++ ")" +-- show (ParseControlError e) = "(ParseControlError " ++ Please.show e ++ ")" +-- show x = show x + +instance Exception ControlFileError + +instance Eq ControlFileError where + _ == _ = False + +debianPackageParagraphs :: HasDebianControl a => a -> (Paragraph' Text, [Paragraph' Text]) +debianPackageParagraphs ctl = + case removeCommentParagraphs ctl of + DebianControl (Control [_]) -> throw $ NoBinaryParagraphs [$__LOC__] (show ctl) + DebianControl (Control []) -> throw $ NoParagraphs [$__LOC__] + DebianControl (Control (sourceParagraph : binParagraphs)) -> (sourceParagraph, binParagraphs) + +-- | Comment paragraphs are rare, but they happen. +removeCommentParagraphs :: HasDebianControl a => a -> DebianControl +removeCommentParagraphs c = + DebianControl (Control (filter (not . isCommentParagraph) (unControl (unDebianControl (debianControl c))))) + where + isCommentParagraph (Paragraph fields) = all isCommentField fields + isCommentField (Comment _) = True + isCommentField _ = False + +debianSourceParagraph :: HasDebianControl a => a -> Paragraph' Text +debianSourceParagraph = fst . debianPackageParagraphs + +debianBinaryParagraphs :: HasDebianControl a => a -> [Paragraph' Text] +debianBinaryParagraphs = snd . debianPackageParagraphs + +debianPackageNames :: HasDebianControl a => a -> (SrcPkgName, [BinPkgName]) +debianPackageNames c = + let (srcParagraph, binParagraphs) = debianPackageParagraphs c in + (mapFieldValue (SrcPkgName . toList) "Source" srcParagraph, map (mapFieldValue (BinPkgName . toList) "Package") binParagraphs) + +debianSourcePackageName :: HasDebianControl a => a -> SrcPkgName +debianSourcePackageName = fst . debianPackageNames + +debianBinaryPackageNames :: HasDebianControl a => a -> [BinPkgName] +debianBinaryPackageNames = snd . debianPackageNames + +debianBuildDepsIndep :: HasDebianControl a => a -> Maybe Relations +debianBuildDepsIndep ctl = either throw id $ debianRelations "Build-Depends-Indep" (debianControl ctl) + +debianBuildDeps :: HasDebianControl a => a -> Maybe Relations +debianBuildDeps ctl = either throw id $ debianRelations "Build-Depends" (debianControl ctl) + +-- | Version of fieldValue that may throw a ControlFileError. We only +-- use this internally on fields that we already validated. +fieldValue' :: ControlFunctions text => String -> Paragraph' text -> text +fieldValue' fieldName paragraph = maybe (throw $ MissingField [$__LOC__] fieldName) id $ fieldValue fieldName paragraph + +-- | This could access fields we haven't validated, so +-- it can return an error. Additionally, the field might +-- be absent, in which case it returns Nothing. +debianRelations :: HasDebianControl a => String -> a -> Either ControlFileError (Maybe Relations) +debianRelations fieldName ctl = maybe (Right Nothing) (either (Left . ParseRelationsError [$__LOC__]) (Right . Just) . parseRelations) $ fieldValue fieldName (debianSourceParagraph ctl) + +-- | Apply a function to the text from a named field in a control file paragraph. +mapFieldValue :: (Text -> a) -> String -> Paragraph' Text -> a +mapFieldValue f fieldName paragraph = f $ fieldValue' fieldName paragraph diff --git a/src/Debian/Control/String.hs b/src/Debian/Control/String.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Control/String.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} +module Debian.Control.String + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + , ControlParser + , ControlFunctions(..) + -- * Control File Parser + , pControl + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + ) where + +import qualified Control.Exception as E +import Data.Char (toLower) +import Data.List (find) +import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, protectFieldText, asString), + Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment), + mergeControls, fieldValue, removeField, prependFields, appendFields, + renameField, modifyField, raiseFields, protectFieldText') +import System.IO (hGetContents) +import Text.ParserCombinators.Parsec (CharParser, parse, parseFromFile, sepEndBy, satisfy, oneOf, string, lookAhead, try, many, many1, (<|>), noneOf, char, eof) + +type Field = Field' String +type Control = Control' String +type Paragraph = Paragraph' String + +-- * ControlFunctions + +instance ControlFunctions String where + parseControlFromFile filepath = + parseFromFile pControl filepath + parseControlFromHandle sourceName handle = + E.try (hGetContents handle) >>= + either (\ (e :: E.SomeException) -> error ("parseControlFromHandle String: Failure parsing " ++ sourceName ++ ": " ++ show e)) (return . parseControl sourceName) + parseControl sourceName c = + parse pControl sourceName c + lookupP fieldName (Paragraph paragraph) = + find (hasFieldName (map toLower fieldName)) paragraph + where hasFieldName name (Field (fieldName',_)) = name == map toLower fieldName' + hasFieldName _ _ = False + stripWS = reverse . strip . reverse . strip + where strip = dropWhile (flip elem (" \t" :: [Char])) + protectFieldText = protectFieldText' + asString = id + +-- * Control File Parser + +type ControlParser a = CharParser () a + +-- |A parser for debian control file. This parser handles control files +-- that end without a newline as well as ones that have several blank +-- lines at the end. It is very liberal and does not attempt validate +-- the fields in any way. All trailing, leading, and folded whitespace +-- is preserved in the field values. See 'stripWS'. +pControl :: ControlParser Control +pControl = + do many $ char '\n' + sepEndBy pParagraph pBlanks >>= return . Control + +pParagraph :: ControlParser Paragraph +pParagraph = many1 (pComment <|> pField) >>= return . Paragraph + +-- |We are liberal in that we allow *any* field to have folded white +-- space, even though the specific restricts that to a few fields. +pField :: ControlParser Field +pField = + do c1 <- noneOf "#\n" + fieldName <- many1 $ noneOf ":\n" + char ':' + fieldValue <- many fcharfws + (char '\n' >> return ()) <|> eof + return $ Field (c1 : fieldName, fieldValue) + +pComment :: ControlParser Field +pComment = + do char '#' + text <- many (satisfy (not . ((==) '\n'))) + char '\n' + return $ Comment ("#" ++ text ++ "\n") + +fcharfws :: ControlParser Char +fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') + +fchar :: ControlParser Char +fchar = satisfy (/='\n') + +_fws :: ControlParser String +_fws = + try $ do char '\n' + ws <- many1 (char ' ') + c <- many1 (satisfy (not . ((==) '\n'))) + return $ '\n' : (ws ++ c) + +-- |We go with the assumption that 'blank lines' mean lines that +-- consist of entirely of zero or more whitespace characters. +pBlanks :: ControlParser String +pBlanks = many1 (oneOf " \n") diff --git a/src/Debian/Control/Text.hs b/src/Debian/Control/Text.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Control/Text.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} +module Debian.Control.Text + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + -- , ControlParser + , ControlFunctions(..) + -- * Control File Parser + -- , pControl + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + , decodeControl + , decodeParagraph + , decodeField + ) where + +import qualified Data.ByteString.Char8 as B +import Data.Char (toLower, chr) +import Data.List (find) +import qualified Data.Text as T (Text, pack, unpack, map, dropAround) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +--import Data.Text.IO as T (readFile) +import qualified Debian.Control.ByteString as B +--import Text.Parsec.Error (ParseError) +--import Text.Parsec.Text (Parser) +--import Text.Parsec.Prim (runP) +import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, asString), + Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment), + mergeControls, fieldValue, removeField, prependFields, appendFields, + renameField, modifyField, raiseFields, protectFieldText') + +-- | @parseFromFile p filePath@ runs a string parser @p@ on the +-- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError' +-- ('Left') or a value of type @a@ ('Right'). +-- +-- > main = do{ result <- parseFromFile numbers "digits.txt" +-- > ; case result of +-- > Left err -> print err +-- > Right xs -> print (sum xs) +-- > } +{- +parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile p fname + = do input <- T.readFile fname `E.catch` (\ (_ :: E.SomeException) -> B.readFile fname >>= return . decode) + return (runP p () fname input) +-} + +type Field = Field' T.Text +type Control = Control' T.Text +type Paragraph = Paragraph' T.Text + +decodeControl :: B.Control -> Control +decodeControl (B.Control paragraphs) = Control (map decodeParagraph paragraphs) + +decodeParagraph :: B.Paragraph -> Paragraph +decodeParagraph (B.Paragraph s) = B.Paragraph (map decodeField s) + +decodeField :: Field' B.ByteString -> Field' T.Text +decodeField (B.Field (name, value)) = Field (decode name, decode value) +decodeField (B.Comment s) = Comment (decode s) + +decode :: B.ByteString -> T.Text +decode = decodeUtf8With (\ _ w -> fmap (chr . fromIntegral) w) + +-- * ControlFunctions + +instance ControlFunctions T.Text where + parseControlFromFile filepath = + -- The ByteString parser is far more efficient than the Text + -- parser. By calling decodeControl we tell the compiler to + -- use it instead. + parseControlFromFile filepath >>= return . either Left (Right . decodeControl) + parseControlFromHandle sourceName handle = + parseControlFromHandle sourceName handle >>= return . either Left (Right . decodeControl) + parseControl sourceName c = + -- Warning: This is very slow, it does a utf8 round trip + either Left (Right . decodeControl) (parseControl sourceName (encodeUtf8 c)) + lookupP fieldName (Paragraph paragraph) = + find (hasFieldName (map toLower fieldName)) paragraph + where hasFieldName :: String -> Field' T.Text -> Bool + hasFieldName name (Field (fieldName',_)) = T.pack name == T.map toLower fieldName' + hasFieldName _ _ = False + stripWS = T.dropAround (`elem` (" \t" :: String)) + -- T.strip would also strip newlines + protectFieldText = protectFieldText' + asString = T.unpack + +-- * Control File Parser +{- +-- type ControlParser = GenParser T.Text +type ControlParser a = Parsec T.Text () a + +-- |A parser for debian control file. This parser handles control files +-- that end without a newline as well as ones that have several blank +-- lines at the end. It is very liberal and does not attempt validate +-- the fields in any way. All trailing, leading, and folded whitespace +-- is preserved in the field values. See 'stripWS'. +pControl :: ControlParser Control +pControl = + do many $ char '\n' + sepEndBy pParagraph pBlanks >>= return . Control + +pParagraph :: ControlParser Paragraph +pParagraph = many1 (pComment <|> pField) >>= return . Paragraph + +-- |We are liberal in that we allow *any* field to have folded white +-- space, even though the specific restricts that to a few fields. +pField :: ControlParser Field +pField = + do c1 <- noneOf "#\n" + fieldName <- many1 $ noneOf ":\n" + char ':' + fieldValue <- many fcharfws + (char '\n' >> return ()) <|> eof + return $ Field (T.cons c1 (T.pack fieldName), T.pack fieldValue) + +pComment :: ControlParser Field +pComment = + do char '#' + text <- many (satisfy (not . ((==) '\n'))) + char '\n' + return $ Comment (T.pack ("#" <> text <> "\n")) + +fcharfws :: ControlParser Char +fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') + +fchar :: ControlParser Char +fchar = satisfy (/='\n') + +_fws :: ControlParser T.Text +_fws = + try $ do char '\n' + ws <- many1 (char ' ') + c <- many1 (satisfy (not . ((==) '\n'))) + return $ T.cons '\n' (T.pack ws <> T.pack c) + +-- |We go with the assumption that 'blank lines' mean lines that +-- consist of entirely of zero or more whitespace characters. +pBlanks :: ControlParser T.Text +pBlanks = + do s <- many1 (oneOf " \n") + return . T.pack $ s +-} diff --git a/src/Debian/Control/TextLazy.hs b/src/Debian/Control/TextLazy.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Control/TextLazy.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} +module Debian.Control.TextLazy + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + -- , ControlParser + , ControlFunctions(..) + -- * Control File Parser + -- , pControl + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + , decodeControl + , decodeParagraph + , decodeField + ) where + +import qualified Data.ByteString.Char8 as B +import Data.Char (toLower, chr) +import Data.List (find) +import qualified Data.Text.Lazy as T (Text, pack, unpack, map, dropAround, {-reverse,-} fromStrict, toStrict) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +--import Data.Text.IO as T (readFile) +import qualified Debian.Control.ByteString as B +--import Text.Parsec.Error (ParseError) +--import Text.Parsec.Text (Parser) +--import Text.Parsec.Prim (runP) +import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, asString), + Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment), + mergeControls, fieldValue, removeField, prependFields, appendFields, + renameField, modifyField, raiseFields, protectFieldText') + +-- | @parseFromFile p filePath@ runs a string parser @p@ on the +-- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError' +-- ('Left') or a value of type @a@ ('Right'). +-- +-- > main = do{ result <- parseFromFile numbers "digits.txt" +-- > ; case result of +-- > Left err -> print err +-- > Right xs -> print (sum xs) +-- > } +{- +parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile p fname + = do input <- T.readFile fname `E.catch` (\ (_ :: E.SomeException) -> B.readFile fname >>= return . decode) + return (runP p () fname input) +-} + +type Field = Field' T.Text +type Control = Control' T.Text +type Paragraph = Paragraph' T.Text + +decodeControl :: B.Control -> Control +decodeControl (B.Control paragraphs) = Control (map decodeParagraph paragraphs) + +decodeParagraph :: B.Paragraph -> Paragraph +decodeParagraph (B.Paragraph s) = B.Paragraph (map decodeField s) + +decodeField :: Field' B.ByteString -> Field' T.Text +decodeField (B.Field (name, value)) = Field (decode name, decode value) +decodeField (B.Comment s) = Comment (decode s) + +decode :: B.ByteString -> T.Text +decode = T.fromStrict . decodeUtf8With (\ _ w -> fmap (chr . fromIntegral) w) + +-- * ControlFunctions + +instance ControlFunctions T.Text where + parseControlFromFile filepath = + -- The ByteString parser is far more efficient than the Text + -- parser. By calling decodeControl we tell the compiler to + -- use it instead. + parseControlFromFile filepath >>= return . either Left (Right . decodeControl) + parseControlFromHandle sourceName handle = + parseControlFromHandle sourceName handle >>= return . either Left (Right . decodeControl) + parseControl sourceName c = + -- Warning: This is very slow, it does a utf8 round trip + either Left (Right . decodeControl) (parseControl sourceName (encodeUtf8 (T.toStrict c))) + lookupP fieldName (Paragraph paragraph) = + find (hasFieldName (map toLower fieldName)) paragraph + where hasFieldName :: String -> Field' T.Text -> Bool + hasFieldName name (Field (fieldName',_)) = T.pack name == T.map toLower fieldName' + hasFieldName _ _ = False + stripWS = T.dropAround (`elem` (" \t" :: String)) + -- T.strip would also strip newlines + protectFieldText = protectFieldText' + asString = T.unpack + +-- * Control File Parser +{- +-- type ControlParser = GenParser T.Text +type ControlParser a = Parsec T.Text () a + +-- |A parser for debian control file. This parser handles control files +-- that end without a newline as well as ones that have several blank +-- lines at the end. It is very liberal and does not attempt validate +-- the fields in any way. All trailing, leading, and folded whitespace +-- is preserved in the field values. See 'stripWS'. +pControl :: ControlParser Control +pControl = + do many $ char '\n' + sepEndBy pParagraph pBlanks >>= return . Control + +pParagraph :: ControlParser Paragraph +pParagraph = many1 (pComment <|> pField) >>= return . Paragraph + +-- |We are liberal in that we allow *any* field to have folded white +-- space, even though the specific restricts that to a few fields. +pField :: ControlParser Field +pField = + do c1 <- noneOf "#\n" + fieldName <- many1 $ noneOf ":\n" + char ':' + fieldValue <- many fcharfws + (char '\n' >> return ()) <|> eof + return $ Field (T.cons c1 (T.pack fieldName), T.pack fieldValue) + +pComment :: ControlParser Field +pComment = + do char '#' + text <- many (satisfy (not . ((==) '\n'))) + char '\n' + return $ Comment (T.pack ("#" <> text <> "\n")) + +fcharfws :: ControlParser Char +fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') + +fchar :: ControlParser Char +fchar = satisfy (/='\n') + +_fws :: ControlParser T.Text +_fws = + try $ do char '\n' + ws <- many1 (char ' ') + c <- many1 (satisfy (not . ((==) '\n'))) + return $ T.cons '\n' (T.pack ws <> T.pack c) + +-- |We go with the assumption that 'blank lines' mean lines that +-- consist of entirely of zero or more whitespace characters. +pBlanks :: ControlParser T.Text +pBlanks = + do s <- many1 (oneOf " \n") + return . T.pack $ s +-} diff --git a/src/Debian/Deb.hs b/src/Debian/Deb.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Deb.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module Debian.Deb where + +import Control.Monad + +import Debian.Control.Common +import System.Directory (canonicalizePath) +import System.Exit (ExitCode(..)) +import System.Process (readProcessWithExitCode) +import System.Unix.Directory (withTemporaryDirectory, withWorkingDirectory) + +fields :: (ControlFunctions a) => FilePath -> IO (Control' a) +fields debFP = + withTemporaryDirectory ("fields.XXXXXX") $ \tmpdir -> + do debFP <- canonicalizePath debFP + withWorkingDirectory 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"] "" + when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ show out ++ "\n" ++ show err ++ "\n" ++ show res) + c <- parseControlFromFile "control" + case c of + Left e -> error (show e) + (Right c) -> return c -- I don't think we need seq because parsec will force everything from the file diff --git a/src/Debian/Extra/Files.hs b/src/Debian/Extra/Files.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Extra/Files.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE PackageImports #-} +-- |Domain independent functions used by the haskell-debian package. +module Debian.Extra.Files + ( withTemporaryFile + ) where + +import "mtl" Control.Monad.Trans (MonadIO, liftIO) +import System.Directory (getTemporaryDirectory, removeFile) +import System.IO (hPutStr, hClose, openBinaryTempFile) + +withTemporaryFile :: MonadIO m + => (FilePath -> m a) -- ^ The function we want to pass a FilePath to + -> String -- ^ The text that the file should contain + -> m a -- ^ The function's return value +withTemporaryFile f text = + do path <- liftIO writeTemporaryFile + result <- f path + liftIO $ removeFile path + return result + where + writeTemporaryFile = + do dir <- getTemporaryDirectory + (path, h) <- openBinaryTempFile dir "wtf.tmp" + hPutStr h text + hClose h + return path + +-- Example: write the path of the temporary file and its contents into /tmp/result: +-- test = +-- withTemporaryFile f "Some text\n" +-- where f path = readFile path >>= return . (("Contents of " ++ path ++ ":\n") ++) >>= writeFile "/tmp/result" diff --git a/src/Debian/GenBuildDeps.hs b/src/Debian/GenBuildDeps.hs new file mode 100644 --- /dev/null +++ b/src/Debian/GenBuildDeps.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-} +{-# LANGUAGE NoDisambiguateRecordFields, NoRecordWildCards #-} +-- |Figure out the dependency relation between debianized source +-- directories. The code to actually solve these dependency relations +-- for a particular set of binary packages is in Debian.Repo.Dependency. +module Debian.GenBuildDeps + ( DepInfo(..) + , sourceName' + , relations' + , binaryNames' + -- * Preparing dependency info + , buildDependencies + , RelaxInfo + , relaxDeps + -- * Using dependency info + , BuildableInfo(..) + , ReadyTarget(..) + , buildable + , compareSource + -- * Obsolete? + , orderSource + , genDeps + , failPackage + , getSourceOrder + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import Control.Exception (throw) +import Control.Monad (filterM, foldM) +import Control.Monad.State (evalState, get, modify, State) +import Data.Graph (Graph, Edge, Vertex, buildG, topSort, reachable, transposeG, edges, scc) +import Data.List as List (elemIndex, find, map, nub, partition, tails) +import Data.Map as Map (empty, findWithDefault, fromList, insert, Map, lookup) +import Data.Maybe +import Data.Set as Set (fromList, intersection, null, Set) +import Data.Tree as Tree (Tree(Node, rootLabel, subForest)) +import Debian.Control (parseControlFromFile) +import Debian.Control.Policy (HasDebianControl, DebianControl, ControlFileError(..), validateDebianControl, debianSourcePackageName, debianBinaryPackageNames, debianBuildDeps, debianBuildDepsIndep) +import Debian.Loc (__LOC__) +import Debian.Relation +import Debian.Relation.Text () +-- import Debug.Trace (trace) +import System.Directory (getDirectoryContents, doesFileExist) + +-- | This type describes the build dependencies of a source package. +data DepInfo = DepInfo { + sourceName :: SrcPkgName -- ^ source package name + , relations :: Relations -- ^ dependency relations + , binaryNames :: [BinPkgName] -- ^ binary dependency names (is this a function of relations?) + , depSet :: Set.Set BinPkgName -- ^ Set containing all binary package names mentioned in relations + , binSet :: Set.Set BinPkgName -- ^ Set containing binaryNames + } deriving Show + +instance Eq DepInfo where + a == b = (sourceName a == sourceName b) && + Set.fromList (map Set.fromList (relations a)) == Set.fromList (map Set.fromList (relations b)) && + Set.fromList (binaryNames a) == Set.fromList (binaryNames b) + +-- |Return the dependency info for a source package with the given dependency relaxation. +-- |According to debian policy, only the first paragraph in debian\/control can be a source package +-- +buildDependencies :: HasDebianControl control => control -> DepInfo +buildDependencies control = do + let rels = concat [fromMaybe [] (debianBuildDeps control), + fromMaybe [] (debianBuildDepsIndep control)] + bins = debianBinaryPackageNames control + DepInfo { sourceName = debianSourcePackageName control + , relations = rels + , binaryNames = bins + , depSet = Set.fromList (List.map (\(Rel x _ _) -> x) (concat rels)) + , binSet = Set.fromList bins } + +-- | source package name +sourceName' :: HasDebianControl control => control -> SrcPkgName +sourceName' control = debianSourcePackageName control + +-- | dependency relations +relations' :: HasDebianControl control => control -> Relations +relations' control = concat [fromMaybe [] (debianBuildDeps control), + fromMaybe [] (debianBuildDepsIndep control)] + +-- | binary dependency names (is this a function of relations?) +binaryNames' :: HasDebianControl control => control -> [BinPkgName] +binaryNames' control = debianBinaryPackageNames control + +-- |Specifies build dependencies that should be ignored during the build +-- decision. If the pair is (BINARY, Nothing) it means the binary package +-- BINARY should always be ignored when deciding whether to build. If the +-- pair is (BINARY, Just SOURCE) it means that binary package BINARY should +-- be ignored when deiciding whether to build package SOURCE. +newtype OldRelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)] deriving Show + +-- | Given a source package name and a binary package name, return +-- False if the binary package should be ignored hwen deciding whether +-- to build the source package. This is used to prevent build +-- dependency cycles from triggering unnecessary rebuilds. (This is a +-- replacement for the RelaxInfo type, which we temporarily rename +-- OldRelaxInfo.) +type RelaxInfo = SrcPkgName -> BinPkgName -> Bool + +-- |Remove any dependencies that are designated \"relaxed\" by relaxInfo. +relaxDeps :: RelaxInfo -> [DepInfo] -> [DepInfo] +relaxDeps relaxInfo deps = + List.map relaxDep deps + where + relaxDep :: DepInfo -> DepInfo + relaxDep info = info {relations = filteredDependencies} + where + -- Discard any dependencies not on the filtered package name list. If + -- this results in an empty list in an or-dep the entire dependency can + -- be discarded. + filteredDependencies :: Relations + filteredDependencies = filter (/= []) (List.map (filter keepDep) (relations info)) + keepDep :: Relation -> Bool + keepDep (Rel name _ _) = not (relaxInfo (sourceName info) name) + +data ReadyTarget a + = ReadyTarget { ready :: a + -- ^ Some target whose build dependencies are all satisfied + , waiting :: [a] + -- ^ The targets that are waiting for the ready target + , other :: [a] + -- ^ The rest of the targets that need to be built + } + +data BuildableInfo a + = BuildableInfo + { readyTargets :: [ReadyTarget a] + , allBlocked :: [a] } + | CycleInfo + { depPairs :: [(a, a)] } + +-- | Given an ordering function representing the dependencies on a +-- list of packages, return a ReadyTarget triple: One ready package, +-- the packages that depend on the ready package directly or +-- indirectly, and all the other packages. +buildable :: forall a. (a -> DepInfo) -> [a] -> BuildableInfo a +buildable relax packages = + -- Find all packages which can't reach any other packages in the + -- graph of the "has build dependency" relation on the + -- yet-to-be-built packages + case partition (\ x -> reachable hasDep x == [x]) verts of + -- None of the packages are buildable, return information + -- about how to break this build dependency cycle. + ([], _) -> CycleInfo {depPairs = List.map ofEdge $ head $ (allCycles hasDep)} + -- We have some buildable packages, return them along with + -- the list of packages each one directly blocks + (allReady, blocked) -> + BuildableInfo { readyTargets = List.map (makeReady blocked allReady) allReady + , allBlocked = List.map ofVertex blocked } + where + makeReady :: [Vertex] -> [Vertex] -> Vertex -> ReadyTarget a + makeReady blocked ready thisReady = + let otherReady = filter (/= thisReady) ready + (directlyBlocked, otherBlocked) = partition (\ x -> elem x (reachable isDep thisReady)) blocked in + ReadyTarget { ready = ofVertex thisReady + , waiting = List.map ofVertex directlyBlocked + , other = List.map ofVertex (otherReady ++ otherBlocked) } + --allDeps x = (ofVertex x, List.map ofVertex (filter (/= x) (reachable hasDep x))) + isDep :: Graph + isDep = transposeG hasDep + hasDep :: Graph + hasDep = buildG (0, length packages - 1) hasDepEdges + + hasDepEdges :: [(Int, Int)] + hasDepEdges = +#if 0 + nub (foldr f [] (tails vertPairs)) + where f :: [(Int, DepInfo)] -> [(Int, Int)] -> [(Int, Int)] + f [] es = es + f (x : xs) es = catMaybes (List.map (toEdge x) xs) ++ es + toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> Maybe Edge + toEdge (xv, xa) (yv, ya) = + case compareSource xa ya of + EQ -> Nothing + LT -> Just (yv, xv) + GT -> Just (xv, yv) +#else + nub (evalState (foldM f [] (tails vertPairs)) Map.empty) + where f :: [(Int, Int)] -> [(Int, DepInfo)] -> State (Map.Map (Int, Int) Ordering) [(Int, Int)] + f es [] = return es + f es (x : xs) = mapM (toEdge x) xs >>= \es' -> return (catMaybes es' ++ es) + toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> State (Map.Map (Int, Int) Ordering) (Maybe Edge) + toEdge (xv, xa) (yv, ya) = do + mp <- get + r <- case Map.lookup (xv, yv) mp of + Just r' -> return r' + Nothing -> do + let r' = compareSource xa ya + -- trace ("compareSource " ++ show (unSrcPkgName $ sourceName xa) ++ " " ++ show (unSrcPkgName $ sourceName ya) ++ " -> " ++ show r') (return ()) + modify (Map.insert (xv, yv) r') + return r' + case r of + EQ -> return Nothing + LT -> return $ Just (yv, xv) + GT -> return $ Just (xv, yv) +#endif + ofEdge :: Edge -> (a, a) + ofEdge (a, b) = (ofVertex a, ofVertex b) + ofVertex :: Int -> a + ofVertex n = fromJust (Map.findWithDefault Nothing n (Map.fromList (zip [0..] (map Just packages)))) + verts :: [Int] + verts = map fst vertPairs + vertPairs :: [(Int, DepInfo)] + vertPairs = zip [0..] $ map relax packages + +-- | Find a cycle in a graph that involves +allCycles :: Graph -> [[Edge]] +allCycles g = + -- Every cycle is confined to an SCC (strongly connected component). + -- Every node in an SCC is part of some cycle. + concatMap sccCycles (scc g) + where + -- Find all the cycles in an SCC + sccCycles :: Tree Vertex -> [[Edge]] + sccCycles t = mapMaybe addBackEdge (treePaths t) + + addBackEdge :: [Vertex] -> Maybe [Edge] + addBackEdge path@(root : _) = + let back = (last path, root) in + if elem back (edges g) then Just (pathEdges (path ++ [root])) else Nothing + +-- | All the paths from root to a leaf +treePaths :: Tree a -> [[a]] +treePaths (Node {rootLabel = r, subForest = []}) = [[r]] +treePaths (Node {rootLabel = r, subForest = ts}) = map (r :) (concatMap treePaths ts) + +pathEdges :: [a] -> [(a, a)] +pathEdges (v1 : v2 : vs) = (v1, v2) : pathEdges (v2 : vs) +pathEdges _ = [] + +-- | Remove any packages which can't be built given that a package has failed. +failPackage :: Eq a => (a -> a -> Ordering) -> a -> [a] -> ([a], [a]) +failPackage cmp failed packages = + let graph = buildGraph cmp packages in + let root = elemIndex failed packages in + let victims = maybe [] (map (fromJust . vertex) . reachable graph) root in + partition (\ x -> not . elem x $ victims) packages + where + vertex n = Map.findWithDefault Nothing n vertexMap + vertexMap = Map.fromList (zip [0..] (map Just packages)) + +-- | Given a list of packages, sort them according to their apparant +-- build dependencies so that the first element doesn't depend on any +-- of the other packages. +orderSource :: (a -> a -> Ordering) -> [a] -> [a] +orderSource cmp packages = + map (fromJust . vertex) (topSort graph) + where + graph = buildGraph cmp packages + vertex n = Map.findWithDefault Nothing n vertexMap + vertexMap = Map.fromList (zip [0..] (map Just packages)) + +-- | Build a graph with the list of packages as its nodes and the +-- build dependencies as its edges. +buildGraph :: (a -> a -> Ordering) -> [a] -> Graph +buildGraph cmp packages = + let es = someEdges (zip packages [0..]) in + buildG (0, length packages - 1) es + where + someEdges [] = [] + someEdges (a : etc) = aEdges a etc ++ someEdges etc + aEdges (ap, an) etc = + concat (map (\ (bp, bn) -> + case cmp ap bp of + LT -> [(an, bn)] + GT -> [(bn, an)] + EQ -> []) etc) + +-- |This is a nice start. It ignores circular build depends and takes +-- a pretty simplistic approach to 'or' build depends. However, I +-- think this should work pretty nicely in practice. +compareSource :: DepInfo -> DepInfo -> Ordering +compareSource p1 p2 +#if 0 + | any (\rel -> isJust (find (checkPackageNameReq rel) (binaryNames p2))) (concat (relations p1)) = GT + | any (\rel -> isJust (find (checkPackageNameReq rel) (binaryNames p1))) (concat (relations p2)) = LT + | otherwise = EQ + where + checkPackageNameReq :: Relation -> BinPkgName -> Bool + checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName +#else + | not (Set.null (Set.intersection (depSet p1) (binSet p2))) = GT + | not (Set.null (Set.intersection (depSet p2) (binSet p1))) = LT + | otherwise = EQ +#endif + +compareSource' :: HasDebianControl control => control -> control -> Ordering +compareSource' control1 control2 + | any (\rel -> isJust (find (checkPackageNameReq rel) bins2)) (concat depends1) = GT + | any (\rel -> isJust (find (checkPackageNameReq rel) bins1)) (concat depends2) = LT + | otherwise = EQ + where + bins1 = binaryNames' control1 + bins2 = binaryNames' control2 + depends1 = relations' control1 + depends2 = relations' control2 + checkPackageNameReq :: Relation -> BinPkgName -> Bool + checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName + +-- |Return the dependency info for a list of control files. +genDeps :: [FilePath] -> IO [DebianControl] +genDeps controlFiles = do + orderSource compareSource' <$> mapM genDep' controlFiles + where + -- Parse the control file and extract the build dependencies + genDep' controlPath = parseControlFromFile controlPath >>= + either (\ x -> throw (ParseRelationsError [$__LOC__] x)) + (\ x -> validateDebianControl x {- `mapExn` (pushLoc $__LOC__) -} >>= either throw return) + +-- pushLoc :: Loc -> ControlFileError -> ControlFileError +-- pushLoc loc e = e {locs = loc : locs e} + +-- |One example of how to tie the below functions together. In this +-- case 'fp' is the path to a directory that contains a bunch of +-- checked out source packages. The code will automatically look for +-- debian\/control. It returns a list with the packages in the +-- order they should be built. +getSourceOrder :: FilePath -> IO [SrcPkgName] +getSourceOrder fp = + findControlFiles fp >>= genDeps >>= return . map sourceName' + where + -- Return a list of the files that look like debian\/control. + findControlFiles :: FilePath -> IO [FilePath] + findControlFiles root = + getDirectoryContents root >>= + mapM (\ x -> return $ root ++ "/" ++ x ++ "/debian/control") >>= + filterM doesFileExist diff --git a/src/Debian/Loc.hs b/src/Debian/Loc.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Loc.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-} +module Debian.Loc + ( __LOC__ + , mapExn + ) where + +import Control.Applicative ((<$>), (<*>), pure) +import Control.Exception (Exception, throw) +import Control.Monad.Catch (MonadCatch, catch) +import Language.Haskell.TH + +__LOC__ :: Q Exp +__LOC__ = location >>= \ x -> + recConE 'Loc [ (,) <$> (pure 'loc_filename) <*> litE (stringL (loc_filename x)) + , (,) <$> (pure 'loc_package) <*> litE (stringL (loc_package x)) + , (,) <$> (pure 'loc_module) <*> litE (stringL (loc_module x)) + , (,) <$> (pure 'loc_start) <*> [|($(litE (integerL (fromIntegral (fst (loc_start x))))), + $(litE (integerL (fromIntegral (snd (loc_start x)))))) :: (Int, Int)|] + , (,) <$> (pure 'loc_end) <*> [|($(litE (integerL (fromIntegral (fst (loc_end x))))), + $(litE (integerL (fromIntegral (snd (loc_end x)))))) :: (Int, Int)|] ] + +mapExn :: forall e m a. (MonadCatch m, Exception e) => m a -> (e -> e) -> m a +mapExn task f = task `catch` (\ (e :: e) -> throw (f e)) diff --git a/src/Debian/Pretty.hs b/src/Debian/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Pretty.hs @@ -0,0 +1,48 @@ +-- | A constructor we can wrap around values to avoid any built in +-- Pretty instance - for example, instance Pretty [a]. +-- +-- * display is now prettyShow +-- * display' is now prettyText +-- * ppDisplay is now ppShow +-- * ppDisplay' is now ppText +{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-} +module Debian.Pretty + ( PP(PP, unPP) + , prettyText + , ppPrint + , ppShow + , ppText + -- * Re-export + , prettyShow + ) where + +import Data.Text (Text, unpack, pack) +import Text.PrettyPrint.HughesPJClass (Doc, text, empty) +import Distribution.Pretty (Pretty(pretty), prettyShow) + +-- | This type is wrapped around values before we pretty print them so +-- we can write our own Pretty instances for common types without +-- polluting the name space of clients of this package with instances +-- they don't want. +newtype PP a = PP {unPP :: a} deriving (Functor) + +instance Pretty (PP Text) where + pretty = text . unpack . unPP + +instance Pretty (PP String) where + pretty = text . unPP + +instance Pretty (PP a) => Pretty (PP (Maybe a)) where + pretty = maybe empty ppPrint . unPP + +prettyText :: Pretty a => a -> Text +prettyText = pack . prettyShow + +ppPrint :: Pretty (PP a) => a -> Doc +ppPrint = pretty . PP + +ppShow :: Pretty (PP a) => a -> String +ppShow = prettyShow . PP + +ppText :: Pretty (PP a) => a -> Text +ppText = pack . prettyShow . PP diff --git a/src/Debian/Relation.hs b/src/Debian/Relation.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Relation.hs @@ -0,0 +1,25 @@ +-- |A module for working with debian relationships +module Debian.Relation + ( -- * Types + PkgName(..) + , SrcPkgName(..) + , BinPkgName(..) + , Relations + , AndRelation + , OrRelation + , Relation(..) + , ArchitectureReq(..) + , Arch(..) + , ArchOS(..) + , ArchCPU(..) + , VersionReq(..) + -- * Helper Functions + , checkVersionReq + -- * Relation Parser + , RelParser + , ParseRelations(..) + ) where + +import Debian.Arch (Arch(..), ArchOS(..), ArchCPU(..)) +import Debian.Relation.Common (SrcPkgName(..), BinPkgName(..), PkgName(pkgNameFromString)) +import Debian.Relation.String diff --git a/src/Debian/Relation/ByteString.hs b/src/Debian/Relation/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Relation/ByteString.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -fno-warn-orphans #-} +-- |A module for working with debian relationships +module Debian.Relation.ByteString + ( -- * Types + AndRelation + , OrRelation + , Relations + , Relation(..) + , ArchitectureReq(..) + , VersionReq(..) + -- * Helper Functions + , checkVersionReq + -- * Relation Parser + , RelParser + , ParseRelations(..) + ) where + +import qualified Data.ByteString.Char8 as C + +-- Local Modules + +--import Debian.Relation.Common +import Debian.Relation.String +--import Debian.Version + +-- * ParseRelations + +-- For now we just wrap the string version +instance ParseRelations C.ByteString where + parseRelations byteStr = parseRelations (C.unpack byteStr) diff --git a/src/Debian/Relation/Common.hs b/src/Debian/Relation/Common.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Relation/Common.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-} +module Debian.Relation.Common where + +-- Standard GHC Modules + +import Data.Data (Data) +import Data.List as List (map, intersperse) +import Data.Monoid (mconcat, (<>)) +import Data.Function +import Data.Set as Set (Set, toList) +import Data.Typeable (Typeable) +import Debian.Arch (Arch, prettyArch) +import Debian.Pretty (PP(..)) +import Prelude hiding (map) +import Text.ParserCombinators.Parsec +import Text.PrettyPrint (Doc, text, empty) +import Distribution.Pretty (Pretty(pretty)) + +-- Local Modules + +import Debian.Version + +-- Datatype for relations + +type Relations = AndRelation +type AndRelation = [OrRelation] +type OrRelation = [Relation] + +data Relation = Rel BinPkgName (Maybe VersionReq) (Maybe ArchitectureReq) deriving (Eq, Read, Show) + +newtype SrcPkgName = SrcPkgName {unSrcPkgName :: String} deriving (Read, Show, Eq, Ord, Data, Typeable) +newtype BinPkgName = BinPkgName {unBinPkgName :: String} deriving (Read, Show, Eq, Ord, Data, Typeable) + +class Pretty (PP a) => PkgName a where + pkgNameFromString :: String -> a + +instance PkgName BinPkgName where + pkgNameFromString = BinPkgName + +instance PkgName SrcPkgName where + pkgNameFromString = SrcPkgName + +class ParseRelations a where + -- |'parseRelations' parse a debian relation (i.e. the value of a + -- Depends field). Return a parsec error or a value of type + -- 'Relations' + parseRelations :: a -> Either ParseError Relations + +-- | This needs to be indented for use in a control file: intercalate "\n " . lines . show +prettyRelations :: [[Relation]] -> Doc +prettyRelations xss = mconcat . intersperse (text "\n, ") . List.map prettyOrRelation $ xss + +prettyOrRelation :: [Relation] -> Doc +prettyOrRelation xs = mconcat . intersperse (text " | ") . List.map prettyRelation $ xs + +prettyRelation :: Relation -> Doc +prettyRelation (Rel name ver arch) = + pretty (PP name) <> maybe empty prettyVersionReq ver <> maybe empty prettyArchitectureReq arch + +instance Ord Relation where + compare (Rel pkgName1 mVerReq1 _mArch1) (Rel pkgName2 mVerReq2 _mArch2) = + case compare pkgName1 pkgName2 of + LT -> LT + GT -> GT + EQ -> compare mVerReq1 mVerReq2 + +data ArchitectureReq + = ArchOnly (Set Arch) + | ArchExcept (Set Arch) + deriving (Eq, Ord, Read, Show) + +prettyArchitectureReq :: ArchitectureReq -> Doc +prettyArchitectureReq (ArchOnly arch) = text " [" <> mconcat (List.map prettyArch (toList arch)) <> text "]" +prettyArchitectureReq (ArchExcept arch) = text " [" <> mconcat (List.map ((text "!") <>) (List.map prettyArch (toList arch))) <> text "]" + +data VersionReq + = SLT DebianVersion + | LTE DebianVersion + | EEQ DebianVersion + | GRE DebianVersion + | SGR DebianVersion + deriving (Eq, Read, Show) + +prettyVersionReq :: VersionReq -> Doc +prettyVersionReq (SLT v) = text " (<< " <> prettyDebianVersion v <> text ")" +prettyVersionReq (LTE v) = text " (<= " <> prettyDebianVersion v <> text ")" +prettyVersionReq (EEQ v) = text " (= " <> prettyDebianVersion v <> text ")" +prettyVersionReq (GRE v) = text " (>= " <> prettyDebianVersion v <> text ")" +prettyVersionReq (SGR v) = text " (>> " <> prettyDebianVersion v <> text ")" + +-- |The sort order is based on version number first, then on the kind of +-- relation, sorting in the order <<, <= , ==, >= , >> +instance Ord VersionReq where + compare = compare `on` extr + where extr (SLT v) = (v,0 :: Int) + extr (LTE v) = (v,1 :: Int) + extr (EEQ v) = (v,2 :: Int) + extr (GRE v) = (v,3 :: Int) + extr (SGR v) = (v,4 :: Int) + +-- |Check if a version number satisfies a version requirement. +checkVersionReq :: Maybe VersionReq -> Maybe DebianVersion -> Bool +checkVersionReq Nothing _ = True +checkVersionReq _ Nothing = False +checkVersionReq (Just (SLT v1)) (Just v2) = v2 < v1 +checkVersionReq (Just (LTE v1)) (Just v2) = v2 <= v1 +checkVersionReq (Just (EEQ v1)) (Just v2) = v2 == v1 +checkVersionReq (Just (GRE v1)) (Just v2) = v2 >= v1 +checkVersionReq (Just (SGR v1)) (Just v2) = v2 > v1 + +instance Pretty (PP BinPkgName) where + pretty = text . unBinPkgName . unPP + +instance Pretty (PP SrcPkgName) where + pretty = text . unSrcPkgName . unPP + +-- | Wrap `PP` around type synonyms that might overlap with the +-- `Pretty [a]` instance. +instance Pretty (PP Relations) where + pretty = prettyRelations . unPP + +instance Pretty (PP OrRelation) where + pretty = prettyOrRelation . unPP + +instance Pretty (PP Relation) where + pretty = prettyRelation . unPP + +instance Pretty (PP VersionReq) where + pretty = prettyVersionReq . unPP + +instance Pretty (PP ArchitectureReq) where + pretty = prettyArchitectureReq . unPP diff --git a/src/Debian/Relation/String.hs b/src/Debian/Relation/String.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Relation/String.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE FlexibleInstances, PackageImports, TypeSynonymInstances #-} +{-# OPTIONS -fno-warn-unused-do-bind -fno-warn-orphans #-} +-- |A module for working with debian relationships +module Debian.Relation.String + ( -- * Types + AndRelation + , OrRelation + , Relations + , Relation(..) + , ArchitectureReq(..) + , VersionReq(..) + -- * Helper Functions + , checkVersionReq + -- * Relation Parser + , RelParser + , ParseRelations(..) + , pRelations + ) where + +-- Standard GHC Modules + +import "mtl" Control.Monad.Identity (Identity) +import Data.Set (fromList) +import Text.ParserCombinators.Parsec +import Text.Parsec.Prim (ParsecT) + +-- Local Modules + +import Debian.Arch (Arch, parseArch) +import Debian.Relation.Common +import Debian.Version + +-- * ParseRelations + +instance ParseRelations String where + parseRelations str = + let str' = scrub str in + case parse pRelations str' str' of + Right relations -> Right (filter (/= []) relations) + x -> x + where + scrub = unlines . filter (not . comment) . lines + comment s = case dropWhile (`elem` [' ', '\t']) s of + ('#' : _) -> True + _ -> False + +-- * Relation Parser + +type RelParser a = CharParser () a + +-- "Correct" dependency lists are separated by commas, but sometimes they +-- are omitted and it is possible to parse relations without them. +pRelations :: RelParser Relations +pRelations = do -- rel <- sepBy pOrRelation (char ',') + rel <- many pOrRelation + eof + return rel + +pOrRelation :: RelParser OrRelation +pOrRelation = do skipMany (char ',' <|> whiteChar) + rel <- sepBy1 pRelation (char '|') + skipMany (char ',' <|> whiteChar) + return rel + +whiteChar :: ParsecT String u Identity Char +whiteChar = oneOf [' ','\t','\n'] + +pRelation :: RelParser Relation +pRelation = + do skipMany whiteChar + pkgName <- many1 (noneOf [' ',',','|','\t','\n','(']) + skipMany whiteChar + mVerReq <- pMaybeVerReq + skipMany whiteChar + mArch <- pMaybeArch + return $ Rel (BinPkgName pkgName) mVerReq mArch + +pMaybeVerReq :: RelParser (Maybe VersionReq) +pMaybeVerReq = + do char '(' + skipMany whiteChar + op <- pVerReq + skipMany whiteChar + ver <- many1 (noneOf [' ',')','\t','\n']) + skipMany whiteChar + char ')' + return $ Just (op (parseDebianVersion' ver)) + <|> + do return $ Nothing + +pVerReq :: ParsecT [Char] u Identity (DebianVersion -> VersionReq) +pVerReq = + do char '<' + (do char '<' <|> char ' ' <|> char '\t' + return $ SLT + <|> + do char '=' + return $ LTE) + <|> + do string "=" + return $ EEQ + <|> + do char '>' + (do char '=' + return $ GRE + <|> + do char '>' <|> char ' ' <|> char '\t' + return $ SGR) + +pMaybeArch :: RelParser (Maybe ArchitectureReq) +pMaybeArch = + do char '[' + (do archs <- pArchExcept + char ']' + skipMany whiteChar + return (Just (ArchExcept (fromList . map parseArchExcept $ archs))) + <|> + do archs <- pArchOnly + char ']' + skipMany whiteChar + return (Just (ArchOnly (fromList . map parseArch $ archs))) + ) + <|> + return Nothing + +-- Some packages (e.g. coreutils) have architecture specs like [!i386 +-- !hppa], even though this doesn't really make sense: once you have +-- one !, anything else you include must also be (implicitly) a !. +pArchExcept :: RelParser [String] +pArchExcept = sepBy (char '!' >> many1 (noneOf [']',' '])) (skipMany1 whiteChar) + +pArchOnly :: RelParser [String] +pArchOnly = sepBy (many1 (noneOf [']',' '])) (skipMany1 whiteChar) + +-- | Ignore the ! if it is present, we already know this list has at +-- least one, and the rest are implicit. +parseArchExcept :: String -> Arch +parseArchExcept ('!' : s) = parseArch s +parseArchExcept s = parseArch s diff --git a/src/Debian/Relation/Text.hs b/src/Debian/Relation/Text.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Relation/Text.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -fno-warn-orphans #-} +-- |A module for working with debian relationships +module Debian.Relation.Text + ( -- * Types + AndRelation + , OrRelation + , Relations + , Relation(..) + , ArchitectureReq(..) + , VersionReq(..) + -- * Helper Functions + , checkVersionReq + -- * Relation Parser + , RelParser + , ParseRelations(..) + ) where + +import qualified Data.Text as T + +-- Local Modules + +--import Debian.Relation.Common +import Debian.Relation.String +--import Debian.Version + +-- * ParseRelations + +-- For now we just wrap the string version +instance ParseRelations T.Text where + parseRelations text = parseRelations (T.unpack text) diff --git a/src/Debian/Release.hs b/src/Debian/Release.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Release.hs @@ -0,0 +1,48 @@ +-- | This module name is spurious - "Release" is not an official term +-- in the debian documentation. + +{-# LANGUAGE DeriveDataTypeable #-} + +module Debian.Release + ( Section(..) + , SubSection(..) + , sectionName + , sectionName' + , sectionNameOfSubSection + , parseSection + , parseSection' + ) where + +import Network.URI (unEscapeString, escapeURIString, isAllowedInURI) + +-- |A section of a repository such as main, contrib, non-free, +-- restricted. The indexes for a section are located below the +-- distribution directory. +newtype Section = Section String deriving (Read, Show, Eq, Ord) + +-- |A package's subsection is only evident in its control information, +-- packages from different subsections all reside in the same index. +data SubSection = SubSection { section :: Section, subSectionName :: String } deriving (Read, Show, Eq, Ord) + +sectionName :: SubSection -> String +sectionName (SubSection (Section "main") y) = y +sectionName (SubSection x y) = sectionName' x ++ "/" ++ y + +sectionName' :: Section -> String +sectionName' (Section s) = escapeURIString isAllowedInURI s + +sectionNameOfSubSection :: SubSection -> String +sectionNameOfSubSection = sectionName' . section + +-- |Parse the value that appears in the @Section@ field of a .changes file. +-- (Does this need to be unesacped?) +parseSection :: String -> SubSection +parseSection s = + case span (/= '/') s of + (x, "") -> SubSection (Section "main") x + ("main", y) -> SubSection (Section "main") y + (x, y) -> SubSection (Section x) (tail y) + +parseSection' :: String -> Section +parseSection' name = + Section (unEscapeString name) diff --git a/src/Debian/Report.hs b/src/Debian/Report.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Report.hs @@ -0,0 +1,88 @@ +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/src/Debian/Sources.hs b/src/Debian/Sources.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Sources.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module Debian.Sources + {- ( SourceType(..) + , SourceOption(..) + , SourceOp(..) + , DebSource(..) + , parseSourceLine + , parseSourceLine' + , parseSourcesList + ) -} where + +import Control.Lens (makeLenses, review, view) +import Data.Maybe (fromJust) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Debian.Codename (Codename, codename, parseCodename) +import Debian.Pretty (PP(..)) +import Debian.Release +import Debian.TH (here, Loc) +import Debian.VendorURI (parseVendorURI, VendorURI, vendorURI) +import Network.URI (parseURI, unEscapeString, escapeURIString, isAllowedInURI) +import Test.HUnit +import Text.ParserCombinators.Parsec +import Text.PrettyPrint (hcat, punctuate, render, text) +import Distribution.Pretty (Pretty(pretty), prettyShow) + +data SourceType + = Deb | DebSrc + deriving (Eq, Ord, Show) + +-- arch +-- lang +-- target +-- pdiffs +-- by-hash +-- allow-insecure=no +-- allow-weak=no +-- allow-downgrade-to-insecure=no +-- trusted=no +-- signed-by +-- check-valid-until +-- valid-until-min +-- valid-until-max +data SourceOption + = SourceOption String SourceOp [String] + deriving (Eq, Ord, Show) + +data SourceOp = OpSet | OpAdd | OpDel deriving (Eq, Ord, Show) + +instance Pretty SourceOp where + pretty OpSet = text "=" + pretty OpAdd = text "+=" + pretty OpDel = text "-=" + +data DebSource + = DebSource + { _sourceType :: SourceType + , _sourceOptions :: [SourceOption] + , _sourceUri :: VendorURI + , _sourceDist :: Either String (Codename, [Section]) + } deriving (Eq, Ord, Show) + +instance Pretty SourceType where + pretty Deb = text "deb" + pretty DebSrc = text "deb-src" + +instance Pretty SourceOption where + pretty (SourceOption k op vs) = text k <> pretty op <> hcat (punctuate (text ",") (map text vs)) + +instance Pretty DebSource where + pretty (DebSource thetype theoptions theuri thedist) = + hcat (punctuate (text " ") + ([pretty thetype] ++ + (case theoptions of + [] -> [] + _ -> [text "[" <> hcat (punctuate (text ", ") (map pretty theoptions)) <> text "]"]) ++ + [text (show (view vendorURI theuri))] ++ + case thedist of + Left exactPath -> [text (escapeURIString isAllowedInURI exactPath)] + Right (dist, sections) -> + map text (codename dist : map sectionName' sections))) + +instance Pretty (PP [DebSource]) where + pretty = hcat . map (\ x -> pretty x <> text "\n") . unPP + +{- + +deb uri distribution [component1] [componenent2] [...] + +The URI for the deb type must specify the base of the Debian +distribution, from which APT will find the information it needs. + +distribution can specify an exact path, in which case the components +must be omitted and distribution must end with a slash (/). + +If distribution does not specify an exact path, at least one component +must be present. + +Distribution may also contain a variable, $(ARCH), which expands to +the Debian architecture (i386, m68k, powerpc, ...) used on the +system. + +The rest of the line can be marked as a comment by using a #. + +Additional Notes: + + + Lines can begin with leading white space. + + + If the dist ends with slash (/), then it must be an absolute path + and it is an error to specify components after it. + +-} + +-- |quoteWords - similar to words, but with special handling of +-- double-quotes and brackets. +-- +-- The handling double quotes and [] is supposed to match: +-- apt-0.6.44.2\/apt-pkg\/contrib\/strutl.cc:ParseQuoteWord() +-- +-- The behaviour can be defined as: +-- +-- Break the string into space seperated words ignoring spaces that +-- appear between \"\" or []. Strip trailing and leading white space +-- around words. Strip out double quotes, but leave the square +-- brackets intact. +quoteWords :: String -> [String] +quoteWords [] = [] +quoteWords s = quoteWords' (dropWhile (==' ') s) + where + quoteWords' :: String -> [String] + quoteWords' [] = [] + quoteWords' str = + case break (flip elem (" [\"" :: String)) str of + ([],[]) -> [] + (w, []) -> [w] + (w, (' ':rest)) -> w : (quoteWords' (dropWhile (==' ') rest)) + (w, ('"':rest)) -> + case break (== '"') rest of + (w',('"':rest)) -> + case quoteWords' rest of + [] -> [w ++ w'] + (w'':ws) -> ((w ++ w' ++ w''): ws) + (_w',[]) -> error ("quoteWords: missing \" in the string: " ++ s) + _ -> error ("the impossible happened in SourcesList.quoteWords") + (w, ('[':rest)) -> + case break (== ']') rest of + (w',(']':rest)) -> + case quoteWords' rest of + [] -> [w ++ "[" ++ w' ++ "]"] + (w'':ws) -> ((w ++ "[" ++ w' ++ "]" ++ w''): ws) + (_w',[]) -> error ("quoteWords: missing ] in the string: " ++ s) + _ -> error ("the impossible happened in SourcesList.quoteWords") + _ -> error ("the impossible happened in SourcesList.quoteWords") + +stripLine :: String -> String +stripLine = takeWhile (/= '#') . dropWhile (== ' ') + +sourceLines :: String -> [String] +sourceLines = filter (not . null) . map stripLine . lines + +-- |parseSourceLine -- parses a source line +-- the argument must be a non-empty, valid source line with comments stripped +-- see: 'sourceLines' +parseSourceLine :: [Loc] -> String -> DebSource +parseSourceLine locs str = either error id (parseSourceLine' locs str) +{- + case quoteWords str of + (theTypeStr : theUriStr : theDistStr : sectionStrs) -> + let sections = map parseSection' sectionStrs + theType = case unEscapeString theTypeStr of + "deb" -> Deb + "deb-src" -> DebSrc + o -> error ("parseSourceLine: invalid type " ++ o ++ " in line:\n" ++ str) + theUri = case parseURI theUriStr of + Nothing -> error ("parseSourceLine: invalid uri " ++ theUriStr ++ " in the line:\n" ++ str) + Just u -> u + theDist = unEscapeString theDistStr + in + case last theDist of + '/' -> if null sections + then DebSource { sourceType = theType, sourceOptions = [], sourceUri = theUri, sourceDist = Left theDist } + else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str) + _ -> if null sections + then error ("parseSourceLine: Dist is not an exact path, so at least one section is required on the line:\n" ++ str) + else DebSource { sourceType = theType, sourceOptions = [], sourceUri = theUri, sourceDist = Right (parseReleaseName theDist, sections) } + _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str) +-} + +parseOptions :: String -> Either ParseError [SourceOption] +parseOptions s = parse pOptions s s + +pOptions :: CharParser () [SourceOption] +pOptions = do _ <- char '[' + skipMany (oneOf [' ','\t']) + opts <- sepBy1 pOption (char ',') + skipMany (oneOf [' ','\t']) + _ <- char ']' + return opts + +pOption :: CharParser () SourceOption +pOption = do skipMany (oneOf [' ','\t']) + key <- many1 (noneOf ['+','-','=',' ','\t']) + skipMany (oneOf [' ','\t']) + op <- pOp + skipMany (oneOf [' ','\t']) + values <- sepBy1 (many1 (noneOf [',',']',' ','\t'])) (char ',') + skipMany (oneOf [' ','\t']) + return $ SourceOption key op values + +pOp :: CharParser () SourceOp +pOp = do (char '+' >> char '=' >> return OpAdd) + <|> + (char '-' >> char '=' >> return OpDel) + <|> + (char '=' >> return OpSet) + +parseSourceLine' :: [Loc] -> String -> Either String DebSource +parseSourceLine' locs str = + case quoteWords str of + theTypeStr : theOptionStr@('[' : _) : theURIStr : theDistStr : sectionStrs -> + either + (Left . show) + (\opts -> go theTypeStr opts theURIStr theDistStr sectionStrs) + (parseOptions theOptionStr) + theTypeStr : theURIStr : theDistStr : sectionStrs -> + go theTypeStr [] theURIStr theDistStr sectionStrs + _ -> Left ("parseSourceLine: invalid line in sources.list:\n" ++ str) + where + go :: String -> [SourceOption] -> String -> String -> [String] -> Either String DebSource + go theTypeStr theOptions theURIStr theDistStr sectionStrs = + let sections = map parseSection' sectionStrs + theType = case unEscapeString theTypeStr of + "deb" -> Right Deb + "deb-src" -> Right DebSrc + s -> Left ("parseSourceLine" ++ prettyShow ($here : locs) ++ ": invalid type " ++ s ++ " in line:\n" ++ str ++ " str=" ++ show str) + theURI = case parseVendorURI ($here : locs) theURIStr of + Nothing -> Left ("parseSourceLine' " ++ prettyShow ($here : locs) ++ ": invalid uri " ++ theURIStr ++ " str=" ++ show str) + Just u -> Right u + theDist = unEscapeString theDistStr + in + case (last theDist, theType, theURI) of + ('/', Right typ, Right uri) -> if null sections + then Right $ DebSource { _sourceType = typ, _sourceOptions = theOptions, _sourceUri = uri, _sourceDist = Left theDist } + else Left ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str) + (_, Right typ, Right uri) -> if null sections + then Left ("parseSourceLine: Dist is not an exact path, so at least one section is required on the line:\n" ++ str) + else Right $ DebSource { _sourceType = typ, _sourceOptions = theOptions, _sourceUri = uri, _sourceDist = Right ((parseCodename theDist), sections) } + (_, Left msg, _) -> Left msg + (_, _, Left msg) -> Left msg + +parseSourcesList :: [Loc] -> String -> [DebSource] +parseSourcesList locs = map (parseSourceLine locs) . sourceLines + +-- * Unit Tests + +-- TODO: add test cases that test for unterminated double-quote or bracket +testQuoteWords :: Test +testQuoteWords = + test [ assertEqual "Space seperate words, no quoting" ["hello", "world","!"] (quoteWords " hello world ! ") + , assertEqual "Space seperate words, double quotes" ["hello world","!"] (quoteWords " hel\"lo world\" ! ") + , assertEqual "Space seperate words, square brackets" ["hel[lo worl]d","!"] (quoteWords " hel[lo worl]d ! ") + , assertEqual "Space seperate words, square-bracket at end" ["hel[lo world]"] (quoteWords " hel[lo world]") + , assertEqual "Space seperate words, double quote at end" ["hello world"] (quoteWords " hel\"lo world\"") + , assertEqual "Space seperate words, square-bracket at beginning" ["[hello wo]rld","!"] (quoteWords "[hello wo]rld !") + , assertEqual "Space seperate words, double quote at beginning" ["hello world","!"] (quoteWords "\"hello wor\"ld !") + ] + +testSourcesList :: Test +testSourcesList = + test [ assertEqual "parse and pretty sources.list" validSourcesListExpected (render . pretty . PP . parseSourcesList [$here] $ validSourcesListStr) ] + +testSourcesList2 :: Test +testSourcesList2 = + test [ assertEqual "pretty sources.list" validSourcesListExpected (render . pretty . PP $ validSourcesList) ] + +validSourcesListStr :: String +validSourcesListStr = + unlines $ [ " # A comment only line " + , " deb ftp://ftp.debian.org/debian unstable main contrib non-free # typical deb line" + , " deb-src ftp://ftp.debian.org/debian unstable main contrib non-free # typical deb-src line" + , "" + , "# comment line" + , "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ # exact path" + , "deb [trusted=yes] http://ftp.debian.org/whee \"space dist\" main" + , "deb [trusted=yes] http://ftp.debian.org/whee dist space%20section" + ] + +validSourcesList :: [DebSource] +validSourcesList = + [DebSource {_sourceType = Deb, _sourceOptions = [], _sourceUri = (review vendorURI . fromJust) (parseURI "ftp://ftp.debian.org/debian"), _sourceDist = Right (parseCodename "unstable",[Section "main",Section "contrib",Section "non-free"])}, + DebSource {_sourceType = DebSrc, _sourceOptions = [], _sourceUri = (review vendorURI . fromJust) (parseURI "ftp://ftp.debian.org/debian"), _sourceDist = Right (parseCodename "unstable",[Section "main",Section "contrib",Section "non-free"])}, + DebSource {_sourceType = Deb, _sourceOptions = [], _sourceUri = (review vendorURI . fromJust) (parseURI "http://pkg-kde.alioth.debian.org/kde-3.5.0/"), _sourceDist = Left "./"}, + DebSource {_sourceType = Deb, _sourceOptions = [SourceOption "trusted" OpSet ["yes"]], _sourceUri = (review vendorURI . fromJust) (parseURI "http://ftp.debian.org/whee"), _sourceDist = Right (parseCodename "space dist",[Section "main"])}, + DebSource {_sourceType = Deb, _sourceOptions = [SourceOption "trusted" OpSet ["yes"]], _sourceUri = (review vendorURI . fromJust) (parseURI "http://ftp.debian.org/whee"), _sourceDist = Right (parseCodename "dist",[Section "space section"])}] + +validSourcesListExpected :: String +validSourcesListExpected = + unlines $ [ "deb ftp://ftp.debian.org/debian unstable main contrib non-free" + , "deb-src ftp://ftp.debian.org/debian unstable main contrib non-free" + , "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./" + , "deb [trusted=yes] http://ftp.debian.org/whee space%20dist main" + , "deb [trusted=yes] http://ftp.debian.org/whee dist space%20section" + ] +_invalidSourcesListStr1 :: Text +_invalidSourcesListStr1 = "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ main contrib non-free # exact path with sections" + +testSourcesListParse :: Test +testSourcesListParse = + test [ assertEqual "" gutsy (concat . map (<> "\n") . map (render . pretty) . parseSourcesList [$here] $ gutsy) ] + where + 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"] + +sourcesListTests :: Test +sourcesListTests = + TestList [ testQuoteWords, testSourcesList, testSourcesList2, testSourcesListParse ] + +$(makeLenses ''DebSource) diff --git a/src/Debian/TH.hs b/src/Debian/TH.hs new file mode 100644 --- /dev/null +++ b/src/Debian/TH.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP, FlexibleInstances, TemplateHaskell #-} +{-# OPTIONS -Wall #-} + +module Debian.TH + ( here + , Loc + ) where + +import Data.List (intersperse) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif +import Distribution.Pretty (Pretty(..)) +import Language.Haskell.TH (ExpQ, Loc(..), location) +import Language.Haskell.TH.Instances () +import Language.Haskell.TH.Lift (lift) +--import Text.PrettyPrint (Doc, text) +import Text.PrettyPrint.HughesPJClass (Doc, hcat, text) + +here :: ExpQ +here = lift =<< location + +instance Pretty Loc where + pretty = prettyLoc + +prettyLoc :: Loc -> Doc +prettyLoc (Loc _filename _package modul (line, col) _) = text (modul <> ":" ++ show line ++ ":" ++ show col) + +instance Pretty [Loc] where + pretty locs = text "[" <> hcat (intersperse (text " → ") (fmap prettyLoc locs)) <> text "]" diff --git a/src/Debian/Time.hs b/src/Debian/Time.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Time.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} +module Debian.Time where + +import Data.Time +#if !MIN_VERSION_time(1,5,0) +import System.Locale (defaultTimeLocale) +#endif +import Data.Time.Clock.POSIX +import System.Posix.Types + +-- * Time Helper Functions + +rfc822DateFormat' :: String +rfc822DateFormat' = "%a, %d %b %Y %T %z" + +epochTimeToUTCTime :: EpochTime -> UTCTime +epochTimeToUTCTime = posixSecondsToUTCTime . fromIntegral . fromEnum + +formatTimeRFC822 :: (FormatTime t) => t -> String +formatTimeRFC822 = formatTime defaultTimeLocale rfc822DateFormat' + +parseTimeRFC822 :: (ParseTime t) => String -> Maybe t +parseTimeRFC822 = parseTimeM True defaultTimeLocale rfc822DateFormat' + +getCurrentLocalRFC822Time :: IO String +getCurrentLocalRFC822Time = getCurrentTime >>= utcToLocalZonedTime >>= return . formatTime defaultTimeLocale rfc822DateFormat' + diff --git a/src/Debian/URI.hs b/src/Debian/URI.hs new file mode 100644 --- /dev/null +++ b/src/Debian/URI.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, OverloadedStrings, PackageImports, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall -fno-warn-orphans #-} + +module Debian.URI + ( module Network.URI + +#if 0 + , _NodeElement -- :: Prism' Node Element + , _NodeContent -- :: Prism' Node Text + , eltAttrsLens -- :: Lens' Element (HashMap AttrName AttrValue) + , eltChildrenLens -- :: Lens' Element [Node] + , eltNameLens -- :: Lens' Element Text +#endif + + , URIError(..) + , uriSchemeLens + , uriAuthorityLens + , uriPathLens + , uriQueryLens + , uriFragmentLens + -- * String known to parsable by parseURIReference. Mainly + -- useful because it has a Read instance. + , URI'(..) + , fromURI' + , toURI' + , readURI' + + -- Show URI as a Haskell expression + , showURI + -- Monadic URI parsers + , parseURIReference' + , parseURI' + , parseAbsoluteURI' + , parseRelativeReference' + , parseURIUnsafe + -- URI appending + , appendURI + , appendURIs + , parentURI + , uriToString' + -- * Lift IO operations into a MonadError instance + , HasParseError(fromParseError) + , HasURIError(fromURIError) + -- * QuickCheck properties + , prop_print_parse + , prop_append_singleton + ) where + +import Control.Lens (makeLensesFor) +import Control.Monad.Except (MonadError, throwError) +import Data.Foldable (foldrM) +import Data.Maybe (fromJust, fromMaybe) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif +import Network.URI (nullURI, parseURIReference, parseURI, parseAbsoluteURI, parseRelativeReference, URI(..), URIAuth(..), uriToString) +import System.FilePath ((), dropTrailingPathSeparator, takeDirectory) +import Test.QuickCheck (Arbitrary) +import Text.Parsec (ParseError) + +$(makeLensesFor [("uriScheme", "uriSchemeLens"), + ("uriAuthority", "uriAuthorityLens"), + ("uriPath", "uriPathLens"), + ("uriQuery", "uriQueryLens"), + ("uriFragment", "uriFragmentLens")] ''URI) + +showURI :: URI -> String +showURI (URI {..}) = + "URI {uriScheme = " <> show uriScheme <> + ", uriAuthority = " <> show uriAuthority <> + ", uriPath = " <> show uriPath <> + ", uriQuery = " <> show uriQuery <> + ", uriFragment = " <> show uriFragment <> "}" + +-- | parseURI with MonadError +parseURI' :: (HasURIError e, MonadError e m) => String -> m URI +parseURI' s = maybe (throwError $ fromURIError $ URIParseError "parseURI" s) return (parseURI s) +parseURIReference' :: (HasURIError e, MonadError e m) => String -> m URI +parseURIReference' s = maybe (throwError $ fromURIError $ URIParseError "parseURIReference" s) return (parseURIReference s) +parseAbsoluteURI' :: (HasURIError e, MonadError e m) => String -> m URI +parseAbsoluteURI' s = maybe (throwError $ fromURIError $ URIParseError "parseAbsoluteURI" s) return (parseAbsoluteURI s) +parseRelativeReference' :: (HasURIError e, MonadError e m) => String -> m URI +parseRelativeReference' s = maybe (throwError $ fromURIError $ URIParseError "parseRelativeReference" s) return (parseRelativeReference s) + +parseURIUnsafe :: String -> URI +parseURIUnsafe s = fromMaybe (error ("parseURIUnsafe " ++ show s)) $ parseURIReference s + +--parseAbsoluteURI :: String -> Maybe URI +--parseRelativeReference :: String -> Maybe URI +--parseURI :: String -> Maybe URI +--parseURIReference :: String -> Maybe URI + +data URIError = + URIParseError String String + | URIAppendError URI URI + deriving (Eq, Ord, Show) + +-- | Conservative appending of absolute and relative URIs. There may +-- be other cases that can be implemented, lets see if they turn up. +appendURI :: MonadError URIError m => URI -> URI -> m URI + -- Append the two paths +appendURI (URI scheme auth path1 "" "") (URI "" Nothing path2 query fragment) = return $ URI scheme auth (path1 path2) query fragment + -- Use query from RHS +appendURI a b = throwError (URIAppendError a b) + +-- | Append a list of URI +-- @@ +-- λ> appendURIs (parseURI "http://host.com") (parseURIRelative "/bar") +appendURIs :: (Foldable t, MonadError URIError m) => t URI -> m URI +appendURIs uris = foldrM appendURI nullURI uris + +parentURI :: URI -> URI +parentURI uri = uri {uriPath = takeDirectory (dropTrailingPathSeparator (uriPath uri))} + +-- properties +-- appendURIs [x] == x + +prop_append_singleton :: URI -> Bool +prop_append_singleton uri = appendURIs [uri] == Right uri + +prop_print_parse :: URI -> Bool +prop_print_parse uri = parseURIReference (show uri) == Just uri + +-- | A wrapper around a String containing a known parsable URI. Not +-- absolutely safe, because you could say read "URI' \"bogus string\"" +-- :: URI'. But enough to save me from myself. +newtype URI' = URI' String deriving (Read, Show, Eq, Ord) + +readURI' :: String -> Maybe URI' +readURI' s = maybe Nothing (const (Just (URI' s))) (parseURIReference s) + +fromURI' :: URI' -> URI +fromURI' (URI' s) = fromJust (parseURI s) -- this should provably parse + +-- | Using the bogus Show instance of URI here. If it ever gets fixed +-- this will stop working. Worth noting that show will obscure any +-- password info embedded in the URI, so that's nice. +toURI' :: URI -> URI' +toURI' = URI' . show + +uriToString' :: URI -> String +uriToString' uri = uriToString id uri "" + +instance Arbitrary URI where + -- Replace with import from network-arbitrary package + +class HasParseError e where fromParseError :: ParseError -> e +instance HasParseError ParseError where fromParseError = id + +class HasURIError e where fromURIError :: URIError -> e +instance HasURIError URIError where fromURIError = id + +instance Ord ParseError where + compare a b = compare (show a) (show b) diff --git a/src/Debian/UTF8.hs b/src/Debian/UTF8.hs new file mode 100644 --- /dev/null +++ b/src/Debian/UTF8.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} +-- | There are old index files that have funky characters like 'ø' +-- that are not properly UTF8 encoded. As far as I can tell, these +-- files are otherwise plain ascii, so just naivelyinsert the +-- character into the output stream. +module Debian.UTF8 + ( decode + , readFile + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif +import qualified Data.ByteString.Char8 as B (concat) +import qualified Data.ByteString.Lazy.Char8 as L (ByteString, readFile, toChunks) +import Data.Char (chr) +import Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Word (Word8) +import Prelude hiding (readFile) + +decode :: L.ByteString -> T.Text +decode b = decodeUtf8With e (B.concat (L.toChunks b)) + where + e :: String -> Maybe Word8 -> Maybe Char + e _description w = fmap (chr . fromIntegral) w + +readFile :: FilePath -> IO T.Text +readFile path = decode <$> L.readFile path diff --git a/src/Debian/Util/FakeChanges.hs b/src/Debian/Util/FakeChanges.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Util/FakeChanges.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +module Debian.Util.FakeChanges (fakeChanges) where + +--import Control.Arrow +import Control.Exception +import Control.Monad hiding (mapM) +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Data (Data, Typeable) +import Data.Digest.Pure.SHA as SHA +import Data.Foldable (concat, all, foldr) +import Data.List as List (intercalate, nub, partition, isSuffixOf) +import Data.Maybe +import Debian.Pretty (prettyShow) +import Data.Traversable +import Debian.Control +import qualified Debian.Deb as Deb +import Debian.Time +import Network.HostName (getHostName) +import Prelude hiding (concat, foldr, all, mapM, sum) +import System.Environment +import System.FilePath +import System.Posix.Files +import Text.Regex.TDFA + +data Error + = NoDebs + | TooManyDscs [FilePath] + | TooManyTars [FilePath] + | TooManyDiffs [FilePath] + | UnknownFiles [FilePath] + | MalformedDebFilename [FilePath] + | VersionMismatch [Maybe String] + deriving (Read, Show, Eq, Typeable, Data) + +data Files + = Files { dsc :: Maybe (FilePath, Paragraph) + , debs :: [(FilePath, Paragraph)] + , tar :: Maybe FilePath + , diff :: Maybe FilePath + } + +fakeChanges :: [FilePath] -> IO (FilePath, String) +fakeChanges fps = + do files <- loadFiles fps + let version = getVersion files + source = getSource files + maintainer = getMaintainer files + arches = getArches files + binArch = getBinArch files + dist = "unstable" + urgency = "low" + (invalid, binaries) = unzipEithers $ map (debNameSplit . fst) (debs files) + when (not . null $ invalid) (error $ "Some .deb names are invalid: " ++ show invalid) + uploader <- getUploader + date <- getCurrentLocalRFC822Time + fileLines <- mapM mkFileLine fps + let changes = Control $ return . Paragraph $ map Field + [ ("Format"," 1.7") + , ("Date", ' ' : date) + , ("Source", ' ' : source) + , ("Binary", ' ' : (intercalate " " $ map (\(n,_,_) -> n) binaries)) + , ("Architecture", ' ' : intercalate " " arches) + , ("Version", ' ' : version) + , ("Distribution", ' ' : dist) + , ("Urgency", ' ' : urgency) + , ("Maintainer", ' ' : maintainer) + , ("Changed-By", ' ' : uploader) + , ("Description", "\n Simulated description") + , ("Changes", "\n" ++ unlines (map (' ':) [ source ++ " (" ++ version ++") " ++ dist ++ "; urgency=" ++ urgency + , "." + , " * Simulated changes" + ] + )) + , ("Files", "\n" ++ unlines fileLines) + ] + return $ (concat [ source, "_", version, "_", binArch, ".changes"], prettyShow changes) +-- let (invalid, binaries) = unzipEithers $ map debNameSplit debs +{- + when (not . null $ invalid) (throwDyn [MalformedDebFilename invalid]) + version <- getVersion dsc debs + putStrLn version + source <- getSource dsc debs + putStrLn source +-} +-- TODO: seems like this could be more aggressive about ensure the +-- versions make sense. Except with packages like libc, the versions +-- don't make sense. Maybe we want a flag that disables version check +-- ? +getVersion :: Files -> String +getVersion files + | isNothing (dsc files) = + let versions = map (fieldValue "Version" . snd) (debs files) + in + if (all isJust versions) && (length (nub versions) == 1) + then fromJust (head versions) + else error (show [VersionMismatch (nub versions)]) + | otherwise = + case fieldValue "Version" (snd . fromJust $ dsc files) of + (Just v) -> v + Nothing -> error $ "show (dsc files)" ++ " does not have a Version field :(" + + +getSource :: Files -> String +getSource files = + let dscSource = + case (dsc files) of + Nothing -> [] + (Just (fp, p)) -> + case fieldValue "Source" p of + (Just v) -> [v] + Nothing -> error $ fp ++ " does not have a Source field :(" + debSources = map debSource (debs files) + srcs = nub (dscSource ++ debSources) + in + if (singleton srcs) + then (head srcs) + else error $ "Could not determine source." + where + debSource (deb,p) = + case (fieldValue "Source" p) of + (Just v) -> v + Nothing -> + case fieldValue "Package" p of + (Just v) -> v + Nothing -> error $ "Could not find Source or Package field in " ++ deb + + + +getMaintainer :: Files -> String +getMaintainer files + | isJust (dsc files) = + let (fp, p) = fromJust (dsc files) + in + case fieldValue "Maintainer" p of + Nothing -> error $ fp ++ " is missing the Maintainer field." + (Just v) -> v + | otherwise = + let maintainers = catMaybes $ map (fieldValue "Maintainer" . snd) (debs files) + maintainer = nub maintainers + in + if singleton maintainer + then head maintainer + else error $ "Could not uniquely determine the maintainer: " ++ show maintainer + +getArches :: Files -> [String] +getArches files = + let debArchs = map (fieldValue "Architecture" . snd) (debs files) + tarArch = fmap (const "source") (tar files) + diffArch = fmap (const "source") (diff files) + in + nub $ catMaybes (tarArch : diffArch : debArchs) + + +getBinArch :: Files -> String +getBinArch files = + let binArch = nub $ mapMaybe (fieldValue "Architecture" . snd) (debs files) + in + if singleton binArch + then head binArch + else case (filter (/= "all") binArch) of + [b] -> b + _ -> error $ "Could not uniquely determine binary architecture: " ++ show binArch + +mkFileLine :: FilePath -> IO String +mkFileLine fp + | ".deb" `isSuffixOf` fp = + do sum <- L.readFile fp >>= return . show . sha256 + size <- liftM fileSize $ getFileStatus fp + (Control (p:_)) <- Deb.fields fp + return $ concat [ " ", sum, " ", show size, " ", fromMaybe "unknown" (fieldValue "Section" p), " " + , fromMaybe "optional" (fieldValue "Priority" p), " ", (takeBaseName fp) + ] + | otherwise = + do sum <- L.readFile fp >>= return . show . sha256 + size <- liftM fileSize $ getFileStatus fp + return $ concat [ " ", sum, " ", show size, " ", "unknown", " " + , "optional"," ", (takeBaseName fp) + ] + +-- more implementations can be found at: +-- http://www.google.com/codesearch?hl=en&lr=&q=%22%5BEither+a+b%5D+-%3E+%28%5Ba%5D%2C%5Bb%5D%29%22&btnG=Search +unzipEithers :: [Either a b] -> ([a],[b]) +unzipEithers = foldr unzipEither ([],[]) + where + unzipEither (Left l) ~(ls, rs) = (l:ls, rs) + unzipEither (Right r) ~(ls, rs) = (ls, r:rs) + +-- move to different library +debNameSplit :: String -> Either FilePath (String, String, String) +debNameSplit fp = + case (takeFileName fp) =~ "^(.*)_(.*)_(.*).deb$" of + [[_, name, version, arch]] -> Right (name, version, arch) + _ -> Left fp + + +loadFiles :: [FilePath] -> IO Files +loadFiles files = + let (dscs', files'') = partition (isSuffixOf ".dsc") files' + (debs', files') = partition (isSuffixOf ".deb") files + (tars', files''') = partition (isSuffixOf ".tar.gz") files'' + (diffs', rest) = partition (isSuffixOf ".diff.gz") files''' + errors = concat [ if (length debs' < 1) then [NoDebs] else [] + , if (length dscs' > 1) then [TooManyDscs dscs'] else [] + , if (length tars' > 1) then [TooManyTars tars'] else [] + , if (length diffs' > 1) then [TooManyDiffs diffs'] else [] + , if (length rest > 0) then [UnknownFiles rest] else [] + ] + in + do when (not . null $ errors) (error $ show errors) + dsc' <- mapM loadDsc (listToMaybe dscs') + debs'' <- mapM loadDeb debs' + return $ Files { dsc = dsc', debs = debs'', tar = listToMaybe tars', diff = listToMaybe diffs' } + -- if (not . null $ errors) then throwDyn errors else return (debs, listToMaybe dscs, listToMaybe tars, listToMaybe diffs) + where + loadDsc :: FilePath -> IO (FilePath, Paragraph) + loadDsc dsc' = + do res <- parseControlFromFile dsc' + 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: " ++ prettyShow 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: " ++ prettyShow res + + +getUploader :: IO String +getUploader = + do debFullName <- + do dfn <- try (getEnv "DEBFULLNAME") + case dfn of + (Right n) -> return n + (Left (_ :: SomeException)) -> + do dfn' <-try (getEnv "USER") + case dfn' of + (Right n) -> return n + (Left (_ :: SomeException)) -> error $ "Could not determine user name, neither DEBFULLNAME nor USER enviroment variables were set." + emailAddr <- + do eml <- try (getEnv "DEBEMAIL") + case eml of + (Right e) -> return e + (Left (_ :: SomeException)) -> + do eml' <- try (getEnv "EMAIL") + case eml' of + (Right e) -> return e + (Left (_ :: SomeException)) -> getHostName -- FIXME: this is not a FQDN + return $ debFullName ++ " <" ++ emailAddr ++ ">" + +-- * Utils + +singleton :: [a] -> Bool +singleton [_] = True +singleton _ = False diff --git a/src/Debian/VendorURI.hs b/src/Debian/VendorURI.hs new file mode 100644 --- /dev/null +++ b/src/Debian/VendorURI.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Debian.VendorURI + ( VendorURI(..) + , vendorURI + , parseVendorURI + ) where + +import Control.Lens (makeLenses, review) +import Debian.TH (here) +import Debian.URI (parseURI, URI(uriPath)) +import Distribution.Pretty (prettyShow) +import Language.Haskell.TH.Syntax (Loc) +import System.FilePath (splitDirectories) + +newtype VendorURI = VendorURI {_vendorURI :: URI} deriving (Eq, Ord) + +instance Show VendorURI where + show (VendorURI uri) = "VendorURI (fromJust (parseURIReference " ++ show (show uri) ++ "))" + +$(makeLenses ''VendorURI) + +parseVendorURI :: [Loc] -> String -> Maybe VendorURI +parseVendorURI locs s = fmap (review vendorURI) (parseURI s) + +-- toURI' :: VendorURI -> URI' +-- toURI' = URI' . show . view vendorURI diff --git a/src/Debian/Version.hs b/src/Debian/Version.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Version.hs @@ -0,0 +1,16 @@ +-- |A module for parsing, comparing, and (eventually) modifying debian version +-- numbers. +module Debian.Version + (DebianVersion -- |Exported abstract because the internal representation is likely to change + , prettyDebianVersion + , parseDebianVersion + , parseDebianVersion' + , epoch + , version + , revision + , buildDebianVersion + , evr + ) where + +import Debian.Version.Common +import Debian.Version.String () diff --git a/src/Debian/Version/ByteString.hs b/src/Debian/Version/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Version/ByteString.hs @@ -0,0 +1,18 @@ +{-# OPTIONS -fno-warn-orphans #-} +module Debian.Version.ByteString + ( ParseDebianVersion(..) + ) where + +import Text.ParserCombinators.Parsec + +import qualified Data.ByteString.Char8 as C + +import Debian.Version.Common +import Debian.Version.Internal + +instance ParseDebianVersion C.ByteString where + parseDebianVersion byteStr = + let str = C.unpack byteStr in + case parse parseDV str str of + Left e -> Left e + Right dv -> Right (DebianVersion str dv) diff --git a/src/Debian/Version/Common.hs b/src/Debian/Version/Common.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Version/Common.hs @@ -0,0 +1,185 @@ +-- |A module for parsing, comparing, and (eventually) modifying debian version +-- numbers. +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans -fno-warn-unused-do-bind #-} +module Debian.Version.Common + ( DebianVersion -- |Exported abstract because the internal representation is likely to change + , prettyDebianVersion + , ParseDebianVersion(..) + , parseDebianVersion' + , evr -- DebianVersion -> (Maybe Int, String, Maybe String) + , epoch + , version + , revision + , buildDebianVersion + , parseDV + ) where + +import Data.Char (ord, isDigit, isAlpha) +import Debian.Pretty (PP(..)) +import Debian.Version.Internal +import Text.ParserCombinators.Parsec +import Text.Regex +import Text.PrettyPrint (Doc, render, text) +import Distribution.Pretty (Pretty(pretty)) + +prettyDebianVersion :: DebianVersion -> Doc +prettyDebianVersion (DebianVersion s _) = text s + +instance Pretty (PP DebianVersion) where + pretty = prettyDebianVersion . unPP + +instance Eq DebianVersion where + (DebianVersion _ v1) == (DebianVersion _ v2) = v1 == v2 + +instance Ord DebianVersion where + compare (DebianVersion _ v1) (DebianVersion _ v2) = compare v1 v2 + +instance Show DebianVersion where + show v = "(Debian.Version.parseDebianVersion (" ++ show (render (prettyDebianVersion v)) ++ " :: String))" + +-- make ~ less than everything, and everything else higher that letters +order :: Char -> Int +order c + | isDigit c = 0 + | isAlpha c = ord c + | c == '~' = -1 + | otherwise = (ord c) + 256 + +-- |We have to do this wackiness because ~ is less than the empty string +compareNonNumeric :: [Char] -> [Char] -> Ordering +compareNonNumeric "" "" = EQ +compareNonNumeric "" ('~':_cs) = GT +compareNonNumeric ('~':_cs) "" = LT +compareNonNumeric "" _ = LT +compareNonNumeric _ "" = GT +compareNonNumeric (c1:cs1) (c2:cs2) = + if (order c1) == (order c2) + then compareNonNumeric cs1 cs2 + else compare (order c1) (order c2) + +instance Eq NonNumeric where + (NonNumeric s1 n1) == (NonNumeric s2 n2) = + case compareNonNumeric s1 s2 of + EQ -> n1 == n2 + _o -> False + +instance Ord NonNumeric where + compare (NonNumeric s1 n1) (NonNumeric s2 n2) = + case compareNonNumeric s1 s2 of + EQ -> compare n1 n2 + o -> o + +instance Eq Numeric where + (Numeric n1 mnn1) == (Numeric n2 mnn2) = + case compare n1 n2 of + EQ -> case compareMaybeNonNumeric mnn1 mnn2 of + EQ -> True + _ -> False + _ -> False + +compareMaybeNonNumeric :: Maybe NonNumeric -> Maybe NonNumeric -> Ordering +compareMaybeNonNumeric mnn1 mnn2 = + case (mnn1, mnn2) of + (Nothing, Nothing) -> EQ + (Just (NonNumeric nn _), Nothing) -> compareNonNumeric nn "" + (Nothing, Just (NonNumeric nn _)) -> compareNonNumeric "" nn + (Just nn1, Just nn2) -> compare nn1 nn2 + +instance Ord Numeric where + compare (Numeric n1 mnn1) (Numeric n2 mnn2) = + case compare n1 n2 of + EQ -> compareMaybeNonNumeric mnn1 mnn2 + o -> o + +-- * Parser + +class ParseDebianVersion a where + parseDebianVersion :: a-> Either ParseError DebianVersion +-- |Convert a string to a debian version number. May throw an +-- exception if the string is unparsable -- but I am not sure if that +-- can currently happen. Are there any invalid version strings? +-- Perhaps ones with underscore, or something? + +parseDebianVersion' :: ParseDebianVersion string => string -> DebianVersion +parseDebianVersion' str = either (\e -> error (show e)) id (parseDebianVersion str) + +{- +showNN :: NonNumeric -> String +showNN (NonNumeric s n) = s ++ showN n + +showN :: Found Numeric -> String +showN (Found (Numeric n nn)) = show n ++ maybe "" showNN nn +showN (Simulated _) = "" +-} + +parseDV :: CharParser () (Found Int, NonNumeric, Found NonNumeric) +parseDV = + do skipMany $ oneOf " \t" + e <- parseEpoch + upstreamVersion <- parseNonNumeric True True + debianRevision <- option (Simulated (NonNumeric "" (Simulated (Numeric 0 Nothing)))) (char '-' >> parseNonNumeric True False >>= return . Found) + return (e, upstreamVersion, debianRevision) + +parseEpoch :: CharParser () (Found Int) +parseEpoch = + option (Simulated 0) (try (many1 digit >>= \d -> char ':' >> return (Found (read d)))) + + +parseNonNumeric :: Bool -> Bool -> CharParser () NonNumeric +parseNonNumeric zeroOk upstream = + do nn <- (if zeroOk then many else many1) ((noneOf "-0123456789") <|> (if upstream then upstreamDash else pzero)) + n <- parseNumeric upstream + return $ NonNumeric nn n + where + upstreamDash :: CharParser () Char + upstreamDash = try $ do char '-' + lookAhead $ (many (noneOf "- \n\t") >> char '-') + return '-' + +parseNumeric :: Bool -> CharParser () (Found Numeric) +parseNumeric upstream = + do n <- many1 (satisfy isDigit) + nn <- option Nothing (parseNonNumeric False upstream >>= return . Just) + return $ Found (Numeric (read n) nn) + <|> + return (Simulated (Numeric 0 Nothing)) + +{- +compareTest :: String -> String -> Ordering +compareTest str1 str2 = + let v1 = either (error . show) id $ parse parseDV str1 str1 + v2 = either (error . show) id $ parse parseDV str2 str2 + in + compare v1 v2 +-} + +-- |Split a DebianVersion into its three components: epoch, version, +-- revision. It is not safe to use the parsed version number for +-- this because you will lose information, such as leading zeros. +evr :: DebianVersion -> (Maybe Int, String, Maybe String) +evr (DebianVersion s _) = + let re = mkRegex "^(([0-9]+):)?(([^-]*)|((.*)-([^-]*)))$" in + -- ( ) ( ( )) + -- ( e ) ( v ) (v2) ( r ) + case matchRegex re s of + Just ["", _, _, v, "", _, _] -> (Nothing, v, Nothing) + Just ["", _, _, _, _, v, r] -> (Nothing, v, Just r) + Just [_, e, _, v, "", _, _] -> (Just (read e), v, Nothing) + Just [_, e, _, _, _, v, r] -> (Just (read e), v, Just r) + -- I really don't think this can happen. + _ -> error ("Invalid Debian Version String: " ++ s) + +epoch :: DebianVersion -> Maybe Int +epoch v = case evr v of (x, _, _) -> x +version :: DebianVersion -> String +version v = case evr v of (_, x, _) -> x +revision :: DebianVersion -> Maybe String +revision v = case evr v of (_, _, x) -> x + +-- Build a Debian version number from epoch, version, revision +buildDebianVersion :: Maybe Int -> String -> Maybe String -> DebianVersion +buildDebianVersion e v r = + either (error . show) (DebianVersion str) $ parse parseDV str str + where + str = (maybe "" (\ n -> show n ++ ":") e ++ v ++ maybe "" (\ s -> "-" ++ s) r) diff --git a/src/Debian/Version/Internal.hs b/src/Debian/Version/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Version/Internal.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} +module Debian.Version.Internal + ( DebianVersion(..) + , Numeric(..) + , NonNumeric(..) + , Found(..) + ) where + +import Data.Data (Data) +import Data.Typeable (Typeable) + +-- Currently we store the original version string in the data-type so +-- that we can faithfully reproduce it quickly. Currently we do not +-- have any way to modify a version number -- so this works fine. May +-- have to change later. +data DebianVersion + = DebianVersion String (Found Int, NonNumeric, Found NonNumeric) deriving (Data, Typeable) + +data NonNumeric + = NonNumeric String (Found Numeric) + deriving (Show, Data, Typeable) + +data Numeric + = Numeric Int (Maybe NonNumeric) + deriving (Show, Data, Typeable) + +data Found a + = Found { unFound :: a } + | Simulated { unFound :: a } + deriving (Show, Data, Typeable) + +instance (Eq a) => Eq (Found a) where + f1 == f2 = (unFound f1) == (unFound f2) + +instance (Ord a) => Ord (Found a) where + compare f1 f2 = compare (unFound f1) (unFound f2) diff --git a/src/Debian/Version/String.hs b/src/Debian/Version/String.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Version/String.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans #-} +module Debian.Version.String + ( ParseDebianVersion(..) + ) where + +import Text.ParserCombinators.Parsec + +import Data.List (stripPrefix) +import Debian.Version.Common +import Debian.Version.Internal + +instance ParseDebianVersion String where + parseDebianVersion str = + case parse parseDV str str of + Left e -> Left e + Right dv -> Right (DebianVersion str dv) + +instance Read DebianVersion where + readsPrec _ s = + case stripPrefix "Debian.Version.parseDebianVersion " s of + Just s' -> case reads s' :: [(String, String)] of + []-> [] + (v, s'') : _ -> [(parseDebianVersion' v, s'')] + Nothing -> [] diff --git a/src/Debian/Version/Text.hs b/src/Debian/Version/Text.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Version/Text.hs @@ -0,0 +1,18 @@ +{-# OPTIONS -fno-warn-orphans #-} +module Debian.Version.Text + ( ParseDebianVersion(..) + ) where + +import Text.ParserCombinators.Parsec + +import qualified Data.Text as T + +import Debian.Version.Common +import Debian.Version.Internal + +instance ParseDebianVersion T.Text where + parseDebianVersion text = + let str = T.unpack text in + case parse parseDV str str of + Left e -> Left e + Right dv -> Right (DebianVersion str dv) diff --git a/utils/Report.hs b/utils/Report.hs --- a/utils/Report.hs +++ b/utils/Report.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-} +{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables, TemplateHaskell #-} module Main where #if !MIN_VERSION_base(4,8,0) @@ -10,6 +10,7 @@ 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) @@ -17,7 +18,6 @@ import Text.XML.HaXml.Pretty (document) import Text.XML.HaXml.Posn import Text.PrettyPrint.HughesPJ -import Text.Read (readMaybe) import System.IO import System.Posix.Env @@ -29,8 +29,8 @@ 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 $ readFile sourcesAFP - sourcesB <- liftM parseSourcesList $ readFile sourcesBFP + 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 @@ -96,7 +96,7 @@ do (cols, _) <- getWinSize case cols of -- 0 -> return . fmap read =<< getEnv "COLUMNS" - 0 -> either (\(e :: IOError) -> Nothing) (fmap read) <$> try (getEnv "COLUMNS") + 0 -> either (\(_ :: IOError) -> Nothing) (fmap read) <$> try (getEnv "COLUMNS") _ -> return (Just cols)