module Debian.Repo.Package
(
sourceFilePaths
, binaryPackageSourceVersion
, binarySourceVersion
, sourcePackageBinaryNames
, sourceBinaryNames
, toSourcePackage
, toBinaryPackage
, binaryPackageSourceID
, sourcePackageBinaryIDs
, sourcePackagesOfIndex
, sourcePackagesOfIndex'
, binaryPackagesOfIndex
, binaryPackagesOfIndex'
, getPackages
, putPackages
, releaseSourcePackages
, releaseBinaryPackages
) 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
binaryPackageSourceVersion :: BinaryPackage -> Maybe (String, DebianVersion)
binaryPackageSourceVersion package =
let binaryName = packageName . packageID $ package
binaryVersion = packageVersion . packageID $ package in
binarySourceVersion' binaryName binaryVersion (packageInfo package)
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
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 _ = []
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
binaryID version name = PackageID { packageIndex = binaryIndex
, packageName = name
, packageVersion = version }
sourceIndex = packageIndex (sourcePackageID package)
binaryIndex = sourceIndex { packageIndexArch = arch }
info = sourceParagraph package
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
binaryPackagesOfIndex :: CIO m => PackageIndex -> m (Either Exception [BinaryPackage])
binaryPackagesOfIndex index =
case packageIndexArch index of
Source -> return (Right [])
_ -> getPackages 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 [])
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
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
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
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)
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)
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
text = L.fromChunks [B.concat (intersperse (B.pack "\n") . map formatParagraph . map packageInfo $ packages)]