From 349bb4b440f0f8f953925a215e16cfdf49b6eb49 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 21 Jul 2021 12:57:35 +1200
Subject: [PATCH] Allow sites to cookies in response to HTTP POST requests.

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