Upload.hs 2.39 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
{-# LANGUAGE PatternGuards #-}
-- 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(..) )
17
import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)
18
19

import Control.Monad
20
         ( forM_ )
21
import System.FilePath.Posix
22
         ( (</>) )
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)

type BuildReportId = URI
type BuildLog = String

uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] ->  BrowserAction ()
uploadReports uri reports
    = forM_ reports $ \(report, mbBuildLog) ->
      do buildId <- postBuildReport uri report
         case mbBuildLog of
           Just buildLog -> putBuildLog buildId buildLog
           Nothing       -> return ()

postBuildReport :: URI -> BuildReport -> BrowserAction BuildReportId
postBuildReport uri buildReport = do
  setAllowRedirects False
  (_, response) <- request Request {
41
    rqURI     = uri { uriPath = "/buildreports" },
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
    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
                                     relativeTo rel uri
                                  | Header HdrLocation location <- rspHeaders response ]
              -> return $ buildId
    _         -> error "Unrecognised response from server."
  where body  = BuildReport.show buildReport

putBuildLog :: BuildReportId -> BuildLog -> BrowserAction ()
putBuildLog reportId buildLog = do
Duncan Coutts's avatar
Duncan Coutts committed
58
  --FIXME: do something if the request fails
59
60
61
62
63
64
65
66
67
  (_, response) <- request Request {
      rqURI     = reportId{uriPath = uriPath reportId </> "buildlog"},
      rqMethod  = PUT,
      rqHeaders = [Header HdrContentType   ("text/plain"),
                   Header HdrContentLength (show (length buildLog)),
                   Header HdrAccept        ("text/plain")],
      rqBody    = buildLog
    }
  return ()