cabal-upload (empty) → 0.1

raw patch · 3 files changed

+122/−0 lines, 3 filesdep +HTTPdep +basedep +networkbuild-type:Customsetup-changed

Dependencies added: HTTP, base, network

Files

• Setup.lhs +8/−0
• cabal-upload.cabal +17/−0
• src/CabalUpload.hs +97/−0

@@ -0,0 +1,8 @@+#!/usr/bin/enb runghc++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain

@@ -0,0 +1,17 @@+Name: cabal-upload+Version: 0.1+License: BSD4+License-File: ../LICENSE+Author: Bjorn Bringert+Maintainer: Bjorn Bringert+Copyright: 2007 Bjorn Bringert <bjorn@bringert.net>+Stability: Experimental+Category: Distribution+Build-depends: base, network, 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.++Executable: cabal-upload+Main-Is: CabalUpload.hs+Hs-Source-Dirs: src

@@ -0,0 +1,97 @@+-- 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 Data.Char+import Data.Maybe+import Network.URI+import Numeric+import System.Environment+import System.Exit+import System.IO+import System.Random++type Username = String+type Password = String++main :: IO ()+main = do args <- getArgs+          (user, pwd, paths) <- parseOptions args+          mapM_ (uploadPackage user pwd) 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 +                      >> setOutHandler ignoreMsg +                      >> addAuthority 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++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+       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 :: String -> IO String+genBoundary pkg = 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++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