packages feed

debian 1.2.1 → 3.14

raw patch · 82 files changed

+8830/−2416 lines, 82 filesdep +Cabaldep +Extradep +HaXmldep ~basesetup-changednew-component:exe:cabal-debiannew-component:exe:debian-reportnew-component:exe:debian-versionsnew-component:exe:fakechanges

Dependencies added: Cabal, Extra, HaXml, Unixutils, bzlib, directory, filepath, old-locale, old-time, process, regex-posix, time, zlib

Dependency ranges changed: base

Files

+ COPYING view
@@ -0,0 +1,35 @@+This package was debianized by David Fox+<dsf@seereason.com> on September 18, 2007.++Copyright (c) 2007, David Fox+Copyright (c) 2007, Jeremy Shaw++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The names of contributors may not be used to endorse or promote+      products derived from this software without specific prior+      written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Debian/Apt/Dependencies.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Debian.Apt.Dependencies+{-+    ( solve+    , State +    , binaryDepends+    , search+    , bj'+    , bt+    , CSP(..)+    ) -} where++-- test gutsyPackages "libc6" (\csp -> bt csp)++import Data.List+import Data.Maybe+import Data.Tree+--import qualified Data.Map as Map++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Char8 as C++import Debian.Control.ByteString+import Debian.Control.PrettyPrint+import Debian.Relation.ByteString+import Debian.Apt.Package+import Debian.Version++-- * Basic CSP Types and Functions++data Status +    = Remaining AndRelation+    | MissingDep Relation+    | Complete+      deriving (Show, 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 -> (String, 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 -> String+      getName p = case lookupP "Package" p of Nothing -> error "Missing Package field" ; (Just (Field (_,n))) -> C.unpack (stripWS n)+      conflicts' :: Paragraph -> Relations+      conflicts' p = +          case lookupP "Conflicts" p of+            Nothing -> []+            Just (Field (_, c)) -> either (error . show) id (parseRelations c)++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 paragraphs) ->+             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)+        depends =+            case lookupP "Depends" p of+              Nothing -> []+              Just (Field (_,pd)) -> +                  either (error . show) id (parseRelations pd)+    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 . packageVersionParagraph) p ) . take 1 . search labeler)++-- TODO: add better errors+packageVersionParagraph :: Paragraph -> (String, 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 (_, version))) -> (C.unpack (stripWS name), parseDebianVersion (C.unpack version))++++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' :: (String, DebianVersion) -> Relation -> Bool+conflict' (pName, pVersion) rel@(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) (or:ors) =+          orRelation (candidates, ors ++ remaining) or+      orRelation :: ([a],AndRelation) -> OrRelation -> [Tree (State a)]+      orRelation acc or =+          concat (fmap (relation acc) or)+      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) package =+          if ((packageVersion csp) package) `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, (package : candidates)) (andRelation ((package : candidates), remaining) ((depFunction csp) package))+++-- |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 ((String, DebianVersion), (String, 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 = ([(String, 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 view
@@ -0,0 +1,289 @@+{-# LANGUAGE DeriveDataTypeable #-}+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 Data.Function+import Data.List+import qualified Data.Map as M+import Data.Time+import Data.Generics+import Debian.Apt.Methods+import Debian.Control (formatControl)+import Debian.Control.ByteString+import Debian.Control.Common+import Debian.Repo.Types+import Debian.URI+import System.Directory+import System.FilePath ((</>))+import System.Posix.Files+import System.Unix.FilePath+import qualified System.Unix.Misc as Misc+import Text.ParserCombinators.Parsec.Error+++-- |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, Data, Typeable, 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+       return 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: " ++ show 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' B.ByteString)+controlFromIndex GZ path s = parseControl path . B.concat . L.toChunks . GZip.decompress $ s+controlFromIndex BZ2 path s = parseControl path . B.concat . L.toChunks . BZip.decompress $ s+controlFromIndex Uncompressed path s = parseControl path . B.concat . L.toChunks $ s++-- |parse an index possibly compressed file +controlFromIndex' :: Compression -> FilePath -> IO (Either ParseError (Control' B.ByteString))+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 . 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 -- ^ A release file+                 -> [(CheckSums, Integer, FilePath)] -- ^ +indexesInRelease filterp (Control [p]) =+    let md5sums =+            case md5sumField p of+              (Just md5) -> md5+              Nothing -> error $ "Did not find MD5Sum field."+    in+      filter (\(_,_,fp) -> filterp fp) $ map (makeTuple . B.words) $ filter (not . B.null) (B.lines md5sums)+    where+      makeTuple :: [B.ByteString] -> (CheckSums, Integer, FilePath)+      makeTuple [md5sum, size, fp] = (CheckSums { md5sum = Just (B.unpack md5sum), sha1 = Nothing, sha256 = Nothing }, read (B.unpack size), B.unpack fp)+      makeTuple x = error $ "Invalid line in release file: " ++ show x+indexesInRelease _ x = error $ "Invalid release file: " ++ B.unpack (B.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 <- Misc.md5sum (basePath </> fp)+                      return $ Just (CheckSums { md5sum = Just md5, sha1 = Nothing, sha256 = Nothing }, 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-" . baseName) files
+ Debian/Apt/Methods.hs view
@@ -0,0 +1,481 @@+-- |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 Control.Monad.Error+import Data.List+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 (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+          | 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) }+      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)+++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 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 String [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 -> String) -> [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 -> [PkgName]) -> [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 -> [PkgName]) -> [p] -> [(PkgName, p)]+findProvides providesf packages = foldl addProvides [] packages+    where addProvides :: [(PkgName, p)] -> p -> [(PkgName, 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 -> (String, 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/Control.hs view
@@ -0,0 +1,48 @@+-- |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+    ) where++--import Control.Monad+--import Data.List+--import Text.ParserCombinators.Parsec+--import System.IO+import Debian.Control.String+import Data.List+import qualified Debian.Control.ByteString as B+import qualified Debian.Control.String as S+import qualified Data.ByteString.Char8 as B++packParagraph :: S.Paragraph -> B.Paragraph+packParagraph (S.Paragraph s) = B.Paragraph (map packField s)+packField (S.Field (name, value)) = B.Field (B.pack name, B.pack value)+packField (S.Comment s) = B.Comment (B.pack s)++formatControl (B.Control paragraphs) = intersperse (B.pack "\n") . map formatParagraph $ paragraphs+formatParagraph (B.Paragraph fields) = B.concat . map formatField $ fields+formatField (B.Field (name, value)) = B.concat [name, B.pack ":", value, B.pack "\n"]+formatField (B.Comment s) = s
+ Debian/Control/ByteString.hs view
@@ -0,0 +1,343 @@+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++import Control.Monad.State++import Data.Char(chr,ord)+import Data.List+import Data.Maybe+import Data.Word++--import Foreign.C.String         (CString, CStringLen)+--import Foreign.C.Types          (CSize)+import Foreign.ForeignPtr+--import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable         (Storable(..))++import System.IO.Unsafe+--import System.Environment++import Text.ParserCombinators.Parsec.Error+import Text.ParserCombinators.Parsec.Pos++-- Third Party Modules++import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as BB+import qualified Data.ByteString.Internal as BB+import qualified Data.ByteString.Char8 as C++import Debian.Control.Common++-- 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 = pTakeWhile2 (\a b -> not (endOfValue a b))+    where+      endOfValue :: Char -> Maybe Char -> Bool+      endOfValue '\n' Nothing = True+      endOfValue '\n' (Just ' ') = False+      endOfValue '\n' (Just '\t') = False+      endOfValue '\n' (Just '#') = False+      endOfValue '\n' _ = True+      endOfValue _ _ = False++pField :: ControlParser Field+pField =+    do k <- pKey+       pChar ':'+       v <- pValue+--       pChar '\n'+       (pChar '\n' >> return ()) <|> pEOF+       return (Field (k,v))++pComment :: ControlParser Field+pComment =+    do c1 <- pChar '#'+       text <- pTakeWhile2 (\ a b -> not (endOfComment a b))+       return . Comment $ (B.append (B.singleton . c2w $ c1) text)+    where+      endOfComment '\n' Nothing = True+      endOfComment '\n' (Just '#') = False+      endOfComment '\n' _ = True+      endOfComment _ _ = False++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 =+        C.hGetContents handle >>= 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 fieldName in+        find (\ (Field (fieldName',_)) -> fieldName' == pFieldName) fields+    -- NOTE: probably inefficient+    stripWS = C.reverse . strip . C.reverse . strip+        where strip = C.dropWhile (flip elem " \t")+    asString = C.unpack++{-+main = +    do [fp] <- getArgs+       C.readFile fp >>= \c -> maybe (putStrLn "failed.") (print . length . fst) (parse pControl c)+-}+-- * Helper Functions++-- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@,+-- returns the longest prefix (possibly empty) of @xs@ of elements that+-- satisfy @p@.+_takeWhile2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> B.ByteString+_takeWhile2 f ps = BB.unsafeTake (findIndex2OrEnd (\w1 w2 -> not (f w1 w2)) ps) ps+{-# INLINE _takeWhile2 #-}++break2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe (B.ByteString, B.ByteString)+break2 p ps = case findIndex2OrEnd p ps of n -> Just (BB.unsafeTake n ps, BB.unsafeDrop n ps)++span2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe (B.ByteString, B.ByteString)+span2 p ps = break2 (\a b -> not (p a b)) ps+++-- | 'findIndexOrEnd' is a variant of findIndex, that returns the length+-- of the string if no element is found, rather than Nothing.++findIndex2OrEnd :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Int+findIndex2OrEnd k (BB.PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0+  where+    go a b | a `seq` b `seq` False = undefined+    go ptr n | n >= l    = return l+             | otherwise = do w1 <- peek ptr+                              w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing+                              if k w1 w2+                                then return n+                                else go (ptr `plusPtr` 1) (n+1)+++{-+findIndex2OrEnd :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Int+findIndex2OrEnd k (B.PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0+  where+    go a b | a `seq` b `seq` False = undefined+    go ptr n | n >= l    = return l+             | otherwise = do w1 <- peek ptr+                              case (w2c w1) of+                                '\n' ->+                                    if (n + 1 < l)+                                    then do w2 <- peek (ptr `plusPtr` 1)+                                            case (w2c w2) of+                                              ' ' -> go (ptr `plusPtr` 2) (n + 2)+                                              _ -> return n+                                    else return l -- go (ptr `plusPtr` 1) (n + 1)+                                _ -> go (ptr `plusPtr` 1) (n + 1)+-}+{-+                              w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing+                              if k w1 w2+                                then return n+                                else go (ptr `plusPtr` 1) (n+1)+-}+{-# INLINE findIndex2OrEnd #-}++-- | The 'findIndex' function takes a predicate and a 'ByteString' and+-- returns the index of the first element in the ByteString+-- satisfying the predicate.+_findIndex2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe Int+_findIndex2 k (BB.PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0+  where+    go a b | a `seq` b `seq` False = undefined+    go ptr n | n >= l    = return Nothing+             | otherwise = do w1 <- peek ptr+                              w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing+                              if k w1 w2+                                then return (Just n)+                                else go (ptr `plusPtr` 1) (n+1)+{-# INLINE _findIndex2 #-}++-- Copied from ByteStream because they are not exported++w2c :: Word8 -> Char+w2c = chr . fromIntegral++c2w :: Char -> Word8+c2w = fromIntegral . ord++-- * 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 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)+++(<|>) :: Parser state a -> Parser state a -> Parser state a+(<|>) = mplus+++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++pTakeWhile2 :: (Char -> Maybe Char -> Bool) -> Parser C.ByteString C.ByteString+pTakeWhile2 f =+    Parser $ \bs -> m2r (span2 (\w1 w2 -> f (w2c w1) (fmap w2c w2)) bs)++pTakeWhile :: (Char -> Bool) -> Parser C.ByteString C.ByteString+pTakeWhile f =+    Parser $ \bs -> Ok (B.span (\w -> f (w2c w)) 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 view
@@ -0,0 +1,127 @@+module Debian.Control.Common+    ( -- * Types+      Control'(..)+    , Paragraph'(..)+    , Field'(..)+    , ControlFunctions(..)+    , mergeControls+    , fieldValue+    , removeField+    , prependFields+    , appendFields+    , renameField+    , modifyField+    , raiseFields+    , parseControlFromCmd+    , md5sumField+    )+    where++import Text.ParserCombinators.Parsec+import System.Exit+import System.IO+import System.Process+import Data.List++newtype Control' a+    = Control { unControl :: [Paragraph' a] }++newtype Paragraph' a+    = Paragraph [Field' a]++-- |NOTE: we do not strip the leading or trailing whitespace in the+-- name or value+data Field' a+    = Field (a, a)+    | Comment a+      deriving Eq++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+    asString :: a -> String++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 =+    case fieldValue "MD5Sum" p of+      m@(Just _) -> m+      Nothing -> +          case fieldValue "Md5Sum" p of+            m@(Just _) -> m+            Nothing -> fieldValue "MD5sum" p
+ Debian/Control/PrettyPrint.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TypeSynonymInstances #-}+module Debian.Control.PrettyPrint where++import qualified Data.ByteString.Char8 as C+import Text.PrettyPrint.HughesPJ++import Debian.Control.Common++ppControl :: (ToText a) => Control' a -> Doc+ppControl (Control paragraph) =+    fsep (map ppParagraph paragraph)++ppParagraph :: (ToText a) => Paragraph' a -> Doc+ppParagraph (Paragraph fields) =+    fsep (map ppField fields)++ppField :: (ToText a) => Field' a -> Doc+ppField (Field (n,v)) = totext n <> text ":" <> totext v+++class ToText a where+    totext :: a -> Doc++instance ToText String where+    totext = text++instance ToText C.ByteString where+    totext = text . C.unpack
+ Debian/Control/String.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+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 Control.Monad+import Data.List+import Text.ParserCombinators.Parsec+import System.IO+import Debian.Control.Common++-- |This may have bad performance issues +instance Show (Control' String) where+    show (Control paragraph) = intercalate "\n" (map show paragraph)++instance Show (Paragraph' String) where+    show (Paragraph fields) = unlines (map show fields)++instance Show (Field' String) where+    show (Field (name,value)) = name ++":"++ value+    show (Comment text) = text++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 = +        hGetContents handle >>= return . parseControl sourceName+    parseControl sourceName c = +        parse pControl sourceName c+    lookupP fieldName (Paragraph paragraph) = +        find hasFieldName paragraph+        where hasFieldName (Field (fieldName',_)) = fieldName == fieldName'+              hasFieldName _ = False+    stripWS = reverse . strip . reverse . strip+        where strip = dropWhile (flip elem " \t")+    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/Deb.hs view
@@ -0,0 +1,22 @@+module Debian.Deb where++import Control.Monad++import Debian.Control.Common+import System.Unix.Directory+import System.Unix.FilePath+import System.Unix.Process++fields :: (ControlFunctions a) => FilePath -> IO (Control' a)+fields debFP =+    withTemporaryDirectory ("fields.XXXXXX") $ \tmpdir ->+      do debFP <- realpath debFP+         withWorkingDirectory tmpdir $ +           do (out, err, res) <- simpleProcess "ar" ["x",debFP,"control.tar.gz"] +              when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ out ++ "\n" ++ err ++ "\n" ++ show res)+              (out, err, res) <- simpleProcess "tar" ["xzf", "control.tar.gz", "./control"]+              when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ out ++ "\n" ++ 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/CIO.hs view
@@ -0,0 +1,61 @@+module Debian.Extra.CIO+    ( tMessage+    , vMessage+    , printStdout+    , printStderr+    , printOutput+    , dotOutput+    ) where++import qualified Data.ByteString.Char8 as B+import Extra.CIO+import Prelude hiding (putStr)+import System.Unix.Process++-- |Print a message without forcing the command's output+tMessage :: CIO m => String -> a -> m a+tMessage message output = ePutStrBl message >> return output++-- |Print a message without forcing the command's output+vMessage :: CIO m => Int -> String -> a -> m a+vMessage v message output = vEPutStrBl v message >> return output++-- |Print stdout to stdout+printStdout :: CIO m => [Output] -> m [Output]+printStdout output =+    bol >> mapM print output+    where+      print x@(Stdout s) = putStr (B.unpack s) >> return x+      print x = return x++-- |Print stderr to stderr+printStderr :: CIO m => [Output] -> m [Output]+printStderr output =+    eBOL >> mapM print output+    where+      print x@(Stderr s) = ePutStr (B.unpack s) >> return x+      print x = return x++-- |Print all the output to the appropriate output channel+printOutput :: CIO m => [Output] -> m [Output]+printOutput output =+    eBOL >> mapM print output+    where+      print x@(Stdout s) = putStr (B.unpack s) >> return x+      print x@(Stderr s) = ePutStr (B.unpack s) >> return x+      print x = return x++-- |Print one dot to stderr for every COUNT characters of output.+dotOutput :: CIO m => Int -> [Output] -> m [Output]+dotOutput groupSize output =+    mapM (\ (count, elem) -> ePutStr (replicate count '.') >> return elem) pairs+    where+      pairs = zip (dots 0 (map length output)) output+      dots _ [] = []+      dots rem (count : more) =+          let (count', rem') = divMod (count + rem) groupSize in+          count' : dots rem' more+      length (Stdout s) = B.length s+      length (Stderr s) = B.length s+      length _ = 0+
+ Debian/Extra/Files.hs view
@@ -0,0 +1,30 @@+-- |Domain independent functions used by the haskell-debian package.+module Debian.Extra.Files+    ( withTemporaryFile+    ) where++import 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 text+       result <- f path+       liftIO $ removeFile path+       return result+    where+      writeTemporaryFile text =+          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 view
@@ -0,0 +1,221 @@+-- |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+    , SrcPkgName(..)+    , BinPkgName(..)+    -- * Preparing dependency info+    , buildDependencies+    , RelaxInfo(..)+    , relaxDeps+    -- * Using dependency info+    , buildable+    , compareSource+{-+    , orderSource+    , genDeps+    , failPackage+    , getSourceOrder+-}+    ) where++import		 Control.Monad (filterM)+import		 Debian.Control+import		 Data.Graph (Graph,buildG,topSort,reachable, transposeG, vertices, edges)+import		 Data.List+import qualified Data.Map as Map+import		 Data.Maybe+import qualified Data.Set as Set+import		 Debian.Relation+import		 Extra.Either (concatEithers)+import		 System.Directory (getDirectoryContents, doesFileExist)+import		 System.IO++newtype SrcPkgName = SrcPkgName PkgName deriving (Show, Eq)+newtype BinPkgName = BinPkgName PkgName deriving (Show, Eq)++-- |This type describes the build dependencies of a source package.+type DepInfo = (SrcPkgName,	-- source package name+                Relations,	-- dependency relations+                [BinPkgName])	-- binary package names++-- |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 :: Control -> Either String DepInfo+buildDependencies (Control []) = error "Control file seems to be empty"+buildDependencies (Control (source:binaries)) =+    either (Left . concat) (\ deps -> Right (sourcePackage, deps, bins)) deps+    where+      sourcePackage = maybe (error "First Paragraph in control file lacks a Source field") SrcPkgName $ assoc "Source" source+      -- The raw list of build dependencies for this package+      deps = either Left (Right . concat) (concatEithers [buildDeps, buildDepsIndep])+      buildDeps =+          case assoc "Build-Depends" source of+            Just v -> either (\ e -> Left ("Error parsing Build-Depends for" ++ show sourcePackage ++ ": " ++ show e)) Right (parseRelations v)+            _ -> Right []+      buildDepsIndep =+          case assoc "Build-Depends-Indep" source of+            (Just v) -> either (\ e -> Left ("Error parsing Build-Depends-Indep for" ++ show sourcePackage ++ ": " ++ show e)) Right (parseRelations v)+            _ -> Right []+      bins = mapMaybe lookupPkgName binaries+      lookupPkgName :: Paragraph -> Maybe BinPkgName+      lookupPkgName p = maybe Nothing (Just . BinPkgName) (assoc "Package" p)++-- |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 RelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)]++-- |Remove any dependencies that are designated \"relaxed\" by relaxInfo.+relaxDeps :: RelaxInfo -> [DepInfo] -> [DepInfo]+relaxDeps relaxInfo deps =+    map (relaxDep relaxInfo) deps+    where+      relaxDep :: RelaxInfo -> DepInfo -> DepInfo+      relaxDep relaxInfo (sourceName, relations, binaryNames) =+          (sourceName, filteredDependencies, binaryNames)+          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 (/= []) (map (filter keepDep) relations)+            keepDep :: Relation -> Bool+            keepDep (Rel name _ _) = not (elem (BinPkgName name) ignored)+            -- Binary packages to be ignored wrt this source package's build decision+            ignored = ignoredForSourcePackage sourceName relaxInfo+            -- Return a list of binary packages which should be ignored for this+            -- source package.+            ignoredForSourcePackage :: SrcPkgName -> RelaxInfo -> [BinPkgName]+            ignoredForSourcePackage source (RelaxInfo pairs) =+                map fst . filter (maybe True (== source) . snd) $ pairs+                -- concat . map binaries . catMaybes . map snd . filter (\ (_, x) -> maybe True (== source) x) $ pairs++-- |Given an ordering function representing the dependencies on a+-- list of packages, return a triple: One ready package, the packages+-- that depend on the ready package directly or indirectly, and all+-- the other packages.+buildable :: Show a => (a -> a -> Ordering) -> [a] -> Either [(a, a)] (a, [a], [a])+buildable cmp packages =+    case partition (\ x -> reachable hasDep x == [x]) verts of+      ([], _) -> Left (map ofEdge (cycleEdges hasDep))+      (thisReady : moreReady, allBlocked) ->+          let (deps, other) = partition (\ x -> elem x (reachable isDep thisReady)) allBlocked in+          Right (ofVertex thisReady, map ofVertex deps, map ofVertex (moreReady ++ other))+    where+      allDeps x = (ofVertex x, map ofVertex (filter (/= x) (reachable hasDep x)))+      isDep = buildG (0, length packages - 1) edges'+      edges' = map (\ (a, b) -> (b, a)) edges+      hasDep = buildG (0, length packages - 1) edges+      edges :: [(Int, Int)]+      edges =+          nub (foldr f [] (tails vertPairs))+          where f [] edges = edges+                f (x : xs) edges = catMaybes (map (toEdge x) xs) ++ edges+                toEdge (xv, xa) (yv, ya) =+                    case cmp xa ya of+                      EQ -> Nothing+                      LT -> Just (yv, xv)+                      GT -> Just (xv, yv)+      ofEdge (a, b) = (ofVertex a, ofVertex b)+      ofVertex n = fromJust (Map.findWithDefault Nothing n (Map.fromList (zip [0..] (map Just packages))))+      verts :: [Int]+      verts = map fst vertPairs+      vertPairs = zip [0..] packages++cycleEdges g =+    filter (`elem` (edges g))+               (Set.toList (Set.intersection+                            (Set.fromList (closure g))+                            (Set.fromList (closure (transposeG g)))))+    where+      closure g = concat (map (\ v -> (map (\ u -> (v, u)) (reachable g v))) (vertices g))+      self (a, b) = a == b+      distrib = concat . map (\ (n, ms) -> map (\ m -> (n, m)) ms) +      swap (a, b) = (b, a)++-- | 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 compare failed packages =+    let graph = buildGraph compare 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 compare packages =+    map (fromJust . vertex) (topSort graph)+    where+      graph = buildGraph compare 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 compare packages =+    let edges = someEdges (zip packages [0..]) in+    buildG (0, length packages - 1) edges+    where+      someEdges [] = []+      someEdges (a : etc) = aEdges a etc ++ someEdges etc+      aEdges (ap, an) etc =+          concat (map (\ (bp, bn) ->+                           case compare 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 (_, depends1, bins1) (_, depends2, bins2)+    | any (\rel -> isJust (find (checkPackageNameReq rel) bins2)) (concat depends1) = GT+    | any (\rel -> isJust (find (checkPackageNameReq rel) bins1)) (concat depends2) = LT+    | otherwise = EQ+    where+      checkPackageNameReq :: Relation -> BinPkgName -> Bool+      checkPackageNameReq (Rel rPkgName _ _) (BinPkgName bPkgName) = rPkgName == bPkgName ++-- |Return the dependency info for a list of control files.+genDeps :: [FilePath] -> IO (Either String [DepInfo])+genDeps controlFiles =+    mapM genDep' controlFiles >>=+    return . either (Left . concat) (Right . orderSource compareSource) . concatEithers+    where+      genDep' :: FilePath -> IO (Either String DepInfo)+      genDep' controlPath = parseControlFromFile controlPath >>=+                            return . either (Left . show) buildDependencies++-- |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+-- fp\/*\/debian\/control. It returns a list with the packages in the+-- order they should be built.+getSourceOrder :: FilePath -> IO (Either String [SrcPkgName])+getSourceOrder fp =+    findControlFiles fp >>=+    genDeps >>=+    return . either Left (Right . map ( \(pkgName,_,_) -> pkgName) . orderSource compareSource)+    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+++assoc :: String -> Paragraph -> Maybe String+assoc name fields = maybe Nothing (\ (Field (_, v)) -> Just (stripWS v)) (lookupP name fields)
+ Debian/Relation.hs view
@@ -0,0 +1,18 @@+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+module Debian.Relation+    ( -- * Types+      PkgName+    , AndRelation+    , OrRelation+    , Relations+    , Relation(..)+    , ArchitectureReq(..)+    , VersionReq(..)+    -- * Helper Functions+    , checkVersionReq+    -- * Relation Parser+    , RelParser+    , ParseRelations(..)+    ) where ++import Debian.Relation.String
+ Debian/Relation/ByteString.hs view
@@ -0,0 +1,41 @@+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+module Debian.Relation.ByteString+    ( -- * Types+      PkgName+    , AndRelation+    , OrRelation+    , Relations+    , Relation(..)+    , ArchitectureReq(..)+    , VersionReq(..)+    -- * Helper Functions+    , checkVersionReq+    -- * Relation Parser+    , RelParser+    , ParseRelations(..)+    ) where ++-- Standard GHC Modules++import Data.List+import Text.ParserCombinators.Parsec++-- 3rd Party Modules++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 = +        let str = C.unpack byteStr in+        case parse pRelations str str of+          Right relations -> Right (filter (/= []) relations)+          x -> x
+ Debian/Relation/Common.hs view
@@ -0,0 +1,86 @@+module Debian.Relation.Common where++-- Standard GHC Modules++import Data.List+import Text.ParserCombinators.Parsec++-- Local Modules++import Debian.Version++-- Datatype for relations++type PkgName = String++type Relations = AndRelation+type AndRelation = [OrRelation]+type OrRelation = [Relation]++data Relation = Rel PkgName (Maybe VersionReq) (Maybe ArchitectureReq)+		deriving Eq+++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+++instance Show Relation where+    show (Rel name ver arch) =+        name ++ maybe "" show ver ++ maybe "" show 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 [String]+    | ArchExcept [String]+      deriving Eq++instance Show ArchitectureReq where+    show (ArchOnly arch) = " [" ++ intercalate " " arch ++ "]"+    show (ArchExcept arch) = " [!" ++ intercalate " !" arch ++ "]"++data VersionReq+    = SLT DebianVersion+    | LTE DebianVersion+    | EEQ  DebianVersion+    | GRE  DebianVersion+    | SGR DebianVersion+      deriving Eq++instance Show VersionReq where+    show (SLT v) = " (<< " ++ show v ++ ")"+    show (LTE v) = " (<= " ++ show v ++ ")"+    show (EEQ v) = " (= " ++ show v ++ ")"+    show (GRE v) = " (>= " ++ show v ++ ")"+    show (SGR v) = " (>> " ++ show v ++ ")"++-- |@FIXME:@ This instance is currently incomplete and only handles the case+-- where two version requirements are equal.+instance Ord VersionReq where+    compare r1 r2 =+	if r1 == r2 +	   then EQ +	   else+	case (r1, r2) of+	     (EEQ v1, EEQ v2) -> compare v1 v2+	     (a,b) -> error $ "Ord VersionReq does not handle (" ++ show a ++", "++ show b++")"+++-- |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
+ Debian/Relation/String.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TypeSynonymInstances #-}+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+module Debian.Relation.String+    ( -- * Types+      PkgName+    , AndRelation+    , OrRelation+    , Relations+    , Relation(..)+    , ArchitectureReq(..)+    , VersionReq(..)+    -- * Helper Functions+    , checkVersionReq+    -- * Relation Parser+    , RelParser+    , ParseRelations(..)+    , pRelations+    ) where ++-- Standard GHC Modules++import Data.List+import Text.ParserCombinators.Parsec++-- Local Modules++import Debian.Relation.Common+import Debian.Version++-- * ParseRelations++instance ParseRelations String where+    parseRelations str = +        case parse pRelations str str of+          Right relations -> Right (filter (/= []) relations)+          x -> x++-- * 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 rel <- sepBy1 pRelation (char '|')+                 skipMany (char ',' <|> whiteChar)+                 return rel++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 pkgName mVerReq mArch++pMaybeVerReq :: RelParser (Maybe VersionReq)+pMaybeVerReq =+    do char '('+       skipMany whiteChar+       op <- pVerReq+       skipMany whiteChar+       version <- many1 (noneOf [' ',')','\t','\n'])+       skipMany whiteChar+       char ')'+       return $ Just (op (parseDebianVersion version))+    <|>+    do return $ Nothing++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 archs))+	<|>+	do archs <- pArchOnly+	   char ']'+           skipMany whiteChar+	   return (Just (ArchOnly 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)
+ Debian/Repo.hs view
@@ -0,0 +1,38 @@+-- |This is a set of modules tied together by the AptIO monad in+-- IO.hs, which keeps track of the contents of all the Apt+-- repositories which are queried in the course of execution.+module Debian.Repo +    ( module Debian.Repo.AptImage+    , module Debian.Repo.Cache+    , module Debian.Repo.Changes+    , module Debian.Repo.Dependencies+    , module Debian.Repo.Insert+    , module Debian.Repo.IO+    , module Debian.Repo.LocalRepository+    , module Debian.Repo.OSImage+    , module Debian.Repo.Package+    , module Debian.Repo.PackageIndex+    , module Debian.Repo.Release+    , module Debian.Repo.Repository+    , module Debian.Repo.Slice+    , module Debian.Repo.SourcesList+    , module Debian.Repo.SourceTree+    , module Debian.Repo.Types+    ) where++import Debian.Repo.AptImage+import Debian.Repo.Cache+import Debian.Repo.Changes+import Debian.Repo.Dependencies+import Debian.Repo.Insert+import Debian.Repo.IO+import Debian.Repo.LocalRepository+import Debian.Repo.OSImage+import Debian.Repo.Package+import Debian.Repo.PackageIndex+import Debian.Repo.Release+import Debian.Repo.Repository+import Debian.Repo.Slice+import Debian.Repo.SourcesList+import Debian.Repo.SourceTree+import Debian.Repo.Types
+ Debian/Repo/AptImage.hs view
@@ -0,0 +1,180 @@+-- |The AptImage object represents a partial OS image which is capable+-- of running apt-get, and thus obtaining repository info and source+-- code packages.+module Debian.Repo.AptImage +    ( prepareAptEnv+    , updateAptEnv+    , aptGetSource+    ) where++import		 Debian.Shell+import		 Debian.Repo.Cache+import		 Debian.Repo.Changes+import		 Debian.Repo.Package+import		 Debian.Repo.IO+import		 Debian.Repo.Slice+import		 Debian.Repo.SourceTree+import		 Debian.Repo.Types+import		 Debian.Relation+import		 Debian.Version++import		 Control.Exception+import		 Control.Monad.State (get, put)+import		 Control.Monad.Trans+import		 Extra.CIO+import		 Data.List+import		 Data.Maybe+import		 Extra.Files+import		 Extra.List+import		 System.Unix.Directory+import		 System.Unix.Process+import		 System.Cmd+import		 System.Directory++instance Show AptImage where+    show apt = "AptImage " ++ relName (aptImageReleaseName apt)++instance AptCache AptImage where+    globalCacheDir = aptGlobalCacheDir+    rootDir = aptImageRoot+    aptArch = aptImageArch+    aptBaseSliceList = aptImageSliceList+    aptSourcePackages = aptImageSourcePackages+    aptBinaryPackages = aptImageBinaryPackages+    aptReleaseName = aptImageReleaseName++instance Ord AptImage where+    compare a b = compare (aptImageReleaseName a) (aptImageReleaseName b)++instance Eq AptImage where+    a == b = compare a b == EQ++prepareAptEnv :: CIO m+	      => FilePath		-- Put environment in a subdirectory of this+              -> SourcesChangedAction	-- What to do if environment already exists and sources.list is different+              -> NamedSliceList		-- The sources.list+              -> AptIOT m AptImage		-- The resulting environment+prepareAptEnv cacheDir sourcesChangedAction sources =+    get >>= return . lookupAptImage (sliceListName sources) >>=+    maybe (prepareAptEnv' cacheDir sourcesChangedAction sources) return++-- |Create a skeletal enviroment sufficient to run apt-get.+{-# NOINLINE prepareAptEnv' #-}+prepareAptEnv' :: CIO m => FilePath -> SourcesChangedAction -> NamedSliceList -> AptIOT m AptImage+prepareAptEnv' cacheDir sourcesChangedAction sources =+    do let root = rootPath (cacheRootDir cacheDir (ReleaseName (sliceName (sliceListName sources))))+       --vPutStrLn 2 $ "prepareAptEnv " ++ sliceName (sliceListName sources)+       io $ createDirectoryIfMissing True (root ++ "/var/lib/apt/lists/partial")+       io $ createDirectoryIfMissing True (root ++ "/var/lib/apt/lists/partial")+       io $ createDirectoryIfMissing True (root ++ "/var/cache/apt/archives/partial")+       io $ createDirectoryIfMissing True (root ++ "/var/lib/dpkg")+       io $ createDirectoryIfMissing True (root ++ "/etc/apt")+       io $ writeFileIfMissing True (root ++ "/var/lib/dpkg/status") ""+       io $ writeFileIfMissing True (root ++ "/var/lib/dpkg/diversions") ""+       -- We need to create the local pool before updating so the+       -- sources.list will be valid.+       let sourceListText = show (sliceList sources)+       -- ePut ("writeFile " ++ (root ++ "/etc/apt/sources.list") ++ "\n" ++ sourceListText)+       io $ replaceFile (root ++ "/etc/apt/sources.list") sourceListText+       arch <- io $ buildArchOfRoot+       let os = AptImage { aptGlobalCacheDir = cacheDir+                         , aptImageRoot = EnvRoot root+                         , aptImageArch = arch+                         , aptImageReleaseName = ReleaseName . sliceName . sliceListName $ sources+                         , aptImageSliceList = sliceList sources+                         , aptImageSourcePackages = []+                         , aptImageBinaryPackages = [] }+       os' <- updateCacheSources sourcesChangedAction os >>= updateAptEnv+       get >>= put . insertAptImage (sliceListName sources) os'+       return os'++-- |Run apt-get update and then retrieve all the packages referenced+-- by the sources.list.  The source packages are sorted so that+-- packages with the same name are together with the newest first.+{-# NOINLINE updateAptEnv #-}+updateAptEnv :: CIO m => AptImage -> AptIOT m AptImage+updateAptEnv os =+    do+      io $ system ("apt-get" ++ aptOpts os ++ " update >/dev/null 2>&1")+      -- Make the loading of the package indexes lazy.+      sourcePackages <- getSourcePackages os >>= return . sortBy cmp+      binaryPackages <- getBinaryPackages os+      return $ os { aptImageSourcePackages = sourcePackages+                  , aptImageBinaryPackages = binaryPackages }+    where+      cmp p1 p2 =+          compare v2 v1		-- Flip args to get newest first+          where+            v1 = packageVersion . sourcePackageID $ p1+            v2 = packageVersion . sourcePackageID $ p2++getSourcePackages :: CIO m => AptImage -> AptIOT m [SourcePackage]+getSourcePackages os = +    mapM (sourcePackagesOfIndex' os) indexes >>= return . concat+    where+      indexes = concat . map (sliceIndexes os) . slices . sourceSlices . aptImageSliceList $ os++getBinaryPackages :: CIO m => AptImage -> AptIOT m [BinaryPackage]+getBinaryPackages os = +    mapM (binaryPackagesOfIndex' os) indexes >>= return . concat+    where+      indexes = concat . map (sliceIndexes os) . slices . binarySlices . aptImageSliceList $ os++-- |Retrieve a source package via apt-get.+aptGetSource :: (AptCache t, CIO m)+             => EnvPath			-- Where to put the source+             -> t			-- Where to apt-get from+             -> PkgName			-- The name of the package+             -> Maybe DebianVersion	-- The desired version, if Nothing get newest+             -> m DebianBuildTree	-- The resulting source tree+aptGetSource dir os package version =+    do liftIO $ createDirectoryIfMissing True (outsidePath dir)+       ready <- findDebianBuildTrees dir+       let newest = listToMaybe . map (packageVersion . sourcePackageID) . filter ((== package) . packageName . sourcePackageID) . aptSourcePackages $ os+       let version' = maybe newest Just version+       case (version', ready) of+         (Nothing, _) ->+             error ("No available versions of " ++ package ++ " in " ++ rootPath (rootDir os))+         (Just requested, [tree])+             | requested == (logVersion . entry $ tree) ->+                 return tree+         (Just requested, []) ->+             do runAptGet os dir "source" [(package, Just requested)]+                trees <- findDebianBuildTrees dir+                case trees of+                  [tree] -> return tree+                  _ -> error "apt-get source failed"+         (Just requested, _) ->+             do -- One or more incorrect versions are available, remove them+                liftIO $ removeRecursiveSafely (outsidePath dir)+                vBOL 0+                vEPutStr 0 $ "Retrieving APT source for " ++ package+                runAptGet os dir "source" [(package, Just requested)]+                trees <- findDebianBuildTrees dir+                case trees of+                  [tree] -> return tree+                  _ -> error "apt-get source failed"+{-+    where+      _availableStyle = setStyle (setStart (Just ("Finding available versions of " ++ package ++ " in APT pool")))+      aptGetStyle = setStyle (setStart (Just ("Retrieving APT source for " ++ package)))+-}++runAptGet :: (AptCache t, CIO m) => t -> EnvPath -> String -> [(PkgName, Maybe DebianVersion)] -> m (Either String [Output])+runAptGet os dir command packages =+    mkdir >>= aptget+    where+      mkdir = liftIO . try . createDirectoryIfMissing True . outsidePath $ dir+      aptget (Left e) = return . Left . show $ e+      aptget (Right _) = runTaskAndTest (SimpleTask 0 cmd)          +      cmd = (consperse " " ("cd" : outsidePath dir : "&&" : "apt-get" : aptOpts os : command : map formatPackage packages))+      formatPackage (name, Nothing) = name+      formatPackage (name, Just version) = name ++ "=" ++ show version++aptOpts :: AptCache t => t -> String+aptOpts os =+    (" -o=Dir::State::status=" ++ root ++ "/var/lib/dpkg/status" +++     " -o=Dir::State::Lists=" ++ root ++ "/var/lib/apt/lists" +++     " -o=Dir::Cache::Archives=" ++ root ++ "/var/cache/apt/archives" +++     " -o=Dir::Etc::SourceList=" ++ root ++ "/etc/apt/sources.list")+    where root = rootPath . rootDir $ os
+ Debian/Repo/Cache.hs view
@@ -0,0 +1,292 @@+-- |An AptCache represents a local cache of a remote repository.  The+-- cached information is usually downloaded by running "apt-get+-- update", and appears in @\/var\/lib\/apt\/lists@.+module Debian.Repo.Cache+    ( SourcesChangedAction(..)+    , aptSourcePackagesSorted+    , sliceIndexes+    , cacheDistDir+    , distDir+    , aptDir+    , cacheRootDir+    , cacheSourcesPath+    , sourcesPath+    , sourceDir+    , aptCacheFiles+    , aptCacheFilesOfSlice+    , archFiles+    , buildArchOfEnv+    , buildArchOfRoot+    , updateCacheSources+    , sourcePackages+    , binaryPackages+    ) where++import Control.Monad.Trans+import qualified Data.ByteString.Lazy.Char8 as L+import Data.List+import Debian.Repo.IO+import Debian.Repo.Slice+import Debian.Repo.SourcesList+import Debian.Repo.Types+import Debian.URI+import Extra.CIO (CIO, vPutStr, vPutStrBl)+import Extra.Files (replaceFile)+import System.Unix.Directory+import System.Unix.Process+import System.Directory+import System.IO++-- The following are path functions which can be used while+-- constructing instances of AptCache.  Each is followed by a+-- corresponding function that gives the same result when applied to+-- an AptCache instance.++-- | A directory which will hold all the cached files for this+-- NamedSliceList.+cacheDistDir :: FilePath -> ReleaseName -> FilePath+cacheDistDir cacheDir release = cacheDir ++ "/dists/" ++ relName release++cacheRootDir :: FilePath -> ReleaseName -> EnvRoot+cacheRootDir cacheDir release = EnvRoot (cacheDistDir cacheDir release ++ "/aptEnv")++distDir :: AptCache c => c -> FilePath+distDir cache = cacheDistDir (globalCacheDir cache) (aptReleaseName cache)++aptDir :: AptCache c => c -> String -> FilePath+aptDir cache package = distDir cache ++ "/apt/" ++ package++-- | The path where a text of the SliceList is stored.+cacheSourcesPath :: FilePath -> ReleaseName -> FilePath+cacheSourcesPath cacheDir release = cacheDistDir cacheDir release ++ "/sources"++sourcesPath :: AptCache c => c -> FilePath+sourcesPath cache = cacheSourcesPath (globalCacheDir cache) (aptReleaseName cache)++-- Additional functions which can only be used on already constructed+-- instances of AptCache.++-- | A directory holding all files downloaded by apt-get source for a+-- certain package+sourceDir :: AptCache t => t -> String -> FilePath+sourceDir c package = distDir c ++ "/apt/" ++ package++-- |Return all the named source packages sorted by version+aptSourcePackagesSorted :: AptCache t => t -> [String] -> [SourcePackage]+aptSourcePackagesSorted os names =+    sortBy cmp . filterNames names . aptSourcePackages $ os+    where+      filterNames names packages =+          filter (flip elem names . packageName . sourcePackageID) packages+      cmp p1 p2 =+          compare v2 v1		-- Flip args to get newest first+          where+            v1 = packageVersion . sourcePackageID $ p1+            v2 = packageVersion . sourcePackageID $ p2++-- |Return a list of the index files that contain the packages of a+-- slice.+sliceIndexes :: AptCache a => a -> Slice -> [PackageIndex]+sliceIndexes cache slice =+    case (sourceDist . sliceSource $ slice) of+      Left exact -> error $ "Can't handle exact path in sources.list: " ++ exact+      Right (release, sections) -> map (makeIndex release) sections+    where+      makeIndex release section =+          PackageIndex { packageIndexRelease = Release { releaseRepo = sliceRepo slice+                                                       , releaseInfo = findReleaseInfo release }+                       , packageIndexComponent = section+                       , packageIndexArch = case (sourceType . sliceSource $ slice) of+                                              DebSrc -> Source+                                              Deb -> aptArch cache }+      findReleaseInfo release =+          case filter ((==) release . releaseInfoName) (repoReleaseInfo (sliceRepo slice)) of+            [x] -> x+            [] -> error $ ("sliceIndexes: Invalid release name: " ++ releaseName' release +++                           "\n  Available: " ++ (show . map releaseInfoName . repoReleaseInfo . sliceRepo $ slice))+            xs -> error $ "Internal error 5 - multiple releases named " ++ releaseName' release ++ "\n" ++ show xs++-- |Return the paths in the local cache of the index files of a slice list.+aptCacheFiles :: AptCache a => a -> SliceList -> [FilePath]+aptCacheFiles apt sources = concat . map (aptCacheFilesOfSlice apt) $ (slices sources)++-- |Return the paths in the local cache of the index files of a single slice.+aptCacheFilesOfSlice :: AptCache a => a -> Slice -> [FilePath]+aptCacheFilesOfSlice apt slice = archFiles (aptArch apt) (sliceSource slice)++-- |Return the list of files that apt-get update would write into+-- \/var\/lib\/apt\/lists when it processed the given list of DebSource.+archFiles :: Arch -> DebSource -> [FilePath]+archFiles arch deb =+    case (arch, deb) of+      (Source, _) -> error "Invalid build architecture: Source"+      (Binary _, deb@(DebSource DebSrc _ _)) ->+          map (++ "_source_Sources") (archFiles' deb)+      (Binary arch, deb@(DebSource Deb _ _)) ->+          map (++ ("_binary-" ++ arch ++ "_Packages")) (archFiles' deb)++archFiles' :: DebSource -> [FilePath]+archFiles' deb =+    let uri = sourceUri deb+        distro = sourceDist deb in+    let scheme = uriScheme uri+        auth = uriAuthority uri+        path = uriPath uri in+    let userpass = maybe "" uriUserInfo auth+        reg = maybeOfString $ maybe "" uriRegName auth+        port = maybe "" uriPort auth in+    let (user, pass) = break (== ':') userpass in+    let user' = maybeOfString user+        pass' = maybeOfString pass in+    let uriText = prefix scheme user' pass' reg port path in+    -- what about dist?+    either (\ exact -> [(escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText ++ escape exact))])+           (\ (dist, sections) ->+                map (\ section -> +                         (escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText +?+ "dists_") +++                          releaseName' dist ++ "_" ++ sectionName' section))+                    sections)+           distro+    where+      -- If user is given and password is not, the user name is+      -- added to the file name.  Otherwise it is not.  Really.+      prefix "http:" (Just user) Nothing (Just host) port path =+          user ++ host ++ port ++ escape path+      prefix "http:" _ _ (Just host) port path =+          host ++ port ++ escape path+      prefix "ftp:" _ _ (Just host) _ path =+          host ++ escape path+      prefix "file:" Nothing Nothing Nothing "" path =+          escape path+      prefix "ssh:" (Just user) Nothing (Just host) port path =+          user ++ host ++ port ++ escape path+      prefix "ssh" _ _ (Just host) port path =+          host ++ port ++ escape path+      prefix _ _ _ _ _ _ = error ("invalid DebSource: " ++ show deb)+      maybeOfString "" = Nothing+      maybeOfString s = Just s+      escape s = intercalate "_" (wordsBy (== '/') s)++buildArchOfEnv :: EnvRoot -> IO Arch+buildArchOfEnv (EnvRoot root)  =+    do output <- lazyCommand cmd L.empty+       case exitCodeOnly output of+         [ExitSuccess] ->+             case (words . L.unpack . stdoutOnly $ output) of+               [] -> error $ "Invalid output from " ++ cmd+               (arch : _) -> return (Binary arch)+         _ -> error $ "Failure: " ++ cmd+    where+      cmd = "export LOGNAME=root; chroot " ++ show root ++ " dpkg-architecture -qDEB_BUILD_ARCH"++buildArchOfRoot :: IO Arch+buildArchOfRoot =+    do output <- lazyCommand cmd L.empty+       case exitCodeOnly output of+         [ExitSuccess] ->+             case (words . L.unpack . stdoutOnly $ output) of+               [] -> error $ "Invalid output from " ++ cmd+               (arch : _) -> return (Binary arch)+         _ -> error $ "Failure: " ++ cmd+    where+      cmd = "dpkg-architecture -qDEB_BUILD_ARCH"++(+?+) :: String -> String -> String+(+?+) a ('_' : b) = a +?+ b+(+?+) "" b = b+(+?+) a b =+    case last a of+      '_' -> (init a) +?+ b+      _ -> a ++ "_" ++ b++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)++data SourcesChangedAction =+    SourcesChangedError |+    UpdateSources |+    RemoveRelease++-- |Change the sources.list of an AptCache object, subject to the+-- value of sourcesChangedAction.+updateCacheSources :: (AptCache c, CIO m) => SourcesChangedAction -> c -> AptIOT m c+updateCacheSources sourcesChangedAction distro =+    do+      let baseSources = aptBaseSliceList distro+      --let distro@(ReleaseCache _ dist _) = releaseFromConfig' top text+      let dir = Debian.Repo.Cache.distDir distro+      distExists <- liftIO $ doesFileExist (Debian.Repo.Cache.sourcesPath distro)+      case distExists of+        True ->+            do+	      fileSources <- liftIO (readFile (Debian.Repo.Cache.sourcesPath distro)) >>= verifySourcesList Nothing . parseSourcesList+	      case (fileSources == baseSources, sourcesChangedAction) of+	        (True, _) -> return ()+	        (False, SourcesChangedError) ->+                    do+                      lift (vPutStrBl 0 ("The sources.list in the existing '" ++ relName (aptReleaseName distro) +++                                         "' build environment doesn't match the parameters passed to the autobuilder" +++			                 ":\n\n" ++ Debian.Repo.Cache.sourcesPath distro ++ ":\n\n" +++                                         show fileSources +++			                 "\nRun-time parameters:\n\n" +++                                         show baseSources ++ "\n" +++			                 "It is likely that the build environment in\n" +++                                         dir ++ " is invalid and should be rebuilt."))+                      lift (vPutStr 0 "Remove it and continue (or exit)?  [y/n]: ")+                      result <- liftIO $ hGetLine stdin+                      case result of+                        ('y' : _) ->+                            do+                              liftIO $ removeRecursiveSafely dir+                              liftIO $ createDirectoryIfMissing True dir+                              liftIO $ replaceFile (Debian.Repo.Cache.sourcesPath distro) (show baseSources)+                        _ ->+                            error ("Please remove " ++ dir ++ " and restart.")+                (False, RemoveRelease) ->+                    do+                      lift (vPutStrBl 0 ("Removing suspect environment: " ++ dir))+                      liftIO $ removeRecursiveSafely dir+                      liftIO $ createDirectoryIfMissing True dir+                      liftIO $ replaceFile (Debian.Repo.Cache.sourcesPath distro) (show baseSources)+                (False, UpdateSources) ->+                    do+                      -- The sources.list has changed, but it should be+                      -- safe to update it.+                      lift (vPutStrBl 0 ("Updating environment with new sources.list: " ++ dir))+                      liftIO $ removeFile (Debian.Repo.Cache.sourcesPath distro)+                      liftIO $ replaceFile (Debian.Repo.Cache.sourcesPath distro) (show baseSources)+        False ->+	    do+              liftIO $ createDirectoryIfMissing True dir+	      liftIO $ replaceFile (Debian.Repo.Cache.sourcesPath distro) (show baseSources)+      return distro++-- | Return a sorted list of available source packages, newest version first.+sourcePackages :: AptCache a => a -> [String] -> [SourcePackage]+sourcePackages os names =+    sortBy cmp . filterNames names . aptSourcePackages $ os+    where+      filterNames :: [String] -> [SourcePackage] -> [SourcePackage]+      filterNames names packages =+          filter (flip elem names . packageName . sourcePackageID) packages+      cmp p1 p2 =+          compare v2 v1		-- Flip args to get newest first+          where+            v1 = packageVersion . sourcePackageID $ p1+            v2 = packageVersion . sourcePackageID $ p2++binaryPackages :: AptCache a => a -> [String] -> [BinaryPackage]+binaryPackages os names =+    sortBy cmp . filterNames names . aptBinaryPackages $ os+    where+      filterNames :: [String] -> [BinaryPackage] -> [BinaryPackage]+      filterNames names packages =+          filter (flip elem names . packageName . packageID) packages+      cmp p1 p2 =+          compare v2 v1		-- Flip args to get newest first+          where+            v1 = packageVersion . packageID $ p1+            v2 = packageVersion . packageID $ p2
+ Debian/Repo/Changes.hs view
@@ -0,0 +1,292 @@+-- |Basic types for the Apt library.+module Debian.Repo.Changes+    (-- * read, show+      parseLog			-- String -> [ChangeLogEntry]+    , parseEntry		-- String -> Maybe (ChangeLogEntry, String)+    , parseChanges		-- String -> Maybe ChangeLogEntry+    , showHeader		-- ChangeLogEntry -> String+    -- * Changes File+    , findChangesFiles+    --, Section+    --, sectionName+    --, subSectionName+    --, load+    , parseChangesFilename+    , parseChangesFile+    , save+    , key+    , matchKey+    , base+    , Debian.Repo.Changes.path+    , name+    --, poolDir			-- PackageIndex -> ChangesFile -> FilePath+    , poolDir'			-- Release -> ChangesFile -> ChangedFileSpec -> FilePath+    , uploadLocal+    , ChangesFile(..)+    , changesFileName+    , ChangedFileSpec(..)+    , ChangeLogEntry(..)+    ) where++import Control.Monad.Trans+import Data.List (isSuffixOf, intercalate)+import Data.Maybe+import qualified Debian.Control.String as S+import Debian.Repo.LocalRepository+import Debian.Repo.Types+import Debian.Version+import Extra.Files (replaceFile)+import Extra.CIO (CIO)+import System.FilePath(splitFileName, (</>))+import System.Directory+import qualified System.Posix.Files as F+import Text.ParserCombinators.Parsec+import Text.Regex++import qualified Debian.Control.ByteString as B+import Debian.URI()++import System.Posix.Types++-- |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		-- ^ 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+            }++-- |An entry in the list of files generated by the build.+data ChangedFileSpec =+    ChangedFileSpec { changedFileMD5sum :: String+                    , changedFileSize :: FileOffset+                    , changedFileSection :: SubSection+                    , changedFilePriority :: String+                    , changedFileName :: FilePath+                    }++-- |A changelog is a series of ChangeLogEntries+data ChangeLogEntry = Entry { logPackage :: String+                            , logVersion :: DebianVersion+                            , logDists :: [ReleaseName]+                            , logUrgency :: String+                            , logComments :: String+                            , logWho :: String+                            , logDate :: String+                            }++instance Show ChangesFile where+    show = changesFileName++changesFileName :: ChangesFile -> String+changesFileName changes =+    changePackage changes ++ "_" ++ show (changeVersion changes) ++ "_" ++ archName (changeArch changes) ++ ".changes"++instance Show ChangedFileSpec where+    show file = changedFileMD5sum file ++ " " +++                show (changedFileSize file) ++ " " +++                sectionName (changedFileSection file) ++ " " +++                changedFilePriority file ++ " " +++                changedFileName file++instance Show ChangeLogEntry where+    show (Entry package version dists urgency details who date) =+        package ++ " (" ++ show version ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "\n\n" +++             details ++ " -- " ++ who ++ "  " ++ date ++ "\n\n"++-- |Show just the top line of a changelog entry (for debugging output.)+showHeader :: ChangeLogEntry -> String+showHeader (Entry package version dists urgency _ _ _) =+    package ++ " (" ++ show version ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "..."++-- |Parse a Debian Changelog and return a lazy list of entries+parseLog :: String -> [Either String ChangeLogEntry]+parseLog text =+    case parseEntry text of+      Nothing -> []+      Just (Left message) -> [Left message]+      Just (Right (entry, text')) -> Right entry : parseLog text'++-- |Parse a single changelog entry, returning the entry and the remaining text.+parseEntry :: String -> Maybe (Either String (ChangeLogEntry, String))+parseEntry text | dropWhile (\ x -> elem x " \t\n") text == "" = Nothing+parseEntry text =+    case matchRegexAll entryRE text of+      Nothing -> Just (Left ("Parse error in changelog:\n" ++ text))+      Just ("", _, remaining, [_, name, version, dists, urgency, _, details, _, _, _, _, _, who, date, _]) ->+          let entry =+                  Entry name +                        (parseDebianVersion version)+                        (map parseReleaseName . words $ dists)+                        urgency+			details+                        who+                        date in+          Just (Right (entry, remaining))+      Just ("", _, _remaining, submatches) -> Just (Left ("Internal error 15, submatches=" ++ show submatches))+      Just (before, _, _, _) -> Just (Left ("Parse error in changelog at:\n" ++ show before ++ "\nin:\n" ++ text))+    where+      entryRE = mkRegex $ bol ++ blankLines ++ headerRE ++ nonSigLines ++ blankLines ++ signature ++ blankLines+      nonSigLines = "(((  .*)|([ \t]*)\n)+)"+      -- In the debian repository, sometimes the extra space in front of the+      -- day-of-month is missing, sometimes an extra one is added.+      signature = "( -- ([^\n]*)  (..., ? ?.. ... .... ........ .....))[ \t]*\n"++-- |Parse the changelog information that shows up in the .changes+-- file, i.e. a changelog entry with no signature.+parseChanges :: String -> Maybe ChangeLogEntry+parseChanges text =+    case matchRegex changesRE text of+      Nothing -> Nothing+      Just [_, name, version, dists, urgency, _, details] ->+          Just $ Entry name +                       (parseDebianVersion version)+                       (map parseReleaseName . words $ dists)+                       urgency+		       details+                       "" ""+      Just x -> error $ "Unexpected match: " ++ show x+    where+      changesRE = mkRegexWithOpts (bol ++ blankLines ++ optWhite ++ headerRE ++ "(.*)$") False False++headerRE =+    package ++ version ++ dists ++ urgency+    where+      package = "([^ \t(]*)" ++ optWhite+      version = "\\(([^)]*)\\)" ++ optWhite+      dists = "([^;]*);" ++ optWhite+      urgency = "urgency=([^\n]*)\n" ++ blankLines++blankLines = blankLine ++ "*"+blankLine = "(" ++ optWhite ++ "\n)"+optWhite = "[ \t]*"+bol = "^"++findChangesFiles :: FilePath -> IO [ChangesFile]+findChangesFiles dir =+    getDirectoryContents dir >>=+    return . filter (isSuffixOf ".changes") >>=+    mapM (load dir) >>= return . catMaybes++load :: FilePath -> String -> IO (Maybe ChangesFile)+load dir file =+    do+      case parseChangesFilename file of+        Just (name, ver, arch) ->+            do+              result <- parseChangesFile dir file+              case result of+                Right (S.Control changes) ->+                    -- The .changes file should be a single paragraph,+                    -- but there have been instances where extra newlines+                    -- are inserted.  To be forgiving we will concat all+                    -- the paragraphs into one (rather than erroring out+                    -- or discarding all but the first paragraph.)+                    let changes' = mergeParagraphs changes in+                    case (S.fieldValue "Files" changes',+                          maybe Nothing parseChanges (S.fieldValue "Changes" changes'),+                          S.fieldValue "Distribution" changes') of+                      (Just text, Just entry, Just release) ->+                          do return . Just $ Changes { changeDir = dir+                                                     , changePackage = name+                                                     , changeVersion = ver+                                                     , changeRelease = parseReleaseName release+                                                     , changeArch = arch+                                                     , changeInfo = changes'+                                                     , changeEntry = entry+                                                     , changeFiles = parseFileList text }+                      _ -> return Nothing	-- Missing 'Files', 'Changes', or 'Distribution' field in .changes+                Left _error -> return Nothing+        Nothing -> return Nothing		-- Couldn't parse changes filename++mergeParagraphs :: [S.Paragraph] -> S.Paragraph +mergeParagraphs paragraphs =+    S.Paragraph . concat . map fieldsOf $ paragraphs+    where fieldsOf (S.Paragraph fields) = fields++save :: ChangesFile -> IO ()+save changes =+    replaceFile path (show (updateFiles (changeFiles changes) (changeInfo changes)))+    where+      path = changeDir changes ++ "/" ++ changesFileName changes+      updateFiles files info = S.modifyField "Files" (const (showFileList files)) info++key :: ChangesFile -> (String, DebianVersion, Arch)+key changes = (changePackage changes, changeVersion changes, changeArch changes)++matchKey :: ChangesFile -> (String, DebianVersion, Arch) -> Bool+matchKey changes key = key == (changePackage changes, changeVersion changes, changeArch changes)++base :: ChangesFile -> String+base changes =+    changePackage changes ++ "_" ++ show (changeVersion changes) ++ "_" ++ archName (changeArch changes)++name :: ChangesFile -> FilePath+name changes = base changes ++ ".changes"++path :: ChangesFile -> FilePath+path changes = changeDir changes ++ "/" ++ name changes++-- 		       filename     name   version   arch    ext+parseChangesFilename :: String -> Maybe (String, DebianVersion, Arch)+parseChangesFilename name =+    case matchRegex (mkRegex "^(.*/)?([^_]*)_(.*)_([^.]*)\\.changes$") name of+      Just [_, name, version, arch] -> Just (name, parseDebianVersion version, Binary arch)+      _ -> error ("Invalid .changes file name: " ++ name)++parseChangesFile :: FilePath -> String -> IO (Either ParseError S.Control)+parseChangesFile dir file = S.parseControlFromFile (dir ++ "/" ++ file)++parseFileList :: String -> [ChangedFileSpec]+parseFileList text =+    -- md5sum size section priority name+    case (text, matchRegexAll re text) of+      ("", _) -> []+      (_, Just (_, _, remaining, [md5sum, size, section, priority, filename])) ->+	  ChangedFileSpec { changedFileMD5sum = md5sum+                         , changedFileSize = read size+                         , changedFileSection = parseSection section+                         , changedFilePriority = priority+                         , changedFileName = filename } : parseFileList remaining+      _ -> error ("Parse error in Files section of changes file: '" ++ text)+    where+      re = mkRegex ("^[ \t\n]*" ++ g ++w++ g ++w++ g ++w++ g ++w++ g ++ "[ \t\n]*")+      g = "(" ++ t ++ ")"+      t = "[^ \t\n]+"+      w = "[ \t]+"++showFileList :: [ChangedFileSpec] -> String+showFileList files = concat (map (("\n " ++) . show) files)++-- | Return the subdirectory in the pool where a source package would be+-- installed.+poolDir' :: Release -> ChangesFile -> ChangedFileSpec -> FilePath+poolDir' release changes file =+    case S.fieldValue "Source" (changeInfo changes) of+      Nothing -> error "No 'Source' field in .changes file"+      Just source ->+          case releaseRepo release of+             LocalRepo repo -> poolDir repo (section . changedFileSection $ file) source+             x -> error $ "Unexpected repository passed to poolDir': " ++ show x++-- | Move a build result into a local repository's 'incoming' directory.+uploadLocal :: CIO m => LocalRepository -> ChangesFile -> m ()+uploadLocal repo changesFile =+    do let paths = map (\ file -> changeDir changesFile </> changedFileName file) (changeFiles changesFile)+       mapM_ (liftIO . install (outsidePath root)) (Debian.Repo.Changes.path changesFile : paths)+    where+      root = repoRoot repo+      -- Hard link a file into the incoming directory+      install root path =+	  do removeIfExists (dest root path)+	     F.createLink path (dest root path)+             -- F.removeLink path+      dest root path = root ++ "/incoming/" ++ snd (splitFileName path)+      removeIfExists path =+	  do exists <- doesFileExist path+	     if exists then F.removeLink path  else return ()
+ Debian/Repo/Dependencies.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}+-- |This dependency solver determines which binary packages to install +-- in order to satisfy a set of dependency relations.  It uses a brute+-- force method, but tweaked to the point where it is usually able to+-- complete on real-world inputs.+--+-- Author: David Fox <dsf@seereason.com>+module Debian.Repo.Dependencies+    ( simplifyRelations+    , solutions+    , testArch+    ) where++import		 Debian.Control()+import qualified Debian.Control.String as S()+import		 Debian.Repo.Types+import		 Data.List+import qualified Data.Map as Map+import		 Data.Maybe+import		 Debian.Relation+import		 Extra.List (cartesianProduct)++type Excuse = String++type ProvidesMap = Map.Map String [BinaryPackage]++-- |A SimpleRelation just specifies a particular version of a package.+-- The Nothing relation is always satisified.+type SimpleRelation = Maybe PkgVersion++-- |Each element is an or-list of specific package versions.+type SimpleRelations = [[SimpleRelation]]                     ++instance PackageVersion BinaryPackage where+    pkgName = packageName . packageID+    pkgVersion = packageVersion . packageID++-- Does this relation apply to this architecture?+testArch :: Arch -> Relation -> Bool+testArch _ (Rel _ _ Nothing) = True+testArch architecture (Rel _ _ (Just (ArchOnly archList))) = elem architecture (map Binary archList)+testArch architecture (Rel _ _ (Just (ArchExcept archList))) = not (elem architecture (map Binary archList))++-- |Turn the expressive inequality style relations to a set of simple+-- equality relations on only the packages in the available list.+simplifyRelations :: [BinaryPackage]+                  -> Relations+                  -> [String]		-- ^ Given several alternative packages which satisfy+				        -- the relation, sort by name in this order.+                  -> Arch		-- ^ The build architecture+                  -> SimpleRelations+simplifyRelations available relations preferred arch =+    -- Sort the or-relations so that+    --  1. the packages named in the preferred list appear before other packages,+    --  2. the newest version appear before the older+    map (sortBy prefOrder . reverse . sort) relationsSimplified+    where+      relationsSimplified = expandVirtual nameMap providesMap relationsOfArch+          where+            nameMap = listMap (map (\ package -> (packageName (packageID package), package)) available)+            providesMap =+                listMap (concat (map (\ package -> +                                      let names = packageName (packageID package) : map provides (pProvides package) in+                                      map (\ name -> (name, package)) names) available))+            provides [Rel name Nothing Nothing] = name+            provides bzzt = error ("Invalid relation in Provides: " ++ show bzzt)+            relationsOfArch = filter (/= []) (map (nub . filter (testArch arch)) relations)+      prefOrder a b = compare (isPreferred a) (isPreferred b)+          where isPreferred = maybe False (flip elem preferred . getName)++-- |Replace all relations by sets of equality relations on the exact+-- package versions which are actually available in the current+-- environment and satisfy the original relation.+expandVirtual :: ProvidesMap -> ProvidesMap -> Relations -> SimpleRelations+expandVirtual nameMap providesMap relations =+    map (nub . concat . map expand) relations+    where+      -- A relation with no version or architecture requirement+      -- can be satisfied by a provides or a real package.+      expand (Rel name Nothing Nothing) = map eqRel (Map.findWithDefault [] name providesMap)+      expand rel@(Rel name _ _) = map eqRel (filter (satisfies rel) (Map.findWithDefault [] name nameMap))+      eqRel :: BinaryPackage -> SimpleRelation+      eqRel package =+          Just (PkgVersion {getName = packageName p, getVersion = packageVersion p})+          where p = packageID package+      -- Does this package satisfy the relation?+      satisfies :: PackageVersion a => Relation -> a -> Bool+      satisfies rel pkg = testRel (pkgVersion pkg) rel++-- Does this version satisfy the relation?+testRel _ (Rel _ Nothing _) = True+testRel ver1 (Rel _ (Just (LTE ver2)) _) = not (compare ver1 ver2 == GT)+testRel ver1 (Rel _ (Just (GRE ver2)) _) = not (compare ver1 ver2 == LT)+testRel ver1 (Rel _ (Just (SLT ver2)) _) = compare ver1 ver2 == LT+testRel ver1 (Rel _ (Just (EEQ ver2)) _) = compare ver1 ver2 == EQ+testRel ver1 (Rel _ (Just (SGR ver2)) _) = compare ver1 ver2 == GT++-- |Given a root and a dependency list, return a list of possible+-- solutions to the dependency set.  Each solution is a list of+-- package versions which satisfy all the dependencies.  Note that if+-- a package is mentioned in two different clauses of the dependency+-- list, both clauses must be satisfied:+--+-- * a (>= 3.0), a (<< 4.0) | b (>= 2.0), c (>= 1.0) becomes+--+-- * a (>= 3.0), a (<< 4.0), c (>= 1.0) OR a (>= 3.0), b (>= 2.0), c (>= 1.0)+--+-- * [[a (>= 3.0)], [a (<< 4.0), b (>= 2.0)], [c (>= 1.0)]] becomes+--+-- * [[a (>= 3.0), a (<< 4.0), c (>= 1.0)], [a (>= 3.0), b (>= 2.0), c (>= 1.0)]]+--+-- So we can use each clause to eliminate packages which cannot+-- satisfy the dependency set.+solutions :: [BinaryPackage]	-- ^ The packages available to satisfy dependencies+          -> SimpleRelations	-- ^ The dependency relations to be satisfied+          -> Int		-- ^ Give up after this many solutions are computed+          -> (Either String [(Int, [BinaryPackage])])+				-- ^ On success return the set of packages to install,+				-- and the solution's sequence number.  Also returns+				-- the modified list of dependency relations, with all+				-- inequalities replaced by equalities on the particular+				-- versions of each package which are available.+solutions available relations limit =+    -- Do any of the dependencies require packages that simply don't+    -- exist?  If so we don't have to search for solutions, there+    -- aren't any.+    case any (== []) relations of+      True -> Left "Unsatisfiable dependencies"+      False ->+          -- Turn the And-of-Ors dependency list into Or-of-And-of-Ands.+          -- Each element of the result represents a an alternative set of+          -- constraints which a solution must satisfy.  Each element of+          -- the alternative is a list of relations on a single package,+          -- all of which must be satisfied.+          let alternatives = map (map nub . groupByName) (cartesianProduct relations) in+          --let versions = map makeVersion available in+          -- Find a set of packages that satisfies the dependencies+          case solutions' 1 alternatives available of+            -- Add more information about the failure to the error message.+            Left message ->+                let results = map (testAlternative available) (take 20 alternatives) in+                let (errors :: [String]) = catMaybes (map (either Just (const Nothing)) results) in+                Left (message ++ "\n" ++ intercalate "\n" errors)+            Right x -> Right x+    where+      solutions' :: PackageVersion a => Int -> [[[SimpleRelation]]] -> [a] -> Either String [(Int, [a])]+      solutions' _ [] _ = Left "All candidate solutions failed"+      solutions' count (alternative : alternatives) available =+          if count > limit then+              Left ("No solutions found in first " ++ show limit ++ " candidates") else+              case testAlternative available alternative of+                Left _ ->+                    solutions' (count + 1) alternatives available+                Right solution ->+                    Right ((count, solution)+                          : either (const []) id (solutions' (count + 1) alternatives available))++-- |The alternative argument is a possible solution to the dependency+-- problem.  Each element of alternative represents the relations on a+-- particular package.  So each one needs to be satisfied for the+-- alternative to be satisfied.+testAlternative :: PackageVersion a => [a] -> [[SimpleRelation]] -> Either Excuse [a]+testAlternative available alternative =+    -- +    if all (/= []) solution then+        Right (map head solution) else+        Left ("Couldn't satisfy these conditions:\n  " ++ +              intercalate "\n  " (map show (mask (map (== []) solution) alternative)))+    where+      solution = map (testPackage available) alternative+      mask bits elems = map fst (filter snd (zip elems bits))++-- |Return the list of versions of a package that satisfy all of the+-- relations.+testPackage :: PackageVersion a => [a] -> [SimpleRelation] -> [a]+testPackage available rels = foldl satisfies available rels+    where+      -- Which of these packages satisfy the relation?+      satisfies :: PackageVersion a => [a] -> SimpleRelation -> [a]+      satisfies available Nothing = available+      satisfies available (Just pkg) = filter same available+          where same x = pkgName x == pkgName pkg && pkgVersion x == pkgVersion pkg++groupByName :: [SimpleRelation] -> [[SimpleRelation]]+groupByName relations =+    groupBy (\ a b -> compareNames a b == EQ) (sortBy compareNames relations)+    where compareNames a b = compare (maybe Nothing (Just . getName) a) (maybe Nothing (Just . getName) b)++-- Turn a list of (k, a) pairs into a map from k -> [a].+listMap :: (Ord k) => [(k, a)] -> Map.Map k [a]+listMap pairs =+    foldl insertPair Map.empty pairs+    where insertPair m (k,a) = Map.insert k (a : (Map.findWithDefault [] k m)) m
+ Debian/Repo/IO.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |AptIO is an instance of the RWS monad used to manage the global+-- state and output style parameters of clients of the Apt library,+-- such as the autobuilder.+module Debian.Repo.IO+    ( AptIOT+    -- * AptIO Monad+    , io+    , tio		+    , runAptIO+    , tryAB+    -- * State+    , IOState+    , setRepoMap+    , getRepoMap+    , lookupRepository+    , insertRepository+    , lookupAptImage+    , insertAptImage+    , lookupSourcePackages+    , insertSourcePackages+    , lookupBinaryPackages+    , insertBinaryPackages+    , readParagraphs+    , findRelease+    , putRelease+    , countTasks+    ) where++import qualified Debian.Control.ByteString as B+import Debian.Repo.Types++import		 Control.Exception+import		 Control.Monad.RWS+import		 Control.Monad.Trans+import		 Data.Char+import		 Data.List+import qualified Data.Map as Map+import		 Data.Maybe+import		 Debian.URI+import		 Extra.TIO+import qualified System.IO as IO+import		 System.Posix.Files+import		 Text.Printf++instance Ord FileStatus where+    compare a b = compare (deviceID a, fileID a, modificationTime a) (deviceID b, fileID b, modificationTime b)++instance Eq FileStatus where+    a == b = compare a b == EQ++-- | A new monad to support the IO requirements of the autobuilder.+-- This uses the RWS monad.  The reader monad is used to store a flag+-- indicating whether this is a dry run, and the style information+-- associated with each output handle, including indentation, prefixing,+-- and replacing the output with one dot per n output characters.+-- The state monad stores information used to implement the current+-- output style and includes state information about whether the console+-- is at the beginning of a line, per-handle state information, and a+-- cache of the repositories that have been verified.+type AptIOT = RWST () () IOState+type AptIO = AptIOT TIO++-- | This represents the state of the IO system.  The 'bol' flag keeps+-- track of whether we are at the beginning of line on the console.+-- This is computed in terms of what we have sent to the console, but+-- it should be remembered that the order that stdout and stderr are+-- sent to the console may not be the same as the order in which they+-- show up there.  However, this appears to server our purposes for+-- now.+data IOState+    = IOState { repoMap :: Map.Map URI (Maybe Repository)			-- ^ Map to look up known Repository objects+              , releaseMap :: Map.Map (URI, ReleaseName) (Maybe Release)	-- ^ Map to look up known Release objects+              , aptImageMap :: Map.Map SliceName (Maybe AptImage)			-- ^ Map to look up prepared AptImage objects+              , sourcePackageMap :: Map.Map FilePath (Maybe (FileStatus, [SourcePackage]))+              , binaryPackageMap :: Map.Map FilePath (Maybe (FileStatus, [BinaryPackage]))+              }++-- |mark an action that should be run in the regular IO monad+io :: CIO m => IO a -> AptIOT m a+io = lift . liftIO++-- |mark an action that should be run in the terminal IO monad+tio :: CIO m => m a -> AptIOT m a+tio = lift++-- |Perform an AptIO monad task in the IO monad.+runAptIO :: CIO m => AptIOT m a -> m a+runAptIO action = (runRWST action) () initState >>= \ (a, _, _) -> return a++-- |Implementation of try for the AptIO monad.  If the task throws+-- an exception the initial state will be restored.+tryAB :: AptIO a -> AptIO (Either Exception a)+tryAB task =+    do+      state <- get+      liftAB (try' state) task+    where+      try' state task =+          do result <- tryTIO task+             case result of+               Left e -> return (Left e, state, ())+               Right (a, s, _) -> return (Right a, s, ())++      liftAB :: (TIO (a, IOState, ()) -> TIO (b, IOState, ())) -> (AptIO a -> AptIO b)+      liftAB f = {- AptIO . -} mapRWST f++-- |The initial output state - at the beginning of the line, no special handle+-- state information, no repositories in the repository map.+initState :: IOState+initState = IOState { repoMap = Map.empty+                    , releaseMap = Map.empty+                    , aptImageMap = Map.empty+                    , sourcePackageMap = Map.empty+                    , binaryPackageMap = Map.empty+                    }++setRepoMap :: Map.Map URI (Maybe Repository) -> IOState -> IOState+setRepoMap m state = state {repoMap = m}++getRepoMap :: IOState -> Map.Map URI (Maybe Repository)+getRepoMap state = repoMap state++lookupRepository :: URI -> IOState -> Maybe Repository+lookupRepository uri state = Map.findWithDefault Nothing uri (repoMap state)++insertRepository :: URI -> Repository -> IOState -> IOState+insertRepository uri repo state = state {repoMap = Map.insert uri (Just repo) (repoMap state)}++lookupAptImage :: SliceName -> IOState -> Maybe AptImage+lookupAptImage name state = Map.findWithDefault Nothing  name (aptImageMap state)++insertAptImage :: SliceName -> AptImage -> IOState -> IOState+insertAptImage name image state = state {aptImageMap = Map.insert name (Just image) (aptImageMap state)}++lookupSourcePackages :: FilePath -> IOState -> Maybe (FileStatus, [SourcePackage])+lookupSourcePackages key state = Map.findWithDefault Nothing key (sourcePackageMap state)++insertSourcePackages :: FilePath -> (FileStatus, [SourcePackage]) -> IOState -> IOState+insertSourcePackages key packages state = state {sourcePackageMap = Map.insert key (Just packages) (sourcePackageMap state)}++lookupBinaryPackages :: FilePath -> IOState -> Maybe (FileStatus, [BinaryPackage])+lookupBinaryPackages key state = Map.findWithDefault Nothing key (binaryPackageMap state)++insertBinaryPackages :: FilePath -> (FileStatus, [BinaryPackage]) -> IOState -> IOState+insertBinaryPackages key packages state =+    state {binaryPackageMap = Map.insert key (Just packages) (binaryPackageMap state)}++readParagraphs :: FilePath -> IO [B.Paragraph]+readParagraphs path =+    do --IO.hPutStrLn IO.stderr ("OSImage.paragraphsFromFile " ++ path)			-- Debugging output+       h <- IO.openBinaryFile path IO.ReadMode+       B.Control paragraphs <- B.parseControlFromHandle path h >>= return . (either (error . show) id)+       IO.hClose h+       --IO.hPutStrLn IO.stderr ("OSImage.paragraphsFromFile " ++ path ++ " done.")	-- Debugging output+       return paragraphs++findRelease :: Repository -> ReleaseName -> IOState -> Maybe Release+findRelease repo dist state =+    Map.findWithDefault Nothing (repoURI repo, dist) (releaseMap state)++putRelease :: Repository -> ReleaseName -> Release -> IOState -> IOState+putRelease repo dist release state =+    state {releaseMap = Map.insert (repoURI repo, dist) (Just release) (releaseMap state)}++-- | Perform a list of tasks with log messages.+countTasks :: CIO m => [(String, m a)] -> m [a]+countTasks tasks =+    mapM (countTask (length tasks)) (zip [1..] tasks)+    where+      countTask :: CIO m => Int -> (Int, (String, m a)) -> m a+      countTask count (index, (message, task)) =+          (ePutStrBl (printf "[%2d of %2d] %s:" index count message)) >>+          {- setStyle (addPrefix "  ") -} task
+ Debian/Repo/Insert.hs view
@@ -0,0 +1,706 @@+{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}+-- |Insert packages into a release, remove packages from a release.+module Debian.Repo.Insert+    ( scanIncoming+    , InstallResult(..)+    , deleteTrumped+    , deleteGarbage+    , deleteSourcePackages+    , resultToProblems+    , showErrors+    , explainError+    ) where++import Control.Exception (Exception(..))+import Control.Monad+import Control.Monad.Trans+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import Data.List (group, sort, intercalate, sortBy, groupBy, isSuffixOf, partition)+import Data.Maybe (catMaybes)+import qualified Data.Set as Set+import Debian.Control+import qualified Debian.Control.ByteString as B+import qualified Debian.Control.String as S+import Debian.Repo.Changes+import Debian.Repo.IO+import qualified Debian.Repo.Package as DRP+import Debian.Repo.PackageIndex+import Debian.Repo.Release+import Debian.Repo.Repository+import Debian.Repo.Types+import Debian.Version+import Extra.GPGSign (PGPKey)+import Extra.Either (partitionEithers, rights)+import Extra.Files (writeAndZipFileWithBackup)+import Extra.Misc (listDiff)+import Extra.CIO (CIO, vPutStr, vPutStrBl)+import System.FilePath(splitFileName, (</>))+import qualified System.Unix.Misc as Unix+import System.Unix.Process+import System.Directory+import System.IO+import qualified System.Posix.Files as F+import System.Posix.Types (FileOffset)+import System.Process+import qualified Text.Format as F++data InstallResult +    = Ok+    | Failed [Problem]		-- Package can not currently be installed+    | Rejected [Problem]	-- Package can not ever be installed+    deriving (Show, Eq)++data Problem+    = NoSuchRelease ReleaseName+    | NoSuchSection ReleaseName [Section]+    | ShortFile FilePath FileOffset FileOffset+    | LongFile FilePath FileOffset FileOffset+    | MissingFile FilePath+    | BadChecksum FilePath String String+    | OtherProblem Exception+    deriving (Eq)++instance Show Problem where+    show (NoSuchRelease rel) = "NoSuchRelease  " ++ releaseName' rel+    show (NoSuchSection rel sect) = "NoSuchSection " ++ releaseName' rel ++ " " ++ show (map sectionName' sect)+    show (ShortFile path a b) = "ShortFile " ++ path ++ " " ++ show a ++ " " ++ show b+    show (LongFile path a b) = "LongFile " ++ path ++ " " ++ show a ++ " " ++ show b+    show (MissingFile path) = "MissingFile " ++ path+    show (BadChecksum path a b) = "BadChecksum " ++ path ++ " " ++ show a ++ " " ++ show b+    show (OtherProblem s) = "OtherProblem " ++ show s++nub :: (Ord a) => [a] -> [a]+nub = map head . group . sort++mergeResults :: [InstallResult] -> InstallResult+mergeResults results =+    doMerge Ok results+    where+      doMerge x [] = x+      doMerge x (Ok : more) = doMerge x more+      doMerge (Rejected p1) (Rejected p2 : more) = doMerge (Rejected (p1 ++ p2)) more+      doMerge (Rejected p1) (Failed p2 : more) = doMerge (Rejected (p1 ++ p2)) more+      doMerge (Failed p1) (Rejected p2 : more) = doMerge (Rejected (p1 ++ p2)) more+      doMerge (Failed p1) (Failed p2 : more) = doMerge (Failed (p1 ++ p2)) more+      doMerge Ok (x : more) = doMerge x more++showErrors :: [InstallResult] -> String+showErrors errors = intercalate "\n" (map explainError (concat . map resultToProblems $ errors))++resultToProblems :: InstallResult -> [Problem]+resultToProblems Ok = []+resultToProblems (Failed x) = x+resultToProblems (Rejected x) = x++isError :: InstallResult -> Bool+isError Ok = False+isError _ = True++plural "do" [_] = "does"+plural "do" _ = "do"++plural "s" [_] = ""+plural "s" _ = "s"++plural _ _ = ""+++explainError :: Problem -> String+explainError (NoSuchRelease dist) =+    ("\nThe distribution in the .changes file (" ++ releaseName' dist ++ ") does not exist.  There\n" +++     "are three common reasons this might happen:\n" +++     " (1) The value in the latest debian/changelog entry is wrong\n" +++     " (2) A new release needs to be created in the repository.\n" +++     "       newdist --root <root> --create-release " ++ releaseName' dist ++ "\n" +++     " (3) A new alias needs to be created in the repository (typically 'unstable', 'testing', or 'stable'.)\n" +++     "       newdist --root <root> --create-alias <existing release> " ++ releaseName' dist ++ "\n")+explainError (NoSuchSection dist components) =+    ("\nThe component" ++ plural "s" components ++ " " ++ intercalate ", " (map sectionName' components) +++     " in release " ++ releaseName' dist ++ " " +++     plural "do" components ++ " not exist.\n" +++     "either the 'Section' value in debian/control was wrong or the section needs to be created:" +++     concat (map (\ component -> "\n  newdist --root <root> --create-section " ++ releaseName' dist ++ "," ++ sectionName' component) components))+explainError (ShortFile path _ _) =+    ("\nThe file " ++ path ++ "\n" +++     "is shorter than it should be.  This usually\n" +++     "happens while the package is still being uploaded to the repository.")+explainError (LongFile path _ _) =+    ("\nThe file " ++ path +++     "\nis longer than it should be.  This can happen when the --force-build\n" +++     "option is used.  In this case the --flush-pool option should help.")+explainError (BadChecksum path _ _) =+    ("\nThe checksum of the file " ++ path ++ "\n" +++     "is different from the value in the .changes file.\n" +++     "This can happen when the --force-build option is used.  In this case the\n" +++     "--flush-pool option should help.  It may also mean a hardware failure.")+explainError other = show other++-- | Find the .changes files in the incoming directory and try to +-- process each.+scanIncoming :: CIO m => Bool -> Maybe PGPKey -> LocalRepository -> AptIOT m ([ChangesFile], [(ChangesFile, InstallResult)])+scanIncoming createSections keyname repo@(LocalRepository root _ _) =+    do releases <- findReleases repo+       changes <- liftIO (findChangesFiles (outsidePath root </> "incoming"))+       case changes of+         [] -> lift $ vPutStrBl 0 "Nothing to install."+         _ -> lift $ vPutStrBl 1 ("Changes:\n  " ++ (intercalate "\n  " . map show $ changes))+       results <- installPackages createSections keyname repo releases changes+       case results of+         [] -> return ()+         _ -> lift (vPutStrBl 0 ("Upload results:\n  " +++                                 (intercalate "\n  " . map (uncurry showResult) $ (zip changes results))))+       let (bad, good) = partition (isError . snd) (zip changes results)+       return (map fst good, bad)+    where+      showResult changes result =+          changesFileName changes ++ ": " +++          case result of+            Ok -> "Ok"+            Failed lst -> "Failed -\n      " ++ (intercalate "\n      " $ map show lst)+            Rejected lst -> "Rejected -\n      " ++ (intercalate "\n      " $ map show lst)++-- | Install several packages into a repository.  This means+-- 1. getting the list of files from the .changes file,+-- 2. verifying the file checksums,+-- 3. deleting any existing version and perhaps other versions which+--    were listed in the delete list,+-- 4. updating the Packages and Sources files, and+-- 5. moving the files from the incoming directory to the proper+--    place in the package pool.+installPackages :: CIO m+                => Bool				-- ^ ok to create new releases and sections+                -> Maybe PGPKey		-- ^ key to sign repository with+                -> LocalRepository		-- ^ target repository+                -> [Release]			-- ^ Releases in target repository+                -> [ChangesFile]		-- ^ Package to be installed+                -> AptIOT m [InstallResult]	-- ^ Outcome of each source package+installPackages createSections keyname repo@(LocalRepository root layout _) releases changeFileList =+    do live <- findLive repo >>= return . Set.fromList+       (_, releases', results) <- foldM (installFiles root) (live, releases, []) changeFileList+       let results' = reverse results+       results'' <- lift $ updateIndexes root releases' results'+       -- The install is done, now we will try to clean up incoming.+       case elem Ok results'' of+         False ->+             return results''+         True ->+             mapM_ (lift . uncurry (finish root (maybe Flat id layout))) (zip changeFileList results'') >>+             mapM_ (lift . signRelease keyname) (catMaybes . map (findRelease releases) . nub . sort . map changeRelease $ changeFileList) >>+             return results''+    where+      -- Hard link the files of each package into the repository pool,+      -- but don't unlink the files in incoming in case of subsequent+      -- failure.+      installFiles :: CIO m => EnvPath -> (Set.Set FilePath, [Release], [InstallResult]) -> ChangesFile -> AptIOT m (Set.Set FilePath, [Release], [InstallResult])+      installFiles root (live, releases, results) changes =+          findOrCreateRelease releases (changeRelease changes) >>=+          maybe (return (live, releases, Failed [NoSuchRelease (changeRelease changes)] : results)) installFiles'+          where+            installFiles' release =+                let sections = nub . sort . map (section . changedFileSection) . changeFiles $ changes in+                case (createSections, listDiff sections (releaseComponents release)) of+                  (_, []) -> installFiles'' release+                  (True, missing) ->+                      do lift $ vPutStrBl 0 ("Creating missing sections: " ++ intercalate " " (map sectionName' missing))+                         release' <- case releaseRepo release of+                                       LocalRepo repo -> prepareRelease repo (releaseName release) [] missing (releaseArchitectures release)+                                       x -> error $ "Expected local release: " ++ show x+                         installFiles'' release'+                  (False, missing) ->+                      return (live, releases, Failed [NoSuchSection (releaseName release) missing] : results)+            installFiles'' release' =+                do let releases' = release' : filter ((/= releaseName release') . releaseName) releases+                   result <- mapM (installFile root release') (changeFiles changes) >>= return . mergeResults+                   let live' =+                           case result of+                             -- Add the successfully installed files to the live file set+                             Ok -> foldr Set.insert live (map (((outsidePath root) </>) . poolDir' release' changes) (changeFiles changes))+                             _ -> live+                   return (live', releases', result : results)+{-+                   release' <-+                       case (createSections, listDiff sections (releaseComponents release)) of+                         (_, []) -> return release+                         (True, missing) ->+                             vPutStrBl 0 ("Creating missing sections: " ++ show missing) >>+                             prepareRelease (releaseRepo release) (releaseName release) [] missing (releaseArchitectures release)+                         (False, missing) ->+                             error $ "Missing sections: " ++ show missing+                   let releases' = release' : filter ((/= releaseName release') . releaseName) releases+                   result <- mapM (installFile root release') (changeFiles changes) >>= return . mergeResults+                   let live' =+                           case result of+                             -- Add the successfully installed files to the live file set+                             Ok -> foldr Set.insert live (map (((show root) </>) . poolDir' release changes) (changeFiles changes))+                             _ -> live+                   return (live', releases', result : results)+-}+            installFile root release file =+                do let dir = outsidePath root </> poolDir' release changes file+                   let src = outsidePath root </> "incoming" </> changedFileName file+                   let dst = dir </> changedFileName file+                   installed <- liftIO $ doesFileExist dst+                   available <- liftIO $ doesFileExist src+                   let indexed = Set.member dst live+                   case (available, indexed, installed) of+                     (False, _, _) ->			-- Perhaps this file is about to be uploaded+                         return (Failed [MissingFile src])+                     (True, False, False) ->		-- This just needs to be installed +			 liftIO (createDirectoryIfMissing True dir) >>+                         liftIO (F.createLink src dst) >>+                         return Ok+                     (True, False, True) ->		-- A garbage file is already present+                         lift (vPutStrBl 1 ("  Replacing unlisted file: " ++ dst)) >>+			 liftIO (removeFile dst) >>+                         liftIO (F.createLink src dst) >>+                         return Ok+                     (True, True, False) ->		-- Apparantly the repository is damaged.+                         return (Failed [OtherProblem $ (ErrorCall $ "Missing from repository: " ++ dst)])+                     (True, True, True) ->		-- Further inspection is required+                         do installedSize <- liftIO $ F.getFileStatus dst >>= return . F.fileSize+                            installedMD5sum <- liftIO $ Unix.md5sum dst+                            case () of+                              _ | changedFileSize file < installedSize ->+	                            -- File may be in the process of being uploaded+                                    return (Failed [ShortFile dst (changedFileSize file) installedSize])+                              _ | changedFileSize file > installedSize ->+                                    -- We could skip this size test and just do the checksum test,+                                    -- but a file that is too long indicates a different type of+                                    -- failure than a file with a checksum mismatch.+                                    return (Rejected [LongFile dst (changedFileSize file) installedSize])+                              _ | changedFileMD5sum file /= installedMD5sum ->+                                    return (Rejected [BadChecksum dst (changedFileMD5sum file) installedMD5sum])+                              _ -> return Ok	-- The correct file is already installed - so be it.+          +      -- Update all the index files affected by the successful+      -- installs.  This is a time consuming operation, so we want to+      -- do this all at once, rather than one package at a time+      updateIndexes :: CIO m => EnvPath -> [Release] -> [InstallResult] -> m [InstallResult]+      updateIndexes root releases results =+          do vPutStrBl 1 "updateIndexes"+             (pairLists :: [Either InstallResult [(PackageIndexLocal, B.Paragraph)]]) <-+                 mapM (uncurry $ buildInfo root releases) (zip changeFileList results)+             let sortedByIndex = sortBy compareIndex (concat (keepRight pairLists))+             let groupedByIndex = undistribute (groupBy (\ a b -> compareIndex a b == EQ) sortedByIndex)+             result <- addPackagesToIndexes groupedByIndex+             case result of+               Ok -> return $ map (either id (const Ok)) pairLists+               problem -> return $ map (const problem) results +          where+            compareIndex :: (PackageIndexLocal, B.Paragraph) -> (PackageIndexLocal, B.Paragraph) -> Ordering+            compareIndex (a, _) (b, _) = compare a b+      -- Build the control information to be added to the package indexes.+      buildInfo :: CIO m => EnvPath -> [Release] -> ChangesFile -> InstallResult -> m (Either InstallResult [(PackageIndexLocal, B.Paragraph)])+      buildInfo root releases changes Ok =+          do vPutStrBl 1 $ "  buildInfo " ++ changesFileName changes+             case findRelease releases (changeRelease changes) of+               Just release ->+                   do (info :: [Either InstallResult B.Paragraph]) <- mapM (fileInfo root release) indexFiles+                      case keepLeft info of+                        [] ->+                            let (pairs :: [([PackageIndexLocal], Either InstallResult B.Paragraph)]) = zip (indexLists release) info in+                            let (pairs' :: [([PackageIndexLocal], B.Paragraph)]) =+                                    catMaybes $ map (\ (a, b) -> either (const Nothing) (\ b' -> Just (a, b')) b) pairs in+                            let (pairs'' :: [(PackageIndexLocal, B.Paragraph)]) = concat (map distribute pairs') in+                            return (Right pairs'')+                        results -> return (Left (mergeResults results))+               Nothing -> return . Left . Failed $ [NoSuchRelease (changeRelease changes)]+          where+            indexLists :: Release -> [[PackageIndexLocal]]+            indexLists release = map (indexes release) indexFiles+            indexes :: Release  -> ChangedFileSpec -> [PackageIndexLocal]+            indexes release file = map (PackageIndex release (section . changedFileSection $ file)) (archList release changes file)+            indexFiles = dsc ++ debs+            (debs :: [ChangedFileSpec]) = filter f files+                where (f :: ChangedFileSpec -> Bool) = (isSuffixOf ".deb" . changedFileName)+                      (files :: [ChangedFileSpec]) = (changeFiles changes)+            dsc = filter (isSuffixOf ".dsc" . changedFileName) (changeFiles changes)+            -- (debs, nonDebs) = partition (isSuffixOf ".deb" . changedFileName) (changeFiles changes)+            -- (indepDebs, archDebs) = partition (isSuffixOf "_all.deb" . changedFileName) debs+            -- (dsc, other) = partition (isSuffixOf ".dsc" . changedFileName) nonDebs+            --fileIndex release file = map (PackageIndex release (section . changedFileSection $ file)) (archList release changes file)+            fileInfo :: CIO m => EnvPath -> Release -> ChangedFileSpec -> m (Either InstallResult B.Paragraph)+            fileInfo root release file =+                getControl >>= return . addFields+                where+                  getControl :: CIO m => m (Either InstallResult B.Paragraph)+                  getControl =+                      do control <-+                             case isSuffixOf ".deb" . changedFileName $ file of+                               True -> getDebControl path+                               False -> liftIO $ S.parseControlFromFile path >>= return . either (Left . show) Right+                         case control of+                           Left message -> return . Left . Rejected $ [OtherProblem (ErrorCall message)]+                           Right (S.Control [info]) -> return (Right info)+                           Right (S.Control _) -> return . Left . Rejected $ [OtherProblem (ErrorCall "Invalid control file")]+                  addFields :: (Either InstallResult B.Paragraph) -> (Either InstallResult B.Paragraph)+                  addFields (Left result) = Left result+                  addFields (Right info) =+                      case isSuffixOf ".deb" . changedFileName $ file of+                        True -> addDebFields release changes file info+                        False -> addSourceFields release changes file info+                  -- | Extract the control file from a binary .deb.+                  getDebControl :: CIO m => FilePath -> m (Either String B.Control)+                  getDebControl path =+                      do let cmd = "ar p " ++ path ++ " control.tar.gz | tar xzO ./control"+                         (_, outh, _, handle) <- liftIO $ runInteractiveCommand cmd+                         control <- liftIO $ B.parseControlFromHandle cmd outh >>= return . either (Left . show) Right+                         exitcode <- liftIO $ waitForProcess handle+                         case exitcode of+                           ExitSuccess -> return control+                           ExitFailure n -> return . Left $ "Failure: " ++ cmd ++ " -> " ++ show n+                  path = outsidePath root ++ "/incoming/" ++ changedFileName file+      buildInfo _ _ _ notOk = return . Left $ notOk+      -- For a successful install this unlinks the files from INCOMING and+      -- moves the .changes file into INSTALLED.  For a failure it moves+      -- all the files to REJECT.+      finish root layout changes Ok =+          do --vPutStrBl 1 stderr $ "  finish Ok " ++ changesFileName changes+             mapM (liftIO . removeFile . ((outsidePath root ++ "/incoming/") ++) . changedFileName) (changeFiles changes)+             installChangesFile root layout changes+      finish root _ changes (Rejected _) =+          do --vPutStrBl 1 stderr $ "  finish Rejected " ++ changesFileName changes+             mapM (\ name -> liftIO (moveFile (outsidePath root ++ "/incoming/" ++ name) (outsidePath root ++ "/reject/" ++ name)))+                      (map changedFileName (changeFiles changes))+             liftIO (moveFile (outsidePath root ++ "/incoming/" ++ Debian.Repo.Changes.name changes)+                                (outsidePath root ++ "/reject/" ++ Debian.Repo.Changes.name changes))+      finish _ _ changes (Failed _) =+          do vPutStrBl 1 $ "  Finish Failed " ++ changesFileName changes+             return ()+      installChangesFile :: CIO m => EnvPath -> Layout -> ChangesFile -> m ()+      installChangesFile root layout changes =+          liftIO (moveFile (Debian.Repo.Changes.path changes) dst)+          where dst = case layout of+                        Flat -> outsidePath root </> Debian.Repo.Changes.name changes+                        Pool -> outsidePath root ++ "/installed/" ++ Debian.Repo.Changes.name changes+      findOrCreateRelease :: CIO m => [Release] -> ReleaseName -> AptIOT m (Maybe Release)+      findOrCreateRelease releases name =+          case createSections of+            False -> return (findRelease releases name)+            True -> do let release = findRelease releases name+                       case release of+                         Nothing ->+                             do newRelease <- prepareRelease repo name [] [parseSection' "main"] (repoArchList repo)+                                return (Just newRelease)+                         Just release -> return (Just release)+      findRelease :: [Release] -> ReleaseName -> Maybe Release+      findRelease releases name = +          case filter (\ release -> elem name (releaseName release : releaseInfoAliases (releaseInfo release))) releases of+            [] -> Nothing+            [x] -> Just x+            _ -> error $ "Internal error 16 - multiple releases named " ++ releaseName' name++archList :: Release -> ChangesFile -> ChangedFileSpec -> [Arch]+archList release changes file =+    case () of+      _ | isSuffixOf "_all.deb" name -> releaseArchitectures release+      _ | isSuffixOf ".deb" name -> [changeArch changes]+      _ | isSuffixOf ".udeb" name -> []+      _ -> [Source]+    where name = changedFileName file++distribute :: ([a], b) -> [(a, b)]+distribute (ilist, p) = map (\ i -> (i, p)) ilist++undistribute :: [[(a, b)]] -> [(a, [b])]+undistribute [] = []+undistribute ([] : tail) = undistribute tail+undistribute (((index, info) : items) : tail) =+    (index, info : map snd items) : undistribute tail++keepRight :: [Either a b] -> [b]+keepRight xs = catMaybes $ map (either (const Nothing) Just) xs++keepLeft :: [Either a b] -> [a]+keepLeft xs = catMaybes $ map (either Just (const Nothing)) xs++addDebFields :: Release -> ChangesFile -> ChangedFileSpec -> B.Paragraph -> (Either InstallResult B.Paragraph)+addDebFields release changes file info =+    let (binaryVersion :: DebianVersion) =+            maybe (error $ "Missing 'Version' field") (parseDebianVersion . B.unpack) (B.fieldValue "Version" info) in+    let (newfields :: [B.Field]) =+            [B.Field (B.pack "Source", B.pack (" " ++ source ++ versionSuffix binaryVersion)),+             B.Field (B.pack "Filename", B.pack (" " ++ poolDir' release changes file </> changedFileName file)),+             B.Field (B.pack "Size", B.pack (" " ++ show (changedFileSize file))),+             B.Field (B.pack "MD5sum", B.pack (" " ++ changedFileMD5sum file))] in+    Right $ B.appendFields newfields info+    where+      versionSuffix :: DebianVersion -> String+      versionSuffix binaryVersion = if binaryVersion /= sourceVersion then " (" ++ show sourceVersion ++ ")" else ""+      source = maybe (error "Missing 'Source' field in .changes file") id (B.fieldValue "Source" (changeInfo changes))+      sourceVersion = changeVersion changes+++addSourceFields :: Release -> ChangesFile -> ChangedFileSpec -> B.Paragraph -> (Either InstallResult B.Paragraph)+addSourceFields release changes file info =+    let info' = B.renameField (B.pack "Source") (B.pack "Package") info in+    let info'' = B.modifyField (B.pack "Files") (\ b -> (B.pack (B.unpack b ++ "\n " ++ changedFileMD5sum file ++ " "  ++ +                                                                 show (changedFileSize file) ++ " " +++                                                                 changedFileName file))) info' in+    let info''' = B.raiseFields (== (B.pack "Package")) info'' in+    let newfields = [B.Field (B.pack "Priority", B.pack (" " ++ changedFilePriority file)),+                     B.Field (B.pack "Section", B.pack  (" " ++ (sectionName (changedFileSection file)))),+                     B.Field (B.pack "Directory", B.pack (" " ++ poolDir' release changes file))] +++                    maybe [] (\ s -> [B.Field (B.pack "Build-Info", B.pack (" " ++ s))])+                              (B.fieldValue "Build-Info" (changeInfo changes)) in+    Right $ B.appendFields newfields info'''    ++moveFile :: FilePath -> FilePath -> IO ()+moveFile src dst =+    do --vPutStrBl 1 stderr ("moveFile " ++ src ++ " " ++ dst)+       doesFileExist dst >>= (flip when) (removeFile dst)+       F.createLink src dst+       removeFile src++-- |Add control information to several package indexes, making sure+-- that that no duplicate package ids are inserted.+addPackagesToIndexes :: CIO m => [(PackageIndexLocal, [B.Paragraph])] -> m InstallResult+addPackagesToIndexes pairs =+    do oldPackageLists <- mapM DRP.getPackages (map fst pairs)+       case partitionEithers oldPackageLists of+         ([], _) -> +             do let (oldPackageLists' :: [[BinaryPackageLocal]]) = rights oldPackageLists+                let (indexMemberFns :: [BinaryPackageLocal -> Bool]) = map indexMemberFn oldPackageLists'+                -- if none of the new packages are already in the index, add them+                case concat (map (uncurry filter) (zip indexMemberFns newPackageLists)) of+                  [] -> do mapM (liftIO . updateIndex) (zip3 indexes oldPackageLists' newPackageLists)+                           return Ok+                  dupes -> return $ Failed [OtherProblem (ErrorCall ("Duplicate packages: " ++ intercalate " " (map show dupes)))]+         (bad, _) -> return $ Failed (map OtherProblem bad)+{-+    do (oldPackageLists :: [[BinaryPackageLocal]]) <- mapM getPackages (map fst pairs) >>= return . rights+       -- package membership predicates+       let (indexMemberFns :: [BinaryPackageLocal -> Bool]) = map indexMemberFn oldPackageLists+       -- if none of the new packages are already in the index, add them+       case concat (map (uncurry filter) (zip indexMemberFns newPackageLists)) of+         [] -> do mapM (liftIO . updateIndex) (zip3 indexes oldPackageLists newPackageLists)+                  return Ok+         dupes -> return $ Failed [OtherProblem ("Duplicate packages: " ++ (intercalate " " (map show dupes)))]+-}+    where+      updateIndex (index, oldPackages, newPackages) = DRP.putPackages index (oldPackages ++ newPackages)+      indexes = map fst pairs+      indexMemberFn :: [BinaryPackageLocal] -> BinaryPackageLocal -> Bool+      indexMemberFn packages =+          let set = Set.fromList . map packageID $ packages+          in+            \package -> Set.member (packageID package) set+      newPackageLists = map (\ (index, info) -> map (DRP.toBinaryPackage index) info) pairs++-- | Delete any packages from a dist which are trumped by newer+-- packages.  These packages are not garbage because they can still be+-- installed by explicitly giving their version number to apt.+deleteTrumped :: CIO m => Maybe PGPKey -> [Release] -> m [Release]+deleteTrumped _ [] = error "deleteTrumped called with empty release list"+deleteTrumped keyname releases =+    case nub . map releaseRepo $ releases of+      [_] ->+          mapM findTrumped releases >>=+          return . partitionEithers >>=+          \ (bad, good) -> +              case bad of +                [] -> return (concat good) >>=+                      ifEmpty (vPutStr 0 "deleteTrumped: nothing to delete") >>=+                      deleteSourcePackages keyname+                _ -> error $ "Error reading package lists"+      [] -> error "internal error"+      repos -> error ("Multiple repositories passed to deleteTrumped:\n  " +++                      (intercalate "\n  " $ map show repos) ++ "\n")+    where+      ifEmpty action [] = do action; return []+      ifEmpty _ x = return x++-- | Return a list of packages in a release which are trumped by some+-- newer version.+findTrumped :: CIO m => Release -> m (Either String [PackageIDLocal])+findTrumped release =+    do+      --ePutStr ("findTrumped " ++ show release)+      packages <- mapM DRP.getPackages (sourceIndexList release)+      case partitionEithers packages of+        ([], packages') ->+            do let groups = map newestFirst . groupByName . map packageID . concat $ packages'+               mapM_ (vPutStrBl 0) (catMaybes . map formatGroup $ groups)+               return . Right . concat . map tail $ groups+        (bad, _) -> return (Left $ "Error reading source indexes: " ++ intercalate ", " (map show bad))+    where+      groupByName = groupBy equalNames . sortBy compareNames+      equalNames a b = packageName a == packageName b+      compareNames a b = compare (packageName a) (packageName b)+      newestFirst = sortBy (flip compareVersions)+      compareVersions a b = compare (packageVersion a) (packageVersion b)+      formatGroup [] = Nothing+      formatGroup [_] = Nothing+      formatGroup (newest : other) =+          Just ("Trumped by " ++ F.format newest ++ " in " ++ F.format (packageIndex newest) ++ ":\n " +++                intercalate "\n " (map F.format other))++-- | Collect files that no longer appear in any package index and move+-- them to the removed directory.  The .changes files are treated+-- specially: they don't appear in any index files, but the package+-- they belong to can be constructed from their name.+deleteGarbage :: CIO m => LocalRepository -> AptIOT m LocalRepository+deleteGarbage repo =+    case repoLayout repo of+      Just layout ->+          do+            lift (vPutStrBl 0 ("deleteGarbage in " ++ outsidePath root ++ " (layout=" ++ show layout ++ ")"))+            allFiles1 <- liftIO $ poolFiles root layout+            allFiles2 <- liftIO $ changesFileList root layout+            let allFiles = allFiles1 ++ allFiles2+            -- ePutStr ("allFiles:\n  " ++ intercalate "\n  " (sort allFiles) ++ "\n")+            liveFiles <- findLive repo+            -- ePutStr ("liveFiles:\n  " ++ intercalate "\n  " (sort liveFiles) ++ "\n")+            let deadFiles = Set.toList (Set.difference (Set.fromList allFiles) (Set.fromList liveFiles))+            lift (vPutStrBl 0 ("Removing:\n  " ++ intercalate "\n  " (sort deadFiles) ++ "\n"))+            mapM_ (liftIO . moveToRemoved root) deadFiles+            return repo+      _ -> error "Cannot remove files from an empty repository"+    where+      root = repoRoot repo+      poolFiles root Flat = getDirectoryContents (outsidePath root) >>=+                            filterM (doesFileExist . ((outsidePath root ++ "/") ++))+      poolFiles root Pool = +          getSubPaths (outsidePath root ++ "/pool") >>=+          mapM getSubPaths >>= return . concat >>=+          mapM getSubPaths >>= return . concat >>=+          mapM getSubPaths >>= return . concat+      changesFileList root Pool = getDirectoryPaths (outsidePath root ++ "/installed")+      -- In this case we already got the .changes files from the top directory+      changesFileList root Flat = getDirectoryPaths (outsidePath root) >>= return . filter (isSuffixOf ".changes")+      getSubPaths path = +          do+            isDir <- doesDirectoryExist path+            case isDir of+              False -> return [path]+              True -> getDirectoryPaths path+      getDirectoryPaths dir = getDirectoryContents dir >>= return . filter filterDots >>= return . map ((dir ++ "/") ++)+      filterDots "." = False+      filterDots ".." = False+      filterDots _ = True+      -- upload files only appear when we dupload from a flat repository to another.+      moveToRemoved root file =+          renameFile file (outsidePath root ++ "/removed/" ++ snd (splitFileName file))++-- Repository Accessors and Inquiries++-- | Return a list of all the files in a release which are+-- 'live', in the sense that they appear in some index files.+findLive :: CIO m => LocalRepository -> AptIOT m [FilePath]+findLive (LocalRepository _ Nothing _) = return []	-- Repository is empty+findLive repo@(LocalRepository root (Just layout) _) =+    do releases <- findReleases repo+       sourcePackages <- mapM (lift . DRP.releaseSourcePackages) releases >>= return . map (either (error . show) id) >>= return . concat+       binaryPackages <- mapM (lift . DRP.releaseBinaryPackages) releases >>= return . map (either (error . show) id) >>= return . concat+       let sourceFiles = map ((outsidePath root ++ "/") ++) . concat . map DRP.sourceFilePaths $ sourcePackages+       let binaryFiles =+               map ((outsidePath root ++ "/") ++) . map B.unpack . catMaybes $ map (B.fieldValue "Filename" . packageInfo) binaryPackages+       let changesFiles = concat . map (changesFilePaths root layout releases) $ sourcePackages+       let uploadFiles = concat . map (uploadFilePaths root releases) $ sourcePackages+       return $ sourceFiles ++ binaryFiles ++ changesFiles ++ uploadFiles+    where+      changesFilePaths root Flat releases package =+          map ((outsidePath root ++ "/") ++) . changesFileNames releases $ package+      changesFilePaths root Pool releases package =+          map ((outsidePath root ++ "/installed/") ++) . changesFileNames releases $ package+      changesFileNames releases package = +          map (\ arch -> intercalate "_" [packageName . sourcePackageID $ package,+                                          show . packageVersion . sourcePackageID $ package,+                                          archName arch] ++ ".changes") (nub (concat (architectures releases)))+      uploadFilePaths root releases package = map ((outsidePath root ++ "/") ++) . uploadFileNames releases $ package+      uploadFileNames releases package =+          map (\ arch -> intercalate "_" [packageName . sourcePackageID $ package,+                                          show . packageVersion . sourcePackageID $ package,+                                          archName arch] ++ ".upload") (nub (concat (architectures releases)))+      architectures releases = map head . group . sort . map releaseArchitectures $ releases++-- | Although the PackageID type could refer to source or binary+-- packages, we only export the function to remove source packages.+-- This is in order to avoid leaving around references to removed+-- binary packages in the source index.+deleteSourcePackages :: CIO m => Maybe PGPKey -> [PackageIDLocal] -> m [Release]+deleteSourcePackages keyname packages =+    mapM (deleteSourcePackagesFromIndex keyname) (map indexPair indexGroups)+    where+      indexGroups = group (sortBy compareIndex packages)+      compareIndex a b = compare (packageIndex a) (packageIndex b)+      indexPair group@(package : _) = (packageIndex package, group)+      indexPair [] = error "internal error"++deleteSourcePackagesFromIndex :: CIO m => Maybe PGPKey -> (PackageIndexLocal, [PackageIDLocal]) -> m Release+deleteSourcePackagesFromIndex keyname (index, packages) =+    case (packageIndexArch index, packageIndexRelease index) of+      (_, release@(Release {releaseRepo = LocalRepo repo})) ->+          do -- ePutStr (" Repository.deleteSourcePackageFromIndex (" ++ show packages ++ ")")+             (remove, keep) <- DRP.getPackages index >>= return . either (error . show) id >>= return . partition (testSource . packageID)+             case (remove, keep) of+               ([], _) ->+                   do vPutStrBl 0 ("Packages not found:\n " ++ intercalate "\n " (map F.format packages))+                      vPutStrBl 2 ("Available in " ++ F.format index ++ ":\n " ++ intercalate "\n " (map F.format keep))+                      return release+               (remove, keep) ->+                   -- We found one or more source packages to remove+                   do vPutStrBl 0 ("Removing source packages from " ++ F.format index ++ ": " ++ intercalate " " (map (F.format . packageID) remove))+                      mapM_ (deleteBinaryPackages root) binaryIndexes+                      putIndex root index keep+                      signRelease keyname release+                      return release+          where+            --release = packageIndexRelease index+            --repo = releaseRepo release+            root = repoRoot repo+            binaryIndexes = filter (\ index -> packageIndexArch index /= Source) (packageIndexList release)+            deleteBinaryPackages root binaryIndex =+                do binaryPackages <- DRP.getPackages binaryIndex >>= return . either (error . show) id+                   case partition testBinary binaryPackages of+                     ([], _) -> return $ Right ()+                     (remove, keep) -> +                         do vPutStrBl 0 ("Removing binary packages from " ++ F.format binaryIndex ++ ": " ++ intercalate " " (map (F.format . packageID) remove))+                            putIndex root binaryIndex keep+            -- Is this one of the source packages we are looking for?+            testSource package = elem ((packageName package), (packageVersion package)) versions+            testBinary = testSource . DRP.binaryPackageSourceID+            putIndex :: CIO m => EnvPath -> PackageIndexLocal -> [BinaryPackageLocal] -> m (Either [String] ())+            putIndex root index packages =+                let text = L.fromChunks (formatControl (B.Control (map packageInfo packages))) in+                liftIO $ writeAndZipFileWithBackup (outsidePath root </> packageIndexPath index) text+            -- This is not correct - we need to get the correct version numbers from the binary index file+            -- binaryPackages = map (PackageID (PackageIndex release component arch)) versions+            versions = zip (map packageName packages) (map packageVersion packages)+            --archList = releaseArchitectures release+            --component = packageIndexComponent index+      (Binary _, _) -> error $ "Not a source index: " ++ show index+      (_, release) -> error $ "Not a local release: " ++ show release++instance F.Format PackageID where+    format p = packageName p ++ "=" ++ show (packageVersion p)++instance F.Format PackageIndex where+    format i = +        intercalate "/" [F.format (releaseRepo . packageIndexRelease $ i),+                         "dist",+		         (releaseName' . releaseInfoName . releaseInfo . packageIndexRelease $ i),+		         F.format (packageIndexComponent i),+                         F.format (packageIndexArch i)]++instance F.Format Release where+    format r = F.format (releaseRepo r) ++ " " ++ F.format (releaseInfo r)++instance F.Format Repository where+    format (LocalRepo r) = outsidePath (repoRoot r)+    format (VerifiedRepo s _) = s+    format (UnverifiedRepo s) = s++instance F.Format ReleaseInfo where+    format r = intercalate " " (releaseName' (releaseInfoName r) : map F.format (releaseInfoComponents r))++instance F.Format Section where+    format (Section s) = s++instance F.Format Arch where+    format x@(Binary _) = "binary-" ++ archName x+    format x = archName x++instance F.Format BinaryPackage where+    format p = F.format (packageID p)
+ Debian/Repo/LocalRepository.hs view
@@ -0,0 +1,151 @@+module Debian.Repo.LocalRepository where++import qualified Debian.Control.ByteString as B	-- required despite warning+import qualified Debian.Control.String as S+import Debian.Repo.IO+import Debian.Repo.Types+--import Debian.Release+                   +import Control.Monad.Trans+import Control.Monad.State (get, put)+import Extra.CIO+import Control.Monad+import qualified Data.ByteString.Char8 as B+import Data.List+import Data.Maybe+import Extra.Files+import Extra.List(partitionM)+import System.FilePath+import System.Unix.Directory+import System.Directory+import System.IO+import qualified System.Posix.Files as F+import Text.Regex+  +-- | Create or update the compatibility level file for a repository.+setRepositoryCompatibility :: LocalRepository -> IO ()+setRepositoryCompatibility (LocalRepository root _ _) =+    maybeWriteFile path text+    where text = show libraryCompatibilityLevel ++ "\n"+          path = outsidePath root </> compatibilityFile++-- | Return the subdirectory where a source package with the given+-- section and name would be installed given the layout of the+-- repository.+poolDir :: LocalRepository -> Section -> String -> FilePath+poolDir (LocalRepository _ (Just Pool) _) section source =+    "pool/" ++ sectionName' section </> prefixDir </> source+    where prefixDir =+              if isPrefixOf "lib" source then+                  take (min 4 (length source)) source else+                  take (min 1 (length source)) source+poolDir (LocalRepository _ _ _) _ _ = ""++-- | Remove all the packages from the repository and then re-create+-- the empty releases.+flushLocalRepository :: CIO m => LocalRepository -> AptIOT m LocalRepository+flushLocalRepository (LocalRepository path layout _) =+    do liftIO $ removeRecursiveSafely (outsidePath path)+       prepareLocalRepository path layout++-- | Create or verify the existance of the directories which will hold+-- a repository on the local machine.  Verify the index files for each of+-- its existing releases.+prepareLocalRepository :: CIO m => EnvPath -> Maybe Layout -> AptIOT m LocalRepository+prepareLocalRepository root layout =+    do lift (vPutStrBl 3 $ "Preparing local repository at " ++ outsidePath root)+       mapM_ (liftIO . initDir)+                 [(".", 0o40755),+                  ("dists", 0o40755),+                  ("incoming", 0o41755),+                  ("removed", 0o40750),+                  ("reject", 0o40750)]+       layout' <- lift (liftIO (computeLayout (outsidePath root))) >>= (return . maybe layout Just)+                  -- >>= return . maybe (maybe (error "No layout specified for new repository") id layout) id+       mapM_ (liftIO . initDir)+                 (case layout' of+                    Just Pool -> [("pool", 0o40755), ("installed", 0o40755)]+                    Just Flat -> []+                    Nothing -> [])+       readLocalRepo root layout'+    where+      initDir (name, mode) = +          do let path = outsidePath root </> name+             filterM (\ f -> doesDirectoryExist f >>= return . not) [path] >>=+                     mapM_ (\ f -> createDirectoryIfMissing True f)+             actualMode <- F.getFileStatus path >>= return . F.fileMode+             when (mode /= actualMode) (F.setFileMode path mode)+{-      notSymbolicLink root name =+          getSymbolicLinkStatus (root ++ "/dists/" ++ name) >>= return . not . isSymbolicLink+      hasReleaseFile root name =+          doesFileExist (root ++ "/dists/" ++ name ++ "/Release") -}++readLocalRepo :: CIO m => EnvPath -> Maybe Layout -> AptIOT m LocalRepository+readLocalRepo root layout =+    do+      state <- get+      names <- liftIO (getDirectoryContents distDir) >>=+               return . filter (\ x -> not . elem x $ [".", ".."])+      (links, dists) <- partitionM (liftIO . isSymLink . (distDir </>)) names+      linkText <- mapM (liftIO . F.readSymbolicLink) (map (distDir </>) links)+      let aliasPairs = zip linkText links ++ map (\ dist -> (dist, dist)) dists+      let distGroups = groupBy fstEq . sort $ aliasPairs+      let aliases = map (checkAliases  . partition (uncurry (==))) distGroups+      releaseInfo <- mapM (lift . getReleaseInfo) aliases+      let repo = LocalRepository { repoRoot = root+                                 , repoLayout = layout+                                 , repoReleaseInfoLocal = releaseInfo }+      put (insertRepository (repoURI repo) (LocalRepo repo) state)+      return repo+    where+      fstEq (a, _) (b, _) = a == b+      checkAliases :: ([(String, String)], [(String, String)]) -> (ReleaseName, [ReleaseName])+      checkAliases ([(realName, _)], aliases) = (parseReleaseName realName, map (parseReleaseName . snd) aliases)+      checkAliases _ = error "Symbolic link points to itself!"+      getReleaseInfo :: CIO m => (ReleaseName, [ReleaseName]) -> m ReleaseInfo+      getReleaseInfo (dist, aliases) = parseReleaseFile (releasePath dist) dist aliases+      releasePath dist = distDir </> releaseName' dist ++ "/Release"+      distDir = outsidePath root ++ "/dists"++parseReleaseFile :: CIO m => FilePath -> ReleaseName -> [ReleaseName] -> m ReleaseInfo+parseReleaseFile path dist aliases =+    do text <- liftIO (B.readFile path)+       return $ parseRelease path text dist aliases++parseRelease :: FilePath -> B.ByteString -> ReleaseName -> [ReleaseName] -> ReleaseInfo+parseRelease file text name aliases =+    case either (error . show) id (B.parseControl file text) of+      S.Control [] -> error $ "Empty release file: " ++ file+      S.Control (info : _) -> makeReleaseInfo file info name aliases++makeReleaseInfo :: FilePath -> B.Paragraph -> ReleaseName -> [ReleaseName] -> ReleaseInfo+makeReleaseInfo file info name aliases =+    case (B.fieldValue "Architectures" info, B.fieldValue "Components" info) of+      (Just archList, Just compList) ->+          case (splitRegex re (B.unpack archList), splitRegex re (B.unpack compList)) of+            (architectures@(_ : _), components@(_ : _)) ->+                ReleaseInfo { releaseInfoName = name+                            , releaseInfoAliases = aliases+                            , releaseInfoArchitectures = map Binary architectures+                            , releaseInfoComponents = map Section components }+            _ -> error $ "Invalid Architectures or Components field in Release file " ++ file+      _ -> error $ "Missing Architectures or Components field in Release file " ++ file+    where+      re = mkRegex "[ ,]+"++isSymLink path = F.getSymbolicLinkStatus path >>= return . F.isSymbolicLink++-- |Try to determine a repository's layout.+computeLayout :: FilePath -> IO (Maybe Layout)+computeLayout root =+    do+      -- If there are already .dsc files in the root directory+      -- the repository layout is Flat.+      isFlat <- getDirectoryContents root >>= return . (/= []) . catMaybes . map (matchRegex (mkRegex "\\.dsc$"))+      -- If the pool directory already exists the repository layout is+      -- Pool.+      isPool <- doesDirectoryExist (root ++ "/pool")+      case (isFlat, isPool) of+        (True, _) -> return (Just Flat)+        (False, True) -> return (Just Pool)+        _ -> return Nothing
+ Debian/Repo/OSImage.hs view
@@ -0,0 +1,488 @@+module Debian.Repo.OSImage +    ( OSImage(..)+    , prepareEnv+    , updateEnv+    , syncPool+    , chrootEnv+    , syncEnv+    , neuterEnv+    , restoreEnv+    , removeEnv+    , buildEssential+    ) where++import		 Control.Monad.Trans+import		 Control.Exception+import		 Control.Monad+import qualified Data.ByteString.Lazy.Char8 as L+import		 Data.List+import		 Data.Maybe+import		 Debian.Extra.CIO (vMessage)+import		 Debian.Repo.Cache+import		 Debian.Repo.IO+import		 Debian.Repo.Package+import		 Debian.Relation+import		 Debian.Repo.Slice+import		 Debian.Repo.SourcesList+import		 Debian.Repo.Types+import		 Debian.Shell (timeTask, vOutput, runTaskAndTest, SimpleTask(..))+import		 Extra.CIO (CIO, vPutStr, vPutStrBl, vBOL, ePutStr)+import		 Extra.Files (replaceFile)+import		 Extra.List (isSublistOf)+import		 Extra.Misc (sameInode, sameMd5sum)+import		 Extra.SSH (sshCopy)+import		 System.FilePath+import		 System.Unix.Directory+import		 System.Unix.Mount+import		 System.Unix.Process+import		 System.Cmd+import		 System.Directory+import qualified System.IO as IO+import		 System.Posix.Files+import		 System.Time+import		 Text.Regex++-- |This type represents an OS image located at osRoot built from a+-- particular osBaseDistro using a particular osArch.  If an+-- osLocalRepo argument is given, that repository will be copied into+-- the environment and kept in sync, and lines will be added to+-- sources.list to point to it.+data OSImage+    = OS { osGlobalCacheDir :: FilePath+         , osRoot :: EnvRoot+         , osBaseDistro :: SliceList+         , osReleaseName :: ReleaseName+         , osArch :: Arch+	 -- | The associated local repository, where packages we+         -- build inside this image are first uploaded to.+         , osLocalRepoMaster :: Maybe LocalRepository+         -- |A copy of osLocalRepo which is inside the changeroot+         --, osLocalRepoCopy :: Maybe LocalRepo+         -- | Update and return a copy of the local repository+         -- which is inside the changeroot.+         , osSourcePackages :: [SourcePackage]+         , osBinaryPackages :: [BinaryPackage]+         }++instance Show OSImage where+    show os = intercalate " " ["OS {",+                               rootPath (osRoot os),+                               relName (osReleaseName os),+                               archName (osArch os),+                               show (osLocalRepoMaster os)]++instance Ord OSImage where+    compare a b = case compare (osRoot a) (osRoot b) of+                    EQ -> case compare (osBaseDistro a) (osBaseDistro b) of+                            EQ -> compare (osArch a) (osArch b)+                            x -> x+                    x -> x++instance Eq OSImage where+    a == b = compare a b == EQ++instance AptCache OSImage where+    globalCacheDir = osGlobalCacheDir+    rootDir = osRoot+    aptArch = osArch +    -- aptSliceList = osFullDistro+    aptBaseSliceList = osBaseDistro+    aptSourcePackages = osSourcePackages                  +    aptBinaryPackages = osBinaryPackages+    aptReleaseName = osReleaseName++instance AptBuildCache OSImage where+    aptSliceList = osFullDistro++-- |The sources.list is the list associated with the distro name, plus+-- the local sources where we deposit newly built packages.+osFullDistro :: OSImage -> SliceList+osFullDistro os = SliceList { slices = slices (osBaseDistro os) ++ slices (localSources os) }++localSources :: OSImage -> SliceList+localSources os =+    case osLocalRepoMaster os of+      Nothing -> SliceList { slices = [] }+      Just repo ->+          let repo' = repoCD (EnvPath (envRoot (repoRoot repo)) "/work/localpool") repo in+          let name = relName (osReleaseName os) in+          let src = DebSource Deb (repoURI repo') (Right (parseReleaseName name, [parseSection' "main"]))+              bin = DebSource DebSrc (repoURI repo') (Right (parseReleaseName name, [parseSection' "main"])) in+          SliceList { slices = [Slice { sliceRepo = LocalRepo repo', sliceSource = src }, +                                Slice { sliceRepo = LocalRepo repo', sliceSource = bin }] }++-- |Change the root directory of a repository.  FIXME: This should+-- also sync the repository to ensure consistency.+repoCD :: EnvPath -> LocalRepository -> LocalRepository+repoCD path repo = repo { repoRoot = path }++getSourcePackages :: CIO m => OSImage -> AptIOT m [SourcePackage]+getSourcePackages os =+    mapM (sourcePackagesOfIndex' os) indexes >>= return . concat+    where indexes = concat . map (sliceIndexes os) . slices . sourceSlices . aptSliceList $ os++getBinaryPackages :: CIO m => OSImage -> AptIOT m [BinaryPackage]+getBinaryPackages os =+    mapM (binaryPackagesOfIndex' os) indexes >>= return . concat+    where indexes = concat . map (sliceIndexes os) . slices . binarySlices . aptSliceList $ os++-- |Create or update an OS image in which packages can be built.+prepareEnv :: CIO m+           => FilePath+           -> EnvRoot			-- ^ The location where image is to be built+           -> NamedSliceList		-- ^ The sources.list+           -> Maybe LocalRepository	-- ^ The associated local repository, where newly+					-- built packages are stored.  This repository is+					-- periodically copied into the build environment+					-- so apt can access the packages in it.+           -> Bool			-- ^ If true, remove and rebuild the image+           -> SourcesChangedAction	-- ^ What to do if called with a sources.list that+					-- differs from the previous call (unimplemented)+           -> [String]			-- ^ Extra packages to treat as essential+           -> [String]			-- ^ Packages to consider non-essential even if marked essential  +           -> [String]			-- ^ Extra packages to install during the build+           -> AptIOT m OSImage+prepareEnv cacheDir root distro repo flush _ifSourcesChanged extraEssential omitEssential extra =+    do arch <- liftIO buildArchOfRoot+       --vPutStrLn 0 $ "prepareEnv repo: " ++ show repo+       let os = OS { osGlobalCacheDir = cacheDir+                   , osRoot = root+                   , osBaseDistro = sliceList distro+                   , osReleaseName = ReleaseName . sliceName . sliceListName $ distro+                   , osArch = arch+                   , osLocalRepoMaster = repo+                   , osSourcePackages = []+                   , osBinaryPackages = [] }+       update os >>= recreate arch os >>= lift . syncPool+    where+      update _ | flush = return $ Left "--flush option given"+      update os = updateEnv os+      recreate _ _ (Right os) = return os+      recreate arch os (Left reason) =+          do lift (vPutStrBl 0 $ "Removing and recreating build environment at " ++ rootPath root ++ ": " ++ reason)+             lift (vPutStrBl 2 ("removeRecursiveSafely " ++ rootPath root))+             liftIO (removeRecursiveSafely (rootPath root))+             lift (vPutStrBl 2 ("createDirectoryIfMissing True " ++ show (distDir os)))+             liftIO (createDirectoryIfMissing True (distDir os))+             lift (vPutStrBl 3 ("writeFile " ++ show (sourcesPath os) ++ " " ++ show (show . osBaseDistro $ os)))+             liftIO (replaceFile (sourcesPath os) (show . osBaseDistro $ os))+             buildEnv cacheDir root distro arch repo extraEssential omitEssential extra >>= lift . neuterEnv >>= lift . syncPool++-- |Prepare a minimal \/dev directory+prepareDevs :: FilePath -> IO ()+prepareDevs root = do+  mapM_ prepareDev +            ([(root ++ "/dev/null", "c", 1, 3),+              (root ++ "/dev/zero", "c", 1, 5),+              (root ++ "/dev/full", "c", 1, 7),+              (root ++ "/dev/console", "c", 5, 1),+              (root ++ "/dev/random", "c", 1, 8),+              (root ++ "/dev/urandom", "c", 1, 9)] +++             (map (\ n -> (root ++ "/dev/loop" ++ show n, "b", 7, n)) [0..7]) +++             (map (\ n -> (root ++ "/dev/loop/" ++ show n, "b", 7, n)) [0..7]))+  where+    prepareDev (path, typ, major, minor) = do+                     createDirectoryIfMissing True (fst (splitFileName path))+                     let cmd = "mknod " ++ path ++ " " ++ typ ++ " " ++ show major ++ " " ++ show minor+                     exists <- doesFileExist path+                     if not exists then+                         system cmd else+                         return ExitSuccess++-- Create a new clean build environment in root.clean+-- FIXME: create an ".incomplete" flag and remove it when build-env succeeds+buildEnv :: CIO m+         => FilePath+         -> EnvRoot+         -> NamedSliceList+         -> Arch+         -> Maybe LocalRepository+         -> [String]+         -> [String]+         -> [String]+         -> AptIOT m OSImage+buildEnv cacheDir root distro arch repo extraEssential omitEssential extra =+    do+      -- We can't create the environment if the sources.list has any+      -- file:// URIs because they can't yet be visible inside the+      -- environment.  So we grep them out, create the environment, and+      -- then add them back in.+      (output, result) <-+          liftIO (lazyCommand cmd L.empty) >>=+          lift . vMessage 0 ("Creating clean build environment (" ++ sliceName (sliceListName distro) ++ ")") >>=+          lift . vMessage 1 ("# " ++ cmd) >>=+          lift . vOutput 1 >>=+          return . collectStderr . mergeToStderr+      case result of+        -- It is fatal if we can't build the environment+        [Result ExitSuccess] ->+            do lift (ePutStr "done.\n")+               let os = OS { osGlobalCacheDir = cacheDir+                           , osRoot = root+                           , osBaseDistro = sliceList distro+                           , osReleaseName = ReleaseName . sliceName . sliceListName $ distro+                           , osArch = arch+                           , osLocalRepoMaster = repo+                           , osSourcePackages = []+                           , osBinaryPackages = [] }+               let sourcesPath = rootPath root ++ "/etc/apt/sources.list"+               -- Rewrite the sources.list with the local pool added.+               liftIO $ replaceFile sourcesPath (show . aptSliceList $ os)+               updateEnv os >>= either (error . show) return+        failure ->+            (lift . ePutStr . L.unpack $ output) >>+            error ("Could not create build environment:\n " ++ cmd ++ " -> " ++ show failure)+    where+      cmd = ("unset LANG; build-env --allow-missing-indexes --immediate-configure-false " +++             " -o " ++ rootPath root ++ " -s " ++ cacheSourcesPath cacheDir (ReleaseName (sliceName (sliceListName distro))) +++             " --with '" ++ intercalate " " extra ++ "'" +++             " --with-essential '" ++ intercalate " " extraEssential ++ "'" +++             " --omit-essential '" ++ intercalate " " omitEssential ++ "'")++-- |Try to update an existing build environment: run apt-get update+-- and dist-upgrade.+updateEnv :: CIO m => OSImage -> AptIOT m (Either String OSImage)+updateEnv os =+    do verified <- verifySources os+       case verified of+         Left x -> return $ Left x+         Right _ ->+             do liftIO $ prepareDevs (rootPath root)+                os' <- lift $ syncPool os+                liftIO $ sshCopy (rootPath root)+                source <- getSourcePackages os'+                binary <- getBinaryPackages os'+                return . Right $ os' {osSourcePackages = source, osBinaryPackages = binary}+    where+      verifySources :: CIO m => OSImage -> AptIOT m (Either String OSImage)+      verifySources os =+          do let correct = aptSliceList os+                 sourcesPath = rootPath root ++ "/etc/apt/sources.list"+             text <- liftIO (try $ readFile sourcesPath)+             installed <-+                 case text of+                   Left _ -> return Nothing+                   Right s -> verifySourcesList (Just root) (parseSourcesList s) >>= return . Just+             case installed of+               Nothing -> return $ Left ("No sources.list for " ++ relName (osReleaseName os) ++ " at " ++ sourcesPath)+               Just installed+                   | installed /= correct ->+                       return $ Left ("Sources for " ++ relName (osReleaseName os) ++ " in " ++ sourcesPath +++                                      " don't match computed configuration.\n\ncomputed:\n" +++                                      show correct ++ "\ninstalled:\n" ++ +                                      show installed)+               _ -> return $ Right os+      root = osRoot os++chrootEnv :: OSImage -> EnvRoot -> OSImage+chrootEnv os dst = os {osRoot=dst}++-- Sync the environment from the clean copy.  All this does besides+-- performing the proper rsync command is to make sure the destination+-- directory exists, otherwise rsync will fail.  Not sure why the 'work'+-- subdir is appended.  There must have been a reason at one point.+syncEnv :: CIO m => OSImage -> OSImage -> m OSImage+syncEnv src dst =+    mkdir >>= liftIO . umount >>= sync >>= either (error . show) (const (return dst))+{-+    either (return . Left . show) (const (liftIO doUmounts)) >>=+    either (return . Left) (const . syncStyle . runCommand 1 $ cmd) >>=+    either (error . show) (const (return dst))+-}+    where+      mkdir = liftIO (try (createDirectoryIfMissing True (rootPath (osRoot dst) ++ "/work")))+      umount (Left message) = return . Left . show $ message+      umount (Right _) =+          do srcResult <- umountBelow (rootPath (osRoot src))+             dstResult <- umountBelow (rootPath (osRoot dst))+             case filter (\ (_, (_, _, code)) -> code /= ExitSuccess) (srcResult ++ dstResult) of+               [] -> return (Right ())+               failed -> return . Left $ "umount failure(s): " ++ show failed+      sync (Left message) = return (Left message)+      sync (Right _) =+          runTaskAndTest (SimpleTask 1 cmd) >>=+          vMessage 0 ("Copying clean build environment: " +++                      rootPath (osRoot src) ++ " -> " ++ rootPath (osRoot dst))+      cmd = ("rsync -aHxSpDt '--exclude=/work/build/**' --delete '" ++ rootPath (osRoot src) +++             "/' '" ++ rootPath (osRoot dst) ++ "'")+{-+      syncStyle = setStyle (setStart (Just ("Copying clean build environment: " +++                                            rootPath (osRoot src) ++ " -> " ++ rootPath (osRoot dst))) .+                            setError (Just "Could not sync with clean build environment"))+-}++-- |To "neuter" an executable is to replace it with a hard link to+-- \/bin\/true in such a way that the operation can be reversed.  This+-- is done in order to make it safe to install files into it when it+-- isn't "live".  If this operation fails it is assumed that the+-- image is damaged, so it is removed.+neuterEnv :: CIO m => OSImage -> m OSImage+neuterEnv os =+    do+      vBOL 0 >> vPutStr 0 ("Neutering OS image (" ++ stripDist (rootPath root) ++ ")...")+      result <- liftIO $ try $ mapM_ (neuterFile os) neuterFiles+      either (\ e -> error $ "Failed to neuter environment " ++ rootPath root ++ ": " ++ show e)+             (\ _ -> return os)+             result+    where+      root = osRoot os++neuterFiles :: [(FilePath, Bool)]+neuterFiles = [("/sbin/start-stop-daemon", True),+	       ("/usr/sbin/invoke-rc.d", True),+	       ("/sbin/init",False),+	       ("/usr/sbin/policy-rc.d", False)]++-- neuter_file from build-env.ml+neuterFile :: OSImage -> (FilePath, Bool) -> IO ()+neuterFile os (file, mustExist) =+    do+      -- putStrBl ("Neutering file " ++ file)+      exists <- doesFileExist (outsidePath fullPath)+      if exists then+          neuterExistantFile else+          if mustExist then+              error ("Can't neuter nonexistant file: " ++ outsidePath fullPath) else+              return () -- putStrBl "File doesn't exist, nothing to do"++    where+      neuterExistantFile =+          do+            sameFile <- sameInode (outsidePath fullPath) (outsidePath binTrue)+            if sameFile then+                return () else -- putStrBl "File already neutered"+                neuterUnneuteredFile+      neuterUnneuteredFile =+          do+            hasReal <- doesFileExist (outsidePath fullPath ++ ".real")+            if hasReal then+                neuterFileWithRealVersion else+                neuterFileWithoutRealVersion+            createLink (outsidePath binTrue) (outsidePath fullPath)+      neuterFileWithRealVersion =+          do+            sameCksum <- sameMd5sum (outsidePath fullPath) (outsidePath fullPath ++ ".real")+            if sameCksum then+                removeFile (outsidePath fullPath) else+                error (file ++ " and " ++ file ++ ".real differ (in " ++ rootPath root ++ ")")+                           +      neuterFileWithoutRealVersion = renameFile (outsidePath fullPath) (outsidePath fullPath ++ ".real")++      fullPath = EnvPath root file+      binTrue = EnvPath root "/bin/true"+      root = osRoot os++-- |Reverse the neuterEnv operation.+restoreEnv :: OSImage -> IO OSImage+restoreEnv os =+    do+      IO.hPutStr IO.stderr "De-neutering OS image..."+      result <- try $ mapM_ (restoreFile os) neuterFiles+      either (\ e -> error $ "damaged environment " ++ rootPath root ++ ": " ++ show e ++ "\n  please remove it.")+                 (\ _ -> return os) result+    where+      root = osRoot os++-- check_and_restore from build-env.ml+restoreFile :: OSImage -> (FilePath, Bool) -> IO ()+restoreFile os (file, mustExist) =+    do+      exists <- doesFileExist (outsidePath fullPath)+      if exists then+          restoreExistantFile else+          if mustExist then+              error ("Can't restore nonexistant file: " ++ outsidePath fullPath) else+              return ()+    where+      restoreExistantFile =+          do+            isTrue <- sameInode (outsidePath fullPath) (outsidePath binTrue)+            hasReal <- doesFileExist (outsidePath fullPath ++ ".real")+            case (isTrue, hasReal) of+              (True, True) ->+                  do+                    removeFile (outsidePath fullPath)+                    renameFile (outsidePath fullPath ++ ".real") (outsidePath fullPath)+              (False, _) -> error "Can't restore file not linked to /bin/true"+              (_, False) -> error "Can't restore file with no .real version"++      fullPath = EnvPath root file+      binTrue = EnvPath root "/bin/true"+      root = osRoot os++-----------------------------------++-- |Build the dependency relations for the build essential packages.+-- For this to work the build-essential package must be installed in+-- the OSImage.+buildEssential :: OSImage -> Bool -> IO Relations+buildEssential _ True = return []+buildEssential os False =+    do+      essential <-+          readFile (rootPath root ++ "/usr/share/build-essential/essential-packages-list") >>=+          return . lines >>= return . dropWhile (/= "") >>= return . tail >>= return . filter (/= "sysvinit") >>=+          return . parseRelations . (intercalate ", ") >>=+          return . (either (error "parse error in /usr/share/build-essential/essential-packages-list") id)+      let re = mkRegex "^[^ \t]"+      relationText <-+          readFile (rootPath root ++ "/usr/share/build-essential/list") >>=+          return . lines >>=+          return . dropWhile (/= "BEGIN LIST OF PACKAGES") >>= return . tail >>=+          return . takeWhile (/= "END LIST OF PACKAGES") >>=+          return . filter ((/= Nothing) . (matchRegex re))+      -- ePut ("buildEssentialText: " ++ intercalate ", " relationText)+      let buildEssential = parseRelations (intercalate ", " relationText)+      let buildEssential' = either (\ l -> error ("parse error in /usr/share/build-essential/list:\n" ++ show l)) id buildEssential+      return (essential ++ buildEssential')+    where+      root = osRoot os++-- |Remove an image.  The removeRecursiveSafely function is used to+-- ensure that any file systems mounted inside the image are unmounted+-- instead of destroyed.+removeEnv :: OSImage -> IO ()+removeEnv os =+    do+      IO.hPutStr IO.stderr "Removing build environment..."+      removeRecursiveSafely (rootPath root)+      IO.hPutStrLn IO.stderr "done."+    where+      root = osRoot os++-- |Use rsync to synchronize the pool of locally built packages from +-- outside the build environment to the location inside the environment+-- where apt can see and install the packages.+syncPool :: CIO m => OSImage -> m OSImage+syncPool os =+    case osLocalRepoMaster os of+      Nothing -> return os+      Just repo ->+          liftIO (try (createDirectoryIfMissing True (rootPath root ++ "/work"))) >>=+          either (return . Left . show) (const (rsync repo)) >>=+          either (return . Left) (const (updateLists os)) >>=+          either (error . show) (const (return os))+    where+      rsync repo =+          liftIO (lazyCommand (cmd repo) L.empty) >>=+               	      vOutput 0 >>=+                      vMessage 1 ("Syncing local pool from " ++ outsidePath (repoRoot repo) ++ " -> " ++ rootPath root) >>= +                      checkResult (\ n -> return (Left $ "*** FAILURE syncing local pool: " ++ cmd repo ++ " -> " ++ show n)) (return (Right ()))+      cmd repo = "rsync -aHxSpDt --delete '" ++ outsidePath (repoRoot repo) ++ "/' '" ++ rootPath root ++ "/work/localpool'"+      root = osRoot os++updateLists :: CIO m => OSImage -> m (Either String TimeDiff)+updateLists os =+    do vMessage 1 ("Updating OSImage " ++ stripDist (rootPath root) ++ " ") ()+       vMessage 2 ("# " ++ cmd) ()+       ((out, err, code), elapsed) <- liftIO . timeTask $ lazyCommand cmd L.empty >>= return . collectOutputUnpacked+       return $ case code of+                  [ExitSuccess] -> Right elapsed+                  result -> Left $ "*** FAILURE: Could not update environment: " ++ cmd ++ " -> " ++ show result ++ "\n" ++ err+    where+      cmd = ("echo $PATH 1>&2 && /usr/sbin/chroot " ++ rootPath root ++ +             " bash -c 'unset LANG; apt-get update && apt-get -y --force-yes dist-upgrade'")+      root = osRoot os+    +stripDist :: FilePath -> FilePath+stripDist path = maybe path (\ n -> drop (n + 7) path) (isSublistOf "/dists/" path)
+ Debian/Repo/Package.hs view
@@ -0,0 +1,332 @@+module Debian.Repo.Package+    ( -- * Source and binary packages +      sourceFilePaths+    , binaryPackageSourceVersion+    , binarySourceVersion+    , sourcePackageBinaryNames+    , sourceBinaryNames+    , toSourcePackage+    , toBinaryPackage+    , binaryPackageSourceID+    , sourcePackageBinaryIDs+    , sourcePackagesOfIndex+    , sourcePackagesOfIndex'+    , binaryPackagesOfIndex+    , binaryPackagesOfIndex'+    , getPackages+    , putPackages+    , releaseSourcePackages+    , releaseBinaryPackages+    -- * Deprecated stuff for interfacing with Debian.Relation+    ) where++import Debian.Apt.Index (Compression(..), controlFromIndex)+import Debian.Control+import Debian.Repo.PackageIndex+import qualified Debian.Control.ByteString as B+import qualified Debian.Relation.ByteString as B+import Debian.Repo.IO+import Debian.Shell+import Debian.Repo.Types+import Debian.URI+import Debian.Version++import Control.Exception (Exception(..))+import Control.Monad.Trans+import Control.Monad.State (get, put)+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as B+import Data.List+import Data.Maybe+import qualified Extra.Either as EE+import qualified Extra.Files as EF+import Extra.CIO (CIO(..), vEPutStrBl)+import System.Directory+import System.FilePath((</>))+import System.IO.Unsafe+import System.Posix+import System.Unix.Process+import Text.Regex++sourceFilePaths :: SourcePackage -> [FilePath]+sourceFilePaths package =+    map ((sourceDirectory package) </>) . map sourceFileName . sourcePackageFiles $ package++-- | Return the name and version number of the source package that+-- generated this binary package.  +binaryPackageSourceVersion :: BinaryPackage -> Maybe (String, DebianVersion)+binaryPackageSourceVersion package =+    let binaryName = packageName . packageID $ package+        binaryVersion = packageVersion . packageID $ package in+    binarySourceVersion' binaryName binaryVersion (packageInfo package)++-- |Return the name and version number of the source package that+-- generated this binary package.+-- see also: 'binaryPackageSourceVersion'+binarySourceVersion :: B.Paragraph -> Maybe ((String, DebianVersion), (String, DebianVersion))+binarySourceVersion paragraph =+    let mBinaryName = fmap B.unpack $ fieldValue "Package" paragraph+        mBinaryVersion = fmap (parseDebianVersion . B.unpack) $ fieldValue "Version" paragraph+    in+      case (mBinaryName, mBinaryVersion) of+        (Just binaryName, Just binaryVersion) ->+            fmap ((,) (binaryName, binaryVersion)) $ binarySourceVersion' binaryName binaryVersion paragraph+        _ -> Nothing++binarySourceVersion' :: (ControlFunctions a) => String -> DebianVersion -> Paragraph' a -> Maybe (String, DebianVersion)+binarySourceVersion' binaryName binaryVersion paragraph =+    case (B.fieldValue "Source" paragraph) of+      Just source ->+          case matchRegex re (asString source) of+            Just [name, _, ""] -> Just (name, binaryVersion)+            Just [name, _, version] -> Just (name, parseDebianVersion version)+            _ -> error "internal error"+      Nothing ->+          Just (asString binaryName, binaryVersion)+    where+      re = mkRegex "^[ ]*([^ (]*)[ ]*(\\([ ]*([^ )]*)\\))?[ ]*$"++sourcePackageBinaryNames :: SourcePackage -> [String]+sourcePackageBinaryNames package =+    sourceBinaryNames (sourceParagraph package)++sourceBinaryNames :: B.Paragraph -> [String]+sourceBinaryNames paragraph = +    case B.fieldValue "Binary" paragraph of+      Just names -> splitRegex (mkRegex "[ ,]+") (B.unpack names)+      _ -> error ("Source package info has no 'Binary' field:\n" ++ (B.unpack . formatParagraph $ paragraph))++toSourcePackage :: PackageIndex -> B.Paragraph -> SourcePackage+toSourcePackage index package =+    case (B.fieldValue "Directory" package,+          B.fieldValue "Files" package,+          B.fieldValue "Package" package,+          maybe Nothing (Just . parseDebianVersion . B.unpack) (B.fieldValue "Version" package)) of+      (Just directory, Just files, Just name, Just version) ->+          case parseSourcesFileList files of+            Right files ->+                SourcePackage+                { sourcePackageID =+                      PackageID+                      { packageIndex = index+                      , packageName = B.unpack name+                      , packageVersion = version }+                , sourceParagraph = package+                , sourceDirectory = B.unpack directory+                , sourcePackageFiles = files }+            Left messages -> error $ "Invalid file list: " ++ show messages+      _ -> error $ "Missing info in source package control information:\n" ++ B.unpack (formatParagraph package)+    where      +      -- Parse the list of files in a paragraph of a Sources index.+      parseSourcesFileList :: B.ByteString -> Either [String] [SourceFileSpec]+      parseSourcesFileList text =+          merge . catMaybes . map parseSourcesFiles . lines . B.unpack $ text+      parseSourcesFiles line =+          case words line of+            [md5sum, size, name] -> Just (Right (SourceFileSpec md5sum (read size) name))+            [] -> Nothing+            _ -> Just (Left ("Invalid line in Files list: '" ++ show line ++ "'"))+      merge x = case partition (either (const True) (const False)) x of+                  (a, []) -> Left . catMaybes . map (either Just (const Nothing )) $ a+                  (_, a) -> Right . catMaybes . map (either (const Nothing) Just) $ a++toBinaryPackage :: PackageIndex -> B.Paragraph -> BinaryPackage+toBinaryPackage index p =+    case (B.fieldValue "Package" p, B.fieldValue "Version" p) of+      (Just name, Just version) ->+          BinaryPackage +          { packageID = PackageID { packageIndex = index+                                  , packageName = B.unpack name+                                  , packageVersion = parseDebianVersion (B.unpack version) }+          , packageInfo = p+          , pDepends = tryParseRel $ B.lookupP "Depends" p+          , pPreDepends = tryParseRel $ B.lookupP "Pre-Depends" p+          , pConflicts = tryParseRel $ B.lookupP "Conflicts" p+          , pReplaces =  tryParseRel $ B.lookupP "Replaces" p+          , pProvides =  tryParseRel $ B.lookupP "Provides" p+          }+      _ -> error ("Invalid data in source index:\n " ++ packageIndexPath index)++tryParseRel :: Maybe B.Field -> B.Relations+tryParseRel (Just (B.Field (_, relStr))) = either (error . show) id (B.parseRelations relStr)+tryParseRel _ = []++-- | Parse the /Source/ field of a binary package's control+-- information, this may specify a version number for the source+-- package if it differs from the version number of the binary+-- package.+binaryPackageSourceID :: BinaryPackage -> PackageID+binaryPackageSourceID package =+    case maybe Nothing (matchRegex re . B.unpack) (B.fieldValue "Source" (packageInfo package)) of+      Just [name, _, ""] -> PackageID { packageIndex = sourceIndex+                                      , packageName = name+                                      , packageVersion = packageVersion id }+      Just [name, _, version] -> PackageID { packageIndex = sourceIndex+                                           , packageName = name+                                           , packageVersion = parseDebianVersion version }+      _ -> error "Missing Source attribute in binary package info"+    where+      sourceIndex = PackageIndex release component Source+      (PackageIndex release component _) = packageIndex id+      id = packageID package+      re = mkRegex "^[ ]*([^ (]*)[ ]*(\\([ ]*([^ )]*)\\))?[ ]*$"++sourcePackageBinaryIDs :: Arch -> SourcePackage -> [PackageID]+sourcePackageBinaryIDs Source _ = error "invalid argument"+sourcePackageBinaryIDs arch package =+    case (B.fieldValue "Version" info, B.fieldValue "Binary" info) of+      (Just version, Just names) -> map (binaryID (parseDebianVersion (B.unpack version))) $ splitRegex (mkRegex "[ ,]+") (B.unpack names)+      _ -> error ("Source package info has no 'Binary' field:\n" ++ (B.unpack . formatParagraph $ info))+    where+      -- Note that this version number may be wrong - we need to+      -- look at the Source field of the binary package info.+      binaryID version name = PackageID { packageIndex = binaryIndex+                                        , packageName = name+                                        , packageVersion = version }+      sourceIndex = packageIndex (sourcePackageID package)+      binaryIndex = sourceIndex { packageIndexArch = arch }+      info = sourceParagraph package++-- | Get the contents of a package index+getPackages :: CIO m => PackageIndex -> m (Either Exception [BinaryPackage])+getPackages index =+    liftIO (fileFromURI (uri {uriPath = uriPath uri </> packageIndexPath index ++ ".gz"})) >>=+    return . either Left (\ s -> case controlFromIndex GZ (show uri) s of+                                   Left e -> Left (ErrorCall (show e))+                                   Right (B.Control control) -> Right $ map (toBinaryPackage index) control)+    where+      uri = repoURI repo+      release = packageIndexRelease index+      repo = releaseRepo release++-- | Get the contents of a package index+binaryPackagesOfIndex :: CIO m => PackageIndex -> m (Either Exception [BinaryPackage])+binaryPackagesOfIndex index =+    case packageIndexArch index of+      Source -> return (Right [])+      _ -> getPackages index -- >>= return . either Left (Right . map (toBinaryPackage index . packageInfo))++-- | Get the contents of a package index+sourcePackagesOfIndex :: CIO m => PackageIndex -> m (Either Exception [SourcePackage])+sourcePackagesOfIndex index =+    case packageIndexArch index of+      Source -> getPackages index >>= return . either Left (Right . map (toSourcePackage index . packageInfo))+      _ -> return (Right [])++-- FIXME: assuming the index is part of the cache +sourcePackagesOfIndex' :: (AptCache a, CIO m) => a -> PackageIndex -> AptIOT m [SourcePackage]+sourcePackagesOfIndex' cache index =+    do state <- get+       let cached = lookupSourcePackages path state+       status <- liftIO $ getFileStatus path+       case cached of+         Just (status', packages) | status == status' -> return packages+         _ -> do paragraphs <- liftIO $ unsafeInterleaveIO (readParagraphs path)+                 let packages = map (toSourcePackage index) paragraphs +                 put (insertSourcePackages path (status, packages) state)+                 return packages+    where+      path = rootPath (rootDir cache) ++ indexCacheFile cache index++indexCacheFile :: (AptCache a) => a -> PackageIndex -> FilePath+indexCacheFile apt index =+    case (aptArch apt, packageIndexArch index) of+      (Source, _) -> error "Invalid build architecture: Source"+      (Binary _, Source) -> indexPrefix index ++ "_source_Sources"+      (Binary _, Binary arch) -> indexPrefix index ++ "_binary-" ++ arch ++ "_Packages"++indexPrefix :: PackageIndex -> FilePath+indexPrefix index =+    (escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText +?+ "dists_") +++     releaseName' distro ++ "_" ++ (sectionName' $ section))+    where+      release = packageIndexRelease index+      section = packageIndexComponent index+      repo = releaseRepo release+      uri = repoURI repo+      distro = releaseInfoName . releaseInfo $ release+      scheme = uriScheme uri+      auth = uriAuthority uri+      path = uriPath uri+      userpass = maybe "" uriUserInfo auth+      reg = maybeOfString $ maybe "" uriRegName auth+      port = maybe "" uriPort auth+      (user, pass) = break (== ':') userpass+      user' = maybeOfString user+      pass' = maybeOfString pass+      uriText = prefix scheme user' pass' reg port path+      -- If user is given and password is not, the user name is+      -- added to the file name.  Otherwise it is not.  Really.+      prefix "http:" (Just user) Nothing (Just host) port path =+          user ++ host ++ port ++ escape path+      prefix "http:" _ _ (Just host) port path =+          host ++ port ++ escape path+      prefix "ftp:" _ _ (Just host) _ path =+          host ++ escape path+      prefix "file:" Nothing Nothing Nothing "" path =+          escape path+      prefix "ssh:" (Just user) Nothing (Just host) port path =+          user ++ host ++ port ++ escape path+      prefix "ssh" _ _ (Just host) port path =+          host ++ port ++ escape path+      prefix _ _ _ _ _ _ = error ("invalid repo URI: " ++ (uriToString' . repoURI. releaseRepo . packageIndexRelease $ index))+      maybeOfString "" = Nothing+      maybeOfString s = Just s+      escape s = intercalate "_" (wordsBy (== '/') 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)++(+?+) :: String -> String -> String+(+?+) a ('_' : b) = a +?+ b+(+?+) "" b = b+(+?+) a b =+    case last a of+      '_' -> (init a) +?+ b+      _ -> a ++ "_" ++ b++-- FIXME: assuming the index is part of the cache +binaryPackagesOfIndex' :: (AptCache a, CIO m) => a -> PackageIndex -> AptIOT m [BinaryPackage]+binaryPackagesOfIndex' cache index =+    do state <- get+       let cached = lookupBinaryPackages path state+       status <- liftIO $ getFileStatus path+       case cached of+         Just (status', packages) | status == status' -> return packages+         _ -> do paragraphs <- liftIO $ unsafeInterleaveIO (readParagraphs path)+                 let packages = map (toBinaryPackage index) paragraphs +                 put (insertBinaryPackages path (status, packages) state)+                 return packages+    where+      path = rootPath (rootDir cache) ++ indexCacheFile cache index++-- | Return a list of all source packages.+releaseSourcePackages :: CIO m => Release -> m (Either Exception [SourcePackage])+releaseSourcePackages release =+    mapM sourcePackagesOfIndex (sourceIndexList release) >>= return . test+    where+      test xs = case EE.partitionEithers xs of+                  ([], ok) -> Right (concat ok)+                  (bad, _) -> Left . ErrorCall $ intercalate ", " (map show bad)++-- | Return a list of all the binary packages for all supported architectures.+releaseBinaryPackages :: CIO m => Release -> m (Either Exception [BinaryPackage])+releaseBinaryPackages release =+    mapM binaryPackagesOfIndex (binaryIndexList release) >>= return . test+    where+      test xs = case EE.partitionEithers xs of+                  ([], ok) -> Right (concat ok)+                  (bad, _) -> Left . ErrorCall $ intercalate ", " (map show bad)++-- | Write a set of packages into a package index.+putPackages :: PackageIndexLocal ->  [BinaryPackageLocal] -> IO (Either [String] ())+putPackages index packages =+    case releaseRepo release of+      LocalRepo repo -> EF.writeAndZipFileWithBackup (outsidePath (repoRoot repo) </> packageIndexPath index) text+      x -> error $ "Package.putPackages: Expected local repository, found " ++ show x+    where+      release = packageIndexRelease index+      --repo = releaseRepo release+      text = L.fromChunks [B.concat (intersperse (B.pack "\n") . map formatParagraph . map packageInfo $ packages)]
+ Debian/Repo/PackageIndex.hs view
@@ -0,0 +1,86 @@+module Debian.Repo.PackageIndex+    ( packageIndexName+    , packageIndexPath+    , packageIndexDir+    , packageIndexPathList+    , packageIndexDirList+    , packageIndexList+    , sourceIndexList+    , binaryIndexList+    , releaseDir+    , showIndexBrief+    , debSourceFromIndex+    ) where++import Data.List+import Debian.Repo.Types+--import Debian.Release+import System.FilePath((</>))++packageIndexName :: PackageIndex -> FilePath+packageIndexName index =+    case packageIndexArch index of+      Source -> "Sources"+      _ -> "Packages"++packageIndexPath :: PackageIndex -> FilePath+packageIndexPath index = packageIndexDir index ++ "/" ++ packageIndexName index++packageIndexDir :: PackageIndex -> FilePath+packageIndexDir index =+    case packageIndexArch index of+      Source -> releaseDir (packageIndexRelease index) ++ "/" ++ sectionName' (packageIndexComponent index) ++ "/source"+      _ -> (releaseDir (packageIndexRelease index) ++ "/" +++            sectionName' (packageIndexComponent index) +++            "/binary-" ++ archName (packageIndexArch index))++releaseDir release = "dists/" ++ (releaseName' . releaseName $ release)++packageIndexPathList :: Release -> [FilePath]+packageIndexPathList release = map packageIndexPath . packageIndexList $ release++packageIndexDirList :: Release -> [FilePath]+packageIndexDirList release = map packageIndexDir . packageIndexList $ release++packageIndexList :: Release -> [PackageIndex]+packageIndexList release = sourceIndexList release ++ binaryIndexList release++sourceIndexList :: Release -> [PackageIndex]+sourceIndexList release =+    map componentIndex (releaseComponents release)+    where componentIndex component = PackageIndex { packageIndexRelease = release+                                                  , packageIndexComponent = component+                                                  , packageIndexArch = Source }++binaryIndexList :: Release -> [PackageIndex]+binaryIndexList release =+    concat . map componentIndexes $ (releaseComponents release)+    where +      --componentIndexes :: Section -> [PackageIndex]+      componentIndexes component =+          map archIndex (filter (/= Source) (releaseArchitectures release))+          where+            --archIndex :: Arch -> PackageIndex+            archIndex arch = PackageIndex { packageIndexRelease = release+                                          , packageIndexComponent = component+                                          , packageIndexArch = arch }++showIndexBrief :: PackageIndex -> String+showIndexBrief index =+    (releaseName' . releaseName $ release) </> sectionName' (packageIndexComponent index) </> showArch (packageIndexArch index)+    where release = packageIndexRelease index+          showArch Source = "source"+          showArch (Binary x) = "binary-" ++ x++debSourceFromIndex :: PackageIndex -> DebSource+debSourceFromIndex index =+    DebSource {sourceType = typ,+               sourceUri = repoURI repo,+               sourceDist = Right (dist, components)}+    where+      typ = case arch of Binary _ -> Deb; Source -> DebSrc+      arch = packageIndexArch index+      dist = releaseName release+      components = releaseComponents release+      repo = releaseRepo release+      release = packageIndexRelease index
+ Debian/Repo/Release.hs view
@@ -0,0 +1,265 @@+module Debian.Repo.Release+    ( lookupRelease+    , insertRelease+    , prepareRelease+    , findReleases+    , signRelease+    , signReleases+    , mergeReleases+    ) where++import qualified Debian.Control.String as S+import Debian.Repo.IO+import Debian.Repo.Types+import Debian.Repo.LocalRepository+import Debian.Repo.PackageIndex++import Control.Monad.State+import qualified Data.ByteString.Lazy.Char8 as L+import Data.List+import Data.Maybe+import Data.Time+--import Data.Time.Clock.POSIX+--import System.Locale (defaultTimeLocale)+import qualified Extra.Files as EF+import qualified Extra.GPGSign as EG+import qualified Extra.Time as ET+import Extra.CIO (CIO, vPutStrBl)+import System.Directory+import System.Posix.Files+import qualified System.Posix.Files as F+import System.FilePath((</>))+import System.Unix.Process++lookupRelease :: CIO m => Repository -> ReleaseName -> AptIOT m (Maybe Release)+lookupRelease repo dist = get >>= return . findRelease repo dist++insertRelease :: CIO m => Release -> AptIOT m Release+insertRelease release =+    get >>= put . putRelease repo dist release >> return release+    where dist = releaseInfoName (releaseInfo release)+          repo = releaseRepo release++-- | Find or create a (local) release.+prepareRelease :: CIO m => LocalRepository -> ReleaseName -> [ReleaseName] -> [Section] -> [Arch] -> AptIOT m Release+prepareRelease repo dist aliases sections archList =+    -- vPutStrLn 0 ("prepareRelease " ++ name ++ ": " ++ show repo ++ " sections " ++ show sections) >>+    lookupRelease (LocalRepo repo) dist >>= maybe prepare (const prepare) -- return -- JAS - otherwise --create-section does not do anything+    where+      prepare =+          do -- FIXME: errors get discarded in the mapM calls here+	     let release = Release (LocalRepo repo) (ReleaseInfo { releaseInfoName = dist+                                                                 , releaseInfoAliases = aliases+                                                                 , releaseInfoComponents = sections+                                                                 , releaseInfoArchitectures = archList })+             -- vPutStrLn 0 ("packageIndexList: " ++ show (packageIndexList release))+             mapM (initIndex (outsidePath root)) (packageIndexList release)+             mapM (initAlias (outsidePath root) dist) aliases+             lift (writeRelease release)+	     -- This ought to be identical to repo, but the layout should be+             -- something rather than Nothing.+             repo' <- prepareLocalRepository root (repoLayout repo)+             let release' = release { releaseRepo = LocalRepo repo' }+             --vPutStrLn 0 $ "prepareRelease: prepareLocalRepository -> " ++ show repo'+             insertRelease release'+      initIndex root index = initIndexFile (root </> packageIndexDir index) (packageIndexName index)+      initIndexFile dir name =+          do io $ createDirectoryIfMissing True dir+             io $ setFileMode dir 0o040755+             ensureIndex (dir </> name)+      initAlias root dist alias = +          io $ EF.prepareSymbolicLink (releaseName' dist) (root ++ "/dists/" ++ releaseName' alias)+      root = repoRoot repo++-- | Make sure an index file exists.+ensureIndex :: CIO m => FilePath -> AptIOT m (Either [String] ())+ensureIndex path = +    do exists <- io $ doesFileExist path+       case exists of+         False -> io $ EF.writeAndZipFile path L.empty+         True -> return $ Right ()++signReleases :: CIO m => Maybe EG.PGPKey -> [Release] -> m ()+signReleases keyname releases = mapM_ (signRelease keyname) releases++signRelease :: CIO m => Maybe EG.PGPKey -> Release -> m ()+signRelease keyname release@(Release {releaseRepo = LocalRepo repo}) =+    do let root = repoRoot repo+       files <- writeRelease release+       case keyname of+         Nothing -> return ()+         Just key -> do results <- liftIO (EG.pgpSignFiles (outsidePath root) key files)+                        let failed = catMaybes $ map (\ (path, flag) -> if (not flag) then Just path else Nothing) (zip files results)+                        case failed of+                          [] -> return ()+                          files -> vPutStrBl 0 ("Unable to sign:\n  " ++ intercalate "\n  " files)+signRelease keyname release = error $ "Attempt to sign non-local repository"++-- |Write out the @Release@ files that describe a 'Release'.+writeRelease :: CIO m => Release -> m [FilePath]+writeRelease release@(Release {releaseRepo = LocalRepo repo}) =+    do let root = repoRoot repo+       indexReleaseFiles <- liftIO $ writeIndexReleases (outsidePath root) release+       masterReleaseFile <- writeMasterRelease (outsidePath root) release+       return (masterReleaseFile : indexReleaseFiles)+    where+      writeIndexReleases root release =+          mapM (writeIndex root) (packageIndexList release)+      -- It should only be necessary to write these when the component+      -- is created, not every time the index files are changed.  But+      -- for now we're doing it anyway.+      writeIndex root index =+          do let para =+                     S.Paragraph+                          [S.Field ("Archive", releaseName' . releaseInfoName . releaseInfo . packageIndexRelease $ index),+                           S.Field ("Component", sectionName' (packageIndexComponent index)),+                           S.Field ("Architecture", archName (packageIndexArch index)),+                           S.Field ("Origin", " Linspire"),+                           S.Field ("Label", " Freespire")]+             let path = packageIndexDir index ++ "/Release"+             EF.maybeWriteFile (root </> path) (show para)+             return path+      writeMasterRelease :: CIO m => FilePath -> Release -> m FilePath+      writeMasterRelease root release =+          do let paths = concat . map indexPaths $ (packageIndexList release)+             (paths', sums,sizes) <- +                 liftIO (EG.cd root+                         (do paths' <- filterM doesFileExist paths+                             sums <-  mapM md5sum paths'+                             sizes <- mapM (liftM F.fileSize . F.getFileStatus) paths'+                             return (paths', sums, sizes)))+             let checksums = intercalate "\n" $ zipWith3 (formatFileInfo (fieldWidth sizes))+                      	   sums sizes (map (drop (1 + length (releaseDir release))) paths')+             timestamp <- liftIO (getCurrentTime >>= return . ET.formatDebianDate)+             let para = S.Paragraph [S.Field ("Origin", " Linspire"),+                                     S.Field ("Label", " Freespire"),+                                     S.Field ("Suite", " " ++ (releaseName' . releaseInfoName . releaseInfo $ release)),+                                     S.Field ("Codename", " " ++ (releaseName' . releaseInfoName . releaseInfo $ release)),+                                     S.Field ("Date", " " ++ timestamp),+                                     S.Field ("Architectures", " " ++ (intercalate " " . map archName . releaseInfoArchitectures . releaseInfo $ release)),+                                     S.Field ("Components", " " ++ (intercalate " " . map sectionName' . releaseInfoComponents . releaseInfo $ release)),+                                     S.Field ("Description", " Freespire 2.0 - Not Released"),+                                     S.Field ("Md5Sum", "\n" ++ checksums)]+             let path = "dists/" ++ (releaseName' . releaseInfoName . releaseInfo $ release) ++ "/Release"+             liftIO $ EF.maybeWriteFile (root </> path) (show para)+             return path+      indexPaths index | packageIndexArch index == Source =+          map ((packageIndexDir index) </>) ["Sources", "Sources.gz", "Sources.bz2", "Sources.diff/Index", "Release"]+      indexPaths index =+          map ((packageIndexDir index) </>) ["Packages", "Packages.gz", "Packages.bz2", "Packages.diff/Index", "Release"]+      formatFileInfo fw sum size name = intercalate " " $ ["",sum, pad ' ' fw $ show size, name]+      fieldWidth = ceiling . (logBase 10) . fromIntegral . maximum+writeRelease release = error $ "Attempt to write release files to non-local repository"++md5sum f = +    do output <- System.Unix.Process.processOutput "/usr/bin/md5sum" [f]+       return $ either (error $ "md5sum: missing file:" ++ f)+                (takeWhile (/= ' '))+                output++pad padchar padlen s = replicate p padchar ++ s+    where p = padlen - length s++-- Merge a list of releases so each dist only appears once+mergeReleases :: [Release] -> [Release]+mergeReleases releases =+    map (merge repos) . groupBy (==) . sortBy compare $ releases+    where+      repos = nub (map releaseRepo releases)+      merge [repo] releases =+          let aliases = map head . group . sort . concat . map (releaseInfoAliases . releaseInfo) $ releases+              components = map head . group . sort . concat . map (releaseInfoComponents . releaseInfo) $ releases+              architectures = map head . group . sort . concat . map (releaseInfoArchitectures . releaseInfo) $ releases in+          Release { releaseRepo = repo+                  , releaseInfo = ReleaseInfo { releaseInfoName = (releaseInfoName . releaseInfo . head $ releases)+                                              , releaseInfoAliases = aliases+                                              , releaseInfoComponents = components+                                              , releaseInfoArchitectures = architectures } }+      merge _ _ = error "Cannot merge releases from different repositories"++-- | Find all the releases in a repository.+findReleases :: CIO m => LocalRepository -> AptIOT m [Release]+findReleases repo@(LocalRepository _ _ releases) = mapM (findLocalRelease repo) releases++findLocalRelease :: CIO m => LocalRepository -> ReleaseInfo -> AptIOT m (Release)+findLocalRelease repo releaseInfo =+    lookupRelease (LocalRepo repo) dist >>= maybe readRelease return+    where+      readRelease =+          do let path = (outsidePath (repoRoot repo) ++ "/dists/" ++ releaseName' dist ++ "/Release")+             info <- io $ S.parseControlFromFile path+             case info of+               Right (S.Control (paragraph : _)) ->+                   case (S.fieldValue "Components" paragraph, S.fieldValue "Architectures" paragraph) of+                     (Just components, Just architectures) ->+                         let release = Release (LocalRepo repo)+                                       (ReleaseInfo+                                        { releaseInfoName = dist+                                        , releaseInfoAliases = releaseInfoAliases releaseInfo+                                        , releaseInfoComponents = map parseSection' . words $ components+                                        , releaseInfoArchitectures = map Binary . words $ architectures}) in+                         insertRelease release+                     _ -> +                         error $ "Invalid release file: " ++ path+               _ -> error $ "Invalid release file: " ++ path+      dist = releaseInfoName releaseInfo++{-+CB: Here's my take on what needs to be done based on spelunking through the Debian repositories.++Each component (main, contrib, non-free) has a Release file in the same directory as the Packages files.  These are basically static, consisting of the following fields:++    $ cat /var/www/debian/dists/unstable/non-free/binary-i386/Release+    Archive: unstable+    Component: non-free+    Origin: Debian+    Label: Debian+    Architecture: i386++Slightly different for Source:++    $ cat /var/www/debian/dists/unstable/non-free/source/Release+    Archive: unstable+    Component: non-free+    Origin: Debian+    Label: Debian+    Architecture: source++Also, if a dist has been released, then a version number is included:++    $ cat /var/www/debian/dists/sarge/non-free/source/Release+    Archive: stable+    Version: 3.1r4+    Component: non-free+    Origin: Debian+    Label: Debian+    Architecture: source++The top level release file is different.  It has the md5sums of all the indices and release files in the distribution.  We need to find out what we should put in for Origin and Label, but I think those are company and OS respectively, so Linspire and Freespire.  It even has a codename...  As before, the version in sarge has a Version number included.++It is this top level Release file that is signed with gpg.++    $ head /var/www/debian/dists/unstable/Release+    Origin: Debian+    Label: Debian+    Suite: unstable+    Codename: sid+    Date: Wed, 06 Dec 2006 20:13:03 UTC+    Architectures: alpha amd64 arm hppa hurd-i386 i386 ia64 m68k mips mipsel powerpc s390 sparc+    Components: main contrib non-free+    Description: Debian Unstable - Not Released+    MD5Sum:+     397f3216a3a881da263a2fb5e0f8f02e 19487683 main/binary-alpha/Packages+     c3586c0dcdd6be9266a23537b386185d  5712614 main/binary-alpha/Packages.gz+     7acf2b8b938dde2c2e484425c806635a  4355026 main/binary-alpha/Packages.bz2+     dcf0d11800eb007c5435d83c853a241e     2038 main/binary-alpha/Packages.diff/Index+     3af8fbafe3e4538520989de964289712       83 main/binary-alpha/Release+     209177470d05f3a50b5217f64613ccca 19747688 main/binary-amd64/Packages+     a73fd369c6baf422621bfa7170ff1594  5777320 main/binary-amd64/Packages.gz+     380e56b5acec9ac40f160ea97ea088ef  4403167 main/binary-amd64/Packages.bz2+     43cbb8ba1631ab35ed94d43380299c38     2038 main/binary-amd64/Packages.diff/Index+     ab89118658958350f14094b1bc666a62       83 main/binary-amd64/Release+     d605623ac0d088a8bed287e0df128758 19323166 main/binary-arm/Packages+++-}
+ Debian/Repo/Repository.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Debian.Repo.Repository+    ( UploadFile(..)+    , prepareRepository+    , repoArchList+    , readPkgVersion+    , showPkgVersion+    , invalidRevision+    , verifyUploadURI+    , uploadRemote+    ) where++import Control.Exception (Exception(..))+import Control.Monad.Trans+import Control.Monad.State (get, put)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import Data.List+import Data.Maybe+import qualified Data.Set as Set+import qualified Debian.Control.ByteString as B	-- required despite warning+import qualified Debian.Control.String as S+import Debian.Extra.CIO (tMessage, printOutput)+import Debian.Repo.Changes+import Debian.Repo.IO+import Debian.Repo.LocalRepository+import Debian.Repo.Types+import Debian.Shell+import Debian.URI+import Debian.Version+import Extra.Bool+import Extra.Either+import Extra.Files+import Extra.List+import Extra.Net+import Extra.SSH+import Extra.CIO+import System.FilePath+import System.Unix.Process+import System.Cmd+import System.Directory+import qualified System.IO as IO+import System.IO.Unsafe+import System.Time+import Text.Regex++-- |The file produced by dupload when a package upload attempt is made.+data UploadFile = Upload FilePath String DebianVersion Arch++-- |This is a remote repository which we have queried to find out the+-- names, sections, and supported architectures of its releases.+--data VerifiedRepo = VerifiedRepo URI [ReleaseInfo]++{- instance Show VerifiedRepo where+    show (VerifiedRepo uri _) = "Verified Repository " ++ show uri -- ++ " " ++ show dists+instance Ord VerifiedRepo where+    compare a b = compare (repoURI a) (repoURI b)+instance Eq VerifiedRepo where+    a == b = compare a b == EQ -}++-- |This is a repository whose structure we haven't examined +-- to determine what release it contains.+--data UnverifiedRepo = UnverifiedRepo URI++{- instance Show UnverifiedRepo where+    show (UnverifiedRepo uri) = "Unverified Repository " ++ show uri -- ++ " (unverified)"+instance Ord UnverifiedRepo where+    compare a b = compare (repoURI a) (repoURI b)+instance Eq UnverifiedRepo where+    a == b = compare a b == EQ -}++-- | Prepare a repository, which may be remote or local depending on+-- the URI.+prepareRepository :: CIO m => URI -> AptIOT m Repository+prepareRepository uri =+    do state <- get+       repo <- maybe newRepo return (lookupRepository uri state)+       put (insertRepository uri repo state)+       return repo+    where+      newRepo =+             case uriScheme uri of+               "file:" -> prepareLocalRepository (EnvPath (EnvRoot "") (uriPath uri)) Nothing >>= return . LocalRepo+               -- FIXME: We only want to verifyRepository on demand.+               -- Perhaps we want to use System.IO.Unsafe.unsafeInterleaveIO?+               _ -> verifyRepository (UnverifiedRepo (show uri))+               -- _ -> return . Repository . UnverifiedRepo $ uri++{-# NOINLINE verifyRepository #-}+verifyRepository :: CIO m => Repository -> AptIOT m Repository+verifyRepository (UnverifiedRepo uri) =+    do --tio (vHPutStrBl IO.stderr 0 $ "Verifying repository " ++ show uri ++ "...")+       -- Use unsafeInterleaveIO to avoid querying the repository+       -- until the value is actually needed.+       lift (vPutStrBl 2 ("verifyRepository " ++ uri))+       releaseInfo <- do lift (vPutChar 2 '*')+                         liftIO . unsafeInterleaveIO . getReleaseInfoRemote . fromJust . parseURI $ uri+       {- tio (vHPutStrLn IO.stderr 0 $ "\n" {- -> VerifiedRepo " ++ show uri ++ " " ++ show releaseInfo -} ) -}+       return $ VerifiedRepo uri releaseInfo+verifyRepository x = return x++-- |Get the list of releases of a remote repository.+getReleaseInfoRemote :: URI -> IO [ReleaseInfo]+getReleaseInfoRemote uri =+    IO.hPutStr IO.stderr ("(verifying " ++ uriToString' uri ++ ".") >>+    dirFromURI distsURI >>=+    either (error . show) verify >>= return . catMaybes >>= +    (\ result -> IO.hPutStr IO.stderr ")" >> return result)+    where+      distsURI = uri {uriPath = uriPath uri </> "dists/"}+      verify names =+          do let dists = map parseReleaseName names+             releaseFiles <- mapM getReleaseFile dists+             let releasePairs = zip3 (map getSuite releaseFiles) releaseFiles dists+             return $ map (uncurry3 getReleaseInfo) releasePairs+      releaseNameField releaseFile = case fmap B.unpack (B.fieldValue "Origin" releaseFile) of Just "Debian" -> "Codename"; _ -> "Suite"+      getReleaseInfo :: Maybe B.ByteString -> B.Paragraph -> ReleaseName -> Maybe ReleaseInfo+      getReleaseInfo Nothing _ _ = Nothing+      getReleaseInfo (Just dist) _ relname | (parseReleaseName (B.unpack dist)) /= relname = Nothing+      getReleaseInfo (Just dist) info _ = Just $ makeReleaseInfo "" info (parseReleaseName (B.unpack dist)) []+      getSuite releaseFile = B.fieldValue (releaseNameField releaseFile) releaseFile+      getReleaseFile :: ReleaseName -> IO (S.Paragraph' B.ByteString)+      getReleaseFile distName =+          do IO.hPutChar IO.stderr '.'+             release <- fileFromURI releaseURI >>= return . either Left (Right . B.concat . L.toChunks)+             let control = either Left (either (Left . ErrorCall . show) Right . B.parseControl (show uri)) release+             case control of+               Right (B.Control [info]) -> return info+               _ -> error ("Failed to get release info from " ++ show releaseURI)+          where+            releaseURI = distURI {uriPath = uriPath distURI </> "Release"}+            distURI = distsURI {uriPath = uriPath distsURI </> releaseName' distName}+      uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+      uncurry3 f (a, b, c) =  f a b c++-- |Make sure we can access the upload uri without typing a password.+verifyUploadURI :: CIO m => Bool -> URI -> AptIOT m ()+verifyUploadURI doExport uri =+    case doExport of+      True -> export+      False -> verify+    where+      export =+          do liftIO $ uncurry sshExport (uriDest uri)+             verify+             mkdir+      verify =+          do result <- liftIO $ uncurry sshVerify (uriDest uri)+             case result of+               False -> error $ "Unable to reach " ++ uriToString' uri ++ ", consider using --ssh-export"+               True -> return ()+             mkdir+      uriDest uri =+          let auth = maybe (error "Internal error 8") id (uriAuthority uri) in+          let port =+                  case uriPort auth of+                    (':' : number) -> Just (read number)+                    "" -> Nothing+                    x -> error $ "Internal error 9: invalid port " ++ x in+          (uriUserInfo auth ++ uriRegName auth, port)+      mkdir :: CIO m => AptIOT m ()+      mkdir =+          case uriAuthority uri of+            Nothing -> error $ "Internal error 7"+            Just auth ->+                do let cmd = "ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth  ++ " mkdir -p " ++ uriPath uri ++ "/incoming"+                   result <- liftIO $ system cmd+                   case result of+                     ExitSuccess -> return ()+                     _ -> error $ "Failure: " ++ cmd++-- | Upload all the packages in a local repository to a the incoming+-- directory of a remote repository (using dupload.)+uploadRemote :: CIO m+	     => LocalRepository		-- ^ Local repository holding the packages.+             -> URI			-- ^ URI of upload repository+             -> AptIOT m [Either String ([Output], TimeDiff)]+uploadRemote repo uri =+    do uploaded <- liftIO (uploadFind (outsidePath root)) >>=+                   return . Set.fromList . map uploadKey . rightOnly+       (accepted, rejected) <- liftIO (findChangesFiles (outsidePath root)) >>= return . (\x -> (x, [])) >>=+                               return . accept (notUploaded uploaded) (\ x -> (x, "Already uploaded")) >>=+                               return . rejectOlder >>=+                               acceptM (liftIO . validRevision) (\ x -> (x, "Invalid revision"))+       case rejected of+         [] -> return ()+         _ -> lift (vPutStr 0 ("Rejected:\n  " ++ consperse "\n  " (map showReject rejected) ++ "\n"))+       case accepted of+         [] -> do lift (vPutStr 0 "Nothing to upload."); return []+         _ -> do mapM (lift . dupload uri (outsidePath root)) (map Debian.Repo.Changes.path accepted)+    where+      root = repoRoot repo+      rejectOlder :: ([ChangesFile], [(ChangesFile, String)]) ->  ([ChangesFile], [(ChangesFile, String)])+      rejectOlder (accept, reject) =+          (accept', (map tag reject' ++ reject))+          where accept' = map head sortedGroups+                reject' = concat . map tail $ sortedGroups+                sortedGroups = map (sortBy compareVersions) (groupByNameAndDist accept)+                tag x = (x, "Not the newest version in incoming")+      compareVersions a b = compare (changeVersion b) (changeVersion a)+      groupByNameAndDist = groupBy equalNameAndDist . sortBy compareNameAndDist+      equalNameAndDist a b = compareNameAndDist a b == EQ+      compareNameAndDist a b =+          case compare (changePackage a) (changePackage b) of+            EQ -> compare (changeRelease a) (changeRelease b)+            x -> x+      notUploaded uploaded changes = not . Set.member (Debian.Repo.Changes.key changes) $ uploaded+      validRevision c =+          do+            let dscPath = changeDir c </> changePackage c ++ "_" ++ show (changeVersion c) ++ ".dsc"+            doesFileExist dscPath >>= cond (S.parseControlFromFile dscPath >>= either (error . show) (checkRevision dscPath)) (return True)+          where+            checkRevision _dscPath (S.Control [p]) =+                case maybe Nothing parseRevision (S.fieldValue "Revision" p) of+                    Nothing -> return False+                    Just (x, _) | x == invalidRevision -> return False+                    Just _ -> return True+            checkRevision dscPath _ = error ("Invalid .dsc file: " ++ show dscPath)+      showReject (changes, tag) = Debian.Repo.Changes.name changes ++ ": " ++ tag++uploadKey :: UploadFile -> (String, DebianVersion, Arch)+uploadKey (Upload _ name ver arch) = (name, ver, arch)++uploadLoad :: FilePath -> String -> (Either [String] UploadFile)+uploadLoad dir file =+    case parseUploadFilename file of+      Just (name, ver, arch) -> Right $ Upload dir name ver arch+      Nothing -> Left ["Couldn't parse upload filename: " ++ file]++uploadFind :: FilePath -> IO [Either [String] UploadFile]+uploadFind dir =+    getDirectoryContents dir >>=+    return . filter (isSuffixOf ".upload") >>=+    return . map (uploadLoad dir)++{-+base :: UploadFile -> String+base (Upload _ name ver arch) = name ++ "_" ++ show ver ++ "_" ++ show arch+-}++-- 		       filename     name   version   arch    ext+parseUploadFilename :: String -> Maybe (String, DebianVersion, Arch)+parseUploadFilename name =+    case matchRegex (mkRegex "^(.*/)?([^_]*)_(.*)_([^.]*)\\.upload$") name of+      Just [_, name, version, arch] -> Just (name, parseDebianVersion version, Binary arch)+      _ -> error ("Invalid .upload file name: " ++ name)++invalidRevision = "none"++-- | Parse the "Revision:" value describing the origin of the+-- package's source and the dependency versions used to build it:+--   Revision: <revisionstring> dep1=ver1 dep2=ver2 ...+parseRevision :: String -> Maybe (String, [PkgVersion])+parseRevision s =+    case words s of+      [] -> Nothing+      (revision : buildDeps) -> Just (revision, map readPkgVersion buildDeps)++showPkgVersion :: PkgVersion -> String+showPkgVersion v = show v++readPkgVersion :: String -> PkgVersion+readPkgVersion s = case mapSnd (parseDebianVersion . (drop 1)) (span (/= '=') s) of+                     (n, v) -> PkgVersion { getName = n, getVersion = v }++mapSnd f (a, b) = (a, f b)++accept :: (a -> Bool) -> (a -> (a, String)) -> ([a], [(a, String)]) -> ([a], [(a, String)])+accept p tag (accepted, rejected) =+    (accepted', map tag rejected' ++ rejected)+    where (accepted', rejected') = partition p accepted++acceptM :: (Monad m) => (a -> m Bool) -> (a -> (a, String)) -> ([a], [(a, String)]) -> m ([a], [(a, String)])+acceptM p tag (accept, reject) =+    do (accept', reject') <- partitionM p accept+       return (accept', (map tag reject' ++ reject))++-- |Run dupload on a changes file with an optional host (--to)+-- argument.+dupload :: CIO m+	=> URI		-- user+        -> FilePath	-- The directory containing the .changes file+        -> String	-- The name of the .changes file to upload+        -> m (Either String ([Output], TimeDiff))+dupload uri dir changesFile  =+    case uriAuthority uri of+      Nothing -> error ("Invalid Upload-URI: " ++ uriToString' uri)+      Just auth ->+          do+            let config = ("package config;\n" +++                          "$cfg{'default'} = {\n" +++                          "        fqdn => \"" ++ uriRegName auth ++ uriPort auth ++ "\",\n" +++                          "        method => \"scpb\",\n" +++	                  "        login => \"" ++ init (uriUserInfo auth) ++ "\",\n" +++                          "        incoming => \"" ++ uriPath uri ++ "/incoming\",\n" +++                          "        dinstall_runs => 1,\n" +++                          "};\n\n" +++			  "$preupload{'changes'} = '';\n\n" +++                          "1;\n")+            liftIO $ replaceFile (dir ++ "/dupload.conf") config+            liftIO (lazyCommand (cmd changesFile) L.empty) >>=+                   tMessage ("Uploading " ++ show changesFile) >>=+                   printOutput >>=+                   dotOutput 128 >>=+                   (\ output -> timeTask (checkResult fail (return (Right output)) output)) >>=+		   (\ (result, elapsed) -> return (either Left (\ output -> Right (output, elapsed)) result))+            --style' $ runCommandQuietlyTimed (cmd changesFile)+    where+{-+      style' = setStyle (setStart (Just ("Uploading " ++ show changesFile)) .+                         setError (Just "dupload failed") .+                         setEcho True)+-}+      fail n = +          ePutStrBl message >> return (Left message)+          where message = "dupload failed: " ++ cmd changesFile ++ " -> " ++ show n+      cmd file = "cd " ++ dir ++ " && dupload --to default -c " ++ file++repoArchList :: Repo r => r -> [Arch]+repoArchList repo =+    listIntersection (map releaseInfoArchitectures (repoReleaseInfo repo))
+ Debian/Repo/Slice.hs view
@@ -0,0 +1,147 @@+-- |Types that represent a "slice" of a repository, as defined by a+-- list of DebSource.  This is called a slice because some sections+-- may be omitted, and because different repositories may be combined+-- in the list.+module Debian.Repo.Slice+    ( sourceSlices+    , binarySlices+    , inexactPathSlices+    , releaseSlices+    , appendSliceLists+    , verifySourceLine+    , verifySourcesList+    , repoSources+    , parseNamedSliceList+    , parseNamedSliceList'+    ) where++import Control.Exception (throw)+import Control.Monad.Trans+import qualified Data.ByteString.Lazy.Char8 as L+import Data.List+import Data.Maybe+import Debian.Control+import Debian.Extra.CIO (vMessage)+import Debian.Repo.IO+import Debian.Repo.LocalRepository+import Debian.Repo.Repository+import Debian.Shell+import Debian.Repo.SourcesList+import Debian.Repo.Types+import Debian.URI+import Extra.Net (webServerDirectoryContents)+import Extra.CIO (CIO, vPutStrBl)+import System.Unix.Process+import System.Directory+import Text.Regex++sourceSlices :: SliceList -> SliceList+sourceSlices = SliceList . filter ((== DebSrc) . sourceType . sliceSource) . slices++binarySlices :: SliceList -> SliceList+binarySlices = SliceList . filter ((== Deb) . sourceType . sliceSource) . slices++inexactPathSlices :: SliceList -> SliceList+inexactPathSlices = SliceList . filter (either (const False) (const True) . sourceDist . sliceSource) . slices++releaseSlices :: ReleaseName -> SliceList -> SliceList+releaseSlices release list =+    SliceList . filter (isRelease . sourceDist . sliceSource) $ (slices list)+    where isRelease = either (const False) (\ (x, _) -> x == release)++appendSliceLists :: [SliceList] -> SliceList+appendSliceLists lists =+    SliceList { slices = concat (map slices lists) }++-- |Examine the repository whose root is at the given URI and return a+-- set of sources that includes all of its releases.  This is used to+-- ensure that a package we want to upload doesn't already exist in+-- the repository.+repoSources :: CIO m => Maybe EnvRoot -> URI -> AptIOT m SliceList+repoSources chroot uri =+    do lift (vPutStrBl 3 $ "repoSources " ++ uriToString' uri)+       dirs <- lift (uriSubdirs chroot (uri {uriPath = uriPath uri ++ "/dists/"}))+       lift (vPutStrBl 3 $ "  dirs: " ++ show dirs)+       releaseFiles <- mapM (lift . readRelease uri) dirs >>= return . catMaybes+       let codenames = map (maybe Nothing (zap (flip elem dirs))) . map (fieldValue "Codename") $ releaseFiles+       lift (vPutStrBl 3 $ "  codenames: " ++ show (catMaybes codenames))+       let sections = map (maybe Nothing (Just . map parseSection' . splitRegex (mkRegex "[ \t,]+")) . fieldValue "Components") $ releaseFiles+       lift (vPutStrBl 3 $ "  sections: " ++ show (catMaybes codenames))+       let result = concat $ map sources . nubBy (\ (a, _) (b, _) -> a == b) . zip codenames $ sections+       lift (vPutStrBl 2 $ "repoSources " ++ uriToString' uri ++ " ->\n [" ++ unwords (map show result) ++ "]")+       mapM (verifyDebSource Nothing) result >>= (\ list -> return $ SliceList { slices = list })+    where+      sources (Just codename, Just components@(_ : _)) =+          [DebSource {sourceType = Deb, sourceUri = uri, sourceDist = Right (parseReleaseName codename, components)},+           DebSource {sourceType = DebSrc, sourceUri = uri, sourceDist = Right (parseReleaseName codename, components)}]+      sources _ = []+      -- Compute the list of sections for each dist on a remote server.+      zap p x = if p x then Just x else Nothing++-- |Return the list of releases in a repository, which is the+-- list of directories in the dists subdirectory.  Currently+-- this is only known to work with Apache.  Note that some of+-- the returned directories may be symlinks.+uriSubdirs :: CIO m => (Maybe EnvRoot) -> URI -> m [String]+uriSubdirs root uri =+    liftIO (dirFromURI uri') >>= either throw return+    where+      uri' = case uriScheme uri of+               "file:" -> uri {uriPath = maybe "" rootPath root ++ (uriPath uri)}+               _ -> uri++readRelease :: CIO m => URI -> String -> m (Maybe Paragraph)+readRelease uri name =+    do output <- liftIO (fileFromURI uri')+       case output of+         Left e -> throw e+         Right s -> case parseControl (show uri') (L.unpack s) of+                      Right (Control [paragraph]) -> return (Just paragraph)+                      _ -> return Nothing+    where+      uri' = uri {uriPath = uriPath uri ++ "/dists/" ++ name ++ "/Release"}++parseNamedSliceList :: CIO m => String -> AptIOT m (Maybe NamedSliceList)+parseNamedSliceList text =+    case matchRegex re text of+      Just [name, sources] ->+          (verifySourcesList Nothing . parseSourcesList) sources >>=+          \ sources -> return . Just $ NamedSliceList { sliceListName = SliceName name+                                                      , sliceList = sources }+      _ -> return Nothing+    where+      re = mkRegexWithOpts "^[ \t\n]*([^ \t\n]+)[ \t\n]+(.*)$" False True++-- |Create ReleaseCache info from an entry in the config file, which+-- includes a dist name and the lines of the sources.list file.+-- This also creates the basic +parseNamedSliceList' :: CIO m => String -> AptIOT m NamedSliceList+parseNamedSliceList' text =+    -- FIXME: This regexp is too permissive - it will match almost anything+    case matchRegex re text of+      Just [name, sources] -> +          do sources <- (verifySourcesList Nothing . parseSourcesList) sources+             return $ NamedSliceList { sliceListName = SliceName name, sliceList = sources }+      _ -> error "Syntax error in sources text"+    where+      re = mkRegexWithOpts "^[ \t\n]*([^ \t\n]+)[ \t\n]+(.*)$" False True++verifySourcesList :: CIO m => Maybe EnvRoot -> [DebSource] -> AptIOT m SliceList+verifySourcesList chroot list =+    mapM (verifyDebSource chroot) list >>=+    (\ list -> return $ SliceList { slices = list })++verifySourceLine :: CIO m => Maybe EnvRoot -> String -> AptIOT m Slice+verifySourceLine chroot str = verifyDebSource chroot (parseSourceLine str)++verifyDebSource :: CIO m => Maybe EnvRoot -> DebSource -> AptIOT m Slice+verifyDebSource chroot line =+    do repo <- case uriScheme uri of+                 "file:" -> +                     let path = EnvPath (maybe (EnvRoot "") id chroot) (uriPath uri) in+                     prepareLocalRepository path Nothing >>= return . LocalRepo+                 _ ->+                     prepareRepository uri+       return $ Slice { sliceRepo = repo, sliceSource = line }+    where+      uri = sourceUri line
+ Debian/Repo/SourceTree.hs view
@@ -0,0 +1,303 @@+module Debian.Repo.SourceTree +    ( -- * Source Tree+      SourceTreeC(..)+    , DebianSourceTreeC(..)+    , DebianBuildTreeC(..)+    , SourceTree(..)+    , DebianSourceTree(..)+    , DebianBuildTree(..)+    , findChanges+    , SourcePackageStatus(..)+    , buildDebs+    , findSourceTree+    , copySourceTree+    , findDebianSourceTree+    , copyDebianSourceTree+    , findDebianSourceTrees+    , findDebianBuildTree+    , findDebianBuildTrees+    , copyDebianBuildTree+    , findOneDebianBuildTree+    , explainSourcePackageStatus+    , addLogEntry+    --, findBuildChanges+    ) where++import Control.Exception+import Control.Monad.Trans+import qualified Data.ByteString.Lazy.Char8 as L+import Data.List+import Data.Maybe+import Debian.Control.String+import Debian.Extra.CIO (printOutput)+import Debian.Shell+import Debian.Repo.Changes+import Debian.Repo.OSImage+import Debian.Repo.Types+import Debian.Shell+import qualified Debian.Version as V+import Extra.Files (replaceFile, getSubDirectories)+import Extra.CIO (CIO, setStyle, addPrefixes)+import System.Directory+import System.Environment+import System.IO+import System.Time+import System.Unix.Process++-- |Any directory containing source code.+class Show t => SourceTreeC t where+    topdir :: t -> EnvPath		-- ^The top directory of the source tree++-- |A Debian source tree, which has a debian subdirectory containing+-- at least a control file and a changelog.+class (Show t, SourceTreeC t) => DebianSourceTreeC t where+    debdir :: t -> EnvPath		-- ^The directory containing the debian subdirectory+    control :: t -> Control		-- ^The contents of debian\/control+    entry :: t -> ChangeLogEntry	-- ^The latest entry from debian\/changelog++-- |A debian source tree plus a parent directory, which is where the+-- binary and source deb packages appear after a build.+class (Show t, DebianSourceTreeC t) => DebianBuildTreeC t where+    subdir :: t -> String		-- ^The basename of debdir++-- |Any directory containing source code.+data SourceTree =+    SourceTree {dir' :: EnvPath} deriving Show++-- |A Debian source tree, which has a debian subdirectory containing+-- at least a control file and a changelog.+data DebianSourceTree =+    DebianSourceTree {tree' :: SourceTree,+                      control' :: Control,+                      entry' :: ChangeLogEntry} deriving Show++-- |A Debian source tree plus a parent directory, which is where the+-- binary and source deb packages appear after a build.+data DebianBuildTree =+    DebianBuildTree {topdir' :: EnvPath,+                     subdir' :: String,+                     debTree' :: DebianSourceTree} deriving Show++instance SourceTreeC SourceTree where+    topdir = dir'++instance SourceTreeC DebianSourceTree where+    topdir = dir' . tree'++instance DebianSourceTreeC DebianSourceTree where+    debdir = dir' . tree'+    control = control'+    entry = entry'++instance SourceTreeC DebianBuildTree where+    topdir = topdir'++instance DebianSourceTreeC DebianBuildTree where+    debdir t = (topdir' t) { envPath = envPath (topdir' t) ++ "/" ++ subdir' t }+    control = control' . debTree'+    entry = entry' . debTree'++instance DebianBuildTreeC DebianBuildTree where+    subdir = subdir'++-- |Find the .changes file which is generated by a successful run of+-- dpkg-buildpackage.+findChanges :: DebianBuildTree -> IO (Either String ChangesFile)+findChanges tree =+    do let dir = topdir tree+       result <- findChangesFiles (outsidePath dir)+       case result of+         [cf] -> return (Right cf)+         [] -> return (Left ("Couldn't find .changes file in " ++ outsidePath dir))+         lst -> return (Left ("Multiple .changes files in " ++ outsidePath dir ++ ": " ++ show lst))++-- |Rewrite the changelog with an added entry.+addLogEntry :: DebianSourceTreeC t => ChangeLogEntry -> t -> IO ()+addLogEntry entry debtree =+    readFile changelogPath >>= replaceFile changelogPath . ((show entry) ++)+    where+      changelogPath = (outsidePath . debdir $ debtree) ++ "/debian/changelog"++-- |There are three possible results of a build: an upload consisting+-- of only the architecture independent debs (Indep), one including+-- both indep and binary debs (All), or with a failed build (None).+data SourcePackageStatus = All | Indep | None deriving (Show, Eq)++explainSourcePackageStatus :: SourcePackageStatus -> String+explainSourcePackageStatus All = "All architecture dependent files for the current build architecture are present."+explainSourcePackageStatus Indep = "Some or all architecture-dependent files for the current build architecture are missing"+explainSourcePackageStatus None = "This version of the package is not present."++-- | Run dpkg-buildpackage in a source tree.+buildDebs :: (DebianBuildTreeC t, CIO m) => Bool -> [String] -> OSImage -> t -> SourcePackageStatus -> m (Either String TimeDiff)+buildDebs noClean setEnv buildOS buildTree status =+    do+      noSecretKey <- liftIO (getEnv "HOME" >>= return . (++ "/.gnupg") >>= doesDirectoryExist >>= return . not)+      -- Unset LANG so perl doesn't complain about locales.+      -- Set LOGNAME so dpkg-buildpackage doesn't die when it fails to+      -- get the original user's login information+      let buildcmd =+              "dpkg-buildpackage -sa "+              ++ (case status of Indep -> " -B "; _ -> "")+                     ++ (if noSecretKey then " -us -uc" else "")+                            ++ (if noClean then " -nc" else "")+      let fullcmd = ("chroot " ++ rootPath root +++                     " bash -c \"unset LANG; export LOGNAME=root; " +++                     concat (map (\ x -> "export " ++ x ++ "; ") setEnv) +++                     "cd '" ++ path ++ "' && " +++                     "chmod ugo+x debian/rules && " +++                     -- Try to build twice, some packages do configuration the first+                     -- time 'so that it is NEVER run during an automated build.' :-/+                     "{ " ++ buildcmd ++ " || " ++ buildcmd ++ " ; } "+                     ++ "\"")+      liftIO (lazyCommand fullcmd L.empty) >>=+             setStyle (addPrefixes "[1] " "[2] ") . printOutput >>=+             return . discardOutput >>=+             timeTask . checkResult (\ n -> return (Left ("*** FAILURE: " ++ fullcmd ++ " -> " ++ show n))) (return (Right ())) >>=+             \ (result, elapsed) -> return (either Left (const (Right elapsed)) result)+    where+      path = envPath . debdir $ buildTree+      root = rootDir buildOS++-- |Make a copy of a source tree in a directory.+copySourceTree :: (SourceTreeC t, CIO m) => t -> EnvPath -> m (Either String SourceTree)+copySourceTree tree dest =+    liftIO (try (createDirectoryIfMissing True (outsidePath dest))) >>=+    either (return . Left . show) (const (runTaskAndTest (SimpleTask 0 command))) >>=+    return . either Left (const . Right . SourceTree $ dest)+       --copyStyle $ systemTaskDR ("rsync -aHxSpDt --delete '" ++ outsidePath (topdir tree) ++ "/' '" ++ outsidePath dest ++ "'")+       --return $ SourceTree dest+    where+      command = "rsync -aHxSpDt --delete '" ++ outsidePath (topdir tree) ++ "/' '" ++ outsidePath dest ++ "'"+{-+      copyStyle = setStyle (setStart (Just ("Copying source tree (" ++ outsidePath dest ++ ")")) .+                            setError (Just ("Could not copy source tree from " +++                                            outsidePath (topdir tree) ++ " to " ++ outsidePath dest)))+-}++copyDebianSourceTree :: (DebianSourceTreeC t, CIO m) => t -> EnvPath -> m (Either String DebianSourceTree)+copyDebianSourceTree src dest =+    copySourceTree src dest >>=+    return . either Left (\ copy -> Right (DebianSourceTree copy (control src) (entry src))) ++copyDebianBuildTree :: (DebianBuildTreeC t, CIO m) => t -> EnvPath -> m (Either String DebianBuildTree)+copyDebianBuildTree src dest =+    copySource >>= copyTarball >>= makeTree+    where+      copySource = copySourceTree (SourceTree . topdir $ src) dest+      copyTarball (Left message) = return (Left message)+      copyTarball (Right copy) =+          do exists <- liftIO $ doesFileExist origPath+             case exists of+               False -> return (Right copy)+               True -> runCommand 0 cmd >>= return . either Left (const (Right copy))+      makeTree (Left message) = return (Left message)+      makeTree (Right copy) =+          return $ Right (DebianBuildTree (dir' copy) (subdir src)+                          (DebianSourceTree { tree' = SourceTree { dir' = dest { envPath = envPath dest ++ "/" ++ subdir src } }+                                            , control' = (control src)+                                            , entry' = (entry src) }))+{-               +    do copy <- copySourceTree (SourceTree . topdir $ src) dest+       exists <- io $ doesFileExist origPath+       --io $ System.IO.hPutStrLn stderr ("doesFileExist " ++ show origPath ++ " -> " ++ show exists)+       case exists of+         True -> quietRunOutputOnError cmd+         False -> return ([], noTimeDiff)+       return $ DebianBuildTree (dir' copy) (subdir src)+                  (DebianSourceTree { tree' = SourceTree { dir' = dest { envPath = envPath dest ++ "/" ++ subdir src } }+                                    , control' = (control src)+                                    , entry' = (entry src) })+    where+-}+      cmd = ("cp -p " ++ origPath ++ " " ++ outsidePath dest ++ "/")+      origPath = outsidePath (topdir src) ++ "/" ++ orig+      orig = name ++ "_" ++ version ++ ".orig.tar.gz"+      name = logPackage . entry $ src+      version = V.version . logVersion . entry $ src+      +findSourceTree :: CIO m => EnvPath -> m (Either String SourceTree)+findSourceTree path =+    do exists <- liftIO $ doesDirectoryExist (outsidePath path)+       case exists of+         False -> return . Left $ "No such directory: " ++ outsidePath path+         True -> return . Right . SourceTree $ path++findDebianSourceTree :: CIO m => EnvPath -> m (Either String DebianSourceTree)+findDebianSourceTree path =+    do --vPutStrLn 2 stderr $ "findDebianSourceTree " ++ show path+       findSourceTree path >>= either (return . Left) findDebianSource+    where+      findDebianSource :: CIO m => SourceTree -> m (Either String DebianSourceTree)+      findDebianSource tree@(SourceTree path) =+          do let controlPath = outsidePath path ++ "/debian/control"+                 changelogPath = outsidePath path ++ "/debian/changelog"+             control <-+                 liftIO (try . readFile $ controlPath) >>=+                 return . either (Left . (("Could not read control file: " ++ controlPath ++ ": ") ++) . show)+                            (either (const (Left $ "Parse error in control file: " ++ controlPath)) Right .+                                        (parseControl controlPath))+             log <- liftIO (try . readFile $ changelogPath) >>= return . either (Left . ("Failure reading changelog: " ++) . show) (Right . parseLog)+             case (control, log) of+               (Right control, (Right (Right entry : _))) -> return . Right $ DebianSourceTree tree control entry+               (Right _control, (Right (Left x : _))) -> return . Left $ "Bad changelog entry: " ++ changelogPath ++ " -> " ++ show x+               (Right _control, (Right [])) -> return . Left $ "Empty changelog file: " ++ changelogPath+               (Left control, _) -> return . Left $ "Bad control file: " ++ controlPath ++ " -> " ++ show control+               (_, Left log) -> return . Left $ "Bad changelog: " ++ changelogPath ++ " -> " ++ show log++-- |Find a DebianBuildTree inside a directory.  It finds all the+-- DebianSourceTrees, and if they all have the same package name it+-- returns the newest one according to the version numbers.  If there+-- are none, or there are trees with different package names, Nothing+-- is returned.+findOneDebianBuildTree :: CIO m => EnvPath -> m (Maybe DebianBuildTree)+findOneDebianBuildTree path =+    do trees <- findDebianBuildTrees path+       case nubBy eqNames trees of+         [_] -> return $ listToMaybe (sortBy cmpVers trees)+         _ -> return Nothing+    where+      eqNames tree1 tree2 = (logPackage . entry $ tree1) == (logPackage . entry $ tree2)+      cmpVers tree1 tree2 = compare (logVersion . entry $ tree1) (logVersion . entry $ tree2)++-- |Find the DebianBuildTree in a particular subdirectory.+findDebianBuildTree :: CIO m => EnvPath -> String -> m (Either String DebianBuildTree)+findDebianBuildTree path name =+    findDebianSourceTree (appendPath ("/" ++ name) path) >>= return . either Left (Right . DebianBuildTree path name)+    ++-- |Find all the debian source trees in a directory.+findDebianSourceTrees :: CIO m => EnvPath -> m [(String, DebianSourceTree)]+findDebianSourceTrees path =+    do dirs <- liftIO (try (getSubDirectories (outsidePath path))) >>= return . either (const []) id+       trees <- mapM (\ dir -> findDebianSourceTree (appendPath ("/" ++ dir) path)) dirs+       return $ catRightSeconds $ zip dirs trees++-- |Find all the debian source trees in a directory.+findDebianBuildTrees :: CIO m => EnvPath -> m [DebianBuildTree]+findDebianBuildTrees path =+    do dirs <- (liftIO $ try (getSubDirectories (outsidePath path))) >>= return . either (const []) id+       trees <- mapM (\ dir -> findDebianSourceTree (appendPath ("/" ++ dir) path)) dirs+       let trees' = catRightSeconds $ zip dirs trees+       return $ map (\ (subdir, tree) -> DebianBuildTree path subdir tree) trees'++catRightSeconds :: [(a, Either b c)] -> [(a, c)]+catRightSeconds [] = []+catRightSeconds ((y, Right x) : more) = (y, x) : catRightSeconds more+catRightSeconds ((_, _) : more) = catRightSeconds more++-- |Construct the directory name that dpkg-buildpackage expects to find the+-- source code in for this package: <packagename>-<upstreamversion>.+debDir :: DebianSourceTree -> String+debDir (DebianSourceTree _ _ entry) = logPackage entry ++ "-" ++ show (logVersion entry)++-- |Find the .changes file which is generated by a successful run of+-- dpkg-buildpackage.+findBuildChanges :: DebianBuildTree -> IO (Either String ChangesFile)+findBuildChanges tree =+    do let dir = topdir tree+       result <- findChangesFiles (outsidePath dir)+       case result of+         [cf] -> return (Right cf)+         [] -> return (Left ("Couldn't find .changes file in " ++ outsidePath dir))+         lst -> return (Left ("Multiple .changes files in " ++ outsidePath dir ++ ": " ++ show lst))
+ Debian/Repo/SourcesList.hs view
@@ -0,0 +1,143 @@+--- | A DebSource represents a release of a remote repository and a+--- method for accessing that repository.+module Debian.Repo.SourcesList+    (parseSourceLine,	-- String -> DebSource+     parseSourceLine',	-- String -> Maybe DebSource+     parseSourcesList,	-- String -> [DebSource]+     quoteWords	-- String -> [String]+    )+    where++import Debian.URI+import Debian.Repo.Types++import Data.List+import Data.Maybe++{-++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 " [\"") 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 =+    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, 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, sourceUri = theUri, sourceDist = Right (parseReleaseName theDist, sections) }+      _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str)++parseSourceLine' :: String -> Maybe DebSource+parseSourceLine' str =+    case quoteWords str of+      (theTypeStr : theUriStr : theDistStr : sectionStrs) ->+          let sections = map parseSection' sectionStrs+              theType = case unEscapeString theTypeStr of+                          "deb" -> Just Deb+                          "deb-src" -> Just DebSrc+                          _ -> Nothing+              theUri = case parseURI theUriStr of+                         Nothing -> Nothing+                         Just u -> Just u+              theDist = unEscapeString theDistStr+          in+            case (last theDist, theType, theUri) of+              ('/', Just typ, Just uri) -> if null sections+                      then Just $ DebSource { sourceType = typ, sourceUri = uri, sourceDist = Left theDist }+                      else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str)+              (_, Just typ, Just uri) -> if null sections+                    then Nothing+                    else Just $ DebSource { sourceType = typ, sourceUri = uri, sourceDist = Right ((parseReleaseName theDist), sections) }+              _ -> Nothing+      _ -> Nothing++parseSourcesList :: String -> [DebSource]+parseSourcesList = map parseSourceLine . sourceLines
+ Debian/Repo/Types.hs view
@@ -0,0 +1,410 @@+module Debian.Repo.Types +    ( EnvRoot(..)+    , EnvPath(..)+    , outsidePath+    , appendPath+    , rootEnvPath+    -- * Repository+    , PackageVersion(..)+    , PkgVersion(..)+    , Repo(..)+    , libraryCompatibilityLevel+    , compatibilityFile+    , Repository(..)+    , LocalRepository(..)+    , Layout(..)+    -- * Release+    , ReleaseName(..)+    , parseReleaseName+    , ReleaseInfo(..)+    , Arch(..)+    , archName+    , Section(..)+    , SubSection(..)+    , sectionNameOfSubSection+    , sectionName+    , sectionName'+    , parseSection+    , parseSection'+    , Release(..)+    , releaseName'+    , releaseName+    , releaseComponents+    , releaseArchitectures+    -- * Each line of the sources.list represents a slice of a repository+    , SourceType(..)+    , DebSource(..)+    , SliceName(..)+    , Slice(..)+    , SliceList(..)+    , NamedSliceList(..)+    -- * Package, Source and Binary Debs+    , PackageIndex(..)+    , PackageIndexLocal+    , PackageID(..)+    , BinaryPackage(..)+    , SourcePackage(..)+    , SourceFileSpec(..)+    , PackageIDLocal+    , BinaryPackageLocal+    , SourcePackageLocal+    -- * Cached OS Image+    , AptCache(..)+    , AptBuildCache(..)+    , AptImage(..)+    ) where++import qualified Debian.Control.ByteString as B+import qualified Debian.Relation as B+import Debian.URI+import Debian.Version++import Control.Exception (throw)+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char+import Data.List+import Data.Maybe+import Network.URI+import System.FilePath ((</>))+import System.Posix.Types+import System.Unix.Process++-- |The root directory of an OS image.+data EnvRoot = EnvRoot { rootPath :: FilePath } deriving (Ord, Eq, Read, Show)++-- |A directory inside of an OS image.+data EnvPath = EnvPath { envRoot :: EnvRoot+                       , envPath :: FilePath+                       } deriving (Ord, Eq, Read, Show)++outsidePath :: EnvPath -> FilePath+outsidePath path = rootPath (envRoot path) ++ envPath path++appendPath :: FilePath -> EnvPath -> EnvPath+appendPath suff path = path { envPath = envPath path ++ suff }++rootEnvPath :: FilePath -> EnvPath+rootEnvPath s = EnvPath { envRoot = EnvRoot "", envPath = s }++--------------------- REPOSITORY -----------------------++-- | The Repository type reprents any instance of the Repo class, so+-- it might be local or remote.+--data Repository = forall a. (Repo a) => Repository a+data Repository+    = LocalRepo LocalRepository+    | VerifiedRepo URIString [ReleaseInfo]+    | UnverifiedRepo URIString+    deriving (Read, Show)++instance Ord Repository where+    compare a b = compare (repoURI a) (repoURI b)++instance Eq Repository where+    a == b = compare a b == EQ++data LocalRepository+    = LocalRepository+      { repoRoot :: EnvPath+      , repoLayout :: (Maybe Layout)+      , repoReleaseInfoLocal :: [ReleaseInfo]+      } deriving (Read, Show, Ord, Eq)++-- |The possible file arrangements for a repository.  An empty+-- repository does not yet have either of these attributes.+data Layout = Flat | Pool deriving (Eq, Ord, Read, Show)++instance Repo Repository where+    repoURI (LocalRepo (LocalRepository path _ _)) = fromJust . parseURI $ "file://" ++ envPath path+    repoURI (VerifiedRepo uri _) = fromJust (parseURI uri)+    repoURI (UnverifiedRepo uri) = fromJust (parseURI uri)+{-+    repoURI (Repository a) = repoURI a+    repositoryCompatibilityLevel (Repository a) = repositoryCompatibilityLevel a+    repoReleaseInfo (Repository a) = repoReleaseInfo a+-}+    repoReleaseInfo (LocalRepo (LocalRepository _ _ info)) = info+    repoReleaseInfo (VerifiedRepo _ info) = info+    repoReleaseInfo (UnverifiedRepo _uri) = error "No release info for unverified repository"++instance Repo LocalRepository where+    repoURI (LocalRepository path _ _) = fromJust . parseURI $ "file://" ++ envPath path+    repoReleaseInfo (LocalRepository _ _ info) = info++class (Ord t, Eq t) => Repo t where+    repoURI :: t -> URI+    repositoryCompatibilityLevel :: t -> IO (Maybe Int)+    repositoryCompatibilityLevel r =+        fileFromURI uri' >>= either throw (return . parse . L.unpack)+        where+          uri' = uri {uriPath = uriPath uri </> compatibilityFile}+          uri = repoURI r+{-+        lazyCommand cmd L.empty >>= return . collectOutput >>= test cmd+        where+          cmd = "curl -s -g '" ++ uriToString id (repoURI r) "" </> compatibilityFile ++ "'"+          test _ (out, _err, [ExitSuccess]) = return (parse (L.unpack out))+          test cmd (_, _, _) = error $ "*** FAILURE: " ++ cmd+-}+          parse :: String -> Maybe Int+          parse text = case takeWhile isDigit text of+                         "" -> Nothing+                         s -> Just . read $ s+    -- | This method returns a list of all the release in the+    -- repository.  This can be used to identify all of the files+    -- in the repository that are not garbage.+    repoReleaseInfo :: t -> [ReleaseInfo]+    checkCompatibility :: t -> IO ()+    checkCompatibility repo =+        do level <- repositoryCompatibilityLevel repo+           case level of+             Nothing -> return ()+             Just n | n >= libraryCompatibilityLevel -> return ()+             Just n -> error ("Compatibility error: repository level " ++ show n +++                              " < library level " ++ show libraryCompatibilityLevel ++ ", please upgrade.")++-- |The name of the file which holds the repository's compatibility+-- level.+compatibilityFile :: FilePath+compatibilityFile = "repository-compat"++-- | The compatibility level of this library and any applications+-- which use it.  It is an error if we try to use a repository whose+-- compatibility level is higher than this, a newer version of the+-- library must be used.  This value was increased from 1 to 2 due+-- to a new version number tagging policy.+libraryCompatibilityLevel :: Int+libraryCompatibilityLevel = 2++class (Eq a, Ord a) => PackageVersion a where+    pkgName :: a -> B.PkgName+    pkgVersion :: a -> DebianVersion++-- |This is an old type which is still used to interface with the+-- Debian.Relation module.+data PkgVersion = PkgVersion { getName :: B.PkgName+                             , getVersion :: DebianVersion+                             } deriving (Eq, Ord)++instance PackageVersion PkgVersion where+    pkgName = getName+    pkgVersion = getVersion++instance Show PkgVersion where+    show v = getName v ++ "=" ++ show (getVersion v)++-------------------- RELEASE --------------------++-- |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)++parseReleaseName :: String -> ReleaseName+parseReleaseName name = ReleaseName {relName = unEscapeString name}++releaseName' :: ReleaseName -> String+releaseName' (ReleaseName {relName = s}) = escapeURIString isAllowedInURI s++-- FIXME: The lists here should be sets so that == and compare work properly.+data ReleaseInfo = ReleaseInfo { releaseInfoName :: ReleaseName+                               , releaseInfoAliases :: [ReleaseName]+                               , releaseInfoArchitectures :: [Arch]+                               , releaseInfoComponents :: [Section]+                               } deriving (Eq, Ord, Read, Show)++-- |The types of architecture that a package can have, either Source+-- or some type of binary architecture.+data Arch = Source | Binary String deriving (Read, Show, Eq, Ord)++archName :: Arch -> String+archName Source = "source"+archName (Binary arch) = arch++-- |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 section =+    case span (/= '/') section of+      (x, "") -> SubSection (Section "main") x+      ("main", y) -> SubSection (Section "main") y+      (x, y) -> SubSection (Section x) (tail y)++parseSection' name =+    Section (unEscapeString name)++data Release = Release { releaseRepo :: Repository+                       , releaseInfo :: ReleaseInfo+                       } deriving (Eq, Ord, Show)++releaseName :: Release -> ReleaseName+releaseName = releaseInfoName . releaseInfo+--releaseAliases :: Release -> [ReleaseName]+--releaseAliases = releaseInfoAliases . releaseInfo+releaseComponents :: Release -> [Section]+releaseComponents = releaseInfoComponents . releaseInfo+releaseArchitectures :: Release -> [Arch]+releaseArchitectures = releaseInfoArchitectures . releaseInfo++----------------- SLICES (SOURCES.LIST ENTRIES) ---------------++data SourceType+    = Deb | DebSrc+    deriving (Eq, Ord)++data DebSource+    = DebSource+    { sourceType :: SourceType+    , sourceUri :: URI+    , sourceDist :: Either String (ReleaseName, [Section])+    } deriving (Eq, Ord)++instance Show SourceType where+    show Deb = "deb"+    show DebSrc = "deb-src"++instance Show DebSource where+    show (DebSource thetype theuri thedist) =+        (show thetype) ++ " "++ uriToString id theuri " " +++        (case thedist of+           Left exactPath -> escape exactPath+           Right (dist, sections) ->+               releaseName' dist ++ " " ++ intercalate " " (map sectionName' sections))+        where escape = escapeURIString isAllowedInURI++-- |This is a name given to a combination of parts of one or more+-- releases that can be specified by a sources.list file.+data SliceName = SliceName { sliceName :: String } deriving (Eq, Ord)++data Slice+    = Slice { sliceRepo :: Repository+            , sliceSource :: DebSource+            } deriving (Eq, Ord)++data SliceList = SliceList {slices :: [Slice]} deriving (Eq, Ord)++data NamedSliceList+    = NamedSliceList { sliceList :: SliceList+                     , sliceListName :: SliceName+                     } deriving (Eq, Ord)++instance Show Slice where+    show = show . sliceSource++instance Show SliceList where+    show = concat . map ((++ "\n") . show) . slices++---------------- PACKAGES AND PACKAGE INDEXES -------------++-- |The PackageIndex type represents a file containing control+-- information about debian packages, either source or binary.+-- Though the control information for a binary package does not+-- specify an architecture, the architecture here is that of+-- the environment where the package information is cached.+data PackageIndex+    = PackageIndex { packageIndexRelease :: Release+                   , packageIndexComponent :: Section+                   , packageIndexArch :: Arch+                   } deriving (Eq, Ord, Show)++type PackageIndexLocal = PackageIndex++instance Show BinaryPackage where+    show p = packageName (packageID p) ++ "-" ++ show (packageVersion (packageID p))++-- | The 'PackageID' type fully identifies a package by name, version,+-- and a 'PackageIndex' which identifies the package's release,+-- component and architecture.+data PackageID+    = PackageID+      { packageIndex :: PackageIndex+      , packageName :: String+      , packageVersion :: DebianVersion+      } deriving (Eq, Ord, Show)++-- | The 'BinaryPackage' type adds to the 'PackageID' type the control+-- information obtained from the package index.+data BinaryPackage+    = BinaryPackage+      { packageID :: PackageID+      , packageInfo :: B.Paragraph+      , pDepends :: B.Relations+      , pPreDepends :: B.Relations+      , pConflicts ::B.Relations+      , pReplaces :: B.Relations+      , pProvides :: B.Relations+      }++instance Ord BinaryPackage where+    compare a b = compare (packageID a) (packageID b)++instance Eq BinaryPackage where+    a == b = (packageID a) == (packageID b)++data SourcePackage+    = SourcePackage+      { sourcePackageID :: PackageID+      , sourceParagraph :: B.Paragraph+      , sourceDirectory :: String+      , sourcePackageFiles :: [SourceFileSpec]+      }++data SourceFileSpec+    = SourceFileSpec+      { sourceFileMD5sum :: String+      , sourceFileSize :: FileOffset+      , sourceFileName :: FilePath+      }++type PackageIDLocal = PackageID+type BinaryPackageLocal = BinaryPackage+type SourcePackageLocal = SourcePackage++---------------------- CACHED OS IMAGE ---------------------++class (Ord t, Eq t, Show t) => AptCache t where+    globalCacheDir :: t -> FilePath+    -- | The directory you might chroot to.+    rootDir :: t -> EnvRoot+    -- | The sources.list without the local repository+    aptBaseSliceList :: t -> SliceList+    -- | The build architecture+    aptArch :: t -> Arch+    -- | Return the all source packages in this AptCache.+    aptSourcePackages :: t -> [SourcePackage]+    -- | Return the all binary packages for the architecture of this AptCache.+    aptBinaryPackages :: t -> [BinaryPackage]+    -- | Name of release+    aptReleaseName :: t -> ReleaseName++class AptCache t => AptBuildCache t where+    -- | The sources.list+    aptSliceList :: t -> SliceList++data AptImage =+    AptImage { aptGlobalCacheDir :: FilePath+             , aptImageRoot :: EnvRoot+             , aptImageArch :: Arch+             , aptImageSliceList :: SliceList+             , aptImageReleaseName :: ReleaseName+             , aptImageSourcePackages :: [SourcePackage]+             , aptImageBinaryPackages :: [BinaryPackage]+             }
+ Debian/Report.hs view
@@ -0,0 +1,87 @@+module Debian.Report where++import Debian.Apt.Index (Fetcher(..), Compression(..), update, controlFromIndex')+import Debian.Control.ByteString+import Debian.Repo.Types+import Debian.Version++import Data.Maybe+import qualified Data.Map as M+import qualified Data.ByteString.Char8 as B+import Extra.HaXml (mkTxt)+import Text.XML.HaXml++-- * 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 B.ByteString 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 -> M.Map B.ByteString 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 . B.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 B.ByteString (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 B.ByteString DebianVersion -- ^ package map a+           -> M.Map B.ByteString DebianVersion -- ^ package map b+           -> M.Map B.ByteString (DebianVersion, DebianVersion) -- ^ trumped packages (version a, version b)+trumpedMap pmA pmB =+    M.foldWithKey (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 B.ByteString (DebianVersion, DebianVersion) -> CFilter+trumpedXML trumpedMap' =+    mkElem "trumped" (map mkTrumpedPackage (M.toAscList trumpedMap' ))+    where+      mkTrumpedPackage (package, (oldVersion, newVersion)) =+          mkElem "trumpedPackage"+                     [ mkElem "package" [ mkTxt (B.unpack package) ]+                     , mkElem "oldVersion" [ mkTxt (show oldVersion) ]+                     , mkElem "newVersion" [ mkTxt (show newVersion) ]+                     ]
+ Debian/Shell.hs view
@@ -0,0 +1,261 @@+-- |This module probably belongs in haskell-unixutils.+module Debian.Shell +    ( echoCommand+    , echoProcess+    , dotOutput+    , vOutput+    -- * Semi-obsolete+    , runCommand+    , runCommandQuietly+    , runCommandTimed+    , runCommandQuietlyTimed+    , runCommandMsg+    -- * Type Class+    , ShellTask(..)+    , SimpleTask(..)+    , FullTask(..)+    , commandTask+    , processTask+    , showCommand+    , setStart+    , setFinish+    , setError+    , runTask+    , runTaskAndTest+    , timeTask+{-+    , timeTask'+    , timeTask''+-}+    , timeTaskAndTest+    --, runCommandDots+    , timeCommand+    , showElapsed+    , myTimeDiffToString+    ) where++import		 Control.Exception+-- import		 Control.Monad+import		 Control.Monad.Trans+-- import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import		 Data.List+import		 Debian.Extra.CIO (dotOutput, printOutput, vMessage)+import		 Extra.CIO (CIO, ePutStrBl, vEPutStrBl, ePutStr, eBOL, ev, setStyle, addPrefixes)+import		 Prelude hiding (putStr)+import		 System.Locale+import		 System.Time+import		 System.Unix.Process -- as P+import		 Text.Printf++-- io = liftIO++-- There seems to be a bug in Haskell's TimeDiff code,+-- sometimes tdPicosec returns a negative number.+myDiffClockTimes (TOD sa pa) (TOD sb pb) =+    case pa >= pb of+      True ->+          noTimeDiff{ tdSec     = fromIntegral (sa - sb) +                    -- FIXME: can handle just 68 years...+                    , tdPicosec = pa - pb+                    }+      False ->+          noTimeDiff{ tdSec     = fromIntegral (sa - sb - 1) +                    -- FIXME: can handle just 68 years...+                    , tdPicosec = pa + 1000000000000 - pb+                    }++echoCommand :: CIO m => String -> L.ByteString -> m [Output]+echoCommand command input =+    ePutStrBl ("# " ++ command) >>+    liftIO (lazyCommand command input)++-- |Echo the process arguments and then run the process+echoProcess :: CIO m => FilePath -> [String] -> L.ByteString -> m [Output]+echoProcess exec args input =+    ePutStrBl (intercalate " " ("#" : exec : args)) >>+    liftIO (lazyProcess exec args Nothing Nothing input)++vOutput :: CIO m => Int -> [Output] -> m [Output]+vOutput v output =+    do v' <- ev v+       --lift (IO.hPutStr IO.stderr ("(ev=" ++ show (verbosity style) ++ "-" ++ show v ++ "=" ++ show ev ++ ")"))+       case () of+         _ | v' <= (-2) -> return output+           | v' <= (-1) -> dotOutput 128 output+           | True -> setStyle (addPrefixes "[1] " "[2] ") (printOutput output)++-- |Perform a task, print the elapsed time it took, and return the result.+showElapsed :: CIO m => String -> m a -> m a+showElapsed label f =+    do (result, time) <- timeTask f+       ePutStr (label ++ myTimeDiffToString time)+       return result++-- This is a copy of a function Jeremy made private in Debian.Repo.IO.+-- This probably means there is a standard replacement for it - must+-- find out.+myTimeDiffToString diff =+    do+      case () of+        _ | isPrefixOf "00:00:0" s -> drop 7 s ++ printf ".%03d" ms ++ " s."+        _ | isPrefixOf "00:00:" s -> drop 6 s ++ printf ".%03d" ms ++ " s."+        _ | isPrefixOf "00:" s -> drop 3 s+        _ -> s+    where+      s = formatTimeDiff defaultTimeLocale "%T" diff+      ms = ps2ms ps+      ps2ms ps = quot (ps + 500000000) 1000000000+      ps = tdPicosec diff++-- |Run a command and return its result along with the amount of time it took.+timeCommand :: CIO m => m (Either String [Output]) -> m (Either String ([Output], TimeDiff))+timeCommand result =+    timeTask result >>= \ (result, elapsed) -> return (either Left (\ output -> Right (output, elapsed)) result)++-- |Not sure if this is a useful approach.+class ShellTask a where+    command :: a -> Either String (FilePath, [String], Maybe FilePath, Maybe [(String, String)])+    input :: a -> L.ByteString					-- The command input+    input _ = L.empty+    quietness :: a -> Int					-- Verbosity level required for full output+    quietness _ = 0+    introMsg :: a -> Maybe String				-- Message printed before command starts+    introMsg _ = Nothing+    -- If failMsg or finishMsg are given, the command output will be forced+    failMsg :: a -> Maybe (Int -> String)			-- Message printed on failure+    failMsg _ = Nothing+    finishMsg :: a -> Maybe String				-- Message printed on successful finish+    finishMsg _ = Nothing++data SimpleTask = SimpleTask Int String++instance ShellTask SimpleTask where+    command (SimpleTask _ s) = (Left s)+    quietness (SimpleTask n _) = n+    introMsg (SimpleTask _ _) = Nothing++data FullTask =+    FullTask { taskQuietness :: Int+             , taskCommand :: Either String (FilePath, [String], Maybe FilePath, Maybe [(String, String)])+             , taskIntroMsg :: Maybe String+             , taskFailMsg :: Maybe (Int -> String)+             , taskFinishMsg :: Maybe String }++commandTask command =+    FullTask { taskQuietness = 0+             , taskCommand = Left command+             , taskIntroMsg = Nothing+             , taskFailMsg = Nothing+             , taskFinishMsg = Nothing }++processTask exec args path env =+    FullTask { taskQuietness = 0+             , taskCommand = Right (exec, args, path, env)+             , taskIntroMsg = Nothing+             , taskFailMsg = Nothing+             , taskFinishMsg = Nothing }++setStart :: (Maybe String) -> FullTask -> FullTask+setStart s task = task {taskIntroMsg = s}++setFinish :: (Maybe String) -> FullTask -> FullTask+setFinish s task = task {taskFinishMsg = s}++setError :: (Maybe (Int -> String)) -> FullTask -> FullTask+setError s task = task {taskFailMsg = s}++showCommand task = either id (\ (exec, args, _, _) -> intercalate " " ([exec] ++ args)) (command task)++instance ShellTask FullTask where+    quietness = taskQuietness+    command = taskCommand+    introMsg = taskIntroMsg+    failMsg = taskFailMsg+    finishMsg = taskFinishMsg++runTask :: (ShellTask a, CIO m) => a -> m [Output]+runTask task =+    liftIO (either (\ cmd -> lazyCommand cmd (input task)) +                       (\ (exec, args, path, env) -> lazyProcess exec args path env (input task)) (command task)) >>=+    maybe return (vMessage 0) (introMsg task) >>=+    vOutput 2 >>=+    (\ output ->+         (case (failMsg task, finishMsg task) of+            (Nothing, Nothing) -> return output+            _ -> checkResult (onFail task) (onFinish task) output >> return output))+    where+      onFail :: (ShellTask a, CIO m) => a -> Int -> m ()+      onFail task n = maybe (return ()) (\ f -> vEPutStrBl 0 (f n)) (failMsg task)+      onFinish :: (ShellTask a, CIO m) => a -> m ()+      onFinish task = maybe (return ()) (\ s -> vEPutStrBl 0 s) (finishMsg task)++runTaskAndTest :: (ShellTask a, CIO m) => a -> m (Either String [Output])+runTaskAndTest task =+    do output <- runTask task+       checkResult fail (ok output) output+    where+      fail n = return (Left (maybe ("*** FAILURE: " ++ showCommand task ++ " -> " ++ show n) (\ f -> f n) (failMsg task)))+      ok output = return (Right output)++{-+-- |Run a task and return the elapsed time along with its result.+timeTask :: MonadIO m => a -> m (a, TimeDiff)+timeTask x =+    do start <- liftIO getClockTime+       result <- liftIO (evaluate x)+       finish <- liftIO getClockTime+       return (result, myDiffClockTimes finish start)++-- |Run a task and return the elapsed time along with its result.+timeTask' :: MonadIO m => m a -> m (a, TimeDiff)+timeTask' x =+    do start <- liftIO getClockTime+       result <- x >>= liftIO . evaluate+       finish <- liftIO getClockTime+       return (result, myDiffClockTimes finish start)++timeTask'' :: (ShellTask a, CIO m) => a -> m ([Output], TimeDiff)+timeTask'' task = runTask task >>= timeTask+-}++-- |Run a task and return the elapsed time along with its result.+timeTask :: MonadIO m => m a -> m (a, TimeDiff)+timeTask x =+    do start <- liftIO getClockTime+       result <- x >>= liftIO . evaluate+       finish <- liftIO getClockTime+       return (result, myDiffClockTimes finish start)++timeTaskAndTest :: (ShellTask a, CIO m) => a -> m (Either String ([Output], TimeDiff))+timeTaskAndTest task =+    timeTask (runTaskAndTest task) >>= return . fixResult+    where+      fixResult (Left x, _) = Left x+      fixResult (Right x, t) = Right (x, t)++-- Reimplementations of old functions++runCommand :: CIO m => Int -> String -> m (Either String [Output])+runCommand v cmd = runTaskAndTest (SimpleTask v cmd)++runCommandTimed :: CIO m => Int -> String -> m (Either String ([Output], TimeDiff))+runCommandTimed v cmd = timeCommand (runCommand v cmd)++runCommandQuietly :: CIO m => String -> m (Either String [Output])+runCommandQuietly = runCommand 1++runCommandQuietlyTimed :: CIO m => String -> m (Either String ([Output], TimeDiff))+runCommandQuietlyTimed = runCommandTimed 1++runCommandMsg :: CIO m => Int -> Maybe String -> String -> (Int -> m (Either String ())) -> m (Either String ())+runCommandMsg v start cmd fail =+    -- If the program is run with -v -v, v0 will be 2, meaning quit verbose output.+    -- The higher the v argument is the higher the v0 argument must be to achieve+    -- the same verbosity, so the "effective verbosity" ev is v0 - v.+    do eBOL >> +            maybe (return ()) (vEPutStrBl v) start >>+            vEPutStrBl (v+1) ("# " ++ cmd) >>+            liftIO (lazyCommand cmd L.empty) >>=+            vOutput (v+2) >>=+            checkResult fail (return (Right ()))
+ Debian/Time.hs view
@@ -0,0 +1,24 @@+module Debian.Time where++import Data.Time+import Data.Time.Clock.POSIX+import System.Locale (defaultTimeLocale)+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 view
@@ -0,0 +1,48 @@+module Debian.URI+    ( module Network.URI+    , URIString+    , uriToString'+    , fileFromURI+    , dirFromURI+    ) where++import Control.Exception (Exception(..), try)+import Control.Monad.Trans (MonadIO)+import qualified Data.ByteString.Lazy.Char8 as L+import Extra.Net (webServerDirectoryContents)+import Network.URI+import System.Directory (getDirectoryContents)+import System.Exit+import System.Unix.Process (lazyCommand, collectOutput)++uriToString' uri = uriToString id uri ""++instance Ord URI where+    compare a b = compare (uriToString' a) (uriToString' b)++-- |If the URI type could be read and showed this wouldn't be necessary.+type URIString = String++fileFromURI :: URI -> IO (Either Exception L.ByteString)+fileFromURI uri =+    case (uriScheme uri, uriAuthority uri) of+      ("file:", Nothing) -> try (L.readFile (uriPath uri))+      ("ssh:", Just auth) -> cmdOutput ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth +++                                        " cat " ++ show (uriPath uri))+      _ -> cmdOutput ("curl -s -g '" ++ uriToString' uri ++ "'")++dirFromURI :: URI -> IO (Either Exception [String])+dirFromURI uri =+    case (uriScheme uri, uriAuthority uri) of+      ("file:", Nothing) -> try (getDirectoryContents (uriPath uri))+      ("ssh:", Just auth) -> cmdOutput ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth +++                                        " ls -1 " ++ uriPath uri) >>=+                             return . either Left (Right . lines . L.unpack)+      _ -> cmdOutput ("curl -s -g '" ++ uriToString' uri ++ "/'") >>= return . either Left (Right . webServerDirectoryContents)++cmdOutput :: String -> IO (Either Exception L.ByteString)+cmdOutput cmd =+    do (out, err, code) <- lazyCommand cmd L.empty >>= return . collectOutput+       case code of+         [ExitSuccess] -> return (Right out)+         [ExitFailure _] -> return . Left . ErrorCall $ "Failure: " ++ show cmd
+ Debian/Util/FakeChanges.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Debian.Util.FakeChanges (fakeChanges) where++--import Control.Arrow+import Control.Exception+import Control.Monad hiding (mapM)+import Data.Foldable+import Data.List hiding (concat, foldr, all)+import Data.Maybe +--import Data.Typeable+import Data.Generics+import Data.Traversable+import Debian.Time+import System.Environment+import System.Posix.Files+import Text.Regex.Posix+import Prelude hiding (catch, concat, foldr, all, mapM)+import Network.BSD++import Debian.Control+import qualified Debian.Deb as Deb+import System.Unix.FilePath+import System.Unix.Misc+++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+            }+      deriving Show+      +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"], show 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+                [binArch] -> binArch+                _ -> error $ "Could not uniquely determine binary architecture: " ++ show binArch++mkFileLine :: FilePath -> IO String+mkFileLine fp+    | ".deb" `isSuffixOf` fp =+        do sum <- md5sum fp+           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), " ", (baseName fp)+                           ]+    | otherwise =+        do sum <- md5sum fp +           size <- liftM fileSize $ getFileStatus fp+           return $ concat [ " ", sum, " ", show size, " ", "unknown", " "+                           , "optional"," ", (baseName 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 (baseName 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: " ++ show c+      loadDeb :: FilePath -> IO (FilePath, Paragraph)+      loadDeb deb =+          do res <- Deb.fields deb+             case res of+               (Control [p]) -> return (deb, p)+               _ -> error $ deb ++ " did not have exactly one paragraph: " ++ show res+++getUploader :: IO String+getUploader =+    do debFullName <- +           do dfn <- try (getEnv "DEBFULLNAME")+              case dfn of+                (Right n) -> return n+                (Left _) ->+                    do dfn <-try (getEnv "USER")+                       case dfn of+                         (Right n) -> return n+                         (Left _) -> 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 _) ->+                    do eml <- try (getEnv "EMAIL")+                       case eml of+                         (Right e) -> return e+                         (Left _) -> getHostName -- FIXME: this is not a FQDN+       return $ debFullName ++ " <" ++ emailAddr ++ ">"++-- * Utils++singleton :: [a] -> Bool+singleton [_] = True+singleton _ = False
+ Debian/Version.hs view
@@ -0,0 +1,14 @@+-- |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 +    , parseDebianVersion+    , epoch+    , version+    , revision+    , buildDebianVersion+    , evr+    ) where ++import Debian.Version.Common+import Debian.Version.String
+ Debian/Version/ByteString.hs view
@@ -0,0 +1,17 @@+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 -> error (show e)+          Right dv -> DebianVersion str dv
+ Debian/Version/Common.hs view
@@ -0,0 +1,166 @@+-- |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.Common+    (DebianVersion -- |Exported abstract because the internal representation is likely to change +    , ParseDebianVersion(..)+    , evr		-- DebianVersion -> (Maybe Int, String, Maybe String)+    , epoch+    , version+    , revision+    , buildDebianVersion+    , parseDV+    ) where ++import Data.Char+import Text.ParserCombinators.Parsec+import Text.Regex+import Debian.Version.Internal++instance Show DebianVersion where+    show (DebianVersion s _) = s++instance Eq DebianVersion where+    (DebianVersion _ v1) == (DebianVersion _ v2) = v1 == v2++instance Ord DebianVersion where+    compare (DebianVersion _ v1) (DebianVersion _ v2) = compare v1 v2++-- * Ord instance++-- 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-> 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?++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 v = case evr v of (x, _, _) -> x+version v = case evr v of (_, x, _) -> x+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 epoch version revision =+    either (error . show) (DebianVersion str) $ parse parseDV str str+    where+      str = (maybe "" (\ n -> show n ++ ":") epoch +++                   version +++                   maybe "" (\ s -> "-" ++ s) revision)
+ Debian/Version/Internal.hs view
@@ -0,0 +1,33 @@+module Debian.Version.Internal+    ( DebianVersion(..)+    , Numeric(..)+    , NonNumeric(..)+    , Found(..)+    )+    where+-- 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)++data NonNumeric+    = NonNumeric String (Found Numeric)+      deriving Show++data Numeric+    = Numeric Int (Maybe NonNumeric)+      deriving Show+++data Found a+    = Found { unFound :: a }+    | Simulated { unFound :: a }+      deriving Show++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 view
@@ -0,0 +1,15 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+module Debian.Version.String+    ( ParseDebianVersion(..)+    ) where++import Text.ParserCombinators.Parsec++import Debian.Version.Common+import Debian.Version.Internal+    +instance ParseDebianVersion String where+    parseDebianVersion str =+        case parse parseDV str str of+          Left e -> error (show e)+          Right dv -> DebianVersion str dv
+ Debian/VersionPolicy.hs view
@@ -0,0 +1,343 @@+-- |This module contains functions governing the assignment of version+-- numbers, patterned after Ubuntu version number policy:+--+-- (1) To distinguish packages which have been pulled out of one vendor's+-- repository to build for another, we add a vendor name and a build+-- number, so version "1.2-3" becomes "1.2-3vendorname1".  Subsequent+-- builds (perhaps due to changes in build dependencies) would be numbered+-- "1.2-3vendorname2" and so on.+--+-- (2) In addition, packages which are backported, (i.e. built for a+-- non-development release such as Debian etch or Ubuntu feisty) need+-- another tag to distinguish them from the version that would go into+-- the development release (sid or, as of this writing, heron.)  So if+-- we pulled the source for version "1.2-3vendorname4" out of our pool+-- to build for feisty, it would become "1.2-3vendorname4~feisty1".+--+-- (3) The first two policies combine if we+-- are building a package pulled directly from the other vendor into+-- our feisty pool, then "1.2-3" would become 1.2-3vendorname0~feisty1.+-- Subsequent builds of "1.2-3" (perhaps due to changes in build+-- dependencies) would get increasing build numbers,+-- "1.2-3vendorname0~feisty2" etc.+--+-- (4) If the original version number does not end with a digit, a "0" is+-- inserted before the vendor name to facilitate parsing of these tags.+--+-- (5) Finally, an additional tag format is supported for the benefit of+-- one autobuilder client, where before the vendor name an "r" and an+-- integer are inserted.+module Debian.VersionPolicy+    ( VersionTag+    , parseTag+    , getTag+    , dropTag+    , setTag+    , appendTag+    , tagCmp+    , tagMax+    , bumpTag+    , newTag+    , compareSourceAndDist+    ) where++import Debian.Version+import Text.Regex+import Data.List+import Data.Maybe++-- |We implement two types of version number tags.  One has the format+--   @r<releasenumber>vendor<buildnumber>~release<buildnumber>@+-- the other simply+--   @vendor<buildnumber>~release<buildnumber>@+-- There are notes from a meeting that explains why ReleaseTagBuild is+-- more future friendly, but it is also more ugly.+data VersionTag+    = VersionTag { extraNumber :: Maybe Int		-- The number following the "r" (do not+							-- use in new applications.)+                 , vendorTag :: (String, Int)		-- The vendor name and build number+                 , releaseTag :: Maybe (String, Int)	-- The release name and build number+                 } deriving (Show, Eq)++-- | Parse a Debian revision string (the portion of the version number+-- following the final dash) into a prefix and a VersionTag.+parseTag :: String -> DebianVersion -> (DebianVersion, Maybe VersionTag)+parseTag vendor version =+    let (e, v, r) = evr version in+    let (prefix, tag) =+            case r of+              Nothing -> (Nothing, Nothing)+              Just s ->+                  case matchRegex re s of+                    Nothing -> (Just s, Nothing)+                    Just [prefix1, prefix2, buildNo, "", _, _, _, _] ->+                        (Just (prefix1 ++ prefix2),+                         Just (VersionTag { extraNumber = Nothing+                                          , vendorTag = (vendor, read buildNo)+                                          , releaseTag = Nothing }))+                    Just [prefix1, prefix2, buildNo, _, releaseName, _, _, releaseNo] ->+                        (Just (prefix1 ++ prefix2),+                         Just (VersionTag { extraNumber = Nothing+                                          , vendorTag = (vendor, read buildNo)+                                          , releaseTag = Just (releaseName, read releaseNo) }))+                    Just result -> error $ "Internal error: " ++ show result in+    -- Try to parse the r5 from the end of the prefix.+    let (prefix', tag') =+            case (maybe Nothing (matchRegex extraRE) prefix, tag) of+              (Just [prefix1, prefix2, digits], Just tag) -> +                  (Just (prefix1 ++ prefix2), Just (tag {extraNumber = Just (read digits)}))+              _ -> (prefix, tag) in+    (buildDebianVersion e v (if prefix' == Just "0" then Nothing else prefix'), tag')+    where+      re = mkRegex (prefixRE ++ digitsRE ++ vendorRE ++ "(" ++ releaseRE ++ ")?$")+      prefixRE = "^(.*[^0-9])?"+      digitsRE = "([0-9]+)"+      vendorRE = vendor ++ "([0-9]+)"+      releaseRE = "~(([^0-9]+)|(bpo[0-9]+\\+))([0-9]+)"+      extraRE = mkRegex "^(.*)([0-9]+)r([0-9]+)"++-- | The tag returned by splitTag+getTag :: String -> DebianVersion -> Maybe VersionTag+getTag vendor version = snd (parseTag vendor version)++-- | The prefix returned by splitTag+dropTag :: String -> DebianVersion -> DebianVersion+dropTag vendor version = fst (parseTag vendor version)++-- |Modify a version number by adding or changing the vendor tag.  The+-- result will be newer than the distVersion (the newest already+-- uploaded version.)  It will also be different from (though not+-- necessarily newer than) any of the elements of allVersions+setTag :: (String -> String)+       -- ^ The release name alias function.  As an example, this would map+       -- the repository etch to the tag bpo40+, as specified by Debian policy.+       -> String+       -- ^ The vendor tag+       -> Maybe String+       -- ^ The build release, or Nothing if this is a development release+       -> Maybe Int+       -- ^ Use old "r0vendor1" format+       -> Maybe DebianVersion+       -- ^ The newst version that is already present in the dist.  We need+       -- to generate a version number newer than this.+       -> [DebianVersion]+       -- ^ All the versions that are currently available in the pool.  The+       -- result must not be a member of this list.+       -> DebianVersion+       -- ^ The version number that appears in the newest change log+       -- entry of the source package.  The result will be this number+       -- with a version tag added.  If this version is older than the+       -- current version with its tag stripped, the package cannot be+       -- built.+       -> Either String DebianVersion+       -- ^ The modified version number+{-setTag alias vendor release extra distVersion allVersions sourceVersion =+    error ("vendor=" ++ show vendor ++ ", release=" ++ show release ++ ", extra=" ++ show extra ++ ", distVersion=" ++ show distVersion ++ ", allVersions=" ++ show allVersions ++ ", sourceVersion=" ++ show sourceVersion)-}+setTag alias vendor release extra distVersion allVersions sourceVersion =+    let oldTag = +            case maybe Nothing (Just . parseTag vendor) distVersion of+              Nothing -> Right Nothing+              Just (distUpstreamVersion, distTag) ->+                  case compare sourceUpstreamVersion distUpstreamVersion of+                    LT -> Left ("Source version " ++ show sourceVersion +++                                " is too old to trump uploaded version " ++ show distUpstreamVersion)+                    GT -> Right Nothing+                    EQ -> Right distTag in+    either Left (Right . appendTag alias sourceUpstreamVersion . Just . findAvailableTag . newTag) oldTag+    where+      -- The new tag must+      --  1) be newer than the old tag+      --  2) be at least as new as the tag in the source code changelog.+      --  3) have the appropriate releaseTag+      -- The oldTag may not have an appropriate releaseTag, because the+      -- distribution may have recently switched from development to+      -- non-development.  In that case we will have to bump the+      -- vendor build number, not the release build number, and then+      -- add the release tag.+      newTag Nothing =+          VersionTag {vendorTag = (vendor, 1), releaseTag = maybe Nothing (\ relName -> Just (relName, 1)) release, extraNumber = extra}+      newTag (Just distTag) =+          let distTag' = fixReleaseName release (bumpTag distTag) in+          let sourceTag' = maybe Nothing (Just . setReleaseName release) sourceTag in+          case tagMax [Just distTag', sourceTag'] of+            Nothing -> error $ "Internal error"+            Just tag -> tag+{-+          case (release, sourceTag, distTag') of+            (_, _, VersionTag {vendorTag = (distVendorName, distVendorBuild)})+                | distVendorName /= vendor -> +                    error $ "Vendor name mismatch: " ++ show (vendor, distVendorName)+            (_, Just (VersionTag {vendorTag = (sourceVendorName, sourceVendorBuild)}), _)+                | sourceVendorName /= vendor -> +                    error $ "Vendor name mismatch: " ++ show (vendor, sourceVendorName)+            (Just relName, _, VersionTag {releaseTag = Just (distRelName, distRelBuild)})+                | relName /= undefined ->+                    undefined++          let candidate1 = fixTag sourceTag in+          let candidate2 = setRelease release (bumpTag' distTag) in+          let candidate' = tagMax candidate +                  case (tagMax [sourceTag, Just (bumpTag vendor release extra distTag)]) of+                    +          let candidate = maybe Nothing (Just . fixTag) (tagMax [sourceTag, Just (bumpTag vendor release extra distTag)]) in+          appendTag alias sourceUpstreamVersion (findAvailableTag candidate)+      -- Change a tag so it is appropriate for the release, adding or+      -- removing the release tag.+      fixTag tag = case (releaseTag tag, release) of +                     (Just _, Nothing) -> tag {releaseTag = Nothing}+                     (Nothing, Just rel) -> tag {releaseTag = Just (rel, 1)}+                     (Just (oldRel, oldBuild), Just newRel) | oldRel /= newRel -> tag {releaseTag = Just (newRel, 1)}+                     (Just (_, build), Just rel) -> tag {releaseTag = Just (rel, build)}+-}+      (sourceUpstreamVersion, sourceTag) = parseTag vendor sourceVersion+      -- All the tags of existing packages whose upstream version matches the source+      allTags = catMaybes (map snd (filter (\ (v, _) -> v == sourceUpstreamVersion) (map (parseTag vendor) allVersions)))+      -- Repeatedly increment candidate until it differs from the+      -- elements of all.  Note that this is not the same as taking+      -- the maximum element and incrementing it, the value we want+      -- only needs to be not less than candidate.+      findAvailableTag :: VersionTag -> VersionTag+      findAvailableTag candidate =+          if elem candidate allTags then findAvailableTag (bumpTag candidate) else candidate++tagCmp (Just tagA) (Just tagB) =+    let (_, a) = vendorTag tagA+        (_, b) = vendorTag tagB in+    case compare a b of+      EQ -> case (releaseTag tagA, releaseTag tagB) of+              (Just (_, a), Just (_, b)) -> compare a b+              (Nothing, Nothing) -> EQ+              (Nothing, _) -> LT+              (_, Nothing) -> GT+      x -> x+tagCmp Nothing Nothing = EQ+tagCmp Nothing _ = LT+tagCmp _ Nothing = GT++tagMax :: [Maybe VersionTag] -> Maybe VersionTag+tagMax tags = head (sortBy (flip tagCmp) tags)++bumpTag tag@(VersionTag {releaseTag = Just (relName, relBuild)}) = tag {releaseTag = Just (relName, relBuild + 1)}+bumpTag tag@(VersionTag {vendorTag = (name, build), releaseTag = Nothing}) = tag {vendorTag = (name, build + 1)}++-- If one of the version number candidates has the wrong release name+-- this function fixes it, ensuring that the new tag isn't trumped by+-- the old.+fixReleaseName release tag@(VersionTag {vendorTag = (vendorName, vendorBuild)}) =+    case (release, releaseTag tag) of+      (Just relName, Just (oldRelName, _)) | relName == oldRelName -> tag+      -- If the release name doesn't match we need to bump the vendor build+      (Just relName, _) -> tag {vendorTag = (vendorName, vendorBuild+1), releaseTag = Just (relName, 1)}+      -- Removing an existing release tag always increases the version+      (Nothing, Just _) -> tag {releaseTag = Nothing}+      (Nothing, Nothing) -> tag {vendorTag = (vendorName, vendorBuild+1)}++-- This is similer to fixReleaseName, but we don't require the result to+-- trump the argument.  This is applied to the source package version number,+-- which is not necessarily present in the dist.+setReleaseName release tag =+    case (release, releaseTag tag) of+      (Just relName, Just (oldRelName, _)) | relName == oldRelName -> tag+      (Just relName, Just _) -> tag {releaseTag = Just (relName, 1)}+      (Just relName, Nothing) -> tag {releaseTag = Just (relName, 1)}+      (Nothing, _) -> tag {releaseTag = Nothing}+      ++-- Return a tag that is+--  1) slightly newer than the dist tag+--  2) at least as new as the sourceTag+--  3) has the appropriate releaseTag+{-+nextTag vendor release extra sourceTag distTag =+    (fixRelease release sourceTag) (fixRelease release distTag)+@(VendorTag {vendorTag = (sourceVendor, sourceBuild)}) distTag@(VendorTag {vendorTag = (distVendor,  distBuild)}) =+    case (release, releaseTag sourceTag, releaseTag distTag) of+      _ | vendor /= sourceVendor || vendor /= distVendor ->	-- This really shouldn't happen+            error $ "Vendor tags do not match: (" ++ vendor ++ ", " ++ sourceVendor ++ ", " ++ distVendor ++ ")"+      (Just relName, Just (sourceRel, sourceRelBuild), _) | relName /= sourceRel -> +      (Nothing, _, _) | sourceBuild > distBuild -> +       -> +    where+      fixRelease Nothing tag@(VendorTag {vendorTag = (vendor, build), releaseTag = Just (relName, relBuild)}) = tag {vendorTag = (vendor, build+1), releaseTag = Nothing}+      fixRelease (Just name) tag@(VendorTag {vendorTag = (vendor, build), releaseTag = Nothing})++-- |Return a tag which is slightly newer than the argument.  This needs to work+-- even if the release changes.+bumpTag newVendor release extra (Just tag@(VendorTag {vendorTag = (oldVendor, vendorBuild)})) =+    case (release, releaseTag tag) of+      _ | newVendor /= oldVendor -> error $ "Illegal vendor change: " ++ oldVendor ++ " -> " ++ newVendor+      (Just newName, Just (oldName, oldBuild)) | oldName == newName -> tag {releaseTag = Just (oldName, oldBuild + 1)}+      -- It is odd for the release name to change, but we can just+      -- bump the vendor build number to be safe+      (Just newName, Just (oldName, oldBuild)) -> tag {vendorTag = (oldVendor, vendorBuild+1), releaseTag = Just (newName, 1)}+      -- It is also odd for a release to switch from non-development+      -- to development.  So be it.+      (Nothing, Just (oldName, oldBuild)) -> tag {vendorTag = (oldVendor, vendorBuild+1), releaseTag = Nothing }+      -- +      (Just newName, Nothing) -> tag {vendorTag = (+      (Nothing, Just (relName, relBuild)) ->+          +    case release of+      Nothing -> tag { vendorTag = let (vendor, build) = vendorTag tag in (vendor, build + 1) }+      Just name -> tag { releaseTag = case releaseTag tag of +                                        Nothing -> Just (name, 1)+                                        Just (name, build) -> Just (name, build + 1) }+bumpTag vendor release extra Nothing = newTag vendor release extra++-- |Return a tag which is slightly newer, keeping the the same release.+bumpTag' tag@(VersionTag {vendorTag = (vendor, build), releaseTag = release}) =+    case releaseTag of+      Nothing -> tag {vendorTag = (vendor, build+1)}+      Just (name, relBuild) -> tag {releaseTag = Just (name, relBuild + 1)}+-}++-- Create a tag which is one click newer.+newTag vendor Nothing extra = VersionTag { extraNumber = extra, vendorTag = (vendor, 1), releaseTag = Nothing }+newTag vendor (Just name) extra = VersionTag { extraNumber = extra, vendorTag = (vendor, 0), releaseTag = Just (name, 1) }++-- | Format a tag as a string.+showTag :: (String -> String) -> VersionTag -> String+showTag alias (VersionTag { extraNumber = extra+                          , vendorTag = (vendor, vendorBuildNumber)+                          , releaseTag = releaseInfo }) =+   maybe "" (("r" ++) . show) extra +++         vendor ++ show vendorBuildNumber +++         maybe "" (\ (relname, relbuild) -> "~" ++ alias relname ++ show relbuild) releaseInfo++-- | Append a vendor tag to a string containing the revision portion+-- of a debian version number.+appendTag :: (String -> String) -> DebianVersion -> Maybe VersionTag -> DebianVersion+appendTag _ ver Nothing = ver+appendTag alias ver (Just tag) =+    case revision ver of+      Nothing -> setRevision ver (Just ("0" ++ showTag alias tag))+      Just rev -> case matchRegex numericSuffixRE rev of+                    Just [_, ""] -> setRevision ver (Just (rev ++ "0" ++ showTag alias tag))+                    Just [_, _] -> setRevision ver (Just (rev ++ showTag alias tag))+                    _ -> error "internal error"+    where numericSuffixRE = mkRegex "^(.*[^0-9])?([0-9]*)$"++-- | Change the revision part of a Debian version number.  (This may+-- belong in Debian.Version.)+setRevision :: DebianVersion -> Maybe String -> DebianVersion+setRevision ver rev = buildDebianVersion (epoch ver) (version ver) rev++-- Compare the version seen in the source code changelog to a version+-- seen in the distribution.  Since the autobuilder adds tags to the+-- version number of the packages it builds, the distribution version+-- may have been built from the source version even if they differ.+-- Specifically, we must assume that if the version matches when we+-- strip off one or both sections of the tag on the distribution+-- version number.+compareSourceAndDist vendor s d =+    let (verS, tagS) = parseTag vendor s+        (verD, tagD) = parseTag vendor d in+    let venS = maybe Nothing (Just . vendorTag) tagS+        venD = maybe Nothing (Just . vendorTag) tagD+        relS = maybe Nothing releaseTag tagS+        relD = maybe Nothing releaseTag tagD in+    case () of+      _ | verS /= verD -> compare verS verD+        | isNothing venS && isJust venD -> EQ+        | isNothing relS && isJust relD -> EQ+        | True -> compare s d
− Linspire/Debian/Control.hs 
@@ -1,25 +0,0 @@--- |A module for working with Debian control files <http://www.debian.org/doc/debian-policy/ch-controlfields.html>-module Linspire.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-    ) where--import Linspire.Debian.Control.String
− Linspire/Debian/Control/ByteString.hs 
@@ -1,327 +0,0 @@-module Linspire.Debian.Control.ByteString-    ( Control'(..)-    , Paragraph'(..)-    , Field'(..)-    , Control-    , Paragraph-    , Field-    , ControlFunctions(..)-    -- * Helper Functions-    , mergeControls-    , fieldValue-    , removeField-    , prependFields-    , appendFields-    , renameField-    , modifyField-    , raiseFields-    ) where---- Standard GHC modules--import Control.Monad.State--import Data.List-import Data.Maybe-import Data.Word--import Foreign.ForeignPtr-import Foreign.Ptr-import Foreign.Storable         (Storable(..))--import System.IO.Unsafe--import Text.ParserCombinators.Parsec.Error-import Text.ParserCombinators.Parsec.Pos---- Third Party Modules--import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as BB-import qualified Data.ByteString.Char8 as C-import Data.ByteString.Internal-import Linspire.Debian.Control.Common---- 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 = pTakeWhile2 (\a b -> not (endOfValue a b))-    where-      endOfValue :: Char -> Maybe Char -> Bool-      endOfValue '\n' Nothing = True-      endOfValue '\n' (Just ' ') = False-      endOfValue '\n' (Just '\t') = False-      endOfValue '\n' (Just '#') = False-      endOfValue '\n' _ = True-      endOfValue _ _ = False--pField :: ControlParser Field-pField =-    do k <- pKey-       pChar ':'-       v <- pValue---       pChar '\n'-       (pChar '\n' >> return ()) <|> pEOF-       return (Field (k,v))--pComment :: ControlParser Field-pComment =-    do c1 <- pChar '#'-       text <- pTakeWhile2 (\ a b -> not (endOfComment a b))-       return . Comment $ (B.append (B.singleton . c2w $ c1) text)-    where-      endOfComment '\n' Nothing = True-      endOfComment '\n' (Just '#') = False-      endOfComment '\n' _ = True-      endOfComment _ _ = False--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 =-        do c <- C.hGetContents handle-           case parse pControl c of-             Nothing -> return (Left (newErrorMessage (Message ("Failed to parse " ++ sourcename)) (newPos sourcename 0 0)))-             (Just (cntl,_)) -> return (Right cntl)-    lookupP fieldName (Paragraph fields) =-        let pFieldName = C.pack fieldName in-        find (\ (Field (fieldName',_)) -> fieldName' == pFieldName) fields-    -- NOTE: probably inefficient-    stripWS = C.reverse . strip . C.reverse . strip-        where strip = C.dropWhile (flip elem " \t")--{--main =-    do [fp] <- getArgs-       C.readFile fp >>= \c -> maybe (putStrLn "failed.") (print . length . fst) (parse pControl c)--}--- * Helper Functions---- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@,--- returns the longest prefix (possibly empty) of @xs@ of elements that--- satisfy @p@.--- takeWhile2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> B.ByteString--- takeWhile2 f ps = BB.unsafeTake (findIndex2OrEnd (\w1 w2 -> not (f w1 w2)) ps) ps--- {-# INLINE takeWhile2 #-}--break2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe (B.ByteString, B.ByteString)-break2 p ps = case findIndex2OrEnd p ps of n -> Just (BB.unsafeTake n ps, BB.unsafeDrop n ps)--span2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe (B.ByteString, B.ByteString)-span2 p ps = break2 (\a b -> not (p a b)) ps----- | 'findIndexOrEnd' is a variant of findIndex, that returns the length--- of the string if no element is found, rather than Nothing.--findIndex2OrEnd :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Int-findIndex2OrEnd k (PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0-  where-    go a b | a `seq` b `seq` False = undefined-    go ptr n | n >= l    = return l-             | otherwise = do w1 <- peek ptr-                              w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing-                              if k w1 w2-                                then return n-                                else go (ptr `plusPtr` 1) (n+1)---{--findIndex2OrEnd :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Int-findIndex2OrEnd k (B.PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0-  where-    go a b | a `seq` b `seq` False = undefined-    go ptr n | n >= l    = return l-             | otherwise = do w1 <- peek ptr-                              case (w2c w1) of-                                '\n' ->-                                    if (n + 1 < l)-                                    then do w2 <- peek (ptr `plusPtr` 1)-                                            case (w2c w2) of-                                              ' ' -> go (ptr `plusPtr` 2) (n + 2)-                                              _ -> return n-                                    else return l -- go (ptr `plusPtr` 1) (n + 1)-                                _ -> go (ptr `plusPtr` 1) (n + 1)--}-{--                              w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing-                              if k w1 w2-                                then return n-                                else go (ptr `plusPtr` 1) (n+1)--}-{-# INLINE findIndex2OrEnd #-}---- | The 'findIndex' function takes a predicate and a 'ByteString' and--- returns the index of the first element in the ByteString--- satisfying the predicate.--- findIndex2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe Int--- findIndex2 k (PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0---   where---     go a b | a `seq` b `seq` False = undefined---     go ptr n | n >= l    = return Nothing---              | otherwise = do w1 <- peek ptr---                               w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing---                               if k w1 w2---                                 then return (Just n)---                                 else go (ptr `plusPtr` 1) (n+1)--- {-# INLINE findIndex2 #-}---- * 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 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)---(<|>) :: Parser state a -> Parser state a -> Parser state a-(<|>) = mplus---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--pTakeWhile2 :: (Char -> Maybe Char -> Bool) -> Parser C.ByteString C.ByteString-pTakeWhile2 f =-    Parser $ \bs -> m2r (span2 (\w1 w2 -> f (w2c w1) (fmap w2c w2)) bs)--pTakeWhile :: (Char -> Bool) -> Parser C.ByteString C.ByteString-pTakeWhile f =-    Parser $ \bs -> Ok (B.span (\w -> f (w2c w)) 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 (\tl -> f (x:tl))-               <|> return (f [])--notEmpty :: Parser st C.ByteString -> Parser st C.ByteString-notEmpty (Parser p) =-    Parser $ \s -> case p s of-                     o@(Ok (a, _)) ->-                         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)
− Linspire/Debian/Control/Common.hs 
@@ -1,88 +0,0 @@-module Linspire.Debian.Control.Common-    ( -- * Types-      Control'(..)-    , Paragraph'(..)-    , Field'(..)-    , ControlFunctions(..)-    , mergeControls-    , fieldValue-    , removeField-    , prependFields-    , appendFields-    , renameField-    , modifyField-    , raiseFields,-    )-    where--import Text.ParserCombinators.Parsec-import System.IO-import Data.List--newtype Control' a-    = Control { unControl :: [Paragraph' a] }--newtype Paragraph' a-    = Paragraph [Field' a]---- |NOTE: we do not strip the leading or trailing whitespace in the--- name or value-data Field' a-    = Field (a, a)-    | Comment a-      deriving Eq--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))-    -- | '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--mergeControls :: [Control' a] -> Control' a-mergeControls controls =-    Control (concatMap unControl controls)--fieldValue :: (ControlFunctions a) => String -> Paragraph' a -> Maybe a-fieldValue fieldName paragraph =-    fmap value (lookupP fieldName paragraph)-    where value (Field (_, val)) = stripWS val--removeField :: (Eq a) => a -> Paragraph' a -> Paragraph' a-removeField toRemove (Paragraph fields) =-    Paragraph (filter remove fields)-    where-      remove (Field (name,_)) = name == toRemove--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--raiseFields :: (Eq a) => (a -> Bool) -> Paragraph' a -> Paragraph' a--- ^ Move selected fields to the beginning of a paragraph.-raiseFields f (Paragraph fields) =-    let (a, b) = partition f' fields in Paragraph (a ++ b)-    where f' (Field (name, _)) = f name
− Linspire/Debian/Control/PrettyPrint.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-module Linspire.Debian.Control.PrettyPrint where--import qualified Data.ByteString.Char8 as C-import Text.PrettyPrint.HughesPJ--import Linspire.Debian.Control.Common--ppControl :: (ToText a) => Control' a -> Doc-ppControl (Control paragraph) =-    fsep (map ppParagraph paragraph)--ppParagraph :: (ToText a) => Paragraph' a -> Doc-ppParagraph (Paragraph fields) =-    fsep (map ppField fields)--ppField :: (ToText a) => Field' a -> Doc-ppField (Field (n,v)) = totext n <> text ":" <> totext v-ppField (Comment _) = error "ppField on Comments not defined."--class ToText a where-    totext :: a -> Doc--instance ToText String where-    totext = text--instance ToText C.ByteString where-    totext = text . C.unpack
− Linspire/Debian/Control/String.hs 
@@ -1,112 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}--module Linspire.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 Control.Monad-import Data.List-import Text.ParserCombinators.Parsec-import System.IO-import Linspire.Debian.Control.Common---- |This may have bad performance issues-instance Show (Control' String) where-    show (Control paragraph) = concat (intersperse "\n" (map show paragraph))--instance Show (Paragraph' String) where-    show (Paragraph fields) = unlines (map show fields)--instance Show (Field' String) where-    show (Field (name,value)) = name ++":"++ value-    show (Comment text) = text--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 =-        hGetContents handle >>= return . parse pControl sourcename-    lookupP fieldName (Paragraph paragraph) =-        find hasFieldName paragraph-        where hasFieldName (Field (fieldName',_)) = fieldName == fieldName'-              hasFieldName _ = False-    stripWS = reverse . strip . reverse . strip-        where strip = dropWhile (flip elem " \t")---- * 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")
− Linspire/Debian/Dependencies.hs 
@@ -1,270 +0,0 @@-{-# LANGUAGE TypeOperators, ScopedTypeVariables #-}--module Linspire.Debian.Dependencies-{--    ( solve-    , State-    , binaryDepends-    , search-    , bj'-    , bt-    , CSP(..)-    ) -} where--import Data.List-import Data.Maybe-import Data.Tree--import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Char8 as C--import Linspire.Debian.Control.ByteString--- import qualified Linspire.Debian.Control as SC-import Linspire.Debian.Relation.ByteString-import Linspire.Debian.Package-import Linspire.Debian.Version---- * Basic CSP Types and Functions--data Status-    = Remaining AndRelation-    | MissingDep Relation-    | Complete-      deriving (Show, 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 -> (String, 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 -> String-      getName p = case lookupP "Package" p of Nothing -> error "Missing Package field" ; (Just (Field (_,n))) -> C.unpack (stripWS n)-      conflicts' :: Paragraph -> Relations-      conflicts' p =-          case lookupP "Conflicts" p of-            Nothing -> []-            Just (Field (_, c)) -> either (error . show) id (parseRelations c)--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)-        depends =-            case lookupP "Depends" p of-              Nothing -> []-              Just (Field (_,pd)) ->-                  either (error . show) id (parseRelations pd)-    in-      preDepends ++ depends--sidPackages :: String-sidPackages = "/var/lib/apt/lists/ftp.debian.org_debian_dists_unstable_main_binary-i386_Packages"--test :: String -> Labeler Paragraph -> IO ()-test rel labeler =-    testCSP sidPackages depF rel (mapM_ (\ (_,p) -> mapM_ (print . packageVersionParagraph) p ) . take 1 . search labeler)---- TODO: add better errors-packageVersionParagraph :: Paragraph -> (String, 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 (_, vrsn))) -> (C.unpack (stripWS name), parseDebianVersion (C.unpack vrsn))----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' :: (String, 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) (pr:prs) =-          orRelation (candidates, prs ++ remaining) pr-      orRelation :: ([a],AndRelation) -> OrRelation -> [Tree (State a)]-      orRelation acc pr = concat $ fmap (relation acc) pr-      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) pckg =-          if ((packageVersion csp) pckg) `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, (pckg : candidates)) (andRelation ((pckg : candidates), remaining) ((depFunction csp) pckg))----- |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, earliest) inconsistency ??-earliestInconsistency :: CSP a -> State a -> Maybe ((String, DebianVersion), (String, DebianVersion))-earliestInconsistency _ (_,[]) = Nothing-earliestInconsistency _ (_,[_]) = 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 Se--- ^ conflicting packages and relations that require non-existent packages-type ConflictSet = ([(String, 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--
− Linspire/Debian/Package.hs 
@@ -1,54 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- |Functions for dealing with source and binary packages in an abstract-way-module Linspire.Debian.Package where---- Standard GHC Modules--import qualified Data.Map as Map---- Local Modules--import Linspire.Debian.Version-import Linspire.Debian.Relation--type PackageNameMap a = Map.Map String [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 -> String) -> [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 -> [PkgName]) -> [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 -> [PkgName]) -> [p] -> [(PkgName, p)]-findProvides providesf packages = foldl addProvidesLocal [] packages-    where addProvidesLocal :: [(PkgName, p)] -> p -> [(PkgName, p)]-          addProvidesLocal 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 -> (String, DebianVersion)) -> Relation -> [a]-lookupPackageByRel pm packageVersionF (Rel pkgName mVerReq _) =-    case Map.lookup pkgName pm of-      Nothing -> []-      Just packages -> filter filterVer packages-    where filterVer p =-              case mVerReq of-                Nothing -> True-                Just _ ->-                    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)
− Linspire/Debian/PackageDeprecated.hs 
@@ -1,131 +0,0 @@--- |Experimental module for representing a single package , highly likely to change in incompatible ways.-module Linspire.Debian.PackageDeprecated where---- Standard GHC Modules--import qualified Data.Map as Map---- Local Modules--import Linspire.Debian.Version-import Linspire.Debian.Control-import Linspire.Debian.Relation-import Linspire.Debian.Package---- Simple Package Representation---- |A package with a name and list of dependencies-data Package-    = Package { pName :: String-              , pVersion :: Maybe DebianVersion-              , pDepends :: Relations-              , pPreDepends :: Relations-              , pConflicts ::Relations-              , pReplaces :: Relations-              , pProvides :: Relations---              , pParagraph :: Paragraph-              }-      deriving Show--instance Eq Package where-    p1 == p2 = (pName p1 == pName p2) && (pVersion p1 == pVersion p2)---- |FIXME: we do not deal with Provides\/virtual packages yet-paragraphToPackages :: Paragraph -> Package-paragraphToPackages p =-    Package { pName =-                  case lookupP "Package" p of-                    Nothing -> error $ "Paragraph does not have Package field: " ++ (show p)-                    Just (Field (_,a)) -> stripWS a-            , pVersion =-                case lookupP "Version" p of-                  Nothing -> error $ "Version not found for " ++ show p-                  Just (Field (_,a)) -> Just (parseDebianVersion (stripWS a))-            , pDepends =   tryParseRel $ lookupP "Depends" p-            , pPreDepends = tryParseRel $ lookupP "Pre-Depends" p-            , pConflicts = tryParseRel $ lookupP "Conflicts" p-            , pReplaces =  tryParseRel $ lookupP "Replaces" p-            , pProvides =  tryParseRel $ lookupP "Provides" p---            , pParagraph = p-            }--type ProvidesMap = Map.Map String [Package]--{--findProvides :: [Package] -> ProvidesMap-findProvides packages = foldl addProvides Map.empty packages-    where addProvides :: ProvidesMap -> Package -> ProvidesMap-          addProvides pm package =-              foldl (\m [(Rel pkgName Nothing Nothing)] -> Map.insertWith (++) pkgName [package] m) pm (pProvides package)--}--findProvides :: [Package] -> [(PkgName, Package)]-findProvides packages = foldl addprovides [] packages-    where addprovides :: [(PkgName, Package)] -> Package -> [(PkgName, Package)]-          addprovides providesList package =-              foldl (\pl [(Rel pkgName Nothing Nothing)] ->(pkgName, package): pl) providesList (pProvides package)---- |Architecture ?-makeVirtualPackages :: ProvidesMap -> [Package]-makeVirtualPackages pm =-    Map.foldWithKey mVP [] pm-    where mVP vpName packages virtualPackages-              = (Package { pName = vpName-                         , pVersion = Nothing-                         , pDepends = [map mkDepend packages] -- or depends on things that provide it-                         , pPreDepends = []-                         , pConflicts = []-                         , pReplaces = []-                         , pProvides = []---                         , pParagraph = Paragraph []-                         } ) : virtualPackages-          mkDepend package =-              let name = pName package-                  rel = fmap EEQ (pVersion package)-                  in Rel name rel Nothing-{---- |Does not check for duplication or multiple use-addProvides :: [Package] -> PackageNameMap -> PackageNameMap-addProvides ps pnm =-    let provides = findProvides ps in-    foldl (\m (packageName, package) -> Map.insertWith (flip (++)) packageName [package] m) pnm provides---  ++ (makeVirtualPackages (findProvides ps))---tryParseRel :: Maybe Field -> Relations-tryParseRel Nothing = []-tryParseRel (Just (Field (_, relStr))) = either (error . show) id (parseRelations relStr)--}--controlToPackageNameMap :: Control -> (Paragraph -> Package) -> PackageNameMap Package-controlToPackageNameMap (Control p) p2p =-    let packages = (map p2p p) in-    addProvides (map (\ (Rel pkgName _ _) -> pkgName) . concat . pProvides) packages (packageNameMap pName packages)--packagesToPackageNameMap :: [Package] -> PackageNameMap Package-packagesToPackageNameMap packages =-    addProvides (map (\ (Rel pkgName _ _) -> pkgName) . concat . pProvides) packages (packageNameMap pName packages)---- |TODO: Add architecture check-lookupPackageByRel :: PackageNameMap Package -> Relation -> [Package]-lookupPackageByRel pm (Rel pkgName mVerReq _) =-    case Map.lookup pkgName pm of-      Nothing -> []-      Just packages -> filter filterVer packages-    where filterVer p =-              case mVerReq of-                Nothing -> True-                Just _ ->-                    if (pName p) /= pkgName-                       then False -- package is a virtual package, hence we can not do a version req-                       else checkVersionReq mVerReq (pVersion p)---{--      Nothing -> Nothing-      Just packages -> Just $ filter (\p -> checkVersionReq mVerReq (pVersion p)) packages--}--tryParseRel :: Maybe Field -> Relations-tryParseRel Nothing = []-tryParseRel (Just (Field (_, relStr))) = either (error . show) id (parseRelations relStr)
− Linspire/Debian/Relation.hs 
@@ -1,20 +0,0 @@--- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>-module Linspire.Debian.Relation-    ( -- * Types-      PkgName-    , AndRelation-    , OrRelation-    , Relations-    , Relation(..)-    , ArchitectureReq(..)-    , VersionReq(..)-    -- * Helper Functions-    , checkVersionReq-    -- * Relation Parser-    , RelParser-    , ParseRelations(..)-    ) where---- Local Modules--import Linspire.Debian.Relation.String
− Linspire/Debian/Relation/ByteString.hs 
@@ -1,36 +0,0 @@--- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>-module Linspire.Debian.Relation.ByteString-    ( -- * Types-      PkgName-    , AndRelation-    , OrRelation-    , Relations-    , Relation(..)-    , ArchitectureReq(..)-    , VersionReq(..)-    -- * Helper Functions-    , checkVersionReq-    -- * Relation Parser-    , RelParser-    , ParseRelations(..)-    ) where---- Standard GHC Modules-import Data.List-import Text.ParserCombinators.Parsec---- 3rd Party Modules-import qualified Data.ByteString.Char8 as C---- Local Modules-import Linspire.Debian.Relation.String---- * ParseRelations---- For now we just wrap the string version-instance ParseRelations C.ByteString where-    parseRelations byteStr =-        let str = C.unpack byteStr in-        case parse pRelations str str of-          Right relations -> Right (filter (/= []) relations)-          x -> x
− Linspire/Debian/Relation/Common.hs 
@@ -1,86 +0,0 @@-module Linspire.Debian.Relation.Common where---- Standard GHC Modules--import Data.List-import Text.ParserCombinators.Parsec---- Local Modules--import Linspire.Debian.Version---- Datatype for relations--type PkgName = String--type Relations = AndRelation-type AndRelation = [OrRelation]-type OrRelation = [Relation]--data Relation = Rel PkgName (Maybe VersionReq) (Maybe ArchitectureReq)-		deriving Eq---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---instance Show Relation where-    show (Rel name ver arch) =-        name ++ maybe "" show ver ++ maybe "" show arch--instance Ord Relation where-    compare (Rel pkgName1 mVerReq1 _) (Rel pkgName2 mVerReq2 _) =-	case compare pkgName1 pkgName2 of-	     LT -> LT-	     GT -> GT-	     EQ -> compare mVerReq1 mVerReq2--data ArchitectureReq-    = ArchOnly [String]-    | ArchExcept [String]-      deriving Eq--instance Show ArchitectureReq where-    show (ArchOnly arch) = " [" ++ concat (intersperse " " arch) ++ "]"-    show (ArchExcept arch) = " [!" ++ concat (intersperse " !" arch) ++ "]"--data VersionReq-    = SLT DebianVersion-    | LTE DebianVersion-    | EEQ  DebianVersion-    | GRE  DebianVersion-    | SGR DebianVersion-      deriving Eq--instance Show VersionReq where-    show (SLT v) = " (<< " ++ show v ++ ")"-    show (LTE v) = " (<= " ++ show v ++ ")"-    show (EEQ v) = " (= " ++ show v ++ ")"-    show (GRE v) = " (>= " ++ show v ++ ")"-    show (SGR v) = " (>> " ++ show v ++ ")"---- |@FIXME:@ This instance is currently incomplete and only handles the case--- where two version requirements are equal.-instance Ord VersionReq where-    compare r1 r2 =-	if r1 == r2-	   then EQ-	   else-	case (r1, r2) of-	     (EEQ v1, EEQ v2) -> compare v1 v2-	     (a,b) -> error $ "Ord VersionReq does not handle (" ++ show a ++", "++ show b++")"----- |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
− Linspire/Debian/Relation/String.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}---- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>-module Linspire.Debian.Relation.String-    ( -- * Types-      PkgName-    , AndRelation-    , OrRelation-    , Relations-    , Relation(..)-    , ArchitectureReq(..)-    , VersionReq(..)-    -- * Helper Functions-    , checkVersionReq-    -- * Relation Parser-    , RelParser-    , ParseRelations(..)-    , pRelations-    ) where---- Standard GHC Modules--import Data.List-import Text.ParserCombinators.Parsec---- Local Modules--import Linspire.Debian.Relation.Common-import Linspire.Debian.Version---- * ParseRelations--instance ParseRelations String where-    parseRelations str =-        case parse pRelations str str of-          Right relations -> Right (filter (/= []) relations)-          x -> x---- * Relation Parser--type RelParser a = CharParser () a--pRelations :: RelParser Relations-pRelations = sepBy pOrRelation (char ',')--pOrRelation :: RelParser OrRelation-pOrRelation = sepBy pRelation (char '|')--whiteChar :: CharParser st 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 pkgName mVerReq mArch--pMaybeVerReq :: RelParser (Maybe VersionReq)-pMaybeVerReq =-    do char '('-       skipMany whiteChar-       op <- pVerReq-       skipMany whiteChar-       vrsn <- many1 (noneOf [' ',')','\t','\n'])-       skipMany whiteChar-       char ')'-       return $ Just (op (parseDebianVersion vrsn))-    <|>-    do return $ Nothing--pVerReq :: GenParser Char st (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 ']'-           return (Just (ArchExcept archs))-        <|>-        do archs <- pArchOnly-           char ']'-           return (Just (ArchOnly 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)
− Linspire/Debian/SourcesList.hs 
@@ -1,200 +0,0 @@-module Linspire.Debian.SourcesList-    (DebSource(DebSource),-     SourceType(Deb, DebSrc),-     parseSourceLine,   -- String -> DebSource-     parseSourcesList,  -- String -> [DebSource]-     quoteWords,        -- String -> [String]-     archFiles)         -- FilePath -> Maybe String -> DebSource -> [FilePath]-    where--import Data.List-import Network.URI--{---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.---}--data SourceType-    = Deb | DebSrc-    deriving Eq--instance Show SourceType where-    show Deb = "deb"-    show DebSrc = "deb-src"--data DebSource-    = DebSource-    { sourceType :: SourceType-    , sourceUri :: URI-    , sourceDist :: Either String (String, [String]) -- ^ Either (ExactPath) (Distribution, [Section])-    }-    deriving Eq--instance Show DebSource where-    show (DebSource thetype theuri thedist) =-        (show thetype) ++" "++ (uriToString id theuri " ") ++-        case thedist of-          Left exactPath -> escape exactPath-          Right (dist, sections) ->-              (escape dist) ++ " " ++ concat (intersperse " " (map escape sections))-        where escape = escapeURIString isAllowedInURI---- |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' Nothing (dropWhile (==' ') s)-    where-      quoteWords' :: Maybe Char -> String -> [String]-      quoteWords' Nothing [] = []-      quoteWords' Nothing str =-          case break (flip elem " [\"") str of-            ([],[]) -> []-            (w, []) -> [w]-            (w, (' ':rest)) -> w : (quoteWords' Nothing (dropWhile (==' ') rest))-            (w, ('"':rest)) ->-                case break (== '"') rest of-                  (w',('"':rst)) ->-                      case quoteWords' Nothing rst of-                        [] ->  [w ++ w']-                        (w'':ws) -> ((w ++ w' ++ w''): ws)-                  (_,[]) -> error ("quoteWords: missing \" in the string: "  ++ s)-            (w, ('[':rst)) ->-                case break (== ']') rst of-                  (w',(']':rsts)) ->-                      case quoteWords' Nothing rsts of-                        []       -> [w ++ "[" ++ w' ++ "]"]-                        (w'':ws) -> ((w ++ "[" ++ w' ++ "]" ++ w''): ws)-                  (_,[]) -> error ("quoteWords: missing ] in the string: "  ++ s)--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 =-    case quoteWords str of-      (theTypeStr : theUriStr : theDistStr : sectionStrs) ->-          let 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 sectionStrs-                      then DebSource { sourceType = theType, 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 sectionStrs-                    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, sourceUri = theUri, sourceDist = Right (theDist, map unEscapeString sectionStrs) }-      _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str)--parseSourcesList :: String -> [DebSource]-parseSourcesList = map parseSourceLine . sourceLines---- |Return the list of files that apt-get update would write into--- \/var\/lib\/apt\/lists when it processed the given list of DebSource.--- FIXME: remove the root argument from this and just return the names.-archFiles :: FilePath -> Maybe String -> DebSource -> [FilePath]-archFiles root (Just arch) deb@(DebSource Deb _ _) =-    map (++ ("_binary-" ++ arch ++ "_Packages")) (archFiles' root deb)-archFiles root Nothing deb@(DebSource DebSrc _ _) =-    map (++ "_source_Sources") (archFiles' root deb)-archFiles _ _ _ = []    -- error?--archFiles' :: FilePath -> DebSource -> [FilePath]-archFiles' root deb =-    let uri = sourceUri deb-        distro = sourceDist deb in-    let schme = uriScheme uri-        auth = uriAuthority uri-        pth = uriPath uri in-    let userpass = maybe "" uriUserInfo auth-        reg = maybeOfString $ maybe "" uriRegName auth-        port = maybe "" uriPort auth in-    let (user, pass) = break (== ':') userpass in-    let user' = maybeOfString user-        pass' = maybeOfString pass in-    let uriText = prefix schme user' pass' reg port pth in-    -- what about dist?-    either (\ exact -> [root ++ (escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText ++ escape exact))])-           (\ (dist, sections) ->-                map (\ section -> root ++ (escapeURIString (/= '@')-                                           ("/var/lib/apt/lists/" ++-                                            uriText ++-                                            "_dists_" ++ escape dist ++ "_" ++-                                            escape section)))-                    sections)-           distro-    where-      -- If user is given and password is not, the user name is-      -- added to the file name.  Otherwise it is not.  Really.-      prefix "http:" (Just user) Nothing (Just host) port pth =-          user ++ host ++ port ++ escape pth-      prefix "http:" _ _ (Just host) port pth =-          host ++ port ++ escape pth-      prefix "ftp:" _ _ (Just host) _ pth =-          host ++ escape pth-      prefix "file:" Nothing Nothing Nothing "" pth =-          escape pth-      prefix "ssh:" (Just user) Nothing (Just host) port pth =-          user ++ host ++ port ++ escape pth-      prefix "ssh" _ _ (Just host) port pth =-          host ++ port ++ escape pth-      prefix _ _ _ _ _ _ = error ("invalid DebSource: " ++ show deb)-      maybeOfString "" = Nothing-      maybeOfString s = Just s-      escape s = consperse "_" (wordsBy (== '/') s)---- |The mighty consperse function-consperse :: [a] -> [[a]] -> [a]-consperse sep items = concat (intersperse sep items)--wordsBy :: Eq a => (a -> Bool) -> [a] -> [[a]]-wordsBy p s =-    case (break p s) of-      (t, []) -> [t]-      (h, t) -> h : wordsBy p (drop 1 t)
− Linspire/Debian/Version.hs 
@@ -1,14 +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 Linspire.Debian.Version-    (DebianVersion -- |Exported abstract because the internal representation is likely to change-    , parseDebianVersion-    , epoch-    , version-    , revision-    , buildDebianVersion-    , evr-    ) where--import Linspire.Debian.Version.Common-import Linspire.Debian.Version.String
− Linspire/Debian/Version/ByteString.hs 
@@ -1,17 +0,0 @@-module Linspire.Debian.Version.ByteString-    ( ParseDebianVersion(..)-    ) where--import Text.ParserCombinators.Parsec--import qualified Data.ByteString.Char8 as C--import Linspire.Debian.Version.Common-import Linspire.Debian.Version.Internal-    -instance ParseDebianVersion C.ByteString where-    parseDebianVersion byteStr =-        let str = C.unpack byteStr in-        case parse parseDV str str of-          Left e -> error (show e)-          Right dv -> DebianVersion str dv
− Linspire/Debian/Version/Common.hs 
@@ -1,170 +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 Linspire.Debian.Version.Common-    (DebianVersion -- |Exported abstract because the internal representation is likely to change-    , ParseDebianVersion(..)-    , evr               -- DebianVersion -> (Maybe Int, String, Maybe String)-    , epoch-    , version-    , revision-    , buildDebianVersion-    , parseDV-    ) where--import Data.Char-import Text.ParserCombinators.Parsec-import Text.Regex--import Linspire.Debian.Version.Internal--instance Show DebianVersion where-    show (DebianVersion s _) = s--instance Eq DebianVersion where-    (DebianVersion _ v1) == (DebianVersion _ v2) = v1 == v2--instance Ord DebianVersion where-    compare (DebianVersion _ v1) (DebianVersion _ v2) = compare v1 v2---- * Ord instance---- 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 "" ('~':_) = GT-compareNonNumeric ('~':_) "" = 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-          _ -> 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-> 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?---- 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 epch vrsn rvsn =-    either (error . show) (DebianVersion str) $ parse parseDV str str-    where-      str = (maybe "" (\ n -> show n ++ ":") epch ++-                   vrsn ++-                   maybe "" (\ s -> "-" ++ s) rvsn)
− Linspire/Debian/Version/Internal.hs 
@@ -1,33 +0,0 @@-module Linspire.Debian.Version.Internal-    ( DebianVersion(..)-    , Numeric(..)-    , NonNumeric(..)-    , Found(..)-    )-    where--- 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)--data NonNumeric-    = NonNumeric String (Found Numeric)-      deriving Show--data Numeric-    = Numeric Int (Maybe NonNumeric)-      deriving Show---data Found a-    = Found { unFound :: a }-    | Simulated { unFound :: a }-      deriving Show--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)
− Linspire/Debian/Version/String.hs 
@@ -1,15 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-module Linspire.Debian.Version.String-    ( ParseDebianVersion(..)-    ) where--import Text.ParserCombinators.Parsec--import Linspire.Debian.Version.Common-import Linspire.Debian.Version.Internal--instance ParseDebianVersion String where-    parseDebianVersion str =-        case parse parseDV str str of-          Left e -> error (show e)-          Right dv -> DebianVersion str dv
Setup.hs view
@@ -1,21 +1,5 @@ #!/usr/bin/runhaskell -import Distribution.Simple (defaultMainWithHooks, defaultUserHooks, runTests, Args())-import Distribution.PackageDescription (PackageDescription())-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo())-import System.Exit (ExitCode())-import System.Cmd (system)-import System.Directory (getCurrentDirectory, setCurrentDirectory)-import Control.Exception (finally)--withCurrentDirectory :: FilePath -> IO a -> IO a-withCurrentDirectory path f = do-        cur <- getCurrentDirectory-        setCurrentDirectory path-        finally f (setCurrentDirectory cur)--runTestScript :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()-runTestScript args flag pd lbi = withCurrentDirectory "tests" (system "runhaskell Main.hs") >> return ()+import Distribution.Simple -main :: IO ()-main = defaultMainWithHooks defaultUserHooks{runTests = runTestScript}+main = defaultMainWithHooks simpleUserHooks
+ Text/Format.hs view
@@ -0,0 +1,5 @@+module Text.Format where++class Show a => Format a where+    format :: a -> String+    format = show
@@ -1,26 +0,0 @@-Copyright (c) 2006, Jeremy Shaw <jeremy@n-heptane.com>-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-1. Redistributions of source code must retain the above copyright-   notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright-   notice, this list of conditions and the following disclaimer in the-   documentation and/or other materials provided with the distribution.-3. The names of the author may not be used to endorse or promote-   products derived from this software without specific prior written-   permission.--THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF-SUCH DAMAGE.
debian.cabal view
@@ -1,45 +1,107 @@-name:          debian-version:       1.2.1-license:       BSD3-license-file:  copyright-author:        Jeremy Shaw-maintainer:    Jeremy Shaw <jeremy@n-heptane.com>-stability:     obsolete-synopsis:      A set of modules for working with Debian control files and packages-description:   This version is very out of date and no longer-               supported. Get latest version from darcs for now.-               Modules for parsing Debian control files, resolving-               dependencies, comparing version numbers, and other-               useful stuff.-homepage:      http://src.seereason.com/haskell-debian-3-category:      System-tested-with:   GHC==6.8.2-build-depends: base, containers, parsec, mtl, network, unix, regex-compat, bytestring, pretty-build-type:    Custom--exposed-modules:-        Linspire.Debian.Control,-        Linspire.Debian.Control.Common,-        Linspire.Debian.Control.String,-        Linspire.Debian.Control.ByteString,-        Linspire.Debian.Control.PrettyPrint,-        Linspire.Debian.Dependencies,-        Linspire.Debian.Package,-        Linspire.Debian.PackageDeprecated,-        Linspire.Debian.Relation,-        Linspire.Debian.Relation.Common,-        Linspire.Debian.Relation.String,-        Linspire.Debian.Relation.ByteString,-        Linspire.Debian.SourcesList,-        Linspire.Debian.Version,-        Linspire.Debian.Version.Common,-        Linspire.Debian.Version.String,-        Linspire.Debian.Version.ByteString+Name:           debian+Version:        3.14+License:        BSD3+License-File:	COPYING+Author:         David Fox+Category:	System+Maintainer:     david@seereason.com+Homepage:       http://seereason.org/+Build-Depends:  base >= 3 && < 4, unix, Unixutils, Extra >= 0.4, directory, process, bytestring,+		pretty, containers, old-time, old-locale, network, parsec, mtl,+		regex-compat, time, regex-posix, bzlib, zlib, HaXml, filepath+Build-Type:	Simple+Synopsis:       Modules for working with the Debian package system+Description:+  This library includes modules covering almost every aspect of the Debian+  packaging system, including low level data types such as version numbers+  and dependency relations, on up to the types necessary for computing and+  installing build dependencies, building source and binary packages,+  and inserting them into a repository.+ghc-options: -O2 -threaded -W+Extensions: ExistentialQuantification+Exposed-modules:+	Debian.Apt.Dependencies,+	Debian.Apt.Index,+	Debian.Apt.Methods,+	Debian.Apt.Package,+	Debian.Control,+	Debian.Control.Common,+	Debian.Control.PrettyPrint,+	Debian.Control.ByteString,+	Debian.Control.String,+	Debian.Deb,+	Debian.Extra.CIO,+	Debian.Extra.Files,+	Debian.GenBuildDeps,+	Debian.Relation,+	Debian.Relation.ByteString,+	Debian.Relation.Common,+	Debian.Relation.String,+	Debian.Repo,+	Debian.Repo.AptImage,+	Debian.Repo.Cache,+	Debian.Repo.Changes,+	Debian.Repo.Dependencies,+	Debian.Repo.Insert,+	Debian.Repo.IO,+	Debian.Repo.LocalRepository,+	Debian.Repo.OSImage,+	Debian.Repo.Package,+	Debian.Repo.PackageIndex,+	Debian.Repo.Release,+	Debian.Repo.Repository,+	Debian.Repo.Slice,+	Debian.Repo.SourcesList,+	Debian.Repo.SourceTree,+	Debian.Repo.Types,+	Debian.Shell,+	Debian.Time,+	Debian.URI,+	Debian.Version,+	Debian.Version.Common,+	Debian.Version.String,+	Debian.Version.ByteString,+	Debian.VersionPolicy,+	Debian.Report,+	Debian.Util.FakeChanges,+	Text.Format other-modules:-        Linspire.Debian.Version.Internal+	Debian.Version.Internal extra-source-files:-        tests/Dependencies.hs, tests/Main.hs, tests/SourcesList.hs, tests/Versions.hs, debian/changelog,-        debian/compat, debian/control, debian/copyright, debian/haskell-debian-doc.docs, debian/rules+	tests/Main.hs demos/Versions.hs debian/changelog  +	debian/compat debian/control debian/copyright+	debian/rules -extensions:  FlexibleInstances, TypeSynonymInstances, TypeOperators, ScopedTypeVariables-ghc-options: -O2 -funbox-strict-fields -Wall+Executable: fakechanges+Main-is: utils/FakeChanges.hs+ghc-options: -O2 -threaded -W++Executable: debian-report+Main-is: utils/Report.hs+ghc-options: -O2 -threaded -W++Executable: debian-versions+Main-is: demos/Versions.hs+ghc-options: -O2 -threaded -W++Executable: cabal-debian+Main-is: utils/CabalDebian.hs+ghc-options: -O2 -threaded -W+Build-Depends: Cabal++-- For more complex build options see:+-- http://www.haskell.org/ghc/docs/latest/html/Cabal/++--	Debian.AptImage, Debian.Cache, Debian.Control, Debian.Control.ByteString,+--	Debian.Dependencies, Debian.DryRun, Debian.GenBuildDeps, Debian.Index,+--	Debian.IO, Debian.Shell,+--	Debian.Local.Changes, Debian.Local.Index, Debian.Local.Insert,+--	Debian.Local.Package, Debian.Local.Release, Debian.Local.Repo, Debian.OSImage,+--	Debian.Package, Debian.Release, Debian.Repo,+--	Debian.Slice, Debian.SourcesList,+--	Debian.SourceTree, Debian.Types, Debian.UploadFile, , Debian.Apt.Index, Debian.Apt.Methods, Debian.Deb, Debian.Time, Debian.Util.FakeChanges,+--	Debian.Apt.Dependencies, Debian.Apt.Package,+--	Debian.Report,+--	Debian.Types.AptCache, Debian.Types.AptImage, Debian.Types.DebSource, Debian.Types.OSImage,+--	Debian.Types.Package, Debian.Types.PackageIndex, Debian.Types.Release, Debian.Types.ReleaseInfo,+--	Debian.Types.Repo, Debian.Types.Slice, Debian.Types.SourceTree
debian/changelog view
@@ -1,146 +1,335 @@-haskell-debian (1.2.1) unstable; urgency=low+haskell-debian (3.14) unstable; urgency=low -  * Special release so that version on hackageDB works until we have time-    to upload 3.x.+  * Fix a bug that resulted in a fromJust Nothing error. - -- Jeremy Shaw <jeremy@n-heptane.com>  Mon, 23 Jun 2008 12:45:20 -0700+ -- David Fox <dsf@seereason.com>  Thu, 22 Jan 2009 09:59:16 -0800 -haskell-debian (1.2) unstable; urgency=low+haskell-debian (3.13) unstable; urgency=low -  * Cleanup in preperation for upload to hackageDB+  * Add the cabal-debian executable to this package to ease bootstrapping. - -- Jeremy Shaw <jeremy.shaw@linspire.com>  Tue,  3 Apr 2007 11:13:06 -0700+ -- David Fox <dsf@seereason.com>  Fri, 16 Jan 2009 06:41:40 -0800 -haskell-debian (1.1.1) unstable; urgency=low+haskell-debian (3.12) unstable; urgency=low -  * Handle '#' comments-  * fix quoteWords in SourcesList to handle case where last-    character in string is a quote character-  * Remove dependency on missingh-  * Dependency changes for GHC 6.6+  * Export some functions and types from Debian.Apt.Index that were+    already being used by other applications+  * Allow relation parser to skip empty relations like such as: a, ,c - -- David Fox <david.fox@linspire.com>  Tue, 27 Feb 2007 05:59:05 -0800+ -- Jeremy Shaw <jeremy@n-heptane.com>  Fri, 09 Jan 2009 18:22:09 -0600 -haskell-debian (1.1) unstable; urgency=low+haskell-debian (3.11) unstable; urgency=low -  * Deprecated Package data-type and updated a bunch of code-    to remove usage of Package type-     + Add Linspire.Debian.Control.PrettyPrinter -     + Major update to Linsipre.Debian.Dependencies-        - No longer cares what data-type is used to store the package-          information.-     + Major update to Linsipre.Debian.Package-        - moved a bunch of stuff to PackageDeprecated-        - remaining functions now package data-type independent-  * Added Linspire.Debian and Linspire.Debian.DistroSpec-  * Add raiseFields to Control-  * Remove Tag management code from Version module (it will stay-    in the autobuilder source code.)-  * Fix Control parser so it can handle blank lines at the-    beginning of a file.-  - -- David Fox <david.fox@linspire.com>  Sat, 21 Oct 2006 18:48:24 -0400+  * Gather code to retrieve the text an URI points to into the Debian.URI+    module. -haskell-debian (1.0.14) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Tue, 04 Nov 2008 13:53:33 -0800 -  * Create multiple dists in the local repository, manage it-    using scanIncoming et. al.+haskell-debian (3.10) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Thu, 17 Aug 2006 21:41:09 -0700+  * Change name and arch of doc package. -haskell-debian (1.0.13) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Sat, 20 Sep 2008 12:07:38 -0700 -  * Repository API cleanup-  * Allow a quilt 'patches' directory to be a SourceTree-  * Remove DistrCache.localPoolDir function, all the distros-    should share a localpool to avoid version number conflicts.+haskell-debian (3.9) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Thu, 17 Aug 2006 12:40:06 -0700+  * Compute exactly which packages participate in dependency cycles. -haskell-debian (1.0.12) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Mon, 18 Aug 2008 12:42:56 -0700 -  * Add Config module, fix bug in ssh url formatting.+haskell-debian (3.8) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Wed, 16 Aug 2006 09:34:00 -0700+  * Don't add an extra newline at the end of the Files section when+    editing the .changes file. -haskell-debian (1.0.11) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Mon, 21 Jul 2008 10:57:49 -0700 -  * Add DistroCache, Repository, AptImage, and OSImage modules.+haskell-debian (3.7) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Sat, 12 Aug 2006 08:21:28 -0700+  * Eliminate all direct uses of TIO, we always use CIO m => so+    that all functions can be called from the regular IO monad. -haskell-debian (1.0.10) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Sat, 19 Jul 2008 10:27:49 -0700 -  * Add SourceTree, and ChangeLog modules.+haskell-debian (3.6) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Tue,  8 Aug 2006 15:49:43 -0700+  * Remove useless arguments from insertRelease.+  * Replace debianization -haskell-debian (1.0.9) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Tue, 01 Jul 2008 10:41:22 -0700 -  * Add Linspire.Debian.Control.modifyField+haskell-debian (3.5) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Tue,  8 Aug 2006 10:29:38 -0700+  * Debianization generated by cabal-debian -haskell-debian (1.0.8) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Sat, 28 Jun 2008 15:49:07 -0700 -  * Add setTag, changeTag, getTag, dropTag, splitTag.+haskell-debian (3.4) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Sat,  5 Aug 2006 07:02:17 -0700+  * Even correcter code for doing Relax-Depends.  The relaxDeps function+    is now seperate from the other build depenency functions, which makes+    things a bit simpler and easier to document. -haskell-debian (1.0.7) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Wed, 18 Jun 2008 21:00:36 +0000 -  * Add ByteString based versions of Control, Relation, Version (JS)-  * Fix reading of zero length Control file fields (DSF)-  * add a show method for Relations (DSF)-  * Support revisions containing "-" (JS)-  * Support (nonstandard) multi-line build dependencies (DSF)-  * Fix pretty printing of ArchExpect type (JS)-  * Fix compare for version numbers (JS)-  * Accept tab as the beginning of continuation line-  * Version number unit tests+haskell-debian (3.3) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Fri,  9 Jun 2006 14:45:24 -0700+  * Add code to correctly implement Relax-Depends for non-global+    dependencies. -haskell-debian (1.0.6) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Sat, 31 May 2008 07:31:15 +0000 -  * cleaned up to match our emerging standard for debianized haskell libraries (JS)+haskell-debian (3.2) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Wed, 17 May 2006 10:59:08 -0700+  * Redo the buildable function in GenBuildDeps.+  * Improve message from OSImage.updateLists. -haskell-debian (1.0.5) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Sat, 24 May 2008 13:06:09 +0000 -  * Fix bug introduced in 1.0.4 where version 1.0.4 < 1.0.4-.+haskell-debian (3.1-1) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Fri, 12 May 2006 06:11:56 -0700+  * Version number follies. -haskell-debian (1.0.4) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Thu, 22 May 2008 16:18:47 -0700 -  * Add accessors for the version components, modify data structure so-    we get revision Nothing when there is no dash in the version string.+haskell-debian (3.1) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Wed, 10 May 2006 06:37:58 -0700+  * Re-worked the build dependency computation -haskell-debian (1.0.3) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Thu, 22 May 2008 10:59:22 -0700 -  * Version bump to help with autobuilder development+haskell-debian (3.0) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Tue,  9 May 2006 16:06:49 -0700+  * Re-organization of module heirarchy. -haskell-debian (1.0.2) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Mon, 19 May 2008 12:47:25 -0700 -  * Export parseControlFromHandle+haskell-debian (2.28) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Tue,  9 May 2006 14:11:42 -0700+  * Eliminate use of haskell-ugly library. -haskell-debian (1.0.1) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Wed, 14 May 2008 12:30:40 -0700 -  * Jeremy added parseControlFromHandle+haskell-debian (2.27) unstable; urgency=low - -- David Fox <david.fox@linspire.com>  Tue,  9 May 2006 13:40:48 -0700+  * Changes for switch to lazy bytestrings in haskell-unixutils. -haskell-debian (1.0.0) unstable; urgency=low+ -- David Fox <dsf@seereason.com>  Tue, 06 May 2008 05:52:51 -0700 -  * Initial Release.+haskell-debian (2.26) unstable; urgency=low - -- Jeremy Shaw <jeremy.shaw@linspireinc.com>  Tue,  4 Apr 2006 16:15:35 -0700+  * Improve error report from "Missing control file or changelog" + -- David Fox <dsf@seereason.com>  Mon, 05 May 2008 05:59:27 -0700++haskell-debian (2.25) unstable; urgency=low++  * Packaging changes for haskell-devscripts 0.6.10.++ -- David Fox <dsf@seereason.com>  Sat, 29 Mar 2008 10:25:54 -0700++haskell-debian (2.24) unstable; urgency=low++  * New version of dupload reads both /etc/dupload.conf and ~/.dupload.conf, so+    we have to explicitly unset $preupload in ~/.dupload.conf.++ -- David Fox <dsf@seereason.com>  Tue, 25 Mar 2008 05:49:08 -0700++haskell-debian (2.23) unstable; urgency=low++  * Fix a divide by zero error in Debian.Shell.  This should also improve+    the behavior of the code that outputs one dot per 128 characters of+    shell command output.++ -- David Fox <dsf@seereason.com>  Wed, 12 Mar 2008 16:55:59 +0000++haskell-debian (2.22) unstable; urgency=low++  * Add a chars/dot argument to Shell.dotOutput+  * Moved some functions from Shell to haskell-unixutils+  * Moved TIO module to haskell-extra++ -- David Fox <dsf@seereason.com>  Sun, 02 Mar 2008 10:14:13 -0800++haskell-debian (2.21) unstable; urgency=low++  * Change some writeFile calls to avoid lazyness in evaluating the+    second argument, which appears to lead to locked file errors.++ -- David Fox <dsf@seereason.com>  Sun, 24 Feb 2008 11:06:53 -0800++haskell-debian (2.20) unstable; urgency=low++  * Message Improvements+  * Discard duplicate dependency relations+  * Fix rfc822DateFormat++ -- Jeremy Shaw <jeremy@n-heptane.com>  Wed, 20 Feb 2008 13:34:34 -0800++haskell-debian (2.19) unstable; urgency=low++  * Added more functions for working with index files++ -- Jeremy Shaw <jeremy@n-heptane.com>  Tue, 19 Feb 2008 16:07:46 -0800++haskell-debian (2.18) unstable; urgency=low++  * Hack: Debian.Local.Insert.addPackagesToIndexes work-around for optimizer bug+  * Debian.Package: use controlFromIndex instead of calling zcat++ -- Jeremy Shaw <jeremy@n-heptane.com>  Mon, 11 Feb 2008 23:08:30 -0800++haskell-debian (2.17) unstable; urgency=low++  * TIO module fixes and cleanups.++ -- David Fox <dsf@seereason.com>  Thu, 07 Feb 2008 05:45:00 -0800++haskell-debian (2.16) unstable; urgency=low++  * Add setRepoMap to install cached repository info+  * Print more info about what happened when a repository appears not to exist.++ -- David Fox <ddssff@gmail.com>  Wed, 06 Feb 2008 16:00:45 -0800++haskell-debian (2.15) unstable; urgency=low++  * Fix bug in Debian.VersionPolicy+  * Split a simple TIO monad out of the AptIO monad.+  * Simplify Repository type, eliminate parameterized Release etc.+  * Improve type safety of the SourcesList related types++ -- David Fox <ddssff@gmail.com>  Wed, 06 Feb 2008 05:38:12 -0800++haskell-debian (2.14) unstable; urgency=low++  * Rewrite of Debian.VersionPolicy.+  * Run unit tests during build++ -- David Fox <ddssff@gmail.com>  Mon, 28 Jan 2008 13:07:00 -0800++haskell-debian (2.13) unstable; urgency=low++  * Improvements in code currently used to compute the build dependencies.+    This allows builds of packages which previously caused an combinatoric+    explosion in memory and time use.  The specific modifications are to+    avoid making a huge list of all the solution candidates that failed,+    and to put the relations into a normal form which only involves equals+    dependencies on packages that are actually available for installation.+    Finally, a bug in handling of architecture specific dependencies was+    fixed which might have been causing the extremely long and fruitless+    searches for some packages' build dependencies.++ -- David Fox <ddssff@gmail.com>  Sat, 19 Jan 2008 19:28:32 +0000++haskell-debian (2.12) unstable; urgency=low++  * Add Debian.Apt.Dependecies and Debian.Apt.Package to debian.cabal++ -- Jeremy Shaw <jeremy.shaw@linspireinc.com>  Fri, 18 Jan 2008 17:13:24 -0800++haskell-debian (2.11) unstable; urgency=low++  * Added trump detector+  * Added code to find parents and siblings of a binary package from the+    Packages/Sources files+  * Packaging updates++ -- Jeremy Shaw <jeremy.shaw@linspireinc.com>  Fri, 14 Dec 2007 13:55:20 -0800++haskell-debian (2.10) unstable; urgency=low++  * Added new interface, Apt.Debian.Methods.fetch which allows the UI+    portion of fetching (status, authentication), to be controlled by+    providing a set of callback functions.++ -- Jeremy Shaw <jeremy.shaw@linspireinc.com>  Tue, 20 Nov 2007 14:07:43 -0800++haskell-debian (2.9) unstable; urgency=low++  * Add caching of loaded package indexes based on the path and the+    file status of the cached index file.  Also splits Debian.Types+    into several modules.++ -- David Fox <dsf@seereason.org>  Fri,  9 Nov 2007 11:05:11 -0800++haskell-debian (2.8) unstable; urgency=low++  * Last version had bogus dependencies due to an unknown build error.+    Make loading of package indexes less lazy in an attempt to reduce+    memory usage.++ -- David Fox <dsf@seereason.org>  Wed,  7 Nov 2007 10:54:27 -0800++haskell-debian (2.7) unstable; urgency=low++  * Make loading of package indexes lazy.++ -- David Fox <dsf@seereason.org>  Mon, 22 Oct 2007 11:11:34 -0700++haskell-debian (2.6) unstable; urgency=low++  * Pass --immediate-configure-false to build-env so we can create+    environments for gutsy, lenny, and sid.++ -- David Fox <dsf@seereason.org>  Sat, 20 Oct 2007 16:17:59 -0700++haskell-debian (2.5) unstable; urgency=low++  * Reduce amount of apt-get updating that occurs.++ -- David Fox <ddssff@gmail.com>  Sat, 20 Oct 2007 13:50:25 +0000++haskell-debian (2.4) unstable; urgency=low++  * Fix parsing of version tags in VersionPolicy.  It was always failing+    and therefore not understanding versions we had generated.++ -- David Fox <ddssff@gmail.com>  Sat, 13 Oct 2007 04:44:39 -0700++haskell-debian (2.3) unstable; urgency=low++  * The EnvPath and EnvRoot types had show methods that were not+    invertable by read.  Now they use deriving Show, and use rootPath+    and the new outsidePath to convert EnvRoot and EnvPath to the+    FilePath type.  This is a big looking change, but safe.+  * Replace code that looked at the "Package" and "Version" fields+    of a parsed control file with calls to packageName and+    packageVersion, which just returns values already computed and+    saved in the Package object.+  * Use EnvPath instead of FilePath in places where it makes sense, such+    as the copyDebianBuildTree and other places in Debian.SourceTree.+    This change propagated down in various places, and the cutoff may be+    a little out of whack in some places, but it is all typesafe (and+    therefore wonderful?)++ -- David Fox <ddssff@gmail.com>  Thu, 11 Oct 2007 15:43:03 +0000++haskell-debian (2.2) unstable; urgency=low++  * Fix a bug in parsing of dependency relations when there is+    whitespace after a right square brace.++ -- David Fox <ddssff@gmail.com>  Tue,  9 Oct 2007 21:00:24 +0000++haskell-debian (2.1) unstable; urgency=low++  * Fix show method of SliceList, the elements need to be+    terminated by newlines.++ -- David Fox <ddssff@gmail.com>  Fri,  5 Oct 2007 00:11:33 -0700++haskell-debian (2.0) unstable; urgency=low++  * Change Apt. to Debian.+  * Added Debian.Apt.Methods+  * Added Debian.Deb+  * Added Debian.Time++ -- Jeremy Shaw <jeremy.shaw@linspire.com>  Wed, 19 Sep 2007 15:14:10 -0700++haskell-apt (1.0) unstable; urgency=low++  * Initial Debian package.++ -- David Fox <ddssff@gmail.com>  Tue, 18 Sep 2007 09:33:24 -0700
debian/compat view
@@ -1,1 +1,1 @@-4+5
debian/control view
@@ -1,43 +1,89 @@ Source: haskell-debian Priority: optional-Maintainer: Jeremy Shaw <jeremy.shaw@linspireinc.com>-Build-Depends: debhelper (>= 4.0.0), ghc6 (>= 6.4.1), haskell-devscripts (>= 0.5.11+DARCS), ghc6-prof, libghc6-network-dev, libghc6-hunit-dev, libghc6-mtl-dev-Build-Depends-Indep: haddock, hugs (>= 98.200503.08)-Standards-Version: 3.7.2.1-Section: devel+Section: misc+Maintainer: David Fox <dsf@seereason.com>+Build-Depends: debhelper (>= 5.0),+               haskell-devscripts,+               ghc6 (>= 6.10),+               ghc6-doc,+               haddock (>= 2.1.0),+               ghc6-prof,+               libghc6-unixutils-prof (>= 1.18),+               libghc6-unixutils-doc (>= 1.18),+               libghc6-extra-prof (>= 1.26),+               libghc6-extra-doc (>= 1.26),+               libghc6-bzlib-prof,+               libghc6-bzlib-doc,+               libghc6-zlib-prof,+               libghc6-zlib-doc,+               libghc6-haxml-dev,+               haxml-doc+Standards-Version: 3.7.2.2+Homepage: http://seereason.org/  Package: libghc6-debian-dev-Section: devel Architecture: any-Depends: ${haskell:Depends}, libghc6-unixutils-dev (>= 1.2), libghc6-network-dev, libghc6-hunit-dev, libghc6-mtl-dev-Suggests: haskell-debian-doc-Description: GHC library for dealing with debian control files and packages- Modules for parsing debian control files, resolving- depedencies, comparing version numbers, and other useful stuff.+Section: libdevel+Depends: ${haskell:Depends},+         libghc6-unixutils-dev,+         libghc6-extra-dev,+         libghc6-bzlib-dev,+         libghc6-zlib-dev,+         libghc6-haxml-dev+Conflicts: libghc6-debian-dev+Provides: libghc6-debian-dev+Replaces: libghc6-debian-dev+Description: Modules for working with the Debian package system+  This library includes modules covering almost every aspect of the Debian+  packaging system, including low level data types such as version numbers+  and dependency relations, on up to the types necessary for computing and+  installing build dependencies, building source and binary packages,+  and inserting them into a repository.+  .+  Author: David Fox+  .+  This package contains the normal library files. -Package: libghc6-debian-prof-Section: devel+Package: libghc6-debian-doc Architecture: any-Depends: ${haskell:Depends}, libghc6-unixutils-prof (>= 1.2), libghc6-network-dev, libghc6-hunit-dev, libghc6-mtl-dev-Suggests: haskell-debian-doc-Description: GHC library for dealing with debian control files and packages- Modules for parsing debian control files, resolving- depedencies, comparing version numbers, and other useful stuff.- .- This package contains the profiling enabled libraries.+Section: libdevel+Depends: ${haskell:Depends},+         libghc6-unixutils-doc,+         libghc6-extra-doc,+         libghc6-bzlib-doc,+         libghc6-zlib-doc,+         haxml-doc+Description: Modules for working with the Debian package system+  This library includes modules covering almost every aspect of the Debian+  packaging system, including low level data types such as version numbers+  and dependency relations, on up to the types necessary for computing and+  installing build dependencies, building source and binary packages,+  and inserting them into a repository.+  .+  Author: David Fox+  .+  This package contains the documentation files. -Package: libhugs-debian+Package: fakechanges+Architecture: any Section: devel-Architecture: all-Depends: ${haskell:Depends}-Suggests: haskell-debian-doc-Description: GHC library for dealing with debian control files and packages- Modules for parsing debian control files, resolving- depedencies, comparing version numbers, and other useful stuff.+Depends: ${shlibs:Depends}, ${haskell:Depends}+Description: create a fake .changes file+ Sometimes you have the .debs, .dsc, .tar.gz, .diff.gz, etc from a+ package build, but not the .changes file. This package lets you+ create a fake .changes file in case you need one. -Package: haskell-debian-doc-Section: doc-Architecture: all-Description: Documentation for Haskell Debian library- Modules for parsing debian control files, resolving- depedencies, comparing version numbers, and other useful stuff.+Package: debian-report+Architecture: any+Section: devel+Depends: ${shlibs:Depends}, ${haskell:Depends}+Description: create reports about Debian repositories+ Analyze Debian repositories and generate reports about their contents+ and relations. For example, a list of all packages in a distribution+ that are trumped by another distribution.++Package: cabal-debian+Architecture: any+Section: devel+Depends: ${shlibs:Depends}, ${haskell:Depends}, haskell-utils, haskell-devscripts, libghc6-cabal-prof+Description: Tool for creating debianizations of Haskell packages based on the .cabal file.
debian/copyright view
@@ -1,26 +1,35 @@-Copyright (c) 2006, Jeremy Shaw <jeremy@n-heptane.com>+This package was debianized by David Fox+<dsf@seereason.com> on September 18, 2007.++Copyright (c) 2007, David Fox+Copyright (c) 2007, Jeremy Shaw+ All rights reserved.  Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-1. Redistributions of source code must retain the above copyright-   notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright-   notice, this list of conditions and the following disclaimer in the-   documentation and/or other materials provided with the distribution.-3. The names of the author may not be used to endorse or promote-   products derived from this software without specific prior written-   permission.+modification, are permitted provided that the following conditions are+met: -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF-SUCH DAMAGE.+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The names of contributors may not be used to endorse or promote+      products derived from this software without specific prior+      written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− debian/haskell-debian-doc.docs 
@@ -1,1 +0,0 @@-dist/doc/html
debian/rules view
@@ -1,92 +1,2 @@ #!/usr/bin/make -f-# -*- makefile -*--# Sample debian/rules that uses debhelper.-# This file was originally written by Joey Hess and Craig Small.-# As a special exception, when this file is copied by dh-make into a-# dh-make output file, you may use that output file without restriction.-# This special exception was added by Craig Small in version 0.37 of dh-make.--# Uncomment this to turn on verbose mode.-#export DH_VERBOSE=1--build: build-stamp-build-stamp:-	dh_testdir--	# Add here commands to compile the package.-	touch build-stamp--clean:-	dh_testdir-	dh_testroot-	rm -f build-stamp--	# Add here commands to clean up after the build process.-	if [ -x setup ] && [ -e .setup-config ] ; then ./setup clean ; fi-	rm -rf setup Setup.hi Setup.ho Setup.o .*config* dist html-	#make clean--	dh_clean --install: build-	dh_testdir-	dh_testroot-	dh_clean -k -	dh_installdirs -a --	# Add here commands to install the package into debian/tmp-	dh_haskell -a--build-indep: build-indep-stamp-build-indep-stamp:-	dh_testdir--install-indep: build-indep-	dh_testdir-	dh_testroot-	dh_clean -k-	dh_installdirs -i--	dh_haskell -i-	./setup configure-	./setup test-	./setup haddock--# Build architecture-independent files here.-binary-indep: build-indep install-indep-	dh_testdir-	dh_testroot-	dh_installchangelogs -i-	dh_installdocs -i-	dh_installexamples -i-	dh_installman -i-	dh_link -i-	dh_strip -i-	dh_compress -i-	dh_fixperms -i-	dh_installdeb -i-	dh_shlibdeps -i-	dh_gencontrol -i-	dh_md5sums -i-	dh_builddeb -i--# Build architecture-dependent files here.-binary-arch: build install-	dh_testdir-	dh_testroot-	dh_installchangelogs -a-	dh_installdocs -a-	dh_installexamples -a-	dh_installman -a-	dh_link -a-	dh_strip -a-	dh_compress -a-	dh_fixperms -a-	dh_installdeb -a-	dh_shlibdeps -a-	dh_gencontrol -a-	dh_md5sums -a-	dh_builddeb -a--binary: binary-indep binary-arch-.PHONY: build clean binary-indep binary-arch binary install build-indep install-indep+include /usr/share/haskell-devscripts/hlibrary.mk
+ demos/Versions.hs view
@@ -0,0 +1,40 @@+-- |Print the available version numbers of a package.+module Main where++import Control.Exception (throw)+import Control.Monad.Trans+import Data.Maybe+import Debian.Repo.IO+import Debian.Repo.PackageIndex+import Debian.Repo.Package+import Debian.Repo.Release+import Debian.Repo.Repository+import Debian.Repo.Types+import Debian.URI+import Extra.CIO+import Extra.IO ()+import Prelude hiding (putStrLn)++main :: IO ()+main = runAptIO main'++main' :: AptIOT IO ()+main' =+    do repo <- prepareRepository (fromJust (parseURI uri))+       releases <- mapM insertRelease (map (Release repo) (repoReleaseInfo repo))+       let binaryIndexes = map (filter (\ i -> packageIndexArch i == arch)) (map binaryIndexList releases)+       binaryPackages <- mapM packageLists binaryIndexes+       liftIO (putStrLn ("\n" ++ show releases))+{-+    where+      insert repo info = insertRelease repo +-}++packageLists :: [PackageIndex] -> AptIOT IO [[BinaryPackage]]+packageLists indexes = mapM packages indexes++packages :: PackageIndex -> AptIOT IO [BinaryPackage]+packages index = liftIO (binaryPackagesOfIndex index) >>= return . either throw id++uri = "http://deb.seereason.com/ubuntu/"+arch = Binary "i386"
− tests/Dependencies.hs 
@@ -1,180 +0,0 @@-module Dependencies where--import Control.Arrow-import Test.HUnit--import Linspire.Debian.Control.String-import Linspire.Debian.Dependencies hiding (packageVersionParagraph)-import Linspire.Debian.Relation-import Linspire.Debian.Version-import Linspire.Debian.Package---packageA =-    [ ("Package", " a")-    , ("Version", " 1.0")-    , ("Depends", " b")-    ]--packageB =-    [ ("Package", " b")-    , ("Version", " 1.0")-    ]--packageC =-    [ ("Package", " c")-    , ("Version", " 1.0")-    , ("Depends", " doesNotExist")-    ]--packageD =-    [ ("Package", " d")-    , ("Version", " 1.0")-    , ("Depends", " e | f, g | h")-    ]--packageE =-    [ ("Package", " e")-    , ("Version", " 1.0")-    ]--packageF =-    [ ("Package", " f")-    , ("Version", " 1.0")-    ]--packageG =-    [ ("Package", " g")-    , ("Version", " 1.0")-    ]--packageH =-    [ ("Package", " h")-    , ("Version", " 1.0")-    ]--packageI =-    [ ("Package", " i")-    , ("Version", " 1.0")-    , ("Depends", " k")-    ]--packageJ =-    [ ("Package", " j")-    , ("Version", " 1.0")-    , ("Provides", " k")-    ]--packageK =-    [ ("Package", " k")-    , ("Version", " 1.0")-    ]----control -    = [ packageA-      , packageB-      , packageC-      , packageD-      , packageE-      , packageF-      , packageG-      , packageH-      , packageI-      , packageJ-      , packageK-      ]--depends p =-    case lookup "Depends" p of-      Nothing -> []-      (Just v) -> either (error . show) id (parseRelations v)--mkCSP :: [[(String, String)]] -> String -> ([(String, String)] -> Relations) -> CSP [(String, String)]-mkCSP paragraphs relStr depF =-    CSP { pnm = addProvides providesF paragraphs $ packageNameMap getName paragraphs-        , relations = either (error . show) id (parseRelations relStr)-        , depFunction = depF-        , conflicts = conflicts'-        , packageVersion = packageVersionParagraph-        }-    where-      getName :: [(String, String)] -> String-      getName p = case lookup "Package" p of Nothing -> error "Missing Package field" ; (Just n) -> stripWS n-      conflicts' :: [(String, String)] -> Relations-      conflicts' p = -          case lookup "Conflicts" p of-            Nothing -> []-            (Just c) -> either (error . show) id (parseRelations c)--      providesF :: [(String, String)] -> [String]-      providesF p =-          case lookup "Provides" p of-            Nothing -> []-            (Just v) ->-                 parseCommaList v--parseCommaList :: String -> [String]-parseCommaList str =-    words $ map (\c -> if c == ',' then ' ' else c) str--packageVersionParagraph :: [(String, String)] -> (String, DebianVersion) -packageVersionParagraph p =-    case lookup "Package" p of-      Nothing -> error $ "Could not find Package in " ++ show p-      (Just n) -> -          case lookup "Version" p of-            Nothing -> error $ "Could not find Package in " ++ show p-            (Just v) -> -                (stripWS n, parseDebianVersion v)--mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]-mapSnd f = map (second f)--test1 =-    let csp = mkCSP control "a" depends-        expected = [ (Complete, [packageB, packageA])]-    in-      TestCase (assertEqual "test1" expected (search bt csp))--missing1 =-    let csp = mkCSP control "c" depends-        expected = []-    in-      TestCase (assertEqual "missing1" expected (search bt csp))--ors1 =-    let csp = mkCSP control "d" depends-        expected = [ (Complete, [packageG, packageE, packageD])-                   , (Complete, [packageH, packageE, packageD])-                   , (Complete, [packageG, packageF, packageD])-                   , (Complete, [packageH, packageF, packageD])-                   ]-    in-      TestCase (assertEqual "ors1" expected (search bt csp))--provides1 =-    let csp = mkCSP control "i" depends-        expected = [ (Complete, [packageK, packageI])-                   , (Complete, [packageJ, packageI])-                   ]-    in-      TestCase (assertEqual "provides1" expected (search bt csp))--provides2 =-    let csp = mkCSP control "k" depends-        expected = [ (Complete, [packageK])-                   , (Complete, [packageJ])-                   ]-    in-      TestCase (assertEqual "provides2" expected (search bt csp))--dependencyTests =-    [ test1-    , missing1-    , ors1-    , provides1-    , provides2-    ]--- runTestText putTextToShowS test1  >>= \(c,st) -> putStrLn (st "")
tests/Main.hs view
@@ -2,13 +2,15 @@  import Test.HUnit import System.Exit- import Versions+import VersionPolicy import SourcesList+import Dependencies -main :: IO ()-main = do (c,st) <- runTestText putTextToShowS (TestList (versionTests ++ sourcesListTests))-          putStrLn (st "")-          case (failures c) + (errors c) of-            0 -> return ()-            _ -> exitFailure+main =+    do (c,st) <- runTestText putTextToShowS (TestList (versionTests ++ versionPolicyTests ++ sourcesListTests ++ dependencyTests))+       putStrLn (st "")+       case (failures c) + (errors c) of+         0 -> return ()+         n -> exitFailure+
− tests/SourcesList.hs 
@@ -1,44 +0,0 @@-module SourcesList where--import Test.HUnit--import Linspire.Debian.SourcesList---- * 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\"")-         ]--testSourcesList :: Test-testSourcesList =-    test [ assertEqual "valid sources.list" validSourcesListExpected (unlines . map show . parseSourcesList $ validSourcesListStr) ]-    where-      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 http://ftp.debian.org/whee \"space dist\" main"-                    , "deb http://ftp.debian.org/whee dist space%20section"-                    ]-      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 http://ftp.debian.org/whee space%20dist main"-                    , "deb http://ftp.debian.org/whee dist space%20section"-                    ]---      invalidSourcesListStr1 = "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ main contrib non-free # exact path with sections"---sourcesListTests :: [Test]-sourcesListTests = [testQuoteWords, testSourcesList]
− tests/Versions.hs 
@@ -1,120 +0,0 @@-module Versions where--import Test.HUnit--import Linspire.Debian.Version-import Linspire.Debian.Version.Common (ParseDebianVersion())---- * Implicit Values--implicit1, implicit2, implicit3, implicit4, implicit5, implicit6, implicit7 :: Test-implicit1 =-    TestCase (assertEqual "1.0 == 1.0-" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "1.0-")))--implicit2 =-    TestCase (assertEqual "1.0 == 1.0-0" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "1.0-0")))--implicit3 =-    TestCase (assertEqual "1.0 == 0:1.0-0" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "0:1.0-0")))--implicit4 =-    TestCase (assertEqual "1.0 == 1.0-" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "1.0-")))--implicit5 =-    TestCase (assertEqual "apple = apple0" EQ (compare (parseDebianVersion "apple") (parseDebianVersion "apple0")))--implicit6 =-    TestCase (assertEqual "apple = apple0-" EQ (compare (parseDebianVersion "apple") (parseDebianVersion "apple0-")))--implicit7 =-    TestCase (assertEqual "apple = apple0-0" EQ (compare (parseDebianVersion "apple") (parseDebianVersion "apple0-0")))---- * epoch, version, revision--epoch1, epoch2, epoch3 :: Test-epoch1 =-    TestCase (assertEqual "epoch 0:0" (Just 0) (epoch $ parseDebianVersion "0:0"))--epoch2 =-    TestCase (assertEqual "epoch 0" Nothing(epoch $ parseDebianVersion "0"))--epoch3 =-    TestCase (assertEqual "epoch 1:0" (Just 1) (epoch $ parseDebianVersion "1:0"))--version1, version2, version3 :: Test-version1 =-    TestCase (assertEqual "version apple" "apple" (version $ parseDebianVersion "apple"))--version2 =-    TestCase (assertEqual "version apple0" "apple0" (version $ parseDebianVersion "apple0"))--version3 =-    TestCase (assertEqual "version apple1" "apple1" (version $ parseDebianVersion "apple1"))--revision1, revision2, revision3, revision4 :: Test-revision1 =-    TestCase (assertEqual "revision 1.0" Nothing (revision $ parseDebianVersion "1.0"))--revision2 =-    TestCase (assertEqual "revision 1.0-" (Just "") (revision $ parseDebianVersion "1.0-"))--revision3 =-    TestCase (assertEqual "revision 1.0-0" (Just "0") (revision $ parseDebianVersion "1.0-0"))--revision4 =-    TestCase (assertEqual "revision 1.0-apple" (Just "apple") (revision $ parseDebianVersion "1.0-apple"))----- * Ordering--compareV :: (ParseDebianVersion a1, ParseDebianVersion a) => a -> a1 -> Ordering-compareV str1 str2 = compare (parseDebianVersion str1) (parseDebianVersion str2)--order1, order2 :: Test-order1 =-    TestCase (assertEqual "1:1-1 > 0:1-1" GT (compareV "1:1-1" "0:1-1"))--order2 =-    TestCase (assertEqual "1-1-1 > 1-1" GT (compareV "1-1-1" "1-1"))---- * Dashes in upstream version--dash1, dash2, zero1 :: Test-dash1 =-    TestCase (assertEqual "version of upstream-version-revision" "upstream-version" (version (parseDebianVersion "upstream-version-revision")))--dash2 =-    TestCase (assertEqual "revision of upstream-version-revision" (Just "revision") (revision (parseDebianVersion "upstream-version-revision")))---- * Insignificant Zero's--zero1 =-    TestCase (assertEqual "0.09 = 0.9" EQ (compareV "0.09" "0.9"))---- * Tests--versionTests :: [Test]-versionTests =-    [ TestLabel "implicit1" implicit1-    , TestLabel "implicit2" implicit2-    , TestLabel "implicit3" implicit3-    , TestLabel "implicit4" implicit4-    , TestLabel "implicit5" implicit5-    , TestLabel "implicit5" implicit6-    , TestLabel "implicit5" implicit7-    , TestLabel "epoch1" epoch1-    , TestLabel "epoch2" epoch2-    , TestLabel "epoch3" epoch3-    , TestLabel "version1" version1-    , TestLabel "version2" version2-    , TestLabel "version3" version3-    , TestLabel "revision1" revision1-    , TestLabel "revision2" revision2-    , TestLabel "revision3" revision3-    , TestLabel "revision4" revision4-    , TestLabel "order1" order1-    , TestLabel "order2" order2-    , dash1-    , dash2-    , zero1-    ]
+ utils/CabalDebian.hs view
@@ -0,0 +1,20 @@+-- |+-- Module      :  CabalDebian+-- Copyright   :  David Fox 2008+--+-- Maintainer  :  David Fox <dsf@seereason.com>+-- Stability   :  alpha+-- Portability :  portable+--+-- Explanation: Main entry point for generating Debianizations from Cabal data.++-- This software may be used and distributed according to the terms of+-- the GNU General Public License, incorporated herein by reference.++module Main where++import qualified Distribution.Package.Debian.Main as Debian++main :: IO ()++main = Debian.main
+ utils/FakeChanges.hs view
@@ -0,0 +1,38 @@+module Main where++import Debian.Util.FakeChanges+import System.Environment+import System.Console.GetOpt+import System.FilePath+import System.Unix.FilePath (realpath)++data Flag +    = OutputDir FilePath+       deriving Show+    +options :: [OptDescr Flag]+options =+     [ Option ['o']     ["output"]  (ReqArg OutputDir "DIRECTORY")  "output DIRECTORY"+     ]+++fakeChangesOpts :: [String] -> IO ([Flag], [FilePath])+fakeChangesOpts argv = +    case getOpt Permute options argv of+      (o,files,[]) | not (null files) -> return (o, files)+      (_,_,errs) -> +          do h <- header+             error $ (concat errs ++ usageInfo h options)+    where header =+              do pn <- getProgName+                 return $ "\nUsage: " ++ pn ++ " [OPTION...] files..."+main =+    do args <- getArgs+       (opts, files) <- fakeChangesOpts args+       (changesFP, contents) <- fakeChanges files+       outdir <-+           case opts of+             [OutputDir dir] -> realpath dir+             _ -> return "."+       writeFile (outdir </> changesFP) $! contents+
+ utils/Report.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module Main where++import Control.Monad+import Data.List+import Debian.Apt.Methods+import Debian.Report+import Debian.Repo.SourcesList+import Extra.Exit+import Extra.HaXml+import System.Environment+import Text.PrettyPrint.HughesPJ+import System.IO++-- * main++main :: IO ()+main =+    do (sourcesAFP, sourcesBFP) <- parseArgs+       let arch     = "i386" -- not actually used for anything right now, could be when binary package list is enabled+           cacheDir = "."    -- FIXME: replace with tempdir later+       sourcesA <- liftM parseSourcesList $ readFile sourcesAFP+       sourcesB <- liftM parseSourcesList $ readFile sourcesBFP+       trumpMap <- trumped (fetch emptyFetchCallbacks []) cacheDir arch sourcesA sourcesB+       print (showXML "trump.xsl" (trumpedXML trumpMap))++-- * command-line helper functions++helpText :: String -> Doc+helpText progName =+    (text "Usage:" <+> text progName <+> text "<old sources.list>" <+> text "<new sources.list>"$+$ +     text [] $+$ +     (fsep $ map text $ words $ "Find all the packages referenced by the second sources.list which trump packages find in the first sources.list.")+    )+    +parseArgs :: IO (String, String)+parseArgs =+    do args <- getArgs+       case args of+         [dista, distb] -> return (dista, distb)+         _ -> exitWithHelp helpText