{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
-- |
-- 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,
    fromPlanningFailure,
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport)
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport

import Distribution.Client.Types
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
         ( InstallPlan )

import qualified Distribution.Solver.Types.ComponentDeps as CD
import           Distribution.Solver.Types.SourcePackage

import Distribution.Package
         ( PackageId, packageId )
import Distribution.PackageDescription
         ( FlagAssignment )
import Distribution.Simple.InstallDirs
         ( PathTemplate, fromPathTemplate
         , initialPathTemplateEnv, substPathTemplate )
import Distribution.System
         ( Platform(Platform) )
import Distribution.Compiler
         ( CompilerId(..), CompilerInfo(..)  )
import Distribution.Simple.Utils
         ( equating )

import Data.List.NonEmpty
         ( groupBy )
import qualified Data.List as L
import System.FilePath
         ( (</>), takeDirectory )
import System.Directory
         ( createDirectoryIfMissing )

storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO ()
storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO ()
storeAnonymous [(BuildReport, Maybe Repo)]
reports = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
  [ FilePath -> FilePath -> IO ()
appendFile FilePath
file (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BuildReport -> FilePath
format [BuildReport]
reports')
  | (Repo
repo, [BuildReport]
reports') <- [(BuildReport, Maybe Repo)] -> [(Repo, [BuildReport])]
separate [(BuildReport, Maybe Repo)]
reports
  , let file :: FilePath
file = Repo -> FilePath
repoLocalDir Repo
repo FilePath -> FilePath -> FilePath
</> FilePath
"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 :: BuildReport -> FilePath
format BuildReport
r = Char
'\n' forall a. a -> [a] -> [a]
: BuildReport -> FilePath
showBuildReport BuildReport
r forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
    separate :: [(BuildReport, Maybe Repo)]
             -> [(Repo, [BuildReport])]
    separate :: [(BuildReport, Maybe Repo)] -> [(Repo, [BuildReport])]
separate = forall a b. (a -> b) -> [a] -> [b]
map (\rs :: [(BuildReport, Repo, RemoteRepo)]
rs@((BuildReport
_,Repo
repo,RemoteRepo
_):[(BuildReport, Repo, RemoteRepo)]
_) -> (Repo
repo, [ BuildReport
r | (BuildReport
r,Repo
_,RemoteRepo
_) <- [(BuildReport, Repo, RemoteRepo)]
rs ]))
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (forall a b. Eq a => (b -> a) -> b -> b -> Bool
equating (forall {a} {b}. (a, b, RemoteRepo) -> RepoName
repoName' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
head))
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (forall {a} {b}. (a, b, RemoteRepo) -> RepoName
repoName' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
head))
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
groupBy (forall a b. Eq a => (b -> a) -> b -> b -> Bool
equating forall {a} {b}. (a, b, RemoteRepo) -> RepoName
repoName')
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(BuildReport, Maybe Repo)] -> [(BuildReport, Repo, RemoteRepo)]
onlyRemote

    repoName' :: (a, b, RemoteRepo) -> RepoName
repoName' (a
_,b
_,RemoteRepo
rrepo) = RemoteRepo -> RepoName
remoteRepoName RemoteRepo
rrepo

    onlyRemote :: [(BuildReport, Maybe Repo)]
               -> [(BuildReport, Repo, RemoteRepo)]
    onlyRemote :: [(BuildReport, Maybe Repo)] -> [(BuildReport, Repo, RemoteRepo)]
onlyRemote [(BuildReport, Maybe Repo)]
rs =
      [ (BuildReport
report, Repo
repo, RemoteRepo
remoteRepo)
      | (BuildReport
report, Just Repo
repo) <- [(BuildReport, Maybe Repo)]
rs
      , Just RemoteRepo
remoteRepo     <- [Repo -> Maybe RemoteRepo
maybeRepoRemote Repo
repo]
      ]

storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)]
           -> Platform -> IO ()
storeLocal :: CompilerInfo
-> [PathTemplate]
-> [(BuildReport, Maybe Repo)]
-> Platform
-> IO ()
storeLocal CompilerInfo
cinfo [PathTemplate]
templates [(BuildReport, Maybe Repo)]
reports Platform
platform = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
  [ do Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
file)
       FilePath -> FilePath -> IO ()
appendFile FilePath
file FilePath
output
       --TODO: make this concurrency safe, either lock the report file or make
       --      sure the writes for each report are atomic
  | (FilePath
file, [BuildReport]
reports') <- forall {b}. [(FilePath, b)] -> [(FilePath, [b])]
groupByFileName
                          [ (PathTemplate -> BuildReport -> FilePath
reportFileName PathTemplate
template BuildReport
report, BuildReport
report)
                          | PathTemplate
template <- [PathTemplate]
templates
                          , (BuildReport
report, Maybe Repo
_repo) <- [(BuildReport, Maybe Repo)]
reports ]
  , let output :: FilePath
output = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BuildReport -> FilePath
format [BuildReport]
reports'
  ]
  where
    format :: BuildReport -> FilePath
format BuildReport
r = Char
'\n' forall a. a -> [a] -> [a]
: BuildReport -> FilePath
showBuildReport BuildReport
r forall a. [a] -> [a] -> [a]
++ FilePath
"\n"

    reportFileName :: PathTemplate -> BuildReport -> FilePath
