[commit: Cabal] master: Put build-reports into per-server dirs (cad9eef)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/cad9eef590f4c98468ddf9f15d21b0ec74e5ab10

>---------------------------------------------------------------

commit cad9eef590f4c98468ddf9f15d21b0ec74e5ab10
Author: Duncan Coutts <duncan at haskell.org>
Date:   Tue Jun 10 01:40:11 2008 +0000

    Put build-reports into per-server dirs
    Don't bother putting the server url into each report
    since we do not want to upload that information anyway.

>---------------------------------------------------------------

 cabal-install/Hackage/Config.hs    |    6 +---
 cabal-install/Hackage/Reporting.hs |   60 +++++++++++++++++------------------
 2 files changed, 30 insertions(+), 36 deletions(-)

diff --git a/cabal-install/Hackage/Config.hs b/cabal-install/Hackage/Config.hs
index 77ccbd5..93e47c7 100644
--- a/cabal-install/Hackage/Config.hs
+++ b/cabal-install/Hackage/Config.hs
@@ -16,7 +16,7 @@ module Hackage.Config
     , configRepos
     , configPackageDB
     , defaultConfigFile
-    , defaultBuildReportFile
+    , defaultCacheDir
     , loadConfig
     , showConfig
     ) where
@@ -109,10 +109,6 @@ defaultConfigFile :: IO FilePath
 defaultConfigFile = do dir <- defaultCabalDir
                        return $ dir </> "config"
 
-defaultBuildReportFile :: IO FilePath
-defaultBuildReportFile = do dir <- defaultCabalDir
-                            return $ dir </> "build-reports"
-
 defaultCacheDir :: IO FilePath
 defaultCacheDir = do dir <- defaultCabalDir
                      return $ dir </> "packages"
diff --git a/cabal-install/Hackage/Reporting.hs b/cabal-install/Hackage/Reporting.hs
index bc0e37d..b087c0f 100644
--- a/cabal-install/Hackage/Reporting.hs
+++ b/cabal-install/Hackage/Reporting.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Hackage.Reporting
@@ -34,14 +33,13 @@ module Hackage.Reporting (
 
 import Hackage.Types
          ( ConfiguredPackage(..), AvailablePackage(..)
-         , AvailablePackageSource(..), repoURI, BuildResult )
+         , AvailablePackageSource(..), BuildResult
+         , Repo(repoCacheDir), repoName )
 import qualified Hackage.Types as BR
          ( BuildResult(..) )
 import qualified Hackage.InstallPlan as InstallPlan
 import Hackage.InstallPlan
          ( InstallPlan, PlanPackage )
-import Hackage.Config
-         ( defaultBuildReportFile )
 import Hackage.ParseUtils
          ( showFields, parseBasicStanza )
 
@@ -63,25 +61,23 @@ import qualified Distribution.Compat.ReadP as Parse
          ( ReadP, pfail, munch1, char, option, skipSpaces )
 import Text.PrettyPrint.HughesPJ as Disp
          ( Doc, char, text, (<+>), (<>) )
+import Distribution.Simple.Utils
+         ( comparing, equating )
 
 import Data.List
-         ( unfoldr )
+         ( unfoldr, groupBy, sortBy )
 import Data.Maybe
          ( catMaybes )
 import Data.Char as Char
          ( isAlpha, isAlphaNum )
