cabal-upload 0.1 → 0.2
raw patch · 2 files changed
+127/−32 lines, 2 filesdep +Cabal
Dependencies added: Cabal
Files
- cabal-upload.cabal +2/−2
- src/CabalUpload.hs +125/−30
cabal-upload.cabal view
@@ -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 <bjorn@bringert.net> 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.
src/CabalUpload.hs view
@@ -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 <username> <password> [<tarball> ...]"- 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