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)!"
   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)!"
   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