reportFileName PathTemplate
template BuildReport
report =
        PathTemplate -> FilePath
fromPathTemplate (PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env PathTemplate
template)
      where env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv
                    (BuildReport -> PackageIdentifier
BuildReport.package  BuildReport
report)
                    -- TODO: In principle, we can support $pkgkey, but only
                    -- if the configure step succeeds.  So add a Maybe field
                    -- to the build report, and either use that or make up
                    -- a fake identifier if it's not available.
                    (forall a. HasCallStack => FilePath -> a
error FilePath
"storeLocal: package key not available")
                    CompilerInfo
cinfo
                    Platform
platform

    groupByFileName :: [(FilePath, b)] -> [(FilePath, [b])]
groupByFileName = forall a b. (a -> b) -> [a] -> [b]
map (\grp :: [(FilePath, b)]
grp@((FilePath
filename,b
_):[(FilePath, b)]
_) -> (FilePath
filename, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(FilePath, b)]
grp))
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (forall a b. Eq a => (b -> a) -> b -> b -> Bool
equating  forall a b. (a, b) -> a
fst)
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy  (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)

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

fromInstallPlan :: Platform -> CompilerId
                -> InstallPlan
                -> BuildOutcomes
                -> [(BuildReport, Maybe Repo)]
fromInstallPlan :: Platform
-> CompilerId
-> InstallPlan
-> BuildOutcomes
-> [(BuildReport, Maybe Repo)]
fromInstallPlan Platform
platform CompilerId
comp InstallPlan
plan BuildOutcomes
buildOutcomes =
     forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\PlanPackage
pkg -> Platform
-> CompilerId
-> PlanPackage
-> Maybe BuildOutcome
-> Maybe (BuildReport, Maybe Repo)
fromPlanPackage
                         Platform
platform CompilerId
comp PlanPackage
pkg
                         (forall pkg failure result.
HasUnitId pkg =>
pkg
-> BuildOutcomes failure result -> Maybe (Either failure result)
InstallPlan.lookupBuildOutcome PlanPackage
pkg BuildOutcomes
buildOutcomes))
   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList
   forall a b. (a -> b) -> a -> b
$ InstallPlan
plan

fromPlanPackage :: Platform -> CompilerId
                -> InstallPlan.PlanPackage
                -> Maybe BuildOutcome
                -> Maybe (BuildReport, Maybe Repo)
fromPlanPackage :: Platform
-> CompilerId
-> PlanPackage
-> Maybe BuildOutcome
-> Maybe (BuildReport, Maybe Repo)
fromPlanPackage (Platform Arch
arch OS
os) CompilerId
comp
                (InstallPlan.Configured (ConfiguredPackage InstalledPackageId
_ SourcePackage UnresolvedPkgLoc
srcPkg FlagAssignment
flags OptionalStanzaSet
_ ComponentDeps [ConfiguredId]
deps))
                (Just BuildOutcome
buildResult) =
      forall a. a -> Maybe a
Just ( OS
-> Arch
-> CompilerId
-> PackageIdentifier
-> FlagAssignment
-> [PackageIdentifier]
-> BuildOutcome
-> BuildReport
newBuildReport OS
os Arch
arch CompilerId
comp
                             (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId SourcePackage UnresolvedPkgLoc
srcPkg) FlagAssignment
flags
                             (forall a b. (a -> b) -> [a] -> [b]
map forall pkg. Package pkg => pkg -> PackageIdentifier
packageId (forall a. Monoid a => ComponentDeps a -> a
CD.nonSetupDeps ComponentDeps [ConfiguredId]
deps))
                             BuildOutcome
buildResult
           , forall {local}. SourcePackage (PackageLocation local) -> Maybe Repo
extractRepo SourcePackage UnresolvedPkgLoc
srcPkg)
  where
    extractRepo :: SourcePackage (PackageLocation local) -> Maybe Repo
extractRepo (SourcePackage { srcpkgSource :: forall loc. SourcePackage loc -> loc
srcpkgSource = RepoTarballPackage Repo
repo PackageIdentifier
_ local
_ })
                  = forall a. a -> Maybe a
Just Repo
repo
    extractRepo SourcePackage (PackageLocation local)
_ = forall a. Maybe a
Nothing

fromPlanPackage Platform
_ CompilerId
_ PlanPackage
_ Maybe BuildOutcome
_ = forall a. Maybe a
Nothing


fromPlanningFailure :: Platform -> CompilerId
    -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]
fromPlanningFailure :: Platform
-> CompilerId
-> [PackageIdentifier]
-> FlagAssignment
-> [(BuildReport, Maybe Repo)]
fromPlanningFailure (Platform Arch
arch OS
os) CompilerId
comp [PackageIdentifier]
pkgids FlagAssignment
flags =
  [ (OS
-> Arch
-> CompilerId
-> PackageIdentifier
-> FlagAssignment
-> [PackageIdentifier]
-> BuildOutcome
-> BuildReport
newBuildReport OS
os Arch
arch CompilerId
comp PackageIdentifier
pkgid FlagAssignment
flags [] (forall a b. a -> Either a b
Left BuildFailure
PlanningFailed), forall a. Maybe a
Nothing)
  | PackageIdentifier
pkgid <- [PackageIdentifier]
pkgids ]