1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
{-# LANGUAGE OverloadedStrings #-}
module Network.URI.Cache(shouldCacheHTTP) where -- , storeCacheHTTP, writeCacheHTTP)
import Network.HTTP.Client
import Network.HTTP.Types.Status
import Network.HTTP.Types.Header
-- For escaping filepaths, since I already have this dependency
import Network.URI (escapeURIString, isUnescapedInURIComponent, URI, uriToString)
import Data.Time.Clock
import Data.Time.Format
import Data.ByteString as Strict
import Data.ByteString.Char8 as C
import Data.ByteString.Lazy as Lazy
import System.IO as IO
import System.FilePath
import System.Directory
import Data.Maybe (mapMaybe, listToMaybe, isJust, isNothing, fromMaybe)
import Data.Char (isSpace)
import Data.List as L
import Control.Monad (forM)
import Text.Read (readMaybe)
strip = C.dropWhile isSpace -- FIXME Upgrade bytestring dependency for a real strip function.
httpCacheDirective :: Response b -> Strict.ByteString -> Maybe Strict.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
uriToString' uri = uriToString id uri ""
parseHTTPTime str | ',' `L.elem` str = parseTimeM True defaultTimeLocale rfc822DateFormat str
parseHTTPTime str = parseTimeM True defaultTimeLocale "%_d %b %Y %H:%M:%S %Z" str
secondsFromNow i = do
now <- getCurrentTime
-- This ugliness required because regex depends on outdated version of time.
return $ addUTCTime (fromRational $ toRational $ secondsToDiffTime i) now
computeExpires :: Response a -> IO UTCTime
computeExpires resp
| Just header <- lookup hExpires $ responseHeaders resp,
Just time <- parseHTTPTime $ C.unpack header = return time
| Just pragma <- httpCacheDirective resp "max-age",
Just seconds <- readMaybe $ C.unpack pragma = secondsFromNow seconds
| otherwise = secondsFromNow (60*60*24) -- One day
cacheHTTP :: URI -> Response Lazy.ByteString -> IO ()
cacheHTTP uri resp | shouldCacheHTTP resp = do
expires <- computeExpires resp
write (uriToString' uri) ([
("mime", C.unpack $ fromMaybe "application/octet-stream" $
lookup "content-type" $ responseHeaders resp),
("expires", show expires)
], responseBody resp)
cacheHTTP _ _ = return ()
------
--- Key-value storage
------
read :: String -> IO ([(String, String)], Lazy.ByteString)
write :: String -> ([(String, String)], Lazy.ByteString) -> IO ()
openKey :: String -> IO.IOMode -> (Handle -> IO r) -> IO r
openKey key mode act = do
dir <- getXdgDirectory XdgCache "nz.geek.adrian.hurl"
IO.withFile (dir </> "http" </> escapeURIString isUnescapedInURIComponent key) mode act
read key = openKey key ReadMode parseHeaders
where
parseHeaders h = do
line <- IO.hGetLine h
case L.break isSpace $ strip' line of
("", "") -> do
body <- Lazy.hGetContents h
return ([], body)
(key, value) -> do
(headers, body) <- parseHeaders h
return ((key, strip' value):headers, body)
strip' = L.dropWhile isSpace . L.dropWhileEnd isSpace
write key (headers, body) = openKey key WriteMode $ \h -> do
forM headers $ \(key, value) -> do
IO.hPutStrLn h (key++' ':value)
IO.hPutStrLn h ""
Lazy.hPut h body
|