-import Network.URI
-         ( URI, uriToString, parseAbsoluteURI )
+import System.FilePath
+         ( (</>) )
 
 data BuildReport
    = BuildReport {
     -- | The package this build report is about
     package         :: PackageIdentifier,
 
-    -- | Which hackage server this package is from and thus which server this
-    -- report should be sent to.
-    server          :: URI,
-
     -- | The OS and Arch the package was built on
     os              :: OS,
     arch            :: Arch,
@@ -123,19 +119,30 @@ data InstallOutcome
 
 data Outcome = NotTried | Failed | Ok
 
-writeBuildReports :: [BuildReport] -> IO ()
-writeBuildReports reports = do
-  file <- defaultBuildReportFile
-  appendFile file (concatMap (("\n\n"++) . showBuildReport) reports)
+writeBuildReports :: [(BuildReport, Repo)] -> IO ()
+writeBuildReports reports = sequence_
+  [ appendFile file (concatMap format reports')
+  | (repo, reports') <- separate reports
+  , let file = repoCacheDir 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' : showBuildReport r ++ "\n"
+    separate :: [(BuildReport, Repo)] -> [(Repo, [BuildReport])]
+    separate = map (\rs@((_,repo):_) -> (repo, map fst rs))
+             . map concat
+             . groupBy (equating (repoName . snd . head))
+             . sortBy (comparing (repoName . snd . head))
+             . groupBy (equating (repoName . snd))
 
 buildReport :: OS -> Arch -> CompilerId -- -> Version
-            -> URI -> ConfiguredPackage -> BR.BuildResult
+            -> ConfiguredPackage -> BR.BuildResult
             -> BuildReport
-buildReport os' arch' comp uri (ConfiguredPackage pkg flags deps) result =
+buildReport os' arch' comp (ConfiguredPackage pkg flags deps) result =
   BuildReport {
     package               = packageId pkg,
     os                    = os',
-    server                = uri,
     arch                  = arch',
     compiler              = comp,
     flagAssignment        = flags,
@@ -159,7 +166,6 @@ buildReport os' arch' comp uri (ConfiguredPackage pkg flags deps) result =
 initialBuildReport :: BuildReport
 initialBuildReport = BuildReport {
     package         = requiredField "package",
-    server          = requiredField "server",
     os              = requiredField "os",
     arch            = requiredField "arch",
     compiler        = requiredField "compiler",
@@ -204,8 +210,6 @@ fieldDescrs :: [FieldDescr BuildReport]
 fieldDescrs =
  [ simpleField "package"         disp           parse
                                  package        (\v r -> r { package = v })
- , simpleField "server"          disp           parse
-                                 server         (\v r -> r { server = v })
  , simpleField "os"              disp           parse
                                  os             (\v r -> r { os = v })
  , simpleField "arch"            disp           parse
@@ -271,12 +275,6 @@ instance Text Outcome where
       "Ok"       -> return Ok
       _          -> Parse.pfail
 
-instance Text URI where
-  disp uri = Disp.text (uriToString id uri [])
-  parse = do
-    str <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?")
-    maybe Parse.pfail return (parseAbsoluteURI str)
-
 -- ------------------------------------------------------------
 -- * InstallPlan support
 -- ------------------------------------------------------------
@@ -284,7 +282,7 @@ instance Text URI where
 writeInstallPlanBuildReports :: InstallPlan BuildResult -> IO ()
 writeInstallPlanBuildReports = writeBuildReports . installPlanBuildReports
 
-installPlanBuildReports :: InstallPlan BuildResult -> [BuildReport]
+installPlanBuildReports :: InstallPlan BuildResult -> [(BuildReport, Repo)]
 installPlanBuildReports plan = catMaybes
                              . map (planPackageBuildReport os' arch' comp)
                              . InstallPlan.toList
@@ -295,15 +293,15 @@ installPlanBuildReports plan = catMaybes
 
 planPackageBuildReport :: OS -> Arch -> CompilerId
                        -> InstallPlan.PlanPackage BuildResult
-                       -> Maybe BuildReport
+                       -> Maybe (BuildReport, Repo)
 planPackageBuildReport os' arch' comp planPackage = case planPackage of
 
   InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {
                           packageSource = RepoTarballPackage repo }) _ _)
-    -> Just $ buildReport os' arch' comp (repoURI repo) pkg BR.BuildOk
+    -> Just $ (buildReport os' arch' comp pkg BR.BuildOk, repo)
 
   InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {
                        packageSource = RepoTarballPackage repo }) _ _) result
-    -> Just $ buildReport os' arch' comp (repoURI repo) pkg result
+    -> Just $ (buildReport os' arch' comp pkg result, repo)
 
   _ -> Nothing