{-# LANGUAGE CPP #-}

module Darcs.Util.Download.HTTP
    ( fetchUrl, postUrl, requestUrl, waitNextUrl
    ) where

import Prelude ()
import Darcs.Prelude

import Darcs.Util.Global ( debugFail )

import Darcs.Util.Download.Request ( ConnectionError(..) )

import Control.Exception ( catch, IOException )
import Data.IORef ( newIORef, readIORef, writeIORef, IORef )
import Network.HTTP
import Network.Browser ( browse, request, setCheckForProxy, setErrHandler, setOutHandler )
import Network.URI
import System.IO.Error ( ioeGetErrorString )
import System.IO.Unsafe ( unsafePerformIO )
import Darcs.Util.Global ( debugMessage )
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Version ( version )

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

requestUrl :: String -> FilePath -> a -> IO String
waitNextUrl :: IO (String, String, Maybe ConnectionError)

headers :: [Header]
headers :: [Header]
headers =  [HeaderName -> String -> Header
Header HeaderName
HdrUserAgent (String -> Header) -> String -> Header
forall a b. (a -> b) -> a -> b
$ "darcs-HTTP/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
version]

fetchUrl :: String -> IO String
fetchUrl url :: String
url = case String -> Maybe URI
parseURI String
url of
    Nothing -> String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Invalid URI: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
url
    Just uri :: URI
uri -> do String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Fetching over HTTP:  "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
url
                   (URI, Response String)
resp <- IO (URI, Response String)
-> (IOException -> IO (URI, Response String))
-> IO (URI, Response String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (BrowserAction (HandleStream String) (URI, Response String)
-> IO (URI, Response String)
forall conn a. BrowserAction conn a -> IO a
browse (BrowserAction (HandleStream String) (URI, Response String)
 -> IO (URI, Response String))
-> BrowserAction (HandleStream String) (URI, Response String)
-> IO (URI, Response String)
forall a b. (a -> b) -> a -> b
$ do
                     Bool -> BrowserAction (HandleStream String) ()
forall t. Bool -> BrowserAction t ()
setCheckForProxy Bool
True
                     (String -> IO ()) -> BrowserAction (HandleStream String) ()
forall t. (String -> IO ()) -> BrowserAction t ()
setOutHandler String -> IO ()
debugMessage
                     (String -> IO ()) -> BrowserAction (HandleStream String) ()
forall t. (String -> IO ()) -> BrowserAction t ()
setErrHandler String -> IO ()
debugMessage
                     Request String
-> BrowserAction (HandleStream String) (URI, Response String)
forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request :: forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request { rqURI :: URI
rqURI = URI
uri,
                                       rqMethod :: RequestMethod
rqMethod = RequestMethod
GET,
                                       rqHeaders :: [Header]
rqHeaders = [Header]
headers,
                                       rqBody :: String
rqBody = "" })
                     (\(IOException
err :: IOException) -> String -> IO (URI, Response String)
forall a. String -> IO a
debugFail (String -> IO (URI, Response String))
-> String -> IO (URI, Response String)
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
err)
                   case (URI, Response String)
resp of
                     (_, res :: Response String
res@Response { rspCode :: forall a. Response a -> ResponseCode
rspCode = (2,0,0) }) -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Response String -> String
forall a. Response a -> a
rspBody Response String
res)
                     (_, Response { rspCode :: forall a. Response a -> ResponseCode
rspCode = (x :: Int
x,y :: Int
y,z :: Int
z) }) ->
                         String -> IO String
forall a. String -> IO a
debugFail (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "HTTP " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
z String -> String -> String
forall a. [a] -> [a] -> [a]
++ " error getting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
uri

postUrl :: String -> String -> String -> IO ()
postUrl url :: String
url body :: String
body mime :: String
mime = case String -> Maybe URI
parseURI String
url of
    Nothing -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Invalid URI: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
url
    Just uri :: URI
uri -> do String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Posting to HTTP:  "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
url
                   (URI, Response String)
resp <- IO (URI, Response String)
-> (IOException -> IO (URI, Response String))
-> IO (URI, Response String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (BrowserAction (HandleStream String) (URI, Response String)
-> IO (URI, Response String)
forall conn a. BrowserAction conn a -> IO a
browse (BrowserAction (HandleStream String) (URI, Response String)
 -> IO (URI, Response String))
-> BrowserAction (HandleStream String) (URI, Response String)
-> IO (URI, Response String)
forall a b. (a -> b) -> a -> b
$ do
                     Bool -> BrowserAction (HandleStream String) ()
forall t. Bool -> BrowserAction t ()
setCheckForProxy Bool
True
                     (String -> IO ()) -> BrowserAction (HandleStream String) ()
forall t. (String -> IO ()) -> BrowserAction t ()
setOutHandler String -> IO ()
debugMessage
                     (String -> IO ()) -> BrowserAction (HandleStream String) ()
forall t. (String -> IO ()) -> BrowserAction t ()
setErrHandler String -> IO ()
debugMessage
                     Request String
-> BrowserAction (HandleStream String) (URI, Response String)
forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request Request :: forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request { rqURI :: URI
rqURI = URI
uri,
                                       rqMethod :: RequestMethod
rqMethod = RequestMethod
POST,
                                       rqHeaders :: [Header]
rqHeaders = [Header]
headers [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [HeaderName -> String -> Header
Header HeaderName
HdrContentType String
mime,
                                                               HeaderName -> String -> Header
Header HeaderName
HdrAccept "text/plain",
                                                               HeaderName -> String -> Header
Header HeaderName
HdrContentLength
                                                                        (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
body) ],
                                       rqBody :: String
rqBody = String
body })
                     (\(IOException
err :: IOException) -> String -> IO (URI, Response String)
forall a. String -> IO a
debugFail (String -> IO (URI, Response String))
-> String -> IO (URI, Response String)
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
err)
                   case (URI, Response String)
resp of
                     (_, res :: Response String
res@Response { rspCode :: forall a. Response a -> ResponseCode
rspCode = (2,y :: Int
y,z :: Int
z) }) -> do
                        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Success 2" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
z
                        String -> IO ()
putStrLn (Response String -> String
forall a. Response a -> a
rspBody Response String
res)
                        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                     (_, res :: Response String
res@Response { rspCode :: forall a. Response a -> ResponseCode
rspCode = (x :: Int
x,y :: Int
y,z :: Int
z) }) -> do
                        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Response String -> String
forall a. Response a -> a
rspBody Response String
res
                        String -> IO ()
forall a. String -> IO a
debugFail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "HTTP " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
z String -> String -> String
forall a. [a] -> [a] -> [a]
++ " error posting to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
uri

requestedUrl :: IORef (String, FilePath)
requestedUrl :: IORef (String, String)
requestedUrl = IO (IORef (String, String)) -> IORef (String, String)
forall a. IO a -> a
unsafePerformIO (IO (IORef (String, String)) -> IORef (String, String))
-> IO (IORef (String, String)) -> IORef (String, String)
forall a b. (a -> b) -> a -> b
$ (String, String) -> IO (IORef (String, String))
forall a. a -> IO (IORef a)
newIORef ("", "")

requestUrl :: String -> String -> a -> IO String
requestUrl u :: String
u f :: String
f _ = do
  (u' :: String
u', _) <- IORef (String, String) -> IO (String, String)
forall a. IORef a -> IO a
readIORef IORef (String, String)
requestedUrl
  if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
u'
     then do IORef (String, String) -> (String, String) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (String, String)
requestedUrl (String
u, String
f)
             String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ""
     else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "URL already requested"

waitNextUrl :: IO (String, String, Maybe ConnectionError)
waitNextUrl = do
  (u :: String
u, f :: String
f) <- IORef (String, String) -> IO (String, String)
forall a. IORef a -> IO a
readIORef IORef (String, String)
requestedUrl
  if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
u
     then (String, String, Maybe ConnectionError)
-> IO (String, String, Maybe ConnectionError)
forall (m :: * -> *) a. Monad m => a -> m a
return ("", "No URL requested", Maybe ConnectionError
forall a. Maybe a
Nothing)
     else do IORef (String, String) -> (String, String) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (String, String)
requestedUrl ("", "")
             String
e <- (String -> IO String
fetchUrl String
u IO String -> (String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \s :: String
s -> String -> ByteString -> IO ()
B.writeFile String
f (String -> ByteString
BC.pack String
s) IO () -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "") IO String -> (IOException -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOException -> IO String
h
             let ce :: Maybe ConnectionError
ce = case String
e of
                       "timeout" -> ConnectionError -> Maybe ConnectionError
forall a. a -> Maybe a
Just ConnectionError
OperationTimeout
                       _         -> Maybe ConnectionError
forall a. Maybe a
Nothing
             (String, String, Maybe ConnectionError)
-> IO (String, String, Maybe ConnectionError)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
u, String
e, Maybe ConnectionError
ce)
    where h :: IOException -> IO String
h = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String)
-> (IOException -> String) -> IOException -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> String
ioeGetErrorString