diff --git a/cabal-upload.cabal b/cabal-upload.cabal --- a/cabal-upload.cabal +++ b/cabal-upload.cabal @@ -1,5 +1,5 @@ Name: cabal-upload -Version: 0.1 +Version: 0.2 License: BSD4 License-File: ../LICENSE Author: Bjorn Bringert @@ -7,7 +7,7 @@ Copyright: 2007 Bjorn Bringert Stability: Experimental Category: Distribution -Build-depends: base, network, HTTP >= 1.0 +Build-depends: base, network, Cabal, HTTP >= 1.0 Synopsis: Command-line tool for uploading packages to Hackage Description: This is a command-line tool program for uploading packages to the Hackage package database. diff --git a/src/CabalUpload.hs b/src/CabalUpload.hs --- a/src/CabalUpload.hs +++ b/src/CabalUpload.hs @@ -4,10 +4,15 @@ import Network.Browser import Network.HTTP +import Distribution.Compat.FilePath (joinFileName) + +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 @@ -16,41 +21,86 @@ type Username = String type Password = String + +uploadURI :: URI +uploadURI = fromJust $ 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" + + + main :: IO () main = do args <- getArgs - (user, pwd, paths) <- parseOptions args - mapM_ (uploadPackage user pwd) paths + (opts, paths) <- parseOptions args + opts' <- if needsAuth opts then getAuth opts else return opts + mapM_ (handlePackage opts') paths -uploadPackage :: Username -> Password -> FilePath -> IO () -uploadPackage user pwd path = - do - let uri = uploadURI - auth = AuthBasic { auRealm = "Hackage", - auUsername = user, - auPassword = pwd, - auSite = uri } - putStr $ "Uploading " ++ path ++ "... " - hFlush stdout - req <- mkRequest uri path - (_,resp) <- browse (setErrHandler ignoreMsg +handlePackage :: Options -> FilePath -> IO () +handlePackage opts path = + do (uri, auth) <- if optCheck opts + then do putStr $ "Checking " ++ path ++ "... " + hFlush stdout + return (checkURI, return ()) + else do putStr $ "Uploading " ++ path ++ "... " + hFlush stdout + return (uploadURI, + setAuth uploadURI + (fromJust (optUsername opts)) + (fromJust (optPassword opts))) + req <- mkRequest uri path + (_,resp) <- browse (setErrHandler ignoreMsg >> setOutHandler ignoreMsg - >> addAuthority auth + >> auth >> request req) - case rspCode resp of - (2,0,0) -> do putStrLn "OK" - (x,y,z) -> do putStrLn $ "ERROR: " ++ map intToDigit [x,y,z] ++ " " ++ rspReason resp - putStrLn $ rspBody resp + case rspCode resp of + (2,0,0) -> do putStrLn "OK" + (x,y,z) -> do hPutStrLn stderr $ "ERROR: " ++ map intToDigit [x,y,z] ++ " " ++ rspReason resp + hPutStrLn stderr $ rspBody resp +needsAuth :: Options -> Bool +needsAuth = not . optCheck + +setAuth :: URI -> Username -> Password -> BrowserAction () +setAuth uri user pwd = + addAuthority $ AuthBasic { auRealm = "Hackage", + auUsername = user, + auPassword = pwd, + auSite = uri } + +getAuth :: Options -> IO Options +getAuth opts = case (optUsername opts, optPassword opts) of + (Just _, Just _ ) -> return opts + (Just _, Nothing ) -> do pwd <- promptPassword + return $ opts { optPassword = Just pwd } + (Nothing , Just _ ) -> die ["password given, but not username"] + (Nothing , Nothing ) -> do (user,pwd) <- readAuthFile + return $ opts { optUsername = Just user, + optPassword = Just pwd } + +promptPassword :: IO Password +promptPassword = + do putStr "Hackage password: " + hFlush stdout + getLine + +passwordFile :: IO FilePath +passwordFile = do dir <- getAppUserDataDirectory "cabal-upload" + return $ dir `joinFileName` "auth" + +readAuthFile :: IO (Username,Password) +readAuthFile = + do file <- passwordFile + s <- readFile file + return $ read s + ignoreMsg :: String -> IO () ignoreMsg _ = return () -uploadURI :: URI -uploadURI = fromJust $ parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg" - mkRequest :: URI -> FilePath -> IO Request mkRequest uri path = do pkg <- readFile path - boundary <- genBoundary pkg + boundary <- genBoundary let body = printMultiPart boundary (mkFormData path pkg) return $ Request { rqURI = uri, @@ -61,9 +111,9 @@ rqBody = body } -genBoundary :: String -> IO String -genBoundary pkg = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer - return $ showHex i "" +genBoundary :: IO String +genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer + return $ showHex i "" mkFormData :: FilePath -> String -> [BodyPart] mkFormData path pkg = @@ -91,7 +141,52 @@ -- * Command-line options -parseOptions :: [String] -> IO (Username, Password, [FilePath]) -parseOptions (user:pwd:tarballs) = return (user,pwd,tarballs) -parseOptions _ = do hPutStrLn stderr "Usage: cabal-upload [ ...]" - exitFailure +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 pwdFile <- passwordFile + let hdr = unlines ["cabal-upload uploads Cabal source packages to Hackage.", + "", + "You can store your Hackage login in " ++ pwdFile, + "using the format (\"username\",\"password\").", + "", + "Usage: cabal-upload [OPTION ...] [FILE ...]"] + putStrLn (usageInfo hdr optDescr) + exitWith ExitSuccess