From 96f09fdcd64b6a6673e0efbddebd465e84ccd629 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Mon, 5 Oct 2020 20:53:20 +1300
Subject: [PATCH] Implement in-memory request logging.

---
 hurl.cabal               |  5 +++--
 src/Network/URI/Fetch.hs | 36 ++++++++++++++++++++++++++++++++----
 2 files changed, 35 insertions(+), 6 deletions(-)

diff --git a/hurl.cabal b/hurl.cabal
index 26c330c..cce58ca 100644
--- a/hurl.cabal
+++ b/hurl.cabal
@@ -79,7 +79,7 @@ Flag appstream
   Manual:       True
 
 Flag rewriters
-  Description: Support regexp-based URI rewriting/blocking plugins
+  Description:  Support regexp-based URI rewriting/blocking plugins
   Default:		True
   Manual: 		True
 
@@ -100,7 +100,8 @@ library
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.9 && <=4.12, text >= 1.2 && <1.3,
                        network-uri >=2.6 && <2.7, bytestring >= 0.10 && < 0.11,
-                       async >= 2.1 && < 2.3, filepath, directory
+                       async >= 2.1 && < 2.3, filepath, directory,
+                       time >= 1.6 && < 1.7
   
   -- Directories containing source files.
   hs-source-dirs:      src
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index 0d86fb1..73866e6 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -26,6 +26,10 @@ import Text.Read (readMaybe)
 import System.Directory
 import System.FilePath
 
+-- for logging
+import Control.Concurrent.MVar
+import Data.Time.Clock
+
 #ifdef WITH_HTTP_URI
 import qualified Network.HTTP.Client as HTTP
 import qualified Network.HTTP.Client.TLS as TLS
@@ -69,9 +73,21 @@ data Session = Session {
     -- | The languages (RFC2616-encoded) to which responses should be localized.
     locale :: [String],
     -- | Additional files to serve from about: URIs.
-    aboutPages :: [(FilePath, ByteString)]
+    aboutPages :: [(FilePath, ByteString)],
+    -- | Log of timestamped/profiled URL requests
+    requestLog :: MVar [LogRecord]
 }
 
+data LogRecord = LogRecord {
+    url :: URI,
+    accept :: [String],
+    redirected :: URI,
+    mimetype :: String,
+    response :: Either Text ByteString,
+    begin :: UTCTime,
+    end :: UTCTime
+  }
+
 -- | Initializes a default Session object to support HTTPS & Accept-Language
 -- if HTTP is enabled.
 newSession :: IO Session
@@ -93,6 +109,7 @@ newSession' appname = do
 #ifdef WITH_PLUGIN_REWRITES
     rewriters <- parseRewriters appname
 #endif
+    log <- newEmptyMVar
 
     return Session {
 #ifdef WITH_HTTP_URI
@@ -108,7 +125,8 @@ newSession' appname = do
         rewriter = rewriters,
 #endif
         locale = ietfLocale,
-        aboutPages = []
+        aboutPages = [],
+        requestLog = log
     }
 
 llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key]
@@ -124,10 +142,20 @@ fetchURL sess mimes uri = do
     (_, mime, resp) <- fetchURL' sess mimes uri
     return (mime, resp)
 
+fetchURLLogged sess mimes uri = do
+    begin' <- getCurrentTime
+    res@(redirected', mimetype', response') <- fetchURL' sess mimes uri
+    end' <- getCurrentTime
+    modifyMVar_ (requestLog sess) $ \log -> return (
+        LogRecord uri mimes redirected' mimetype' response' begin' end' : log)
+    return res
+
 -- | Concurrently fetch given URLs.
 fetchURLs :: Session -> [String] -> [URI] -> ((URI, String, Either Text ByteString) -> IO a) -> IO [(URI, a)]
-fetchURLs sess mimes uris cb =
-    forConcurrently uris (\u -> fetchURL' sess mimes u >>= cb) >>= return . zip uris
+fetchURLs sess mimes uris cb = do
+    shouldntLog <- isEmptyMVar $ requestLog sess
+    let fetch = if shouldntLog then fetchURL' else fetchURLLogged
+    forConcurrently uris (\u -> fetch sess mimes u >>= cb) >>= return . zip uris
 
 -- | Internal MIMEtypes for error reporting
 mimeERR, htmlERR :: String
-- 
2.30.2