-- 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 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 (opts, paths) <- parseOptions args opts' <- if needsAuth opts then getAuth opts else return opts mapM_ (handlePackage opts') paths handlePackage :: Options -> FilePath -> IO () handlePackage opts path = do (uri, auth) <- if optCheck opts then do output 1 opts $ "Checking " ++ path ++ "... " return (checkURI, return ()) else do output 1 opts $ "Uploading " ++ path ++ "... " return (uploadURI, setAuth uploadURI (fromJust (optUsername opts)) (fromJust (optPassword opts))) req <- mkRequest uri path debug opts $ "\n" ++ show req (_,resp) <- browse (setErrHandler ignoreMsg >> setOutHandler ignoreMsg >> auth >> request req) debug opts $ 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 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 = do (mu, mp) <- readAuthFile u <- case optUsername opts `mplus` mu of Just u -> return u Nothing -> promptUsername p <- case optPassword opts `mplus` mp of Just p -> return p Nothing -> promptPassword return $ opts { optUsername = Just u, optPassword = Just p } promptUsername :: IO Username promptUsername = do putStr "Hackage username: " hFlush stdout getLine promptPassword :: IO Password promptPassword = do putStr "Hackage password: " hFlush stdout getLine authFile :: IO FilePath authFile = do dir <- getAppUserDataDirectory "cabal-upload" return $ dir "auth" readAuthFile :: IO (Maybe Username, Maybe Password) readAuthFile = do file <- authFile e <- doesFileExist file if e then do s <- readFile file let (u,p) = read s return (Just u, Just p) else return (Nothing, Nothing) ignoreMsg :: String -> IO () ignoreMsg _ = return () mkRequest :: URI -> FilePath -> IO Request mkRequest uri path = do pkg <- readFile path boundary <- genBoundary let body = printMultiPart boundary (mkFormData path pkg) return $ Request { rqURI = uri, rqMethod = POST, rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary), Header HdrContentLength (show (length body)), Header HdrAccept ("text/plain")], rqBody = body } genBoundary :: IO String genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer return $ showHex i "" mkFormData :: FilePath -> String -> [BodyPart] mkFormData path pkg = -- yes, web browsers are that stupid (re quoting) [BodyPart [Header hdrContentDisposition ("form-data; name=package; filename=\""++path++"\""), Header HdrContentType "application/x-gzip"] pkg] hdrContentDisposition :: HeaderName hdrContentDisposition = HdrCustom "Content-disposition" -- * Multipart, partly stolen from the cgi package. data BodyPart = BodyPart [Header] String printMultiPart :: String -> [BodyPart] -> String printMultiPart boundary xs = concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf printBodyPart :: String -> BodyPart -> String printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c 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")