2 files changed, 35 insertions(+), 6 deletions(-)

M hurl.cabal
M src/Network/URI/Fetch.hs

@@ 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

@@ 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