Release.hs

module System.Apotiki.Debian.Release where
import System.Apotiki.Debian.Package
import System.Apotiki.Debian.Control
import System.Apotiki.FileInfo
import System.Apotiki.Config
import System.Apotiki.Signature
import System.Directory
import System.IO
import Data.List
import Data.Function
import Data.ByteString.Char8 (pack,unpack)
import Data.Aeson
import qualified System.IO.Strict as SIO
import qualified Codec.Compression.GZip as Z
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M

type ArchRelease = M.Map String DebInfo
type Release = M.Map String ArchRelease

flatinfo fileinfo = [fileinfo M.! "Size", fileinfo M.! "MD5sum",
                     fileinfo M.! "SHA1", fileinfo M.! "SHA256"]

unrollEntry (k,v) = k ++ ": " ++ v
unrollMap input = concat $ intersperse "\n" $ map unrollEntry $ M.assocs input

unroll :: [DebInfo] -> String
unroll input = (concat $ intersperse "\n\n" $ map unrollMap input) ++ "\n"

pkgControl pooldir arch pkg = do
  let path = pooldir ++ "/" ++ arch ++ "/" ++ pkg ++ "/control"
  fd <- openFile path ReadMode
  control_data <- SIO.hGetContents fd
  let output = (read control_data :: DebInfo)
  hClose fd
  return output

archRelease pooldir arch = do
  let path = pooldir ++ "/" ++ arch
  entries <- getDirectoryContents path
  let pkgs = filter ((/= '.') . head) entries
  controls <- mapM (pkgControl pooldir arch) pkgs
  return (M.fromList $ zip pkgs controls)

loadRelease :: String -> IO (Release)
loadRelease pooldir = do
  entries <- getDirectoryContents pooldir
  let archs  = filter ((/= '.') . head) entries
  arch_releases <- mapM (archRelease pooldir) archs
  return (M.fromList $ zip archs arch_releases)

releaseJSON pooldir = do
  release <- loadRelease pooldir
  let encoded = release
  return encoded

same_arch x y = (fst x) == (fst y)

releaseByArch archs debinfo =
  if arch == "all" then
    zip archs (repeat debinfo)
  else
    [(arch, debinfo)]
  where arch = debinfo M.! "Architecture"

releaseDescr (_,deb) = (package, deb) where
  package = deb M.! "Package"

releaseMap debs = (fst $ head $ debs,
                   M.fromList $ map releaseDescr debs)

releaseFrom archs debs = M.fromList release_map where
  all_debs = concatMap (releaseByArch archs) debs
  sorted = sortBy (compare `on` fst) all_debs
  by_arch = groupBy same_arch sorted
  release_map = map releaseMap by_arch

mergeRelease new old arch =
  M.union new_arch old_arch where
    new_arch = case (M.lookup arch new) of
      Nothing -> M.fromList []
      Just x -> x
    old_arch = case (M.lookup arch old) of
      Nothing -> M.fromList []
      Just x -> x

updateRelease archs old new = M.fromList (zip archs updated) where
  updated = map (mergeRelease new old) archs

getPkg :: ApotikiConfig -> (String, ArchRelease) -> (String, B.ByteString)
getPkg config (arch, release) = (relpath, pack str_data) where
  distdir = (configDistDir config)
  component = (configComponent config)
  relname = (configRelease config)
  origin = (configOrigin config)
  label = (configLabel config)
  path = concat $ intersperse "/"
         [distdir, relname, component,
          ("binary-" ++ arch), "Packages"]
  relpath = concat $ intersperse "/"
            [component, ("binary-" ++ arch), "Packages"]
  str_data = unroll $ map snd $ M.assocs release

writePackages :: ApotikiConfig -> (String, B.ByteString) -> IO (String, [String])
writePackages config (relpath, payload) = do
  let path = concat $ intersperse "/" [(configDistDir config),
                                       (configRelease config),
                                       relpath]
  B.writeFile path payload
  return (relpath, flatinfo $ fileinfo payload)

