module Network.HTTP.Conduit.Browser
(
BrowserAction
, GenericBrowserAction
, browse
, parseRelativeUrl
, makeRequest
, makeRequestLbs
, BrowserState
, defaultState
, getBrowserState
, setBrowserState
, withBrowserState
, getManager
, setManager
, getLocation
, setLocation
, withLocation
, getCookieJar
, setCookieJar
, withCookieJar
, getCookieFilter
, setCookieFilter
, withCookieFilter
, getCurrentProxy
, setCurrentProxy
, withCurrentProxy
, getMaxRedirects
, setMaxRedirects
, withMaxRedirects
, getMaxRetryCount
, setMaxRetryCount
, withMaxRetryCount
, getTimeout
, setTimeout
, withTimeout
, getAuthorities
, setAuthorities
, withAuthorities
, getDefaultHeaders
, setDefaultHeaders
, withDefaultHeaders
, getDefaultHeader
, setDefaultHeader
, insertDefaultHeader
, deleteDefaultHeader
, withDefaultHeader
, getOverrideHeaders
, setOverrideHeaders
, withOverrideHeaders
, getOverrideHeader
, setOverrideHeader
, insertOverrideHeader
, deleteOverrideHeader
, withOverrideHeader
, getCheckStatus
, setCheckStatus
, withCheckStatus
)
where
import Network.HTTP.Client
import Network.HTTP.Conduit
import Network.HTTP.Client.Internal (setUri)
import qualified Network.HTTP.Types as HT
import Network.URI (URI (..), parseRelativeReference, relativeTo)
import Data.Time.Clock (getCurrentTime, UTCTime)
import Web.Cookie (parseSetCookie)
import qualified Data.Conduit as C
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
#if !MIN_VERSION_http_client(0,5,0)
import Data.Default
#endif
import Data.Function (on)
import Data.List (partition
,union
)
import Data.Maybe (catMaybes, fromMaybe)
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Control.Monad.Trans.Resource
(ResourceT
,liftResourceT
#if MIN_VERSION_http_client(0,5,0)
,runResourceT
#endif
,MonadResource)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.IO.Class
import Control.Monad.Base
import Control.Monad.Catch (MonadThrow, throwM)
import qualified Control.Exception.Lifted as LE
import Control.Exception (SomeException
,toException)
import qualified Data.Map as Map
#if MIN_VERSION_http_client(0,5,0)
import Data.IORef
#endif
data BrowserState = BrowserState
{ currentLocation :: Maybe URI
, maxRedirects :: Maybe Int
, maxRetryCount :: Int
, timeout :: Maybe Int
, authorities :: Request -> Maybe (BS.ByteString, BS.ByteString)
, cookieFilter :: Request -> Cookie -> IO Bool
, browserCookieJar :: CookieJar
, currentProxy :: Maybe Proxy
, overrideHeaders :: Map.Map HT.HeaderName BS.ByteString
, defaultHeaders :: Map.Map HT.HeaderName BS.ByteString
, browserCheckStatus :: Maybe (HT.Status -> HT.ResponseHeaders -> CookieJar -> Maybe SomeException)
, manager :: Manager
}
defaultState :: Manager -> BrowserState
defaultState m = BrowserState
{ currentLocation = Nothing
, maxRedirects = Nothing
, maxRetryCount = 0
, timeout = Nothing
, authorities = const Nothing
, cookieFilter = const $ const $ return True
, browserCookieJar = mempty
, currentProxy = Nothing
, overrideHeaders = Map.empty
, defaultHeaders = Map.singleton HT.hUserAgent "http-conduit-browser"
, browserCheckStatus = Nothing
, manager = m
}
type BrowserAction = GenericBrowserAction (ResourceT IO)
type GenericBrowserAction m = StateT BrowserState m
browse :: Monad m => Manager -> GenericBrowserAction m a -> m a
browse m act = evalStateT act (defaultState m)
parseRelativeUrl :: MonadThrow m => String -> GenericBrowserAction m Request
parseRelativeUrl url =
maybe err use =<< gets currentLocation
where
err = lift $ throwM $ InvalidUrlException url "Invalid URL"
use loc = maybe err (setUri defReq) $ do
uri <- parseRelativeReference url
relativeTo' uri loc
relativeTo' x = Just . relativeTo x
#if MIN_VERSION_http_client(0,4,30)
defReq = defaultRequest
#else
defReq = def
#endif
makeRequest :: (MonadBaseControl IO m, MonadIO m, MonadResource m) => Request -> GenericBrowserAction m (Response (C.ResumableSource (ResourceT IO) BS.ByteString))
makeRequest req = do
BrowserState
{ maxRetryCount = max_retry_count
, maxRedirects = max_redirects
, timeout = time_out
, currentProxy = current_proxy
, defaultHeaders = default_headers
, overrideHeaders = override_headers
, browserCheckStatus = current_check_status
} <- get
retryHelper
(applyOverrideHeaders override_headers $
applyDefaultHeaders default_headers $
req { redirectCount = 0
, proxy = maybe (proxy req) Just current_proxy
#if MIN_VERSION_http_client(0,5,0)
, checkResponse = \ _ _ -> return ()
, responseTimeout = maybe (responseTimeout req) responseTimeoutMicro time_out
#else
, checkStatus = \ _ _ _ -> Nothing
, responseTimeout = maybe (responseTimeout req) Just time_out
#endif
})
max_retry_count
(fromMaybe (redirectCount req) max_redirects)
#if MIN_VERSION_http_client(0,5,0)
(fromMaybe (checkResponse req) $
fmap
(\check' -> (\ _ rs -> maybe (return ()) LE.throwIO $
check'
(responseStatus rs)
(responseHeaders rs)
(responseCookieJar rs)
))
current_check_status
)
#else
(fromMaybe (checkStatus req) current_check_status)
#endif
Nothing
where
retryHelper
:: (MonadBaseControl IO m, MonadIO m, MonadResource m)
=> Request
-> Int
-> Int
#if MIN_VERSION_http_client(0,5,0)
-> (Request -> Response BodyReader -> IO ())
#else
-> (HT.Status -> HT.ResponseHeaders -> CookieJar -> Maybe SomeException)
#endif
-> Maybe SomeException
-> GenericBrowserAction m (Response (C.ResumableSource (ResourceT IO) BS.ByteString))
retryHelper request' retry_count max_redirects check_status e
| retry_count < 0 = case e of
Just e' -> LE.throwIO e'
#if MIN_VERSION_http_client(0,5,0)
Nothing -> LE.throwIO $ HttpExceptionRequest request' ResponseTimeout
#else
Nothing -> LE.throwIO TooManyRetries
#endif
| otherwise = do
res <- LE.catch
(if max_redirects == 0
then performRequest request'
else runRedirectionChain request' max_redirects)
(\(e'::HttpException) -> retryHelper request' (retry_count 1) max_redirects check_status $ Just $ toException e')
#if MIN_VERSION_http_client(0,5,0)
resBR <- liftIO $ backToBodyReader res
et <- LE.try (liftIO $ check_status request' resBR)
case et of
Right () -> return res
Left e' -> retryHelper request' (retry_count 1) max_redirects check_status (Just e')
#else
case check_status (responseStatus res) (responseHeaders res) (responseCookieJar res) of
Nothing -> return res
Just e' -> retryHelper request' (retry_count 1) max_redirects check_status (Just e')
#endif
runRedirectionChain request' redirect_count
= httpRedirectBase
redirect_count
(\request -> do
res <- performRequest request
let mreq = getRedirectedRequest request (responseHeaders res) (responseCookieJar res) (HT.statusCode $ responseStatus res)
return (res, mreq))
request'
performRequest
:: (MonadBaseControl IO m, MonadIO m, MonadResource m)
=> Request
-> GenericBrowserAction m (Response (C.ResumableSource (ResourceT IO) BS.ByteString))
performRequest request'' = do
s@(BrowserState { manager = manager'
, authorities = auths
, browserCookieJar = cookie_jar'
, cookieFilter = cookie_filter
}) <- get
let request' = (applyAuthorities auths request'')
{cookieJar = Just $ createCookieJar $
(union `on` destroyCookieJar)
(fromMaybe mempty $ cookieJar request'')
cookie_jar'
}
res <- liftResourceT $ http request' manager'
(cookie_jar, _) <- liftBase $ do
now <- getCurrentTime
updateMyCookieJar res request' now cookie_jar' cookie_filter
put $ s { browserCookieJar = cookie_jar
, currentLocation = Just $ getUri request'
}
return res
#if MIN_VERSION_http_client(0,5,0)
backToBodyReader :: Response (C.ResumableSource (ResourceT IO) BS.ByteString) -> IO (Response BodyReader)
backToBodyReader res = do
let origsource = responseBody res
curSourceRef <- newIORef origsource
return res {responseBody = runResourceT $ do
bsource <- liftIO $ readIORef curSourceRef
(bsource', mbs) <- bsource C.$$++ C.await
liftIO $ writeIORef curSourceRef bsource'
case mbs of
Nothing -> do
C.closeResumableSource bsource'
return BS.empty
Just bs ->
return bs
}
#endif
httpRedirectBase
:: (MonadBaseControl IO m, MonadIO m, MonadResource m)
=> Int
-> (Request -> m (Response (C.ResumableSource (ResourceT IO) BS.ByteString), Maybe Request))
-> Request
-> m (Response (C.ResumableSource (ResourceT IO) BS.ByteString))
httpRedirectBase count0 http' req0 = go count0 req0 []
where
#if MIN_VERSION_http_client(0,5,0)
go count req' ress | count < 0 = LE.throwIO . HttpExceptionRequest req' . TooManyRedirects =<< mapM (liftResourceT . lbsResponse) ress
#else
go count _ ress | count < 0 = LE.throwIO . TooManyRedirects =<< mapM (liftResourceT . lbsResponse) ress
#endif
go count req' ress = do
(res, mreq) <- http' req'
case mreq of
Just req -> do
liftIO $ responseClose res
go (count 1) req (res:ress)
Nothing -> return res
applyAuthorities :: (Request -> Maybe (BS.ByteString, BS.ByteString)) -> Request -> Request
applyAuthorities auths request' =
case auths request' of
Just (user, pass) -> applyBasicAuth user pass request'
Nothing -> request'
applyDefaultHeaders :: Map.Map HT.HeaderName BS.ByteString -> Request -> Request
applyDefaultHeaders dv request = request {requestHeaders = x $ requestHeaders request}
where x r = Map.toList $ Map.union (Map.fromList r) dv
applyOverrideHeaders :: Map.Map HT.HeaderName BS.ByteString -> Request -> Request
applyOverrideHeaders ov request = request {requestHeaders = x $ requestHeaders request}
where x r = Map.toList $ Map.union ov (Map.fromList r)
makeRequestLbs :: (MonadIO m, MonadResource m, MonadBaseControl IO m) => Request -> GenericBrowserAction m (Response L.ByteString)
makeRequestLbs = liftResourceT . lbsResponse <=< makeRequest
updateMyCookieJar :: Response a -> Request -> UTCTime -> CookieJar -> (Request -> Cookie -> IO Bool) -> IO (CookieJar, Response a)
updateMyCookieJar response request' now cookie_jar cookie_filter = do
filtered_cookies <- filterM (cookie_filter request') $ catMaybes $ map (\ sc -> generateCookie sc request' now True) set_cookies
return (cookieJar' filtered_cookies, response {responseHeaders = other_headers})
where (set_cookie_headers, other_headers) = partition ((== "Set-Cookie") . fst) $ responseHeaders response
set_cookie_data = map snd set_cookie_headers
set_cookies = map parseSetCookie set_cookie_data
cookieJar' = foldl (\ cj c -> insertCheckedCookie c cj True) cookie_jar
getBrowserState :: Monad m => GenericBrowserAction m BrowserState
getBrowserState = get
setBrowserState :: Monad m => BrowserState -> GenericBrowserAction m ()
setBrowserState = put
withBrowserState :: Monad m => BrowserState -> GenericBrowserAction m a -> GenericBrowserAction m a
withBrowserState s a = do
current <- get
put s
out <- a
put current
return out
getManager :: Monad m => GenericBrowserAction m Manager
getManager = get >>= \ a -> return $ manager a
setManager :: Monad m => Manager -> GenericBrowserAction m ()
setManager b = get >>= \ a -> put a {manager = b}
#define GENERIC_FIELD(getName, setName, withName, field, Type)\
getName :: Monad m => GenericBrowserAction m (Type) ;\
getName = gets field ;\
setName :: Monad m => (Type) -> GenericBrowserAction m () ;\
setName b = get >>= \ a -> put a {field = b} ;\
withName :: Monad m => (Type) -> GenericBrowserAction m a -> GenericBrowserAction m a ;\
withName a b = do \
current <- getName ;\
setName a ;\
out <- b ;\
setName current ;\
return out ;\
GENERIC_FIELD(getLocation, setLocation, withLocation, currentLocation, Maybe URI)
GENERIC_FIELD(getMaxRedirects, setMaxRedirects, withMaxRedirects, maxRedirects, Maybe Int)
GENERIC_FIELD(getMaxRetryCount, setMaxRetryCount, withMaxRetryCount, maxRetryCount, Int)
GENERIC_FIELD(getTimeout, setTimeout, withTimeout, timeout, Maybe Int)
GENERIC_FIELD(getAuthorities, setAuthorities, withAuthorities, authorities, Request -> Maybe (BS.ByteString, BS.ByteString))
GENERIC_FIELD(getCookieFilter, setCookieFilter, withCookieFilter, cookieFilter, Request -> Cookie -> IO Bool)
GENERIC_FIELD(getCookieJar, setCookieJar, withCookieJar, browserCookieJar, CookieJar)
GENERIC_FIELD(getCurrentProxy, setCurrentProxy, withCurrentProxy, currentProxy, Maybe Proxy)
GENERIC_FIELD(getCheckStatus, setCheckStatus, withCheckStatus, browserCheckStatus, Maybe (HT.Status -> HT.ResponseHeaders -> CookieJar -> Maybe SomeException))
#undef GENERIC_FIELD
getDefaultHeaders :: Monad m => GenericBrowserAction m HT.RequestHeaders
getDefaultHeaders = gets $ Map.toList . defaultHeaders
setDefaultHeaders :: Monad m => HT.RequestHeaders -> GenericBrowserAction m ()
setDefaultHeaders b = get >>= \ a -> put a {defaultHeaders = Map.fromList b}
withDefaultHeaders:: Monad m => HT.RequestHeaders -> GenericBrowserAction m a -> GenericBrowserAction m a
withDefaultHeaders a b = do
current <- getDefaultHeaders
setDefaultHeaders a
out <- b
setDefaultHeaders current
return out
getDefaultHeader :: Monad m => HT.HeaderName -> GenericBrowserAction m (Maybe BS.ByteString)
getDefaultHeader b = gets $ Map.lookup b . defaultHeaders
setDefaultHeader :: Monad m => HT.HeaderName -> Maybe BS.ByteString -> GenericBrowserAction m ()
setDefaultHeader b Nothing = deleteDefaultHeader b
setDefaultHeader b (Just c) = insertDefaultHeader (b, c)
insertDefaultHeader :: Monad m => HT.Header -> GenericBrowserAction m ()
insertDefaultHeader (b, c) = get >>= \ a -> put a {defaultHeaders = Map.insert b c (defaultHeaders a)}
deleteDefaultHeader :: Monad m => HT.HeaderName -> GenericBrowserAction m ()
deleteDefaultHeader b = get >>= \ a -> put a {defaultHeaders = Map.delete b (defaultHeaders a)}
withDefaultHeader :: Monad m => HT.Header -> GenericBrowserAction m a -> GenericBrowserAction m a
withDefaultHeader (a,b) c = do
current <- getDefaultHeader a
insertDefaultHeader (a,b)
out <- c
setDefaultHeader a current
return out
getOverrideHeaders :: Monad m => GenericBrowserAction m HT.RequestHeaders
getOverrideHeaders = gets $ Map.toList . overrideHeaders
setOverrideHeaders :: Monad m => HT.RequestHeaders -> GenericBrowserAction m ()
setOverrideHeaders b = get >>= \ a -> put a {overrideHeaders = Map.fromList b}
withOverrideHeaders:: Monad m => HT.RequestHeaders -> GenericBrowserAction m a -> GenericBrowserAction m a
withOverrideHeaders a b = do
current <- getOverrideHeaders
setOverrideHeaders a
out <- b
setOverrideHeaders current
return out
getOverrideHeader :: Monad m => HT.HeaderName -> GenericBrowserAction m (Maybe BS.ByteString)
getOverrideHeader b = gets $ Map.lookup b . overrideHeaders
setOverrideHeader :: Monad m => HT.HeaderName -> Maybe BS.ByteString -> GenericBrowserAction m ()
setOverrideHeader b Nothing = deleteOverrideHeader b
setOverrideHeader b (Just c) = insertOverrideHeader (b, c)
insertOverrideHeader :: Monad m => HT.Header -> GenericBrowserAction m ()
insertOverrideHeader (b, c) = get >>= \ a -> put a {overrideHeaders = Map.insert b c (overrideHeaders a)}
deleteOverrideHeader :: Monad m => HT.HeaderName -> GenericBrowserAction m ()
deleteOverrideHeader b = get >>= \ a -> put a {overrideHeaders = Map.delete b (overrideHeaders a)}
withOverrideHeader :: Monad m => HT.Header -> GenericBrowserAction m a -> GenericBrowserAction m a
withOverrideHeader (a,b) c = do
current <- getOverrideHeader a
insertOverrideHeader (a,b)
out <- c
setOverrideHeader a current
return out