Upload.hs 2.54 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(..) )
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
26
27
28
29
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)

type BuildReportId = URI
type BuildLog = String

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

Duncan Coutts's avatar
Duncan Coutts committed
39
40
postBuildReport :: URI -> BuildReport
                -> BrowserAction (HandleStream BuildLog) BuildReportId
41
42
43
postBuildReport uri buildReport = do
  setAllowRedirects False
  (_, response) <- request Request {
44
    rqURI     = uri { uriPath = "/buildreports" },
45
46
47
48
49
50
51
52
53
54
55
56
57
58
    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

Duncan Coutts's avatar
Duncan Coutts committed
59
60
putBuildLog :: BuildReportId -> BuildLog
            -> BrowserAction (HandleStream BuildLog) ()
61
putBuildLog reportId buildLog = do
Duncan Coutts's avatar
Duncan Coutts committed
62
  --FIXME: do something if the request fails
63
64
65
66
67
68
69
70
71
  (_, 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 ()