module Network.HTTP.Conduit.Browser
(
BrowserAction
, GenericBrowserAction
, browse
, parseRelativeUrl
, makeRequest
, makeRequestLbs
, downloadFile
, BrowserState
, defaultState
, getBrowserState
, setBrowserState
, withBrowserState
, getManager
, setManager
, getLocation
, setLocation
, withLocation
, getCookieJar
, setCookieJar
, withCookieJar
, getCookieFilter
, setCookieFilter
, withCookieFilter
, getCurrentProxy
, setCurrentProxy
, withCurrentProxy
, getCurrentSocksProxy
, setCurrentSocksProxy
, withCurrentSocksProxy
, getMaxRedirects
, setMaxRedirects
, withMaxRedirects
, getMaxRetryCount
, setMaxRetryCount
, withMaxRetryCount
, getTimeout
, setTimeout
, withTimeout
, getAuthorities
, setAuthorities
, withAuthorities
, getClientCertificates
, setClientCertificates
, withClientCertificates
, getDefaultHeaders
, setDefaultHeaders
, withDefaultHeaders
, getDefaultHeader
, setDefaultHeader
, insertDefaultHeader
, deleteDefaultHeader
, withDefaultHeader
, getOverrideHeaders
, setOverrideHeaders
, withOverrideHeaders
, getOverrideHeader
, setOverrideHeader
, insertOverrideHeader
, deleteOverrideHeader
, withOverrideHeader
, getCheckStatus
, setCheckStatus
, withCheckStatus
)
where
import Network.HTTP.Conduit
import Network.HTTP.Conduit.Internal (httpRedirect
,getUri
,setUri
,generateCookie
,insertCheckedCookie
)
import qualified Network.HTTP.Types as HT
import Network.Socks5 (SocksConf)
import Network.URI (URI (..), parseRelativeReference, relativeTo)
import Data.Time.Clock (getCurrentTime, UTCTime)
import Web.Cookie (parseSetCookie)
import Data.Certificate.X509 (X509)
import Network.TLS (PrivateKey)
import qualified Data.Conduit as C
import qualified Data.Conduit.Binary as CB
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import Data.Function (on)
import Data.List (partition
,union
)
import Data.Maybe (catMaybes, fromMaybe)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Control.Monad.Trans.Resource (MonadResource, ResourceT, liftResourceT)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Failure
import qualified Control.Exception.Lifted as LE
import Control.Exception (SomeException
,toException)
import qualified Data.Map as Map
data BrowserState = BrowserState
{ currentLocation :: Maybe URI
, maxRedirects :: Maybe Int
, maxRetryCount :: Int
, timeout :: Maybe Int
, authorities :: Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)
, browserClientCertificates :: Maybe [(X509, Maybe PrivateKey)]
, cookieFilter :: Request (ResourceT IO) -> Cookie -> IO Bool
, browserCookieJar :: CookieJar
, currentProxy :: Maybe Proxy
, currentSocksProxy :: Maybe SocksConf
, 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
, browserClientCertificates = Nothing
, cookieFilter = const $ const $ return True
, browserCookieJar = def
, currentProxy = Nothing
, currentSocksProxy = 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 :: Failure HttpException m => String -> GenericBrowserAction m (Request m')
parseRelativeUrl url =
maybe err use =<< gets currentLocation
where err = lift $ failure $ InvalidUrlException url "Invalid URL"
use loc = maybe err (setUri def) $ do
uri <- parseRelativeReference url
relativeTo' uri loc
#if MIN_VERSION_network(2,4,0)
relativeTo' x = Just . relativeTo x
#else
relativeTo' = relativeTo
#endif
makeRequest :: (MonadBaseControl IO m, MonadResource m) => Request (ResourceT IO) -> 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
, currentSocksProxy = current_socks_proxy
, defaultHeaders = default_headers
, overrideHeaders = override_headers
, browserCheckStatus = current_check_status
, browserClientCertificates = client_certificates
} <- get
retryHelper
(applyOverrideHeaders override_headers $
applyDefaultHeaders default_headers $
req { redirectCount = 0
, proxy = maybe (proxy req) Just current_proxy
, socksProxy = maybe (socksProxy req) Just current_socks_proxy
, checkStatus = \ _ _ _ -> Nothing
, responseTimeout = maybe (responseTimeout req) Just time_out
, clientCertificates = fromMaybe (clientCertificates req) client_certificates
}) max_retry_count
(fromMaybe (redirectCount req) max_redirects)
(fromMaybe (checkStatus req) current_check_status)
Nothing
where
retryHelper request' retry_count max_redirects check_status e
| retry_count < 0 = case e of
Just e' -> LE.throwIO e'
Nothing -> LE.throwIO TooManyRetries
| 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')
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')
runRedirectionChain request' redirect_count
= httpRedirect
redirect_count
(\request -> do
res <- performRequest request
let mreq = getRedirectedRequest request (responseHeaders res) (responseCookieJar res) (HT.statusCode $ responseStatus res)
return (res, mreq))
liftResourceT
request'
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 def $ cookieJar request'')
cookie_jar'
}
res <- liftResourceT $ http request' manager'
(cookie_jar, _) <- liftIO $ do
now <- getCurrentTime
updateMyCookieJar res request' now cookie_jar' cookie_filter
put $ s { browserCookieJar = cookie_jar
, currentLocation = Just $ getUri request'
}
return res
applyAuthorities :: (Request a -> Maybe (BS.ByteString, BS.ByteString)) -> Request a -> Request a
applyAuthorities auths request' =
case auths request' of
Just (user, pass) -> applyBasicAuth user pass request'
Nothing -> request'
applyDefaultHeaders :: Map.Map HT.HeaderName BS.ByteString -> Request a -> Request a
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 a -> Request a
applyOverrideHeaders ov request = request {requestHeaders = x $ requestHeaders request}
where x r = Map.toList $ Map.union ov (Map.fromList r)
makeRequestLbs :: (MonadBaseControl IO m, MonadResource m) => Request (ResourceT IO) -> GenericBrowserAction m (Response L.ByteString)
makeRequestLbs = liftResourceT . lbsResponse <=< makeRequest
downloadFile :: (MonadResource m, MonadBaseControl IO m) => FilePath -> Request (ResourceT IO) -> GenericBrowserAction m ()
downloadFile file request = do
res <- makeRequest request
liftResourceT $ responseBody res C.$$+- CB.sinkFile file
updateMyCookieJar :: Response a -> Request (ResourceT IO) -> UTCTime -> CookieJar -> (Request (ResourceT IO) -> 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 (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString))
GENERIC_FIELD(getClientCertificates, setClientCertificates, withClientCertificates, browserClientCertificates, Maybe [(X509, Maybe PrivateKey)])
GENERIC_FIELD(getCookieFilter, setCookieFilter, withCookieFilter, cookieFilter, Request (ResourceT IO) -> Cookie -> IO Bool)
GENERIC_FIELD(getCookieJar, setCookieJar, withCookieJar, browserCookieJar, CookieJar)
GENERIC_FIELD(getCurrentProxy, setCurrentProxy, withCurrentProxy, currentProxy, Maybe Proxy)
GENERIC_FIELD(getCurrentSocksProxy, setCurrentSocksProxy, withCurrentSocksProxy, currentSocksProxy, Maybe SocksConf)
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