1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
|
-- This is a quick hack for uploading packages to Hackage.
-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload
module Distribution.Client.Upload (check, upload, report) where
import qualified Data.ByteString.Lazy.Char8 as B (concat, length, pack, readFile, unpack)
import Data.ByteString.Lazy.Char8 (ByteString)
import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))
import Distribution.Client.HttpUtils (isOldHackageURI, cabalBrowse)
import Distribution.Simple.Utils (debug, notice, warn, info)
import Distribution.Verbosity (Verbosity)
import Distribution.Text (display)
import Distribution.Client.Config
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import qualified Distribution.Client.BuildReports.Upload as BuildReport
import Network.Browser
( BrowserAction, request
, Authority(..), addAuthority )
import Network.HTTP
( Header(..), HeaderName(..), findHeader
, Request(..), RequestMethod(..), Response(..) )
import Network.TCP (HandleStream)
import Network.URI (URI(uriPath), parseURI)
import Data.Char (intToDigit)
import Numeric (showHex)
import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho)
import Control.Exception (bracket)
import System.Random (randomRIO)
import System.FilePath ((</>), takeExtension, takeFileName)
import qualified System.FilePath.Posix as FilePath.Posix (combine)
import System.Directory
import Control.Monad (forM_, when)
--FIXME: how do we find this path for an arbitrary hackage server?
-- is it always at some fixed location relative to the server root?
legacyUploadURI :: URI
Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"
checkURI :: URI
Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"
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"}
Username username <- maybe promptUsername return mUsername
Password password <- maybe promptPassword return mPassword
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
where
targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given
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
passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do
hSetEcho stdin False -- no echoing for entering the password
fmap Password getLine
putStrLn ""
return passwd
report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO ()
report verbosity repos mUsername mPassword = do
let uploadURI = if isOldHackageURI targetRepoURI
then legacyUploadURI
else targetRepoURI{uriPath = ""}
Username username <- maybe promptUsername return mUsername
Password password <- maybe promptPassword return mPassword
let auth = addAuthority AuthBasic {
auRealm = "Hackage",
auUsername = username,
auPassword = password,
auSite = uploadURI
}
forM_ repos $ \repo -> case repoKind repo of
Left remoteRepo
-> do dotCabal <- defaultCabalDir
let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo
-- We don't want to bomb out just because we haven't built any packages from this repo yet
srcExists <- doesDirectoryExist srcDir
when srcExists $ do
contents <- getDirectoryContents srcDir
forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->
do inp <- readFile (srcDir </> logFile)
let (reportStr, buildLog) = read inp :: (String,String)
case BuildReport.parse reportStr of
Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME
Right report' ->
do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')
cabalBrowse verbosity auth $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]
return ()
Right{} -> return ()
where
targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given
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 (HandleStream ByteString) ()
-> FilePath -> IO ()
handlePackage verbosity uri auth path =
do req <- mkRequest uri path
debug verbosity $ "\n" ++ show req
(_,resp) <- cabalBrowse verbosity auth $ request req
debug verbosity $ show resp
case rspCode resp of
(2,0,0) -> do notice verbosity "Ok"
(x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": "
++ map intToDigit [x,y,z] ++ " "
++ rspReason resp
case findHeader HdrContentType resp of
Just contenttype
| takeWhile (/= ';') contenttype == "text/plain"
-> notice verbosity $ B.unpack $ rspBody resp
_ -> debug verbosity $ B.unpack $ rspBody resp
mkRequest :: URI -> FilePath -> IO (Request ByteString)
mkRequest uri path =
do pkg <- readBinaryFile path
boundary <- genBoundary
let body = printMultiPart (B.pack boundary) (mkFormData path pkg)
return $ Request {
rqURI = uri,
rqMethod = POST,
rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),
Header HdrContentLength (show (B.length body)),
Header HdrAccept ("text/plain")],
rqBody = body
}
readBinaryFile :: FilePath -> IO ByteString
readBinaryFile = B.readFile
genBoundary :: IO String
genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer
return $ showHex i ""
mkFormData :: FilePath -> ByteString -> [BodyPart]
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]
hdrContentDisposition :: HeaderName
hdrContentDisposition = HdrCustom "Content-disposition"
-- * Multipart, partly stolen from the cgi package.
data BodyPart = BodyPart [Header] ByteString
printMultiPart :: ByteString -> [BodyPart] -> ByteString
printMultiPart boundary xs =
B.concat $ map (printBodyPart boundary) xs ++ [crlf, dd, boundary, dd, crlf]
printBodyPart :: ByteString -> BodyPart -> ByteString
printBodyPart boundary (BodyPart hs c) = B.concat $ [crlf, dd, boundary, crlf] ++ map (B.pack . show) hs ++ [crlf, c]
crlf :: ByteString
crlf = B.pack "\r\n"
dd :: ByteString
dd = B.pack "--"
|