writeGzPackages :: ApotikiConfig -> (String, B.ByteString) -> IO (String, [String])
writeGzPackages config (relpath, payload) = do
  let path = concat $ intersperse "/" [(configDistDir config),
                                       (configRelease config),
                                       relpath ++ ".gz"]
  let gzpayload = B.concat $ BL.toChunks $ Z.compress $ BL.fromChunks [payload]
  B.writeFile path gzpayload
  return (relpath ++ ".gz", flatinfo $ fileinfo gzpayload)

writeArchRelease :: ApotikiConfig -> (String, ArchRelease) -> IO (String, [String])
writeArchRelease config (arch,release) = do
  let distdir = (configDistDir config)
  let component = (configComponent config)
  let relname = (configRelease config)
  let origin = (configOrigin config)
  let label = (configLabel config)
  let path = concat $ intersperse "/"
             [distdir, relname, component,
              ("binary-" ++ arch), "Release"]
  let relpath = concat $ intersperse "/"
                [component, ("binary-" ++ arch), "Release"]

  let payload = pack $ unroll [M.fromList [("Archive", relname),
                                           ("Component", component),
                                           ("Origin", origin),
                                           ("Label", label),
                                           ("Architecture", arch)]]
  B.writeFile path payload
  return (relpath, flatinfo $ fileinfo payload)

md5info (path, [size, sum, _, _]) = " " ++ sum ++ " " ++ size ++ " " ++ path
sha1info (path, [size, _, sum, _]) = " " ++ sum ++ " " ++ size ++ " " ++ path
sha256info (path, [size, _, _, sum]) = " " ++ sum ++ " " ++ size ++ " " ++ path

writeGlobalRelease :: ApotikiConfig -> [(String, [String])] -> IO ()
writeGlobalRelease config info = do
  let archs = concat $ intersperse " " (configArchs config)
  let origin = configOrigin config
  let label = configLabel config
  let release = configRelease config
  let component = configComponent config
  let md5s = concat $ intersperse "\n" $ map md5info info
  let sha1s = concat $ intersperse "\n" $ map sha1info info
  let sha256s = concat $ intersperse "\n" $ map sha256info info
  let sums = concat $ intersperse "\n" $ ["MD5Sum:",
                                          md5s,
                                          "SHA1Sum:",
                                          sha1s,
                                          "SHA256Sum:",
                                          sha256s]
  let summary = concat $ intersperse "\n" ["Origin: " ++ origin,
                                           "Label: " ++ label,
                                           "Suite: " ++ release,
                                           "Codename: " ++ release,
                                           "Components: " ++ component,
                                           "Architectures: " ++ archs]
  let payload = pack $ summary ++ "\n" ++ sums ++ "\n"
  let path = concat $ intersperse "/" [(configDistDir config),
                                       (configRelease config),
                                       "Release"]

  (keys, (time, rng)) <- get_key (configKeyPath config)
  let pgp = sign_msg keys time rng payload
  B.writeFile (path ++ ".gpg") pgp
  B.writeFile path payload


releaseMkDir distdir release component arch =
  createDirectoryIfMissing True $ concat $ intersperse "/" [distdir,
                                                            release,
                                                            component,
                                                            "binary-" ++ arch]
releaseMkDirs ApotikiConfig {repoDir = repodir,
                             architectures = archs,
                             release = release,
                             component = component} = do
  mapM_ (releaseMkDir (repodir ++ "/dists") release component) archs

writeRelease :: ApotikiConfig -> Release -> IO ()
writeRelease config release = do
  releaseMkDirs config
  let pkgs = map (getPkg config) (M.assocs release)
  release_files <- mapM (writeArchRelease config) (M.assocs release)
  putStrLn $ "wrote release files: " ++ (show $ length release_files)
  pkg_files <- mapM (writePackages config) pkgs
  putStrLn $ "wrote package files: " ++ (show $ length pkg_files)
  pkg_gz_files <- mapM (writeGzPackages config) pkgs
  putStrLn $ "wrote package compressed files: " ++ (show $ length pkg_gz_files)
  writeGlobalRelease config $ concat [release_files, pkg_files, pkg_gz_files]