Upload.hs

{-# LANGUAGE CPP, PatternGuards #-}
-- This is a quick hack for uploading build reports to Hackage.

module Distribution.Client.BuildReports.Upload
    ( BuildLog
    , BuildReportId
    , uploadReports
    ) where

{-
import Network.Browser
         ( BrowserAction, request, setAllowRedirects )
import Network.HTTP
         ( Header(..), HeaderName(..)
         , Request(..), RequestMethod(..), Response(..) )
import Network.TCP (HandleStream)
-}
import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo)

import Control.Monad
         ( forM_ )
import System.FilePath.Posix
         ( (</>) )
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)
import Distribution.Deprecated.Text (display)
import Distribution.Verbosity (Verbosity)
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 repoCtxt auth uri reports = do
  forM_ reports $ \(report, mbBuildLog) -> do
     buildId <- postBuildReport verbosity repoCtxt auth uri report
     case mbBuildLog of
       Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog
       Nothing       -> return ()

postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId
postBuildReport verbosity repoCtxt auth uri buildReport = do
  let fullURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" }
  transport <- repoContextGetTransport repoCtxt
  res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth)
  case res of
    (303, redir) -> return $ undefined redir --TODO parse redir
    _ -> die' verbosity "unrecognized response" -- give response

{-
  setAllowRedirects False
  (_, response) <- request Request {
    rqURI     = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },
    rqMethod  = POST,
    rqHeaders = [Header HdrContentType   ("text/plain"),
                 Header HdrContentLength (show (length body)),
                 Header HdrAccept        ("text/plain")],
    rqBody    = body
  }
  case rspCode response of
    (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location
#if defined(VERSION_network_uri)
                                     return $ relativeTo rel uri
#elif defined(VERSION_network)
#if MIN_VERSION_network(2,4,0)
                                     return $ relativeTo rel uri
#else
                                     relativeTo rel uri
#endif
#endif
                                  | Header HdrLocation location <- rspHeaders response ]
              -> return $ buildId
    _         -> error "Unrecognised response from server."
  where body  = BuildReport.show buildReport
-}


-- TODO force this to be a PUT?

putBuildLog :: Verbosity -> RepoContext -> (String, String)
            -> BuildReportId -> BuildLog
            -> IO ()
putBuildLog verbosity repoCtxt auth reportId buildLog = do
  let fullURI = reportId {uriPath = uriPath reportId </> "log"}
  transport <- repoContextGetTransport repoCtxt
  res <- postHttp transport verbosity fullURI buildLog (Just auth)
  case res of
    (200, _) -> return ()
    _ -> die' verbosity "unrecognized response" -- give response