summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2021-07-21 13:48:04 +1200
committerAdrian Cochrane <adrian@openwork.nz>2021-07-21 13:48:04 +1200
commit3cb0d7d7bd278aab25146280dc53fac36531769b (patch)
tree77d7b588395fea6a2b2880c8cec4c3d8a667cb6f
parent349bb4b440f0f8f953925a215e16cfdf49b6eb49 (diff)
downloadhurl-3cb0d7d7bd278aab25146280dc53fac36531769b.tar.gz
hurl-3cb0d7d7bd278aab25146280dc53fac36531769b.tar.bz2
hurl-3cb0d7d7bd278aab25146280dc53fac36531769b.zip
Retroactively set cookies upon submitting POST requests to cater to CSRF protections.
-rw-r--r--src/Network/URI/Fetch.hs30
1 files changed, 26 insertions, 4 deletions
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index 8d52d83..45404b9 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -81,6 +81,7 @@ data Session = Session {
managerHTTP :: HTTP.Manager,
globalCookieJar :: MVar HTTP.CookieJar,
cookiesPath :: FilePath,
+ retroactiveCookies :: Maybe (MVar HTTP.CookieJar),
#endif
#ifdef WITH_RAW_CONNECTIONS
connCtxt :: TLS.SSLContext,
@@ -138,6 +139,7 @@ newSession' appname = do
now <- getCurrentTime
let cookies' = HTTP.createCookieJar $ fromMaybe [] cookies
cookieJar <- newMVar $ HTTP.evictExpiredCookies cookies' now
+ cookieJar' <- newMVar $ HTTP.createCookieJar []
#endif
#ifdef WITH_RAW_CONNECTIONS
connCtxt <- TLS.context
@@ -158,6 +160,7 @@ newSession' appname = do
managerHTTP = managerHTTP',
globalCookieJar = cookieJar,
cookiesPath = cookiesPath',
+ retroactiveCookies = Just cookieJar',
#endif
#ifdef WITH_RAW_CONNECTIONS
connCtxt = connCtxt,
@@ -201,7 +204,12 @@ fetchURLLogged log sess mimes uri = do
fetchURLs :: Session -> [String] -> [URI] -> ((URI, String, Either Text ByteString) -> IO a) -> IO [(URI, a)]
fetchURLs sess mimes uris cb = do
let fetch = case requestLog sess of {Nothing -> fetchURL'; Just log -> fetchURLLogged log}
- forConcurrently uris (\u -> fetch sess mimes u >>= cb) >>= return . L.zip uris
+ let sess' = sess {
+#ifdef WITH_HTTP_URI
+ retroactiveCookies = Nothing
+#endif
+ }
+ forConcurrently uris (\u -> fetch sess' mimes u >>= cb) >>= return . L.zip uris
-- | Internal MIMEtypes for error reporting
mimeERR, htmlERR :: String
@@ -210,8 +218,15 @@ 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:"] =
+submitURL session accept uri "POST" query | uriScheme uri `elem` ["http:", "https:"] = do
+ -- HURL is very strict on when it allows cookies to be set: Only POST HTTP requests are considered consent.
+ -- For the sake of most webframeworks' CSRF protection, cookies from retrieving the form are retroactively set.
+ csrfCookies <- case retroactiveCookies session of {
+ Just cookies -> Just <$> readMVar cookies;
+ Nothing -> return Nothing
+ }
fetchHTTPCached session accept uri (\req -> req {
+ HTTP.cookieJar = firstJust csrfCookies $ HTTP.cookieJar req,
HTTP.method = "POST",
HTTP.requestBody = HTTP.RequestBodyBS $ C8.pack query
}) $ \resp -> do
@@ -274,7 +289,11 @@ 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 (\_ -> return ())
+ fetchHTTPCached session accept uri id saveCookies
+ where
+ saveCookies resp
+ | Just cookies <- retroactiveCookies session = putMVar cookies $ HTTP.responseCookieJar resp
+ | otherwise = return ()
#endif
#ifdef WITH_GEMINI_URI
@@ -383,7 +402,7 @@ fetchHTTPCached session accept@(defaultMIME:_) uri cbReq cbResp = do
(cached, cachingHeaders) -> do
request <- HTTP.requestFromURI uri
cookieJar <- readMVar $ globalCookieJar session
- let request' = cbReq request {
+ let request' = cbReq $ request {
HTTP.cookieJar = Just $ cookieJar,
HTTP.requestHeaders = [
("Accept", C8.pack $ intercalate ", " accept),
@@ -492,3 +511,6 @@ writeLog out session = do
breakOn c (a:as) | c == a = ([], as)
| otherwise = let (x, y) = breakOn c as in (a:x, y)
breakOn _ [] = ([], [])
+
+firstJust a@(Just _) _ = a
+firstJust Nothing b = b