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