summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2020-12-07 20:41:39 +1300
committerAdrian Cochrane <adrian@openwork.nz>2020-12-07 20:41:39 +1300
commita4ffbfc2089a8704a5bb76b4aeded612697c20f2 (patch)
treedd276d4befdf4401d58e7c32b8a51df5554744e0
parent9794e7d56e818c566264c7c9a806912e7943767e (diff)
downloadhurl-a4ffbfc2089a8704a5bb76b4aeded612697c20f2.tar.gz
hurl-a4ffbfc2089a8704a5bb76b4aeded612697c20f2.tar.bz2
hurl-a4ffbfc2089a8704a5bb76b4aeded612697c20f2.zip
Draft code to check whether to cachen an HTTP response.
-rw-r--r--hurl.cabal1
-rw-r--r--src/Network/URI/Cache.hs31
2 files changed, 32 insertions, 0 deletions
diff --git a/hurl.cabal b/hurl.cabal
index ac17106..e597ad9 100644
--- a/hurl.cabal
+++ b/hurl.cabal
@@ -113,6 +113,7 @@ library
CPP-options: -DWITH_HTTP_URI
build-depends: http-client, http-types >= 0.12 && <0.13,
http-client-openssl, HsOpenSSL
+ other-modules: Network.URI.Cache
if flag(gemini)
CPP-options: -DWITH_GEMINI_URI -DWITH_RAW_CONNECTIONS
build-depends: HsOpenSSL, openssl-streams >= 1.2 && < 1.3, io-streams >= 1.5 && < 1.6
diff --git a/src/Network/URI/Cache.hs b/src/Network/URI/Cache.hs
new file mode 100644
index 0000000..635826b
--- /dev/null
+++ b/src/Network/URI/Cache.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Network.URI.Cache(shouldCacheHTTP) where -- , storeCacheHTTP, writeCacheHTTP)
+import Network.HTTP.Client
+import Network.HTTP.Types.Status
+import Network.HTTP.Types.Header
+
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 as C
+
+import Data.Maybe (mapMaybe, listToMaybe, isJust, isNothing)
+import Data.Char (isSpace)
+
+strip = C.dropWhile isSpace -- FIXME Upgrade bytestring dependency for a real strip function.
+
+httpCacheDirective :: Response b -> ByteString -> Maybe ByteString
+httpCacheDirective response key | Just header <- lookup hCacheControl $ responseHeaders response =
+ let directives = Prelude.map strip $ C.split ',' header
+ in if key `Prelude.elem` directives
+ then Just ""
+ else listToMaybe $ mapMaybe (C.stripPrefix $ C.snoc key '=') directives
+ | otherwise = Nothing
+
+shouldCacheHTTP :: Response b -> Bool
+-- IETF RFC7234 Section 3
+shouldCacheHTTP response = -- Assume GET
+ statusCode (responseStatus response) `Prelude.elem` [200, 201, 404] && -- Supported response code
+ isNothing (httpCacheDirective response "no-store") && -- Honor no-store
+ True && -- This is a private cache, don't check for Cache-Control: private
+ (isJust (lookup hExpires $ responseHeaders response) || -- Support Expires: header
+ isJust (httpCacheDirective response "max-age") ||
+ isJust (httpCacheDirective response "public")) -- Override directive