summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2020-10-05 20:53:20 +1300
committerAdrian Cochrane <adrian@openwork.nz>2020-10-05 20:53:20 +1300
commit96f09fdcd64b6a6673e0efbddebd465e84ccd629 (patch)
tree05cd23b2225a2588b13eadacce869214c1fa3bc7
parent4371e0f3daceee0cd7d132f8587389f937636dcc (diff)
downloadhurl-96f09fdcd64b6a6673e0efbddebd465e84ccd629.tar.gz
hurl-96f09fdcd64b6a6673e0efbddebd465e84ccd629.tar.bz2
hurl-96f09fdcd64b6a6673e0efbddebd465e84ccd629.zip
Implement in-memory request logging.
-rw-r--r--hurl.cabal5
-rw-r--r--src/Network/URI/Fetch.hs36
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