summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2021-07-21 12:57:35 +1200
committerAdrian Cochrane <adrian@openwork.nz>2021-07-21 12:57:35 +1200
commit349bb4b440f0f8f953925a215e16cfdf49b6eb49 (patch)
tree6dd4e9b938c1114a596cf7adef1b087434cf3339
parent259eca98aab4a11b37e9127d2d78d0816852bc50 (diff)
downloadhurl-349bb4b440f0f8f953925a215e16cfdf49b6eb49.tar.gz
hurl-349bb4b440f0f8f953925a215e16cfdf49b6eb49.tar.bz2
hurl-349bb4b440f0f8f953925a215e16cfdf49b6eb49.zip
Allow sites to cookies in response to HTTP POST requests.
-rw-r--r--src/Network/URI/Fetch.hs33
1 files changed, 25 insertions, 8 deletions
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index d8563ea..8d52d83 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -3,7 +3,7 @@
-- | Retrieves documents for a URL, supporting multiple URL schemes that can be
-- disabled at build-time for reduced dependencies.
module Network.URI.Fetch(Session(locale, aboutPages, redirectCount, cachingEnabled), newSession,
- fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR,
+ fetchURL, fetchURL', fetchURLs, submitURL, mimeERR, htmlERR,
dispatchByMIME, appsForMIME, Application(..), dispatchByApp,
saveDownload, downloadToURI,
-- logging API
@@ -79,6 +79,8 @@ import Network.URI.PlugIns.Rewriters
data Session = Session {
#ifdef WITH_HTTP_URI
managerHTTP :: HTTP.Manager,
+ globalCookieJar :: MVar HTTP.CookieJar,
+ cookiesPath :: FilePath,
#endif
#ifdef WITH_RAW_CONNECTIONS
connCtxt :: TLS.SSLContext,
@@ -128,6 +130,14 @@ newSession' appname = do
TLS.contextSetCADirectory httpsCtxt "/etc/ssl/certs"
TLS.contextSetVerificationMode httpsCtxt $ TLS.VerifyPeer True True Nothing
managerHTTP' <- HTTP.newManager $ TLS.opensslManagerSettings $ return httpsCtxt
+
+ cookiesDir <- getXdgDirectory XdgData "nz.geek.adrian.hurl.cookies"
+ let cookiesPath' = cookiesDir </> appname
+ cookiesExist <- doesFileExist cookiesPath'
+ cookies <- if cookiesExist then readMaybe <$> readFile cookiesPath' else return Nothing
+ now <- getCurrentTime
+ let cookies' = HTTP.createCookieJar $ fromMaybe [] cookies
+ cookieJar <- newMVar $ HTTP.evictExpiredCookies cookies' now
#endif
#ifdef WITH_RAW_CONNECTIONS
connCtxt <- TLS.context
@@ -146,6 +156,8 @@ newSession' appname = do
return Session {
#ifdef WITH_HTTP_URI
managerHTTP = managerHTTP',
+ globalCookieJar = cookieJar,
+ cookiesPath = cookiesPath',
#endif
#ifdef WITH_RAW_CONNECTIONS
connCtxt = connCtxt,
@@ -199,10 +211,13 @@ htmlERR = "html/x-error\t"
submitURL :: Session -> [String] -> URI -> Text -> String -> IO (URI, String, Either Text ByteString)
#ifdef WITH_HTTP_URI
submitURL session accept uri "POST" query | uriScheme uri `elem` ["http:", "https:"] =
- fetchHTTPCached session accept uri $ \req -> req {
+ fetchHTTPCached session accept uri (\req -> req {
HTTP.method = "POST",
HTTP.requestBody = HTTP.RequestBodyBS $ C8.pack query
- }
+ }) $ \resp -> do
+ let cookies = HTTP.responseCookieJar resp
+ putMVar (globalCookieJar session) cookies
+ writeFile (cookiesPath session) $ show $ HTTP.destroyCookieJar cookies
#endif
submitURL session mimes uri _method query = fetchURL' session mimes uri { uriQuery = '?':query }
@@ -259,7 +274,7 @@ fetchURL' Session {aboutPages = pages} _ url@URI {uriScheme = "about:", uriPath
#ifdef WITH_HTTP_URI
fetchURL' session accept uri | uriScheme uri `elem` ["http:", "https:"] =
- fetchHTTPCached session accept uri id
+ fetchHTTPCached session accept uri id (\_ -> return ())
#endif
#ifdef WITH_GEMINI_URI
@@ -361,14 +376,15 @@ dispatchByApp _ _ _ _ = return False
#endif
#ifdef WITH_HTTP_URI
-fetchHTTPCached session accept@(defaultMIME:_) uri cb = do
+fetchHTTPCached session accept@(defaultMIME:_) uri cbReq cbResp = do
cached <- if cachingEnabled session then readCacheHTTP uri else return (Nothing, Nothing)
response <- case cached of
(Just (mime, body), Nothing) -> return $ Right (mime, body)
(cached, cachingHeaders) -> do
request <- HTTP.requestFromURI uri
- let request' = cb request {
- HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form.
+ cookieJar <- readMVar $ globalCookieJar session
+ let request' = cbReq request {
+ HTTP.cookieJar = Just $ cookieJar,
HTTP.requestHeaders = [
("Accept", C8.pack $ intercalate ", " accept),
("Accept-Language", C8.pack $ intercalate ", " $ locale session)
@@ -376,6 +392,7 @@ fetchHTTPCached session accept@(defaultMIME:_) uri cb = do
HTTP.redirectCount = 0
}
response <- HTTP.httpLbs request $ managerHTTP session
+ cbResp response
case (
HTTP.responseStatus response,
HTTP.responseBody response,
@@ -406,7 +423,7 @@ fetchHTTPCached session accept@(defaultMIME:_) uri cb = do
let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime
in return $ resolveCharset' uri mime' body
`catch` \e -> do return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e)
-fetchHTTPCached session [] uri cb =
+fetchHTTPCached session [] uri _ _ =
return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ UnsupportedMIME "")
#endif