Commit c081a9c5 authored by Vo Minh Thu's avatar Vo Minh Thu

cabal report uses the correct URIs and authenticates with username and passwords flags

parent a459fbbc
......@@ -23,25 +23,28 @@ import System.FilePath.Posix
( (</>) )
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport)
import Distribution.Text (display)
type BuildReportId = URI
type BuildLog = String
uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]
-> BrowserAction (HandleStream String) ()
-> BrowserAction (HandleStream BuildLog) ()
uploadReports uri reports
= forM_ reports $ \(report, mbBuildLog) ->
do buildId <- postBuildReport uri report
case mbBuildLog of
Just buildLog -> putBuildLog buildId buildLog
Nothing -> return ()
uploadReports uri reports auth = do
auth
forM_ reports $ \(report, mbBuildLog) -> do
buildId <- postBuildReport uri report
case mbBuildLog of
Just buildLog -> putBuildLog buildId buildLog
Nothing -> return ()
postBuildReport :: URI -> BuildReport
-> BrowserAction (HandleStream BuildLog) BuildReportId
postBuildReport uri buildReport = do
setAllowRedirects False
(_, response) <- request Request {
rqURI = uri { uriPath = "/buildreports" },
rqURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },
rqMethod = POST,
rqHeaders = [Header HdrContentType ("text/plain"),
Header HdrContentLength (show (length body)),
......@@ -61,7 +64,7 @@ putBuildLog :: BuildReportId -> BuildLog
putBuildLog reportId buildLog = do
--FIXME: do something if the request fails
(_, response) <- request Request {
rqURI = reportId{uriPath = uriPath reportId </> "buildlog"},
rqURI = reportId{uriPath = uriPath reportId </> "log"},
rqMethod = PUT,
rqHeaders = [Header HdrContentType ("text/plain"),
Header HdrContentLength (show (length buildLog)),
......
......@@ -34,6 +34,7 @@ import Distribution.Client.Setup
, ConfigExFlags(..), configureExOptions, defaultConfigExFlags
, InstallFlags(..), installOptions, defaultInstallFlags
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
, showRepo, parseRepo )
import Distribution.Simple.Setup
......@@ -101,7 +102,8 @@ data SavedConfig = SavedConfig {
savedConfigureExFlags :: ConfigExFlags,
savedUserInstallDirs :: InstallDirs (Flag PathTemplate),
savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),
savedUploadFlags :: UploadFlags
savedUploadFlags :: UploadFlags,
savedReportFlags :: ReportFlags
}
instance Monoid SavedConfig where
......@@ -112,7 +114,8 @@ instance Monoid SavedConfig where
savedConfigureExFlags = mempty,
savedUserInstallDirs = mempty,
savedGlobalInstallDirs = mempty,
savedUploadFlags = mempty
savedUploadFlags = mempty,
savedReportFlags = mempty
}
mappend a b = SavedConfig {
savedGlobalFlags = combine savedGlobalFlags,
......@@ -121,7 +124,8 @@ instance Monoid SavedConfig where
savedConfigureExFlags = combine savedConfigureExFlags,
savedUserInstallDirs = combine savedUserInstallDirs,
savedGlobalInstallDirs = combine savedGlobalInstallDirs,
savedUploadFlags = combine savedUploadFlags
savedUploadFlags = combine savedUploadFlags,
savedReportFlags = combine savedReportFlags
}
where combine field = field a `mappend` field b
......@@ -324,7 +328,8 @@ commentSavedConfig = do
},
savedUserInstallDirs = fmap toFlag userInstallDirs,
savedGlobalInstallDirs = fmap toFlag globalInstallDirs,
savedUploadFlags = commandDefaultFlags uploadCommand
savedUploadFlags = commandDefaultFlags uploadCommand,
savedReportFlags = commandDefaultFlags reportCommand
}
-- | All config file fields.
......@@ -360,6 +365,10 @@ configFieldDescriptions =
(commandOptions uploadCommand ParseArgs)
["verbose", "check"] []
++ toSavedConfig liftReportFlag
(commandOptions reportCommand ParseArgs)
["verbose"] []
where
toSavedConfig lift options exclusions replacements =
[ lift (fromMaybe field replacement)
......@@ -430,6 +439,10 @@ liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig
liftUploadFlag = liftField
savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })
liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig
liftReportFlag = liftField
savedReportFlags (\flags conf -> conf { savedReportFlags = flags })
parseConfig :: SavedConfig -> String -> ParseResult SavedConfig
parseConfig initial = \str -> do
fields <- readFields str
......
......@@ -23,7 +23,7 @@ module Distribution.Client.Setup
, fetchCommand, FetchFlags(..)
, checkCommand
, uploadCommand, UploadFlags(..)
, reportCommand
, reportCommand, ReportFlags(..)
, unpackCommand, UnpackFlags(..)
, initCommand, IT.InitFlags(..)
......@@ -373,16 +373,62 @@ checkCommand = CommandUI {
commandOptions = \_ -> []
}
reportCommand :: CommandUI (Flag Verbosity)
-- ------------------------------------------------------------
-- * Report flags
-- ------------------------------------------------------------
data ReportFlags = ReportFlags {
reportUsername :: Flag Username,
reportPassword :: Flag Password,
reportVerbosity :: Flag Verbosity
}
defaultReportFlags :: ReportFlags
defaultReportFlags = ReportFlags {
reportUsername = mempty,
reportPassword = mempty,
reportVerbosity = toFlag normal
}
reportCommand :: CommandUI ReportFlags
reportCommand = CommandUI {
commandName = "report",
commandSynopsis = "Upload build reports to a remote server.",
commandDescription = Nothing,
commandUsage = \pname -> "Usage: " ++ pname ++ " report\n",
commandDefaultFlags = toFlag normal,
commandOptions = \_ -> [optionVerbosity id const]
commandDescription = Just $ \_ ->
"You can store your Hackage login in the ~/.cabal/config file\n",
commandUsage = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n"
++ "Flags for upload:",
commandDefaultFlags = defaultReportFlags,
commandOptions = \_ ->
[optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })
,option ['u'] ["username"]
"Hackage username."
reportUsername (\v flags -> flags { reportUsername = v })
(reqArg' "USERNAME" (toFlag . Username)
(flagToList . fmap unUsername))
,option ['p'] ["password"]
"Hackage password."
reportPassword (\v flags -> flags { reportPassword = v })
(reqArg' "PASSWORD" (toFlag . Password)
(flagToList . fmap unPassword))
]
}
instance Monoid ReportFlags where
mempty = ReportFlags {
reportUsername = mempty,
reportPassword = mempty,
reportVerbosity = mempty
}
mappend a b = ReportFlags {
reportUsername = combine reportUsername,
reportPassword = combine reportPassword,
reportVerbosity = combine reportVerbosity
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Unpack flags
-- ------------------------------------------------------------
......
......@@ -63,27 +63,38 @@ upload verbosity repos mUsername mPassword paths = do
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] -> IO ()
report verbosity repos
= forM_ repos $ \repo ->
case repoKind repo of
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
......@@ -95,9 +106,11 @@ report verbosity repos
Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME
Right report' ->
do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')
browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]
browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] auth
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
......
......@@ -25,6 +25,7 @@ import Distribution.Client.Setup
, ListFlags(..), listCommand
, InfoFlags(..), infoCommand
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
, InitFlags, initCommand
, reportCommand
, unpackCommand, UnpackFlags(..)
......@@ -328,16 +329,19 @@ sdistAction sflags extraArgs _globalFlags = do
die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs
sdist sflags
reportAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
reportAction verbosityFlag extraArgs globalFlags = do
reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO ()
reportAction reportFlags extraArgs globalFlags = do
unless (null extraArgs) $ do
die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs
let verbosity = fromFlag verbosityFlag
let verbosity = fromFlag (reportVerbosity reportFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
reportFlags' = savedReportFlags config `mappend` reportFlags
Upload.report verbosity (globalRepos globalFlags')
(flagToMaybe $ reportUsername reportFlags')
(flagToMaybe $ reportPassword reportFlags')
unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()
unpackAction flags extraArgs globalFlags = do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment