Upload.hs 2.86 KB
Newer Older
1
{-# LANGUAGE CPP, PatternGuards #-}
2
3
4
5
6
7
8
9
10
11
12
-- This is a quick hack for uploading build reports to Hackage.

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

import Network.Browser
13
         ( BrowserAction, request, setAllowRedirects )
14
15
16
import Network.HTTP
         ( Header(..), HeaderName(..)
         , Request(..), RequestMethod(..), Response(..) )
Duncan Coutts's avatar
Duncan Coutts committed
17
import Network.TCP (HandleStream)
18
import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)
19
20

import Control.Monad
21
         ( forM_ )
22
import System.FilePath.Posix
23
         ( (</>) )
24
25
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)
26
import Distribution.Text (display)
27
28
29
30

type BuildReportId = URI
type BuildLog = String

Duncan Coutts's avatar
Duncan Coutts committed
31
32
uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]
              ->  BrowserAction (HandleStream BuildLog) ()
33
uploadReports uri reports = do
34
35
36
37
38
  forM_ reports $ \(report, mbBuildLog) -> do
     buildId <- postBuildReport uri report
     case mbBuildLog of
       Just buildLog -> putBuildLog buildId buildLog
       Nothing       -> return ()
39

Duncan Coutts's avatar
Duncan Coutts committed
40
41
postBuildReport :: URI -> BuildReport
                -> BrowserAction (HandleStream BuildLog) BuildReportId
42
43
44
postBuildReport uri buildReport = do
  setAllowRedirects False
  (_, response) <- request Request {
45
    rqURI     = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },
46
47
48
49
50
51
52
53
    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
54
55
56
#if defined(VERSION_network_uri)
                                     return $ relativeTo rel uri
#elif defined(VERSION_network)
57
58
59
#if MIN_VERSION_network(2,4,0)
                                     return $ relativeTo rel uri
#else
60
                                     relativeTo rel uri
61
#endif
62
#endif
63
64
65
66
67
                                  | Header HdrLocation location <- rspHeaders response ]
              -> return $ buildId
    _         -> error "Unrecognised response from server."
  where body  = BuildReport.show buildReport

Duncan Coutts's avatar
Duncan Coutts committed
68
69
putBuildLog :: BuildReportId -> BuildLog
            -> BrowserAction (HandleStream BuildLog) ()
70
putBuildLog reportId buildLog = do
Duncan Coutts's avatar
Duncan Coutts committed
71
  --FIXME: do something if the request fails
refold's avatar
refold committed
72
  (_, _response) <- request Request {
73
      rqURI     = reportId{uriPath = uriPath reportId </> "log"},
74
75
76
77
78
79
80
      rqMethod  = PUT,
      rqHeaders = [Header HdrContentType   ("text/plain"),
                   Header HdrContentLength (show (length buildLog)),
                   Header HdrAccept        ("text/plain")],
      rqBody    = buildLog
    }
  return ()