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 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
prepareRelease :: CIO m => LocalRepository -> ReleaseName -> [ReleaseName] -> [Section] -> [Arch] -> AptIOT m Release
prepareRelease repo dist aliases sections archList =
lookupRelease (LocalRepo repo) dist >>= maybe prepare (const prepare)
where
prepare =
do
let release = Release (LocalRepo repo) (ReleaseInfo { releaseInfoName = dist
, releaseInfoAliases = aliases
, releaseInfoComponents = sections
, releaseInfoArchitectures = archList })
mapM (initIndex (outsidePath root)) (packageIndexList release)
mapM (initAlias (outsidePath root) dist) aliases
lift (writeRelease release)
repo' <- prepareLocalRepository root (repoLayout repo)
let release' = release { releaseRepo = LocalRepo 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
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"
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)
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
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"
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