cabal-install/src/Distribution/Client/BuildReports/Storage.hs

   1 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
   2
   3 -----------------------------------------------------------------------------
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Client.Reporting
   9 -- Copyright   :  (c) David Waern 2008
  10 -- License     :  BSD-like
  11 --
  12 -- Maintainer  :  david.waern@gmail.com
  13 -- Stability   :  experimental
  14 -- Portability :  portable
  15 --
  16 -- Anonymous build report data structure, printing and parsing
  17 module Distribution.Client.BuildReports.Storage
  18   ( -- * Storing and retrieving build reports
  19     storeAnonymous
  20   , storeLocal
  21   --    retrieve,
  22
  23     -- * 'InstallPlan' support
  24   , fromInstallPlan
  25   , fromPlanningFailure
  26   ) where
  27
  28 import Distribution.Client.Compat.Prelude
  29 import Prelude ()
  30
  31 import Distribution.Client.BuildReports.Anonymous (BuildReport, newBuildReport, showBuildReport)
  32 import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
  33
  34 import Distribution.Client.InstallPlan
  35   ( InstallPlan
  36   )
  37 import qualified Distribution.Client.InstallPlan as InstallPlan
  38 import Distribution.Client.Types
  39
  40 import qualified Distribution.Solver.Types.ComponentDeps as CD
  41 import Distribution.Solver.Types.SourcePackage
  42
  43 import Distribution.Compiler
  44   ( CompilerId (..)
  45   , CompilerInfo (..)
  46   )
  47 import Distribution.Package
  48   ( PackageId
  49   , packageId
  50   )
  51 import Distribution.PackageDescription
  52   ( FlagAssignment
  53   )
  54 import Distribution.Simple.InstallDirs
  55   ( PathTemplate
  56   , fromPathTemplate
  57   , initialPathTemplateEnv
  58   , substPathTemplate
  59   )
  60 import Distribution.Simple.Utils
  61   ( equating
  62   )
  63 import Distribution.System
  64   ( Platform (Platform)
  65   )
  66
  67 import qualified Data.List as L
  68 import Data.List.NonEmpty
  69   ( groupBy
  70   )
  71 import System.Directory
  72   ( createDirectoryIfMissing
  73   )
  74 import System.FilePath
  75   ( takeDirectory
  76   , (</>)
  77   )
  78
  79 storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO ()
  80 storeAnonymous reports =
  81   sequence_
  82     [ appendFile file (concatMap format reports')
  83     | (repo, reports') <- separate reports
  84     , let file = repoLocalDir repo </> "build-reports.log"
  85     ]
  86   where
  87     -- TODO: make this concurrency safe, either lock the report file or make sure
  88     -- the writes for each report are atomic (under 4k and flush at boundaries)
  89
  90     format r = '\n' : showBuildReport r ++ "\n"
  91     separate
  92       :: [(BuildReport, Maybe Repo)]
  93       -> [(Repo, [BuildReport])]
  94     separate =
  95       map (\rs@((_, repo, _) : _) -> (repo, [r | (r, _, _) <- rs]))
  96         . map (concatMap toList)
  97         . L.groupBy (equating (repoName' . head))
  98         . sortBy (comparing (repoName' . head))
  99         . groupBy (equating repoName')
 100         . onlyRemote
 101
 102     repoName' (_, _, rrepo) = remoteRepoName rrepo
 103
 104     onlyRemote
 105       :: [(BuildReport, Maybe Repo)]
 106       -> [(BuildReport, Repo, RemoteRepo)]
 107     onlyRemote rs =
 108       [ (report, repo, remoteRepo)
 109       | (report, Just repo) <- rs
 110       , Just remoteRepo <- [maybeRepoRemote repo]
 111       ]
 112
 113 storeLocal
 114   :: CompilerInfo
 115   -> [PathTemplate]
 116   -> [(BuildReport, Maybe Repo)]
 117   -> Platform
 118   -> IO ()
 119 storeLocal cinfo templates reports platform =
 120   sequence_
 121     [ do
 122       createDirectoryIfMissing True (takeDirectory file)
 123       appendFile file output
 124     | -- TODO: make this concurrency safe, either lock the report file or make
 125     --      sure the writes for each report are atomic
 126     (file, reports') <-
 127       groupByFileName
 128         [ (reportFileName template report, report)
 129         | template <- templates
 130         , (report, _repo) <- reports
 131         ]
 132     , let output = concatMap format reports'
 133     ]
 134   where
 135     format r = '\n' : showBuildReport r ++ "\n"
 136
 137     reportFileName template report =
 138       fromPathTemplate (substPathTemplate env template)
 139       where
 140         env =
 141           initialPathTemplateEnv
 142             (BuildReport.package report)
 143             -- TODO: In principle, we can support $pkgkey, but only
 144             -- if the configure step succeeds.  So add a Maybe field
 145             -- to the build report, and either use that or make up
 146             -- a fake identifier if it's not available.
 147             (error "storeLocal: package key not available")
 148             cinfo
 149             platform
 150
 151     groupByFileName =
 152       map (\grp@((filename, _) : _) -> (filename, map snd grp))
 153         . L.groupBy (equating fst)
 154         . sortBy (comparing fst)
 155
 156 -- ------------------------------------------------------------
 157
 158 -- * InstallPlan support
 159
 160 -- ------------------------------------------------------------
 161
 162 fromInstallPlan
 163   :: Platform
 164   -> CompilerId
 165   -> InstallPlan
 166   -> BuildOutcomes
 167   -> [(BuildReport, Maybe Repo)]
 168 fromInstallPlan platform comp plan buildOutcomes =
 169   mapMaybe
 170     ( \pkg ->
 171         fromPlanPackage
 172           platform
 173           comp
 174           pkg
 175           (InstallPlan.lookupBuildOutcome pkg buildOutcomes)
 176     )
 177     . InstallPlan.toList
 178     $ plan
 179
 180 fromPlanPackage
 181   :: Platform
 182   -> CompilerId
 183   -> InstallPlan.PlanPackage
 184   -> Maybe BuildOutcome
 185   -> Maybe (BuildReport, Maybe Repo)
 186 fromPlanPackage
 187   (Platform arch os)
 188   comp
 189   (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps))
 190   (Just buildResult) =
 191     Just
 192       ( newBuildReport
 193           os
 194           arch
 195           comp
 196           (packageId srcPkg)
 197           flags
 198           (map packageId (CD.nonSetupDeps deps))
 199           buildResult
 200       , extractRepo srcPkg
 201       )
 202     where
 203       extractRepo (SourcePackage{srcpkgSource = RepoTarballPackage repo _ _}) =
 204         Just repo
 205       extractRepo _ = Nothing
 206 fromPlanPackage _ _ _ _ = Nothing
 207
 208 fromPlanningFailure
 209   :: Platform
 210   -> CompilerId
 211   -> [PackageId]
 212   -> FlagAssignment
 213   -> [(BuildReport, Maybe Repo)]
 214 fromPlanningFailure (Platform arch os) comp pkgids flags =
 215   [ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing)
 216   | pkgid <- pkgids
 217   ]