src/HTTP.hs

   1 {-# OPTIONS_GHC -cpp #-}
   2 {-# LANGUAGE CPP #-}
   3
   4 module HTTP( fetchUrl, postUrl, request_url, wait_next_url ) where
   5
   6 import Darcs.Global ( debugFail )
   7
   8 #ifdef HAVE_HTTP
   9 import Control.Monad ( when )
  10 import Data.IORef ( newIORef, readIORef, writeIORef, IORef )
  11 import Network.HTTP
  12 import Network.URI
  13 import System.Environment ( getEnv )
  14 import System.IO.Error ( ioeGetErrorString )
  15 import System.IO.Unsafe ( unsafePerformIO )
  16 import Darcs.Global ( debugMessage )
  17 import qualified Data.ByteString as B
  18 import qualified Data.ByteString.Char8 as BC
  19 #endif
  20
  21 fetchUrl :: String -> IO String
  22 postUrl
  23     :: String     -- ^ url
  24     -> String     -- ^ body
  25     -> String     -- ^ mime type
  26     -> IO ()  -- ^ result
  27
  28 request_url :: String -> FilePath -> a -> IO String
  29 wait_next_url :: IO (String, String)
  30
  31 #ifdef HAVE_HTTP
  32
  33 headers :: [Header]
  34 headers =  [Header HdrUserAgent $ "darcs-HTTP/" ++ PACKAGE_VERSION]
  35
  36 fetchUrl url = case parseURI url of
  37     Nothing -> fail $ "Invalid URI: " ++ url
  38     Just uri -> do debugMessage $ "Fetching over HTTP:  "++url
  39                    proxy <- getProxy
  40                    when (not $ null proxy) $
  41                      debugFail "No proxy support for HTTP package yet (try libcurl or libwww)!"
  42                    resp <- simpleHTTP $ Request { rqURI = uri,
  43                                                   rqMethod = GET,
  44                                                   rqHeaders = headers,
  45                                                   rqBody = "" }
  46                    case resp of
  47                      Right res@Response { rspCode = (2,0,0) } -> return (rspBody res)
  48                      Right Response { rspCode = (x,y,z) } ->
  49                          debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error getting " ++ show uri
  50                      Left err -> debugFail $ show err
  51
  52 postUrl url body mime = case parseURI url of
  53     Nothing -> fail $ "Invalid URI: " ++ url
  54     Just uri -> do debugMessage $ "Posting to HTTP:  "++url
  55                    proxy <- getProxy
  56                    when (not $ null proxy) $
  57                      debugFail "No proxy support for HTTP package yet (try libcurl or libwww)!"
  58                    resp <- simpleHTTP $ Request { rqURI = uri,
  59                                                   rqMethod = POST,
  60                                                   rqHeaders = headers ++ [Header HdrContentType mime,
  61                                                                           Header HdrAccept "text/plain",
  62                                                                           Header HdrContentLength
  63                                                                                      (show $ length body) ],
  64                                                   rqBody = body }
  65                    case resp of
  66                      Right res@Response { rspCode = (2,y,z) } -> do
  67                         putStrLn $ "Success 2" ++ show y ++ show z
  68                         putStrLn (rspBody res)
  69                         return ()
  70                      Right res@Response { rspCode = (x,y,z) } -> do
  71                         putStrLn $ rspBody res
  72                         debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error posting to " ++ show uri
  73                      Left err -> debugFail $ show err
  74
  75 requestedUrl :: IORef (String, FilePath)
  76 requestedUrl = unsafePerformIO $ newIORef ("", "")
  77
  78 request_url u f _ = do
  79   (u', _) <- readIORef requestedUrl
  80   if null u'
  81      then do writeIORef requestedUrl (u, f)
  82              return ""
  83      else return "URL already requested"
  84
  85 wait_next_url = do
  86   (u, f) <- readIORef requestedUrl
  87   if null u
  88      then return ("", "No URL requested")
  89      else do writeIORef requestedUrl ("", "")
  90              e <- (fetchUrl u >>= \s -> B.writeFile f (BC.pack s) >> return "") `catch` h
  91              return (u, e)
  92     where h = return . ioeGetErrorString
  93
  94 getProxy :: IO String
  95 getProxy =
  96   getEnv "http_proxy"
  97   `catch` \_ -> getEnv "HTTP_PROXY"
  98   `catch` \_ -> return ""
  99 #else
 100
 101 fetchUrl _ = debugFail "Network.HTTP does not exist"
 102 postUrl _ _ _ = debugFail "Cannot use http POST because darcs was not compiled with Network.HTTP."
 103
 104 request_url _ _ _ = debugFail "Network.HTTP does not exist"
 105 wait_next_url = debugFail "Network.HTTP does not exist"
 106
 107 #endif