packages feed

debian 3.93.5 → 3.95

raw patch · 83 files changed

+5051/−4857 lines, 83 filesdep +Cabaldep +QuickCheckdep +hostnamedep ~network

Dependencies added: Cabal, QuickCheck, hostname, lens, syb, th-lift, th-orphans

Dependency ranges changed: network

Files

− Debian/Apt/Dependencies.hs 
@@ -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--
− Debian/Apt/Index.hs 
@@ -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
− Debian/Apt/Methods.hs 
@@ -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-<em>100 Capabilities</> and APT sending out a <em>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)--}
− Debian/Apt/Package.hs 
@@ -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)
− Debian/Arch.hs 
@@ -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"
− Debian/Changes.hs 
@@ -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 <email address>[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 <autobuilder@seereason.org>  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 <nomeata@debian.org>  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 <nomeata@debian.org>  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 <jgoerzen@complete.org>  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 <arjan@debian.org>  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 <arjan@debian.org>  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) <igloo@debian.org>  Wed, 21 Nov 2007 01:26:57 +0000"]
− Debian/Control.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- |A module for working with Debian control files <http://www.debian.org/doc/debian-policy/ch-controlfields.html>-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
− Debian/Control/Builder.hs 
@@ -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--}
− Debian/Control/ByteString.hs 
@@ -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)
− Debian/Control/Common.hs 
@@ -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]
− Debian/Control/Policy.hs 
@@ -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
− Debian/Control/String.hs 
@@ -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")
− Debian/Control/Text.hs 
@@ -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--}
− Debian/Control/TextLazy.hs 
@@ -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--}
− Debian/Deb.hs 
@@ -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
− Debian/Extra/Files.hs 
@@ -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"
− Debian/GenBuildDeps.hs 
@@ -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--- <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-sourcecontrolfiles>-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
− Debian/Loc.hs 
@@ -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))
− Debian/Pretty.hs 
@@ -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
− Debian/Relation.hs 
@@ -1,25 +0,0 @@--- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>-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
− Debian/Relation/ByteString.hs 
@@ -1,30 +0,0 @@-{-# OPTIONS -fno-warn-orphans #-}--- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>-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)
− Debian/Relation/Common.hs 
@@ -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
− Debian/Relation/String.hs 
@@ -1,139 +0,0 @@-{-# LANGUAGE FlexibleInstances, PackageImports, TypeSynonymInstances #-}-{-# OPTIONS -fno-warn-unused-do-bind -fno-warn-orphans #-}--- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>-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
− Debian/Relation/Text.hs 
@@ -1,30 +0,0 @@-{-# OPTIONS -fno-warn-orphans #-}--- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>-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)
− Debian/Release.hs 
@@ -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)
− Debian/Report.hs 
@@ -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 <trumped /> 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) ]-                     ]
− Debian/Sources.hs 
@@ -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 ]
− Debian/Time.hs 
@@ -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'-
− Debian/URI.hs 
@@ -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 "( <A HREF|<a href)=\"([^/][^\"]*)/\""-      second (Just [_, b]) = Just b-      second _ = Nothing---dirFromURI :: URI -> 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))))
− Debian/UTF8.hs 
@@ -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
− Debian/Util/FakeChanges.hs 
@@ -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
− Debian/Version.hs 
@@ -1,16 +0,0 @@--- |A module for parsing, comparing, and (eventually) modifying debian version--- numbers. <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version>-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 ()
− Debian/Version/ByteString.hs 
@@ -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)
− Debian/Version/Common.hs 
@@ -1,185 +0,0 @@--- |A module for parsing, comparing, and (eventually) modifying debian version--- numbers. <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version>-{-# 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)
− Debian/Version/Internal.hs 
@@ -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)
− Debian/Version/String.hs 
@@ -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 -> []
− Debian/Version/Text.hs 
@@ -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)
Test/Changes.hs view
@@ -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 <marcot@holoscopio.com>  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 <dsf@seereason.com>", 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 <dsf@seereason.com>", 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 <dsf@seereason.com>",@@ -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 <autobuilder@seereason.org>", 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 <nomeata@debian.org>", 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 <nomeata@debian.org>", 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 <jgoerzen@complete.org>", 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 <arjan@debian.org>", 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 <arjan@debian.org>", 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) <igloo@debian.org>", 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 <autobuilder@seereason.org>", 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 <nomeata@debian.org>", 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 <nomeata@debian.org>", 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 <jgoerzen@complete.org>", 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 <arjan@debian.org>", 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 <arjan@debian.org>", 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) <igloo@debian.org>", 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 <autobuilder@seereason.org>",                                      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 <marcot@holoscopio.com>",                                      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 <marcot@holoscopio.com>",
Test/Control.hs view
@@ -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
changelog view
@@ -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 <dsf@seereason.com>  Tue, 12 Feb 2019 16:38:30 -0800++haskell-debian (3.94) unstable; urgency=medium++  * Additions to Debian.URI.++ -- David Fox <dsf@seereason.com>  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 <dsf@seereason.com>  Fri, 25 Jan 2019 12:12:56 -0800+ haskell-debian (3.93.5) unstable; urgency=medium    * Restore import of <$> for older versions of base.
debian.cabal view
@@ -1,5 +1,5 @@ Name:           debian-Version:        3.93.5+Version:        3.95 License:        BSD3 License-File:   debian/copyright Author:         David Fox <dsf@seereason.com>, Jeremy Shaw <jeremy@seereason.com>, Clifford Beshers <beshers@seereason.com>@@ -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
debian/changelog view
@@ -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 <dsf@seereason.com>  Tue, 12 Feb 2019 16:38:30 -0800++haskell-debian (3.94) unstable; urgency=medium++  * Additions to Debian.URI.++ -- David Fox <dsf@seereason.com>  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 <dsf@seereason.com>  Fri, 25 Jan 2019 12:12:56 -0800+ haskell-debian (3.93.5) unstable; urgency=medium    * Restore import of <$> for older versions of base.
+ src/Debian/Apt/Dependencies.hs view
@@ -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++
+ src/Debian/Apt/Index.hs view
@@ -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
+ src/Debian/Apt/Methods.hs view
@@ -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+<em>100 Capabilities</> and APT sending out a <em>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)+-}
+ src/Debian/Apt/Package.hs view
@@ -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)
+ src/Debian/Arch.hs view
@@ -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"
+ src/Debian/Changes.hs view
@@ -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 <email address>[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 <autobuilder@seereason.org>  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 <nomeata@debian.org>  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 <nomeata@debian.org>  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 <jgoerzen@complete.org>  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 <arjan@debian.org>  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 <arjan@debian.org>  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) <igloo@debian.org>  Wed, 21 Nov 2007 01:26:57 +0000"]
+ src/Debian/Codename.hs view
@@ -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
+ src/Debian/Control.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}+-- |A module for working with Debian control files <http://www.debian.org/doc/debian-policy/ch-controlfields.html>+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
+ src/Debian/Control/Builder.hs view
@@ -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+-}
+ src/Debian/Control/ByteString.hs view
@@ -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)
+ src/Debian/Control/Common.hs view
@@ -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]
+ src/Debian/Control/Policy.hs view
@@ -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
+ src/Debian/Control/String.hs view
@@ -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")
+ src/Debian/Control/Text.hs view
@@ -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+-}
+ src/Debian/Control/TextLazy.hs view
@@ -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+-}
+ src/Debian/Deb.hs view
@@ -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
+ src/Debian/Extra/Files.hs view
@@ -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"
+ src/Debian/GenBuildDeps.hs view
@@ -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+-- <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-sourcecontrolfiles>+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
+ src/Debian/Loc.hs view
@@ -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))
+ src/Debian/Pretty.hs view
@@ -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
+ src/Debian/Relation.hs view
@@ -0,0 +1,25 @@+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+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
+ src/Debian/Relation/ByteString.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS -fno-warn-orphans #-}+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+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)
+ src/Debian/Relation/Common.hs view
@@ -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
+ src/Debian/Relation/String.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE FlexibleInstances, PackageImports, TypeSynonymInstances #-}+{-# OPTIONS -fno-warn-unused-do-bind -fno-warn-orphans #-}+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+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
+ src/Debian/Relation/Text.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS -fno-warn-orphans #-}+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+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)
+ src/Debian/Release.hs view
@@ -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)
+ src/Debian/Report.hs view
@@ -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 <trumped /> 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) ]+                     ]
+ src/Debian/Sources.hs view
@@ -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)
+ src/Debian/TH.hs view
@@ -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 "]"
+ src/Debian/Time.hs view
@@ -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'+
+ src/Debian/URI.hs view
@@ -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)
+ src/Debian/UTF8.hs view
@@ -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
+ src/Debian/Util/FakeChanges.hs view
@@ -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
+ src/Debian/VendorURI.hs view
@@ -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
+ src/Debian/Version.hs view
@@ -0,0 +1,16 @@+-- |A module for parsing, comparing, and (eventually) modifying debian version+-- numbers. <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version>+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 ()
+ src/Debian/Version/ByteString.hs view
@@ -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)
+ src/Debian/Version/Common.hs view
@@ -0,0 +1,185 @@+-- |A module for parsing, comparing, and (eventually) modifying debian version+-- numbers. <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version>+{-# 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)
+ src/Debian/Version/Internal.hs view
@@ -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)
+ src/Debian/Version/String.hs view
@@ -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 -> []
+ src/Debian/Version/Text.hs view
@@ -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)
utils/Report.hs view
@@ -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)