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