1 files changed, 26 insertions(+), 4 deletions(-)

M 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