{-# LANGUAGE CPP, PatternGuards #-}
module Distribution.Client.BuildReports.Upload
( BuildLog
, BuildReportId
, uploadReports
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Network.URI (URI, uriPath)
import System.FilePath.Posix
( (</>) )
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport)
import Distribution.Simple.Utils (die')
import Distribution.Client.HttpUtils
import Distribution.Client.Setup
( RepoContext(..) )
type BuildReportId = URI
type BuildLog = String
uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()
uploadReports :: Verbosity
-> RepoContext
-> (String, String)
-> URI
-> [(BuildReport, Maybe String)]
-> IO ()
uploadReports Verbosity
verbosity RepoContext
repoCtxt (String, String)
auth URI
uri [(BuildReport, Maybe String)]
reports = do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(BuildReport, Maybe String)]
reports forall a b. (a -> b) -> a -> b
$ \(BuildReport
report, Maybe String
mbBuildLog) -> do
URI
buildId <- Verbosity
-> RepoContext -> (String, String) -> URI -> BuildReport -> IO URI
postBuildReport Verbosity
verbosity RepoContext
repoCtxt (String, String)
auth URI
uri BuildReport
report
case Maybe String
mbBuildLog of
Just String
buildLog -> Verbosity
-> RepoContext -> (String, String) -> URI -> String -> IO ()
putBuildLog Verbosity
verbosity RepoContext
repoCtxt (String, String)
auth URI
buildId String
buildLog
Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId
postBuildReport :: Verbosity
-> RepoContext -> (String, String) -> URI -> BuildReport -> IO URI
postBuildReport Verbosity
verbosity RepoContext
repoCtxt (String, String)
auth URI
uri BuildReport
buildReport = do
let fullURI :: URI
fullURI = URI
uri { uriPath :: String
uriPath = String
"/package" String -> String -> String
</> forall a. Pretty a => a -> String
prettyShow (BuildReport -> PackageIdentifier
BuildReport.package BuildReport
buildReport) String -> String -> String
</> String
"reports" }
HttpTransport
transport <- RepoContext -> IO HttpTransport
repoContextGetTransport RepoContext
repoCtxt
(HttpCode, String)
res <- HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe (String, String)
-> IO (HttpCode, String)
postHttp HttpTransport
transport Verbosity
verbosity URI
fullURI (BuildReport -> String
showBuildReport BuildReport
buildReport) (forall a. a -> Maybe a
Just (String, String)
auth)
case (HttpCode, String)
res of
(HttpCode
303, String
redir) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => a
undefined String
redir
(HttpCode, String)
_ -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"unrecognized response"
putBuildLog :: Verbosity -> RepoContext -> (String, String)
-> BuildReportId -> BuildLog
-> IO ()
putBuildLog :: Verbosity
-> RepoContext -> (String, String) -> URI -> String -> IO ()
putBuildLog Verbosity
verbosity RepoContext
repoCtxt (String, String)
auth URI
reportId String
buildLog = do
let fullURI :: URI
fullURI = URI
reportId {uriPath :: String
uriPath = URI -> String
uriPath URI
reportId String -> String -> String
</> String
"log"}
HttpTransport
transport <- RepoContext -> IO HttpTransport
repoContextGetTransport RepoContext
repoCtxt
(HttpCode, String)
res <- HttpTransport
-> Verbosity
-> URI
-> String
-> Maybe (String, String)
-> IO (HttpCode, String)
postHttp HttpTransport
transport Verbosity
verbosity URI
fullURI String
buildLog (forall a. a -> Maybe a
Just (String, String)
auth)
case (HttpCode, String)
res of
(HttpCode
200, String
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(HttpCode, String)
_ -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"unrecognized response"