-- 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 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
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 `joinFileName` "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")