From 3cb0d7d7bd278aab25146280dc53fac36531769b Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 21 Jul 2021 13:48:04 +1200
Subject: [PATCH] Retroactively set cookies upon submitting POST requests to
 cater to CSRF protections.

---
 src/Network/URI/Fetch.hs | 30 ++++++++++++++++++++++++++----
 1 file 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
-- 
2.30.2