Storage.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Reporting
-- Copyright   :  (c) David Waern 2008
-- License     :  BSD-like
--
-- Maintainer  :  david.waern@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Anonymous build report data structure, printing and parsing
--
-----------------------------------------------------------------------------
module Distribution.Client.BuildReports.Storage (

    -- * Storing and retrieving build reports
    storeAnonymous,
    storeLocal,
--    retrieve,

    -- * 'InstallPlan' support
    fromInstallPlan,
  ) where

import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)

import Distribution.Client.Types
         ( ConfiguredPackage(..), AvailablePackage(..)
         , AvailablePackageSource(..), Repo(..), RemoteRepo(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
         ( InstallPlan, PlanPackage )
import Distribution.Client.Config
         ( defaultLogsDir )

import Distribution.System
         ( OS, Arch )
import Distribution.Compiler
         ( CompilerId )
import Distribution.Simple.Utils
         ( comparing, equating )

import Data.List
         ( groupBy, sortBy )
import Data.Maybe
         ( catMaybes )
import System.FilePath
         ( (</>) )
import System.Directory
         ( createDirectoryIfMissing )

storeAnonymous :: [(BuildReport, Repo)] -> IO ()
storeAnonymous reports = sequence_
  [ appendFile file (concatMap format reports')
  | (repo, reports') <- separate reports
  , let file = repoLocalDir repo </> "build-reports.log" ]
  --TODO: make this concurrency safe, either lock the report file or make sure
  -- the writes for each report are atomic (under 4k and flush at boundaries)

  where
    format r = '\n' : BuildReport.show r ++ "\n"
    separate :: [(BuildReport, Repo)]
             -> [(Repo, [BuildReport])]
    separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
             . map concat
             . groupBy (equating (repoName . head))
             . sortBy (comparing (repoName . head))
             . groupBy (equating repoName)
             . onlyRemote
    repoName (_,_,rrepo) = remoteRepoName rrepo

    onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]
    onlyRemote rs =
      [ (report, repo, remoteRepo)
      | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]

storeLocal :: [(BuildReport, Repo)] -> IO ()
storeLocal reports = do
  logsDir <- defaultLogsDir
  let file = logsDir </> "build.log"
  createDirectoryIfMissing True logsDir
  appendFile file (concatMap (format . fst) reports)
  --TODO: make this concurrency safe, either lock the report file or make sure
  -- the writes for each report are atomic (under 4k and flush at boundaries)

  where
    format r = '\n' : BuildReport.show r ++ "\n"


-- ------------------------------------------------------------
-- * InstallPlan support
-- ------------------------------------------------------------

fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]
fromInstallPlan plan = catMaybes
                     . map (fromPlanPackage os' arch' comp)
                     . InstallPlan.toList
                     $ plan
  where os'   = InstallPlan.planOS plan
        arch' = InstallPlan.planArch plan
        comp  = InstallPlan.planCompiler plan

fromPlanPackage :: OS -> Arch -> CompilerId
                -> InstallPlan.PlanPackage
                -> Maybe (BuildReport, Repo)
fromPlanPackage os' arch' comp planPackage = case planPackage of

  InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {
                          packageSource = RepoTarballPackage repo }) _ _) result
    -> Just $ (BuildReport.new os' arch' comp pkg (Right result), repo)

  InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {
                       packageSource = RepoTarballPackage repo }) _ _) result
    -> Just $ (BuildReport.new os' arch' comp pkg (Left result), repo)

  _ -> Nothing