module Text.XML.HXT.IO.GetHTTPNative
( module Text.XML.HXT.IO.GetHTTPNative
)
where
import Control.Arrow
import Control.Exception (try)
import Text.XML.HXT.DOM.TypeDefs (Attributes)
import Text.XML.HXT.DOM.Util (stringTrim)
import Text.XML.HXT.DOM.XmlKeywords
import Text.XML.HXT.Arrow.XmlOptions (a_if_modified_since,
a_if_unmodified_since)
import Text.XML.HXT.Parser.ProtocolHandlerUtil (parseContentType)
import Text.ParserCombinators.Parsec (parse)
import qualified Data.ByteString.Lazy as B
import Data.Char (isDigit)
import Data.Int (Int64)
import Data.List (isPrefixOf)
import Data.Maybe
import System.IO (hPutStrLn, stderr)
import System.IO.Error (ioeGetErrorString)
import Network.Browser (BrowserAction,
Proxy (..), browse,
defaultGETRequest_,
request,
setAllowRedirects,
setErrHandler,
setMaxRedirects,
setOutHandler,
setProxy)
import Network.HTTP (Header (..),
HeaderName (..),
Request (..),
Response (..),
httpVersion,
replaceHeader)
import Network.Socket (withSocketsDo)
import Network.URI (URI,
parseURIReference)
getCont :: Bool -> String -> String -> Bool -> Attributes ->
IO (Either ([(String, String)], String)
([(String, String)], B.ByteString)
)
getCont :: Bool
-> String
-> String
-> Bool
-> Attributes
-> IO (Either (Attributes, String) (Attributes, ByteString))
getCont Bool
strictInput String
proxy String
uri Bool
redirect Attributes
options
= do
Either IOError (Response ByteString)
res <- IO (Response ByteString)
-> IO (Either IOError (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (Bool
-> URI -> String -> Bool -> Attributes -> IO (Response ByteString)
getHttp Bool
False URI
uri1 String
proxy Bool
redirect Attributes
options)
(IOError
-> IO (Either (Attributes, String) (Attributes, ByteString)))
-> (Response ByteString
-> IO (Either (Attributes, String) (Attributes, ByteString)))
-> Either IOError (Response ByteString)
-> IO (Either (Attributes, String) (Attributes, ByteString))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOError
-> IO (Either (Attributes, String) (Attributes, ByteString))
forall {m :: * -> *} {b}.
Monad m =>
IOError -> m (Either (Attributes, String) b)
processError Response ByteString
-> IO (Either (Attributes, String) (Attributes, ByteString))
forall {m :: * -> *}.
Monad m =>
Response ByteString
-> m (Either (Attributes, String) (Attributes, ByteString))
processResponse Either IOError (Response ByteString)
res
where
uri1 :: URI
uri1 = Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust (String -> Maybe URI
parseURIReference String
uri)
processError :: IOError -> m (Either (Attributes, String) b)
processError IOError
e
= Either (Attributes, String) b -> m (Either (Attributes, String) b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Attributes, String) b
-> m (Either (Attributes, String) b))
-> Either (Attributes, String) b
-> m (Either (Attributes, String) b)
forall a b. (a -> b) -> a -> b
$
(Attributes, String) -> Either (Attributes, String) b
forall a b. a -> Either a b
Left ( [ (String
transferStatus, String
"999")
, (String
transferMessage, String
"HTTP library error")
]
, String
"http error when requesting URI "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
uri
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
ioeGetErrorString IOError
e
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (perhaps server does not understand HTTP/1.1) "
)
processResponse :: Response ByteString
-> m (Either (Attributes, String) (Attributes, ByteString))
processResponse Response ByteString
response
| ( (Int
rc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
rc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300)
Bool -> Bool -> Bool
||
Int
rc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
304
)
Bool -> Bool -> Bool
&&
Bool
fileSizeOK
= do
if Bool
strictInput
then ByteString -> Int64
B.length ByteString
cs Int64
-> m (Either (Attributes, String) (Attributes, ByteString))
-> m (Either (Attributes, String) (Attributes, ByteString))
forall a b. a -> b -> b
`seq` Either (Attributes, String) (Attributes, ByteString)
-> m (Either (Attributes, String) (Attributes, ByteString))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Attributes, String) (Attributes, ByteString)
forall {a}. Either a (Attributes, ByteString)
res
else Either (Attributes, String) (Attributes, ByteString)
-> m (Either (Attributes, String) (Attributes, ByteString))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Attributes, String) (Attributes, ByteString)
forall {a}. Either a (Attributes, ByteString)
res
| Bool -> Bool
not Bool
fileSizeOK
= Either (Attributes, String) (Attributes, ByteString)
-> m (Either (Attributes, String) (Attributes, ByteString))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Attributes, String) (Attributes, ByteString)
-> m (Either (Attributes, String) (Attributes, ByteString)))
-> Either (Attributes, String) (Attributes, ByteString)
-> m (Either (Attributes, String) (Attributes, ByteString))
forall a b. (a -> b) -> a -> b
$
String -> Either (Attributes, String) (Attributes, ByteString)
forall {b}. String -> Either (Attributes, String) b
ers String
"999 max-filesize exceeded"
| Bool
otherwise
= Either (Attributes, String) (Attributes, ByteString)
-> m (Either (Attributes, String) (Attributes, ByteString))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Attributes, String) (Attributes, ByteString)
-> m (Either (Attributes, String) (Attributes, ByteString)))
-> Either (Attributes, String) (Attributes, ByteString)
-> m (Either (Attributes, String) (Attributes, ByteString))
forall a b. (a -> b) -> a -> b
$
String -> Either (Attributes, String) (Attributes, ByteString)
forall {b}. String -> Either (Attributes, String) b
ers (Int -> String
forall a. Show a => a -> String
show Int
rc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rr)
where
fileSizeOK :: Bool
fileSizeOK = case Attributes -> Maybe Int64
getCurlMaxFileSize Attributes
options of
Maybe Int64
Nothing -> Bool
True
Just Int64
mx -> ByteString -> Int64
B.length ByteString
cs Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
mx
rc :: Int
rc = (Int, Int, Int) -> Int
convertResponseStatus ((Int, Int, Int) -> Int) -> (Int, Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString -> (Int, Int, Int)
forall a. Response a -> (Int, Int, Int)
rspCode Response ByteString
response
rr :: String
rr = Response ByteString -> String
forall a. Response a -> String
rspReason Response ByteString
response
res :: Either a (Attributes, ByteString)
res = (Attributes, ByteString) -> Either a (Attributes, ByteString)
forall a b. b -> Either a b
Right (Attributes
rs, ByteString
cs)
ers :: String -> Either (Attributes, String) b
ers String
e = (Attributes, String) -> Either (Attributes, String) b
forall a b. a -> Either a b
Left (Attributes
rs, String
"http error when accessing URI " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e)
rs :: Attributes
rs = Attributes
rst Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++ Attributes
rsh
rst :: Attributes
rst = [ (String
transferStatus, Int -> String
forall a. Show a => a -> String
show Int
rc)
, (String
transferMessage, String
rr)
]
rsh :: Attributes
rsh = Response ByteString -> Attributes
convertResponseHeaders Response ByteString
response
cs :: ByteString
cs = Response ByteString -> ByteString
forall a. Response a -> a
rspBody Response ByteString
response
getHttp :: Bool -> URI -> String -> Bool -> Attributes -> IO (Response B.ByteString)
getHttp :: Bool
-> URI -> String -> Bool -> Attributes -> IO (Response ByteString)
getHttp Bool
trc' URI
uri' String
proxy' Bool
redirect' Attributes
options'
= IO (Response ByteString) -> IO (Response ByteString)
forall a. IO a -> IO a
withSocketsDo (IO (Response ByteString) -> IO (Response ByteString))
-> IO (Response ByteString) -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$
BrowserAction (HandleStream ByteString) (Response ByteString)
-> IO (Response ByteString)
forall conn a. BrowserAction conn a -> IO a
browse ( do
[BrowserAction (HandleStream ByteString) ()]
-> BrowserAction (HandleStream ByteString) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [BrowserAction (HandleStream ByteString) ()]
forall {t}. [BrowserAction t ()]
configHttp
(URI
_ruri, Response ByteString
rsp) <- Request ByteString
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request (Request ByteString
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString))
-> Request ByteString
-> BrowserAction
(HandleStream ByteString) (URI, Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request ByteString
theRequest
Response ByteString
-> BrowserAction (HandleStream ByteString) (Response ByteString)
forall a. a -> BrowserAction (HandleStream ByteString) a
forall (m :: * -> *) a. Monad m => a -> m a
return Response ByteString
rsp
)
where
theRequest :: Request B.ByteString
theRequest :: Request ByteString
theRequest
= Request ByteString -> Request ByteString
configHeaders (Request ByteString -> Request ByteString)
-> Request ByteString -> Request ByteString
forall a b. (a -> b) -> a -> b
$ URI -> Request ByteString
forall a. BufferType a => URI -> Request a
defaultGETRequest_ URI
uri'
configHeaders :: Request B.ByteString -> Request B.ByteString
configHeaders :: Request ByteString -> Request ByteString
configHeaders
= ((Request ByteString -> Request ByteString)
-> (Request ByteString -> Request ByteString)
-> Request ByteString
-> Request ByteString)
-> (Request ByteString -> Request ByteString)
-> [Request ByteString -> Request ByteString]
-> Request ByteString
-> Request ByteString
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Request ByteString -> Request ByteString)
-> (Request ByteString -> Request ByteString)
-> Request ByteString
-> Request ByteString
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) Request ByteString -> Request ByteString
forall a. a -> a
id ([Request ByteString -> Request ByteString]
-> Request ByteString -> Request ByteString)
-> (Attributes -> [Request ByteString -> Request ByteString])
-> Attributes
-> Request ByteString
-> Request ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, String) -> Request ByteString -> Request ByteString)
-> [(HeaderName, String)]
-> [Request ByteString -> Request ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ((HeaderName -> String -> Request ByteString -> Request ByteString)
-> (HeaderName, String) -> Request ByteString -> Request ByteString
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HeaderName -> String -> Request ByteString -> Request ByteString
forall a. HasHeaders a => HeaderSetter a
replaceHeader) ([(HeaderName, String)]
-> [Request ByteString -> Request ByteString])
-> (Attributes -> [(HeaderName, String)])
-> Attributes
-> [Request ByteString -> Request ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> [(HeaderName, String)])
-> Attributes -> [(HeaderName, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String -> [(HeaderName, String)])
-> (String, String) -> [(HeaderName, String)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> [(HeaderName, String)]
setHOption) (Attributes -> Request ByteString -> Request ByteString)
-> Attributes -> Request ByteString -> Request ByteString
forall a b. (a -> b) -> a -> b
$ Attributes
options'
configHttp :: [BrowserAction t ()]
configHttp
= (String -> IO ()) -> BrowserAction t ()
forall t. (String -> IO ()) -> BrowserAction t ()
setOutHandler (String -> IO ()
trcFct)
BrowserAction t () -> [BrowserAction t ()] -> [BrowserAction t ()]
forall a. a -> [a] -> [a]
: (String -> IO ()) -> BrowserAction t ()
forall t. (String -> IO ()) -> BrowserAction t ()
setErrHandler (String -> IO ()
trcFct)
BrowserAction t () -> [BrowserAction t ()] -> [BrowserAction t ()]
forall a. a -> [a] -> [a]
: ( if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
proxy'
then () -> BrowserAction t ()
forall a. a -> BrowserAction t a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else Proxy -> BrowserAction t ()
forall t. Proxy -> BrowserAction t ()
setProxy (String -> Maybe Authority -> Proxy
Proxy String
proxy' Maybe Authority
forall a. Maybe a
Nothing)
)
BrowserAction t () -> [BrowserAction t ()] -> [BrowserAction t ()]
forall a. a -> [a] -> [a]
: Bool -> BrowserAction t ()
forall t. Bool -> BrowserAction t ()
setAllowRedirects Bool
redirect'
BrowserAction t () -> [BrowserAction t ()] -> [BrowserAction t ()]
forall a. a -> [a] -> [a]
: ((String, String) -> [BrowserAction t ()])
-> Attributes -> [BrowserAction t ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String -> [BrowserAction t ()])
-> (String, String) -> [BrowserAction t ()]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> [BrowserAction t ()]
forall t. String -> String -> [BrowserAction t ()]
setOption) Attributes
options'
trcFct :: String -> IO ()
trcFct String
s
| Bool
trc'
= Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"-- (5) http: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
| Bool
otherwise
= () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
convertResponseStatus :: (Int, Int, Int) -> Int
convertResponseStatus :: (Int, Int, Int) -> Int
convertResponseStatus (Int
a, Int
b, Int
c)
= Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c
convertResponseHeaders :: Response B.ByteString -> [(String, String)]
convertResponseHeaders :: Response ByteString -> Attributes
convertResponseHeaders Response ByteString
r'
= (Int, Int, Int) -> Attributes
cvResponseCode (Response ByteString -> (Int, Int, Int)
forall a. Response a -> (Int, Int, Int)
rspCode Response ByteString
r')
Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++
String -> Attributes
cvResponseReason (Response ByteString -> String
forall a. Response a -> String
rspReason Response ByteString
r')
Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++
[Header] -> Attributes
cvResponseHeaders (Response ByteString -> [Header]
forall a. Response a -> [Header]
rspHeaders Response ByteString
r')
where
cvResponseCode :: (Int, Int, Int) -> [(String, String)]
cvResponseCode :: (Int, Int, Int) -> Attributes
cvResponseCode (Int, Int, Int)
st'
= [ (String
transferStatus, Int -> String
forall a. Show a => a -> String
show ((Int, Int, Int) -> Int
convertResponseStatus (Int, Int, Int)
st'))
, (String
transferVersion, String
httpVersion)
]
cvResponseReason :: String -> [(String, String)]
cvResponseReason :: String -> Attributes
cvResponseReason String
r''
= [ (String
transferMessage, (String -> String
stringTrim String
r'')) ]
cvResponseHeaders :: [Header] -> [(String, String)]
cvResponseHeaders :: [Header] -> Attributes
cvResponseHeaders
= (Header -> Attributes) -> [Header] -> Attributes
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Header -> Attributes
cvResponseHeader
cvResponseHeader :: Header -> [(String, String)]
cvResponseHeader :: Header -> Attributes
cvResponseHeader (Header HeaderName
name String
value)
| HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
HdrContentType
= ( case (Parsec String () Attributes
-> String -> String -> Either ParseError Attributes
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () Attributes
parseContentType (HeaderName -> String
forall a. Show a => a -> String
show HeaderName
HdrContentType) String
value) of
Right Attributes
res -> Attributes
res
Left ParseError
_ -> []
)
Attributes -> Attributes -> Attributes
forall a. [a] -> [a] -> [a]
++
Attributes
addHttpAttr
| Bool
otherwise
= Attributes
addHttpAttr
where
addHttpAttr :: Attributes
addHttpAttr = [ (String
httpPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ (HeaderName -> String
forall a. Show a => a -> String
show HeaderName
name), String
value) ]
setOption :: String -> String -> [BrowserAction t ()]
setOption :: forall t. String -> String -> [BrowserAction t ()]
setOption String
k0 String
v
| String
k String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"max-redirs"
Bool -> Bool -> Bool
&&
String -> Bool
isIntArg String
v = [Maybe Int -> BrowserAction t ()
forall t. Maybe Int -> BrowserAction t ()
setMaxRedirects (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
v)]
| String
k String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"max-redirs"
Bool -> Bool -> Bool
&&
String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
v = [Maybe Int -> BrowserAction t ()
forall t. Maybe Int -> BrowserAction t ()
setMaxRedirects Maybe Int
forall a. Maybe a
Nothing]
| Bool
otherwise = []
where
k :: String
k = String -> String
dropCurlPrefix String
k0
curlPrefix :: String
curlPrefix :: String
curlPrefix = String
"curl--"
dropCurlPrefix :: String -> String
dropCurlPrefix :: String -> String
dropCurlPrefix String
k
| String
curlPrefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
k = Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
curlPrefix) String
k
| Bool
otherwise = String
k
setHOption :: String -> String -> [(HeaderName, String)]
setHOption :: String -> String -> [(HeaderName, String)]
setHOption String
k0 String
v
| String
k String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ String
"-A"
, String
"user-agent"
, String
"curl--user-agent"
] = [(HeaderName
HdrUserAgent, String
v)]
| String
k String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ String
"-e"
, String
"referer"] = [(HeaderName
HdrReferer, String
v)]
| String
k String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
a_if_modified_since = [(HeaderName
HdrIfModifiedSince, String
v)]
| String
k String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
a_if_unmodified_since = [(HeaderName
HdrIfUnmodifiedSince, String
v)]
| Bool
otherwise = []
where
k :: String
k = String -> String
dropCurlPrefix String
k0
isIntArg :: String -> Bool
isIntArg :: String -> Bool
isIntArg String
s = Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
s
getCurlMaxFileSize :: Attributes -> Maybe Int64
getCurlMaxFileSize :: Attributes -> Maybe Int64
getCurlMaxFileSize Attributes
options
= (\ String
s -> if String -> Bool
isIntArg String
s
then Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (String -> Int64
forall a. Read a => String -> a
read String
s)
else Maybe Int64
forall a. Maybe a
Nothing
)
(String -> Maybe Int64)
-> (Attributes -> String) -> Attributes -> Maybe Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
""
(Maybe String -> String)
-> (Attributes -> Maybe String) -> Attributes -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Attributes -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String
curlPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"max-filesize")
(Attributes -> Maybe Int64) -> Attributes -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ Attributes
options