cabal-install/src/Distribution/Client/BuildReports/Upload.hs

   1 {-# LANGUAGE CPP, PatternGuards #-}
   2 -- This is a quick hack for uploading build reports to Hackage.
   3
   4 module Distribution.Client.BuildReports.Upload
   5     ( BuildLog
   6     , BuildReportId
   7     , uploadReports
   8     ) where
   9
  10 import Distribution.Client.Compat.Prelude
  11 import Prelude ()
  12
  13 {-
  14 import Network.Browser
  15          ( BrowserAction, request, setAllowRedirects )
  16 import Network.HTTP
  17          ( Header(..), HeaderName(..)
  18          , Request(..), RequestMethod(..), Response(..) )
  19 import Network.TCP (HandleStream)
  20 -}
  21 import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo)
  22
  23 import System.FilePath.Posix
  24          ( (</>) )
  25 import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
  26 import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport)
  27 import Distribution.Simple.Utils (die')
  28 import Distribution.Client.HttpUtils
  29 import Distribution.Client.Setup
  30          ( RepoContext(..) )
  31
  32 type BuildReportId = URI
  33 type BuildLog = String
  34
  35 uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()
  36 uploadReports verbosity repoCtxt auth uri reports = do
  37   for_ reports $ \(report, mbBuildLog) -> do
  38      buildId <- postBuildReport verbosity repoCtxt auth uri report
  39      case mbBuildLog of
  40        Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog
  41        Nothing       -> return ()
  42
  43 postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId
  44 postBuildReport verbosity repoCtxt auth uri buildReport = do
  45   let fullURI = uri { uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports" }
  46   transport <- repoContextGetTransport repoCtxt
  47   res <- postHttp transport verbosity fullURI (showBuildReport buildReport) (Just auth)
  48   case res of
  49     (303, redir) -> return $ undefined redir --TODO parse redir
  50     _ -> die' verbosity "unrecognized response" -- give response
  51
  52 {-
  53   setAllowRedirects False
  54   (_, response) <- request Request {
  55     rqURI     = uri { uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports" },
  56     rqMethod  = POST,
  57     rqHeaders = [Header HdrContentType   ("text/plain"),
  58                  Header HdrContentLength (show (length body)),
  59                  Header HdrAccept        ("text/plain")],
  60     rqBody    = body
  61   }
  62   case rspCode response of
  63     (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location
  64 #if defined(VERSION_network_uri)
  65                                      return $ relativeTo rel uri
  66 #elif defined(VERSION_network)
  67 #if MIN_VERSION_network(2,4,0)
  68                                      return $ relativeTo rel uri
  69 #else
  70                                      relativeTo rel uri
  71 #endif
  72 #endif
  73                                   | Header HdrLocation location <- rspHeaders response ]
  74               -> return $ buildId
  75     _         -> error "Unrecognised response from server."
  76   where body  = BuildReport.show buildReport
  77 -}
  78
  79
  80 -- TODO force this to be a PUT?
  81
  82 putBuildLog :: Verbosity -> RepoContext -> (String, String)
  83             -> BuildReportId -> BuildLog
  84             -> IO ()
  85 putBuildLog verbosity repoCtxt auth reportId buildLog = do
  86   let fullURI = reportId {uriPath = uriPath reportId </> "log"}
  87   transport <- repoContextGetTransport repoCtxt
  88   res <- postHttp transport verbosity fullURI buildLog (Just auth)
  89   case res of
  90     (200, _) -> return ()
  91     _ -> die' verbosity "unrecognized response" -- give response