Upload.hs 7.3 KB
Newer Older
1
2
3
-- This is a quick hack for uploading packages to Hackage.
-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload

4
module Distribution.Client.Upload (check, upload, report) where
5

6
import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))
7
import Distribution.Client.HttpUtils (proxy, isOldHackageURI)
8

9
import Distribution.Simple.Utils (debug, notice, warn, info)
10
import Distribution.Verbosity (Verbosity)
11
12
13
14
15
import Distribution.Text (display)
import Distribution.Client.Config

import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import qualified Distribution.Client.BuildReports.Upload as BuildReport
16

17
18
19
20
import Network.Browser
         ( BrowserAction, browse, request
         , Authority(..), addAuthority, setAuthorityGen
         , setOutHandler, setErrHandler, setProxy )
21
import Network.HTTP
22
         ( Header(..), HeaderName(..), findHeader
23
         , Request(..), RequestMethod(..), Response(..) )
24
import Network.URI (URI(uriPath), parseURI)
25
26
27

import Data.Char        (intToDigit)
import Numeric          (showHex)
28
29
30
import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho
                        ,openBinaryFile, IOMode(ReadMode), hGetContents)
import Control.Exception (bracket)
31
import System.Random    (randomRIO)
32
import System.FilePath  ((</>), takeExtension, takeFileName)
Duncan Coutts's avatar
Duncan Coutts committed
33
import qualified System.FilePath.Posix as FilePath.Posix (combine)
34
35
import System.Directory
import Control.Monad (forM_)
36
37


38
39
--FIXME: how do we find this path for an arbitrary hackage server?
-- is it always at some fixed location relative to the server root?
40
41
legacyUploadURI :: URI
Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"
42
43

checkURI :: URI
44
Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"
45
46


47
48
49
50
51
upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()
upload verbosity repos mUsername mPassword paths = do
          let uploadURI = if isOldHackageURI targetRepoURI
                          then legacyUploadURI
                          else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"}
52
53
          Username username <- maybe promptUsername return mUsername
          Password password <- maybe promptPassword return mPassword
54
55
56
57
58
59
60
61
62
          let auth = addAuthority AuthBasic {
                       auRealm    = "Hackage",
                       auUsername = username,
                       auPassword = password,
                       auSite     = uploadURI
                     }
          flip mapM_ paths $ \path -> do
            notice verbosity $ "Uploading " ++ path ++ "... "
            handlePackage verbosity uploadURI auth path
63
  where
Duncan Coutts's avatar
Duncan Coutts committed
64
    targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given
65
66
67
68
69
70
71
72
73
74
75
    promptUsername :: IO Username
    promptUsername = do
      putStr "Hackage username: "
      hFlush stdout
      fmap Username getLine

    promptPassword :: IO Password
    promptPassword = do
      putStr "Hackage password: "
      hFlush stdout
      -- save/restore the terminal echoing status
76
      passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do
77
78
        hSetEcho stdin False  -- no echoing for entering the password
        fmap Password getLine
79
80
      putStrLn ""
      return passwd
81

82
83
84
85
86
87
88
89
report :: Verbosity -> [Repo] -> IO ()
report verbosity repos
    = forM_ repos $ \repo ->
      case repoKind repo of
        Left remoteRepo
            -> do dotCabal <- defaultCabalDir
                  let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo
                  contents <- getDirectoryContents srcDir
David Himmelstrup's avatar
David Himmelstrup committed
90
                  forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->
91
                      do inp <- readFile (srcDir </> logFile)
David Himmelstrup's avatar
David Himmelstrup committed
92
                         let (reportStr, buildLog) = read inp :: (String,String)
93
94
                         case BuildReport.parse reportStr of
                           Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME
Duncan Coutts's avatar
Duncan Coutts committed
95
96
97
                           Right report' ->
                               do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')
                                  browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]
98
99
100
                                  return ()
        Right{} -> return ()

101
102
103
104
105
106
107
108
109
check :: Verbosity -> [FilePath] -> IO ()
check verbosity paths = do
          flip mapM_ paths $ \path -> do
            notice verbosity $ "Checking " ++ path ++ "... "
            handlePackage verbosity checkURI (return ()) path

handlePackage :: Verbosity -> URI -> BrowserAction () -> FilePath -> IO ()
handlePackage verbosity uri auth path =
  do req <- mkRequest uri path
110
     p   <- proxy verbosity
111
     debug verbosity $ "\n" ++ show req
112
113
114
115
116
     (_,resp) <- browse $ do
                   setProxy p
                   setErrHandler (warn verbosity . ("http error: "++))
                   setOutHandler (debug verbosity)
                   auth
117
                   setAuthorityGen (\_ _ -> return Nothing)
118
                   request req
119
     debug verbosity $ show resp
120
     case rspCode resp of
121
122
123
124
       (2,0,0) -> do notice verbosity "OK"
       (x,y,z) -> do notice verbosity $ "ERROR: " ++ path ++ ": " 
                                     ++ map intToDigit [x,y,z] ++ " "
                                     ++ rspReason resp
125
126
127
                     case findHeader HdrContentType resp of
                       Just "text/plain" -> notice verbosity $ rspBody resp
                       _                 -> debug verbosity $ rspBody resp
128

129
130
mkRequest :: URI -> FilePath -> IO Request
mkRequest uri path = 
131
    do pkg <- readBinaryFile path
132
133
134
135
136
137
138
139
140
141
142
       boundary <- genBoundary
       let body = printMultiPart boundary (mkFormData path pkg)
       return $ Request {
                         rqURI = uri,
                         rqMethod = POST,
                         rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),
                                      Header HdrContentLength (show (length body)),
                                      Header HdrAccept ("text/plain")],
                         rqBody = body
                        }

143
144
145
readBinaryFile :: FilePath -> IO String
readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents

146
147
148
149
150
genBoundary :: IO String
genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer
                 return $ showHex i ""

mkFormData :: FilePath -> String -> [BodyPart]
151
152
153
154
155
156
mkFormData path pkg =
  -- yes, web browsers are that stupid (re quoting)
  [BodyPart [Header hdrContentDisposition $
             "form-data; name=package; filename=\""++takeFileName path++"\"",
             Header HdrContentType "application/x-gzip"]
   pkg]
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

hdrContentDisposition :: HeaderName
hdrContentDisposition = HdrCustom "Content-disposition"

-- * Multipart, partly stolen from the cgi package.

data BodyPart = BodyPart [Header] String

printMultiPart :: String -> [BodyPart] -> String
printMultiPart boundary xs = 
    concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf

printBodyPart :: String -> BodyPart -> String
printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c

crlf :: String
crlf = "\r\n"