module Debian.Apt.Index
( update
, Fetcher
, CheckSums(..)
, Compression(..)
, FileTuple
, Size
, controlFromIndex
, controlFromIndex'
, findContentsFiles
, findIndexes
, indexesInRelease
, tupleFromFilePath
) where
import Control.Monad
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.BZip as BZip
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Digest.Pure.MD5 as MD5
import Data.Function
import Data.List as List (null, intercalate, sortBy, isSuffixOf, isPrefixOf)
import qualified Data.Map as M
import Data.Monoid ((<>))
import Data.Text as Text (Text, unpack, concat, lines, null, words)
import Data.Time
import Debian.Apt.Methods
import Debian.Control (formatControl)
import Debian.Control.ByteString
import Debian.Control.Common
import Debian.Control.Text (decodeControl)
import Debian.Release
import Debian.Sources
import Debian.URI
import System.Directory
import System.FilePath ((</>))
import System.Posix.Files
import System.FilePath (takeBaseName)
import Text.ParserCombinators.Parsec.Error
import Text.PrettyPrint (render)
import Text.PrettyPrint.HughesPJClass (pPrint)
data Compression
= BZ2 | GZ | Uncompressed
deriving (Read, Show, Eq, Ord, Enum, Bounded)
data CheckSums
= CheckSums { md5sum :: Maybe String
, sha1 :: Maybe String
, sha256 :: Maybe String
}
deriving (Read, Show, Eq)
type Fetcher =
URI ->
FilePath ->
Maybe UTCTime ->
IO Bool
update :: Fetcher
-> FilePath
-> String
-> [DebSource]
-> IO [Maybe (FilePath, Compression)]
update fetcher basePath arch sourcesList =
mapM (uncurry $ fetchIndex fetcher) (map (\(uri, fp, _) -> (uri, (basePath </> fp))) (concatMap (indexURIs arch) sourcesList))
fetchIndex :: Fetcher
-> URI
-> FilePath
-> IO (Maybe (FilePath, Compression))
fetchIndex fetcher uri localPath =
do let localPath' = localPath ++ ".bz2"
res <- fetcher (uri { uriPath = (uriPath uri) ++ ".bz2" }) localPath' Nothing
if res
then return $ Just (localPath', BZ2)
else do let localPath' = localPath ++ ".gz"
lm <- getLastModified localPath'
res <- fetcher (uri { uriPath = (uriPath uri) ++ ".gz" }) localPath' lm
if res
then return $ Just (localPath', GZ)
else do lm <- getLastModified localPath
res <- fetcher (uri { uriPath = (uriPath uri) }) localPath lm
if res
then return (Just (localPath, Uncompressed))
else return Nothing
indexURIs :: String
-> DebSource
-> [(URI, FilePath, DebSource)]
indexURIs arch debSource =
map (\ section -> let (uri, fp) = calcPath (sourceType debSource) arch baseURI release section
in (uri,fp, debSource { sourceDist = (Right (release, [section])) }) ) sections
where
baseURI = sourceUri debSource
(release, sections) =
either (error $ "indexURIs: support not implemented for exact path: " ++ render (pPrint debSource)) id (sourceDist debSource)
calcPath :: SourceType
-> String
-> URI
-> ReleaseName
-> Section
-> (URI, [Char])
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
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)
controlFromIndex :: Compression -> FilePath -> L.ByteString -> Either ParseError (Control' Text)
controlFromIndex GZ path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks . GZip.decompress $ s
controlFromIndex BZ2 path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks . BZip.decompress $ s
controlFromIndex Uncompressed path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks $ s
controlFromIndex' :: Compression -> FilePath -> IO (Either ParseError (Control' Text))
controlFromIndex' compression path = L.readFile path >>= return . controlFromIndex compression path
type Size = Integer
type FileTuple = (CheckSums, Size, FilePath)
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))
filterExists :: FilePath -> (FilePath, [(FileTuple, Compression)]) -> IO (FilePath, [(FileTuple, Compression)])
filterExists distDir (fp, alternatives) =
do e <- filterM ( \((_,_,fp),_) -> fileExist (distDir </> fp)) alternatives
return (fp, e)
findIndexes :: FilePath -> String -> [FileTuple] -> IO [(FileTuple, Compression)]
findIndexes distDir iType controlFiles =
let indexes = groupIndexes controlFiles
in
do indexes' <- mapM (filterExists distDir) (filter (isType iType) indexes)
return $ map (head . snd) (filter (not . List.null . snd) indexes')
where
isType iType (fp, _) = iType `isSuffixOf` fp
uncompressedName :: FilePath -> (FilePath, Compression)
uncompressedName fp
| isSuffixOf ".gz" fp = (reverse . (drop 3) . reverse $ fp, GZ)
| isSuffixOf ".bz2" fp = (reverse . (drop 4) . reverse $ fp, BZ2)
| otherwise = (fp, Uncompressed)
indexesInRelease :: (FilePath -> Bool)
-> Control' Text
-> [(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 . Text.words) $ filter (not . Text.null) (Text.lines md5sums)
where
makeTuple :: [Text] -> (CheckSums, Integer, FilePath)
makeTuple [md5sum, size, fp] = (CheckSums { md5sum = Just (Text.unpack md5sum), sha1 = Nothing, sha256 = Nothing }, read (Text.unpack size), Text.unpack fp)
makeTuple x = error $ "Invalid line in release file: " ++ show x
indexesInRelease _ x = error $ "Invalid release file: " <> Text.unpack (Text.concat (formatControl x))
tupleFromFilePath :: FilePath -> FilePath -> IO (Maybe FileTuple)
tupleFromFilePath basePath fp =
do e <- fileExist (basePath </> fp)
if not e
then return Nothing
else do size <- getFileStatus (basePath </> fp) >>= return . fromIntegral . fileSize
md5 <- L.readFile (basePath </> fp) >>= return . show . MD5.md5
return $ Just (CheckSums { md5sum = Just md5, sha1 = Nothing, sha256 = Nothing }, size, fp)
findContentsFiles :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
findContentsFiles filterP distDir =
do files <- getDirectoryContents distDir
return $ filter filterP $ filter (isPrefixOf "Contents-" . takeBaseName) files