darcs-cabalized-2.0.2: src/HTTP.hs

{-# OPTIONS_GHC -cpp #-}
module HTTP(copyUrl,fetchUrl,postUrl,exists) where

#ifdef HAVE_HTTP
import Network.HTTP
import Network.URI
import Darcs.Global ( debugMessage )
#endif

copyUrl :: String -> String -> a -> IO ()
copyUrl url file _cache = fetchUrl url >>= writeFile file

exists :: Bool
fetchUrl :: String -> IO String
postUrl
    :: String     -- ^ url
    -> String     -- ^ body
    -> String     -- ^ mime type
    -> IO ()  -- ^ result

#ifdef HAVE_HTTP

headers :: [Header]
headers =  [Header HdrUserAgent $ "darcs-HTTP/" ++ PACKAGE_VERSION]

exists = True

fetchUrl url = case parseURI url of
    Nothing -> fail $ "Invalid URI: " ++ url
    Just uri -> do debugMessage $ "Fetching over HTTP:  "++url
                   resp <- simpleHTTP $ Request { rqURI = uri,
                                                  rqMethod = GET,
                                                  rqHeaders = headers,
                                                  rqBody = "" }
                   case resp of
                     Right res@Response { rspCode = (2,0,0) } -> return (rspBody res)
                     Right Response { rspCode = (x,y,z) } ->
                         fail $ "HTTP " ++ show x ++ show y ++ show z ++ " error getting " ++ show uri
                     Left err -> fail $ show err

postUrl url body mime = case parseURI url of
    Nothing -> fail $ "Invalid URI: " ++ url
    Just uri -> do debugMessage $ "Posting to HTTP:  "++url
                   resp <- simpleHTTP $ Request { rqURI = uri,
                                                  rqMethod = POST,
                                                  rqHeaders = headers ++ [Header HdrContentType mime,
                                                                          Header HdrAccept "text/plain",
                                                                          Header HdrContentLength
                                                                                     (show $ length body) ],
                                                  rqBody = body }
                   case resp of
                     Right res@Response { rspCode = (2,y,z) } -> do
                        putStrLn $ "Success 2" ++ show y ++ show z
                        putStrLn (rspBody res)
                        return ()
                     Right res@Response { rspCode = (x,y,z) } -> do
                        putStrLn $ rspBody res
                        fail $ "HTTP " ++ show x ++ show y ++ show z ++ " error posting to " ++ show uri
                     Left err -> fail $ show err

#else

exists = False
fetchUrl _ = fail "Network.HTTP does not exist"
postUrl _ _ _ = fail "Cannot use http POST because darcs was not compiled with Network.HTTP."

#endif