Skip to content

GitLab

Commit f18e9bdd authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Initial integration of upload feature 

It still uses it's own config file, but now uses the same command line stuff
parent 530091ec
Hide whitespace changes
Inline Side-by-side
cabal-install/Hackage/Setup.hs
View file @ f18e9bdd
......@@ -17,6 +17,7 @@ module Hackage.Setup
, updateCommand
, infoCommand
, fetchCommand
, uploadCommand, UploadFlags(..)
, parsePackageArgs
, updateConfig
......@@ -48,6 +49,7 @@ import Hackage.Types (ConfigFlags(..), UnresolvedDependency(..))
import Hackage.Utils (readPToMaybe, parseDependencyOrPackageId)
import Control.Monad (MonadPlus(mplus))
import Data.Monoid (Monoid(..))
-- | This function updates the configuration with the cabal configure flags.
updateConfig :: Cabal.ConfigFlags -> ConfigFlags -> ConfigFlags
......@@ -146,6 +148,78 @@ infoCommand = CommandUI {
commandOptions = \_ -> [optionVerbose id const]
}
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------
type Username = String
type Password = String
data UploadFlags = UploadFlags {
uploadCheck :: Flag Bool,
uploadUsername :: Flag Username,
uploadPassword :: Flag Password,
uploadVerbosity :: Flag Verbosity
} deriving (Show)
defaultUploadFlags :: UploadFlags
defaultUploadFlags = UploadFlags {
uploadCheck = toFlag False,
uploadUsername = mempty,
uploadPassword = mempty,
uploadVerbosity = toFlag normal
}
uploadCommand :: CommandUI UploadFlags
uploadCommand = CommandUI {
commandName = "upload",
commandSynopsis = "Uploads source packages to Hackage",
commandDescription = Just $ \_ ->
"You can store your Hackage login in " ++ "FIXME: configFile"
++ "\nusing the format (\"username\",\"password\").\n",
commandUsage = \pname ->
"Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"
++ "Flags for upload:",
commandDefaultFlags = defaultUploadFlags,
commandOptions = \_ ->
[optionVerbose uploadVerbosity (\v flags -> flags { uploadVerbosity = v })
,option ['c'] ["check"]
"Do not upload, just do QA checks."
uploadCheck (\v flags -> flags { uploadCheck = v })
(noArg (toFlag True) (fromFlagOrDefault False))
,option ['u'] ["username"]
"Hackage username."
uploadUsername (\v flags -> flags { uploadUsername = v })
(reqArg "USERNAME" toFlag flagToList)
,option ['p'] ["password"]
"Hackage password."
uploadPassword (\v flags -> flags { uploadPassword = v })
(reqArg "PASSWORD" toFlag flagToList)
]
}
instance Monoid UploadFlags where
mempty = UploadFlags {
uploadCheck = mempty,
uploadUsername = mempty,
uploadPassword = mempty,
uploadVerbosity = mempty
}
mappend a b = UploadFlags {
uploadCheck = combine uploadCheck,
uploadUsername = combine uploadUsername,
uploadPassword = combine uploadPassword,
uploadVerbosity = combine uploadVerbosity
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------
optionVerbose :: (flags -> Flag Verbosity)
-> (Flag Verbosity -> flags -> flags)
-> Option flags
......
cabal-install/Hackage/Upload.hs
View file @ f18e9bdd
-- This is a quick hack for uploading packages to Hackage.
-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload
import Network.Browser
import Network.HTTP
import System.FilePath ((</>))
import Control.Monad
import Data.Char
import Data.Maybe
import Network.URI
import Numeric
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
import System.IO
import System.Random
module Hackage.Upload (upload) where
import Hackage.Setup (UploadFlags(..))
import Distribution.Simple.Utils (debug, notice)
import Distribution.Simple.Setup (toFlag, fromFlag, flagToMaybe)
import Network.Browser (BrowserAction, browse, request,
Authority(..), addAuthority,
setOutHandler, setErrHandler)
import Network.HTTP (Header(..), HeaderName(..), Request(..),
RequestMethod(..), Response(..))
import Network.URI (URI, parseURI)
import Control.Monad (MonadPlus(mplus))
import Data.Char (intToDigit)
import Numeric (showHex)
import System.Directory (doesFileExist, getAppUserDataDirectory)
import System.IO (hFlush, stdout)
import System.Random (randomRIO)
import System.FilePath ((</>))
type Username = String
type Password = String
uploadURI :: URI
uploadURI = fromJust $ parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"
Just uploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"
checkURI :: URI
checkURI = fromJust $ parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"
Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"
main :: IO ()
main = do args <- getArgs
(opts, paths) <- parseOptions args
opts' <- if needsAuth opts then getAuth opts else return opts
mapM_ (handlePackage opts') paths
upload :: UploadFlags -> [FilePath] -> IO ()
upload flags paths = do
flags' <- if needsAuth flags then getAuth flags else return flags
mapM_ (handlePackage flags') paths
handlePackage :: Options -> FilePath -> IO ()
handlePackage opts path =
do (uri, auth) <- if optCheck opts
then do output 1 opts $ "Checking " ++ path ++ "... "
handlePackage :: UploadFlags -> FilePath -> IO ()
handlePackage flags path =
do (uri, auth) <- if fromFlag (uploadCheck flags)
then do notice verbosity $ "Checking " ++ path ++ "... "
return (checkURI, return ())
else do output 1 opts $ "Uploading " ++ path ++ "... "
else do notice verbosity $ "Uploading " ++ path ++ "... "
return (uploadURI,
setAuth uploadURI
(fromJust (optUsername opts))
(fromJust (optPassword opts)))
(fromFlag (uploadUsername flags))
(fromFlag (uploadPassword flags)))
req <- mkRequest uri path
debug opts $ "\n" ++ show req
debug verbosity $ "\n" ++ show req
(_,resp) <- browse (setErrHandler ignoreMsg
>> setOutHandler ignoreMsg
>> auth
>> request req)
debug opts $ show resp
debug verbosity $ show resp
case rspCode resp of
(2,0,0) -> do outputLn 1 opts "OK"
(x,y,z) -> do outputLn 1 opts "ERROR"
outputLn 0 opts $ "ERROR: " ++ path ++ ": "
++ map intToDigit [x,y,z] ++ " " ++ rspReason resp
outputLn 3 opts $ rspBody resp
(2,0,0) -> do notice verbosity "OK"
(x,y,z) -> do notice verbosity $ "ERROR: " ++ path ++ ": "
++ map intToDigit [x,y,z] ++ " "
++ rspReason resp
debug verbosity $ rspBody resp
where verbosity = fromFlag (uploadVerbosity flags)
needsAuth :: Options -> Bool
needsAuth = not . optCheck
needsAuth :: UploadFlags -> Bool
needsAuth = not . fromFlag . uploadCheck
setAuth :: URI -> Username -> Password -> BrowserAction ()
setAuth uri user pwd =
......@@ -70,17 +74,17 @@ setAuth uri user pwd =
auPassword = pwd,
auSite = uri }
getAuth :: Options -> IO Options
getAuth opts =
getAuth :: UploadFlags -> IO UploadFlags
getAuth flags =
do (mu, mp) <- readAuthFile
u <- case optUsername opts `mplus` mu of
u <- case flagToMaybe (uploadUsername flags) `mplus` mu of
Just u -> return u
Nothing -> promptUsername
p <- case optPassword opts `mplus` mp of
p <- case flagToMaybe (uploadPassword flags) `mplus` mp of
Just p -> return p
Nothing -> promptPassword
return $ opts { optUsername = Just u,
optPassword = Just p }
return $ flags { uploadUsername = toFlag u,
uploadPassword = toFlag p }
promptUsername :: IO Username
promptUsername =
......@@ -151,66 +155,3 @@ printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ con
crlf :: String
crlf = "\r\n"
-- * Command-line options
data Options = Options {
optUsername :: Maybe Username,
optPassword :: Maybe Password,
optCheck :: Bool,
optVerbosity :: Int
} deriving (Show)
defaultOptions :: Options
defaultOptions = Options {
optUsername = Nothing,
optPassword = Nothing,
optCheck = False,
optVerbosity = 1
}
optDescr :: [OptDescr (Options -> Options)]
optDescr =
[
Option ['c'] ["check"] (NoArg (\o -> o { optCheck = True })) "Don't upload, just check.",
Option ['u'] ["username"] (ReqArg (\u o -> o { optUsername = Just u}) "USERNAME") "Hackage username.",
Option ['p'] ["password"] (ReqArg (\u o -> o { optPassword = Just u}) "PASSWORD") "Hackage password.",
Option "v" ["verbose"] (OptArg (\u o -> o { optVerbosity = maybe 3 read u}) "N") "Control verbosity (N is 0--5, normal verbosity level is 1, -v alone is equivalent to -v3)",
Option ['q'] ["quiet"] (NoArg (\o -> o { optVerbosity = 0 })) "Only essential output. Same as -v 0."
]
parseOptions :: [String] -> IO (Options, [FilePath])
parseOptions args =
do let (fs, files, nonopts, errs) = getOpt' RequireOrder optDescr args
when (not (null errs)) $ die errs
case nonopts of
[] -> return $ (foldl (flip ($)) defaultOptions fs, files)
["--help"] -> usage
_ -> die (map (("unrecognized option "++).show) nonopts)
die :: [String] -> IO a
die errs = do mapM_ (\e -> hPutStrLn stderr $ "cabal-upload: " ++ e) $ errs
hPutStrLn stderr "Try `cabal-upload --help' for more information."
exitFailure
usage :: IO a
usage = do aFile <- authFile
let hdr = unlines ["cabal-upload uploads Cabal source packages to Hackage.",
"",
"You can store your Hackage login in " ++ aFile,
"using the format (\"username\",\"password\").",
"",
"Usage: cabal-upload [OPTION ...] [FILE ...]"]
putStrLn (usageInfo hdr optDescr)
exitWith ExitSuccess
-- * Logging
debug = outputLn 5
output :: Int -> Options -> String -> IO ()
output n opts s = when (optVerbosity opts >= n) $ do hPutStr stderr s
hFlush stderr
outputLn :: Int -> Options -> String -> IO ()
outputLn n opts s = output n opts (s++"\n")
cabal-install/Main.hs
View file @ f18e9bdd
......@@ -29,6 +29,7 @@ import Hackage.Info (info)
import Hackage.Update (update)
import Hackage.Fetch (fetch)
--import Hackage.Clean (clean)
import Hackage.Upload (upload)
import Distribution.Verbosity (Verbosity, normal)
import Distribution.Version (showVersion)
......@@ -77,6 +78,7 @@ mainWorker args =
,listCommand `commandAddAction` listAction
,updateCommand `commandAddAction` updateAction
,fetchCommand `commandAddAction` fetchAction
,uploadCommand `commandAddAction` uploadAction
,wrapperAction (Cabal.configureCommand defaultProgramConfiguration)
,wrapperAction (Cabal.buildCommand defaultProgramConfiguration)
......@@ -168,3 +170,12 @@ fetchAction flags extraArgs = do
case parsePackageArgs extraArgs of
Left err -> putStrLn err >> exitWith (ExitFailure 1)
Right pkgs -> fetch config comp conf pkgs
uploadAction :: UploadFlags -> [String] -> IO ()
uploadAction flags extraArgs = do
-- configFile <- defaultConfigFile --FIXME
-- config0 <- loadConfig configFile
-- let config = config0 { configVerbose = fromFlag $ uploadVerbosity flags }
-- FIXME: check that the .tar.gz files exist and report friendly error message if not
let tarfiles = extraArgs
upload flags tarfiles
cabal-install/cabal-install.cabal
View file @ f18e9bdd
......@@ -39,6 +39,7 @@ Executable cabal
Hackage.Tar
Hackage.Types
Hackage.Update
Hackage.Upload
Hackage.Utils
build-depends: Cabal >= 1.3.2, filepath >= 1.0, network,
......
Supports Markdown
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