freckle-http (empty) → 0.0.0.0
raw patch · 18 files changed
+2442/−0 lines, 18 filesdep +Blammodep +Globdep +aeson
Dependencies added: Blammo, Glob, aeson, annotated-exception, base, bytestring, case-insensitive, conduit, directory, errors, extra, filepath, freckle-http, freckle-memcached, hs-opentelemetry-api, hspec, hspec-expectations-json, hspec-expectations-lifted, http-client, http-conduit, http-link-header, http-types, lens, lens-aeson, memcache, monad-logger, monad-validate, mtl, network-uri, retry, safe, semigroupoids, serialise, text, time, transformers, unliftio, unordered-containers, zlib
Files
- CHANGELOG.md +5/−0
- LICENSE +21/−0
- README.md +1/−0
- freckle-http.cabal +134/−0
- library/Freckle/App/Http.hs +302/−0
- library/Freckle/App/Http/Cache.hs +341/−0
- library/Freckle/App/Http/Cache/Gzip.hs +62/−0
- library/Freckle/App/Http/Cache/Memcached.hs +151/−0
- library/Freckle/App/Http/Cache/State.hs +83/−0
- library/Freckle/App/Http/Header.hs +47/−0
- library/Freckle/App/Http/Paginate.hs +101/−0
- library/Freckle/App/Http/Retry.hs +101/−0
- library/Freckle/App/HttpSpec.hs +51/−0
- library/Freckle/App/Test/Http.hs +341/−0
- library/Freckle/App/Test/Http/MatchRequest.hs +187/−0
- package.yaml +112/−0
- tests/Freckle/App/Http/CacheSpec.hs +401/−0
- tests/Main.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-http-v0.0.0.0...main)++## [v0.0.0.0](https://github.com/freckle/freckle-app/tree/freckle-http-v0.0.0.0/freckle-http)++First release, sprouted from `freckle-app-1.19.0.0`.
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2024 Renaissance Learning Inc++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,1 @@+# freckle-http
+ freckle-http.cabal view
@@ -0,0 +1,134 @@+cabal-version: 1.18+name: freckle-http+version: 0.0.0.0+license: MIT+license-file: LICENSE+maintainer: Freckle Education+homepage: https://github.com/freckle/freckle-app#readme+bug-reports: https://github.com/freckle/freckle-app/issues+synopsis: ...+description: Please see README.md+category: Utils+build-type: Simple+extra-source-files: package.yaml+extra-doc-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/freckle/freckle-app++library+ exposed-modules:+ Freckle.App.Http+ Freckle.App.Http.Cache+ Freckle.App.Http.Cache.Gzip+ Freckle.App.Http.Cache.Memcached+ Freckle.App.Http.Cache.State+ Freckle.App.Http.Header+ Freckle.App.Http.Paginate+ Freckle.App.Http.Retry+ Freckle.App.HttpSpec+ Freckle.App.Test.Http+ Freckle.App.Test.Http.MatchRequest++ hs-source-dirs: library+ other-modules: Paths_freckle_http+ default-language: GHC2021+ default-extensions:+ DataKinds DeriveAnyClass DerivingVia DerivingStrategies+ DuplicateRecordFields GADTs LambdaCase NoImplicitPrelude+ NoMonomorphismRestriction OverloadedRecordDot OverloadedStrings+ RecordWildCards TypeFamilies++ ghc-options:+ -fignore-optim-changes -fwrite-ide-info -Weverything+ -Wno-all-missed-specialisations -Wno-missing-exported-signatures+ -Wno-missing-import-lists -Wno-missing-kind-signatures+ -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode+ -Wno-monomorphism-restriction -Wno-prepositive-qualified-module+ -Wno-safe -Wno-unsafe++ build-depends:+ Blammo >=2.0.0.0,+ Glob >=0.10.2,+ aeson >=2.0.3.0,+ annotated-exception >=0.2.0.4,+ base >=4.16.4.0 && <5,+ bytestring >=0.11.4.0,+ case-insensitive >=1.2.1.0,+ conduit >=1.3.5,+ directory >=1.3.6.2,+ errors >=2.3.0,+ extra >=1.7.13,+ filepath >=1.4.2.2,+ freckle-memcached >=0.0.0.1,+ hs-opentelemetry-api >=0.1.0.0,+ hspec >=2.8.1,+ http-client >=0.7.13.1,+ http-conduit >=2.3.5,+ http-link-header >=1.2.1,+ http-types >=0.12.3,+ lens >=5.1.1,+ lens-aeson >=1.2.2,+ memcache >=0.3.0.1,+ monad-logger >=0.3.40,+ monad-validate >=1.3.0.0,+ mtl >=2.2.2,+ network-uri >=2.6.4.2,+ retry >=0.8.1.0,+ safe >=0.3.19,+ semigroupoids >=5.3.7,+ serialise >=0.2.6.0,+ text >=1.2.5.0,+ time >=1.11.1.1,+ transformers >=0.5.6.2,+ unliftio >=0.2.25.0,+ unordered-containers >=0.2.19.1++ if impl(ghc >=9.8)+ ghc-options:+ -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: tests+ other-modules:+ Freckle.App.Http.CacheSpec+ Paths_freckle_http++ default-language: GHC2021+ default-extensions:+ DataKinds DeriveAnyClass DerivingVia DerivingStrategies+ DuplicateRecordFields GADTs LambdaCase NoImplicitPrelude+ NoMonomorphismRestriction OverloadedRecordDot OverloadedStrings+ RecordWildCards TypeFamilies++ ghc-options:+ -fignore-optim-changes -fwrite-ide-info -Weverything+ -Wno-all-missed-specialisations -Wno-missing-exported-signatures+ -Wno-missing-import-lists -Wno-missing-kind-signatures+ -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode+ -Wno-monomorphism-restriction -Wno-prepositive-qualified-module+ -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N++ build-depends:+ aeson >=2.0.3.0,+ base >=4.16.4.0 && <5,+ bytestring >=0.11.4.0,+ freckle-http,+ hspec >=2.10.10,+ hspec-expectations-json >=1.0.0.7,+ hspec-expectations-lifted >=0.10.0,+ http-types >=0.12.3,+ lens >=5.1.1,+ mtl >=2.2.2,+ time >=1.11.1.1,+ unordered-containers >=0.2.19.1,+ zlib >=0.6.3.0++ if impl(ghc >=9.8)+ ghc-options:+ -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures
+ library/Freckle/App/Http.hs view
@@ -0,0 +1,302 @@+-- | Centralized module for making HTTP requests+--+-- These functions:+--+-- - Do not throw exceptions on non-200+-- - May throw for other 'HttpException' cases (e.g. 'ConnectionTimeout')+-- - Capture decoding failures with 'Either' values as the 'Response' body+-- - Handle 429-@Retry-In@ for you (if using an 'IO'-based instance)+module Freckle.App.Http+ ( MonadHttp (..)++ -- * Decoding responses+ , httpJson+ , HttpDecodeError (..)+ , httpDecode++ -- * Pagination+ , httpPaginated+ , sourcePaginated++ -- * Request builders+ , Request+ , parseRequest+ , parseRequest_++ -- * Request modifiers+ , addRequestHeader+ , addAcceptHeader+ , addBearerAuthorizationHeader+ , addToRequestQueryString+ , setRequestBasicAuth+ , setRequestBodyJSON+ , setRequestBodyURLEncoded+ , setRequestCheckStatus+ , setRequestMethod+ , setRequestPath+ , disableRequestDecompress++ -- * Response accessors+ , Response+ , getResponseStatus+ , getResponseBody++ -- ** Unsafe access+ , getResponseBodyUnsafe++ -- * Exceptions+ , HttpException (..)+ -- | Predicates useful for handling 'HttpException's+ --+ -- For example, given a function 'guarded', which returns 'Just' a given value+ -- when a predicate holds for it (otherwise 'Nothing'), you can add+ -- error-handling specific to exceptions caused by 4XX responses:+ --+ -- @+ -- flip 'catchJust' (guard 'httpExceptionIsClientError' *> handle4XXError) $ do+ -- resp <- 'httpJson' $ 'setRequestCheckStatus' $ parseRequest_ "http://..."+ -- body <- 'getResponseBodyUnsafe' resp+ --+ -- -- ...+ -- @+ , httpExceptionIsInformational+ , httpExceptionIsRedirection+ , httpExceptionIsClientError+ , httpExceptionIsServerError++ -- * "Network.HTTP.Types" re-exports+ , Status+ , statusCode+ , statusIsInformational+ , statusIsSuccessful+ , statusIsRedirection+ , statusIsClientError+ , statusIsServerError+ , StdMethod (..)+ ) where++import Prelude++import Conduit (foldC, mapMC, runConduit, (.|))+import Control.Exception.Annotated.UnliftIO (Exception (..), throwWithCallStack)+import Control.Monad.Except (ExceptT)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (ReaderT)+import Control.Monad.State (StateT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT)+import Control.Monad.Validate (ValidateT)+import Control.Monad.Writer (WriterT)+import Data.Aeson (FromJSON)+import Data.Aeson qualified as Aeson+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as BSL+import Data.ByteString.Lazy.Char8 qualified as BSL8+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T+import Freckle.App.Http.Paginate+import Freckle.App.Http.Retry+import GHC.Stack (HasCallStack)+import Network.HTTP.Client qualified as HTTP (Request (..))+import Network.HTTP.Conduit (HttpExceptionContent (..))+import Network.HTTP.Simple hiding (httpLbs, httpNoBody, setRequestMethod)+import Network.HTTP.Simple qualified as HTTP+import Network.HTTP.Types (StdMethod (..), renderStdMethod)+import Network.HTTP.Types.Header (hAccept, hAuthorization)+import Network.HTTP.Types.Status+ ( Status+ , statusCode+ , statusIsClientError+ , statusIsInformational+ , statusIsRedirection+ , statusIsServerError+ , statusIsSuccessful+ )++-- | Type-class for making HTTP requests+--+-- Functions of this module require the 'MonadHttp' constraint. This type class+-- allows us to instantiate differently in different contexts, most usefully+-- with stubbed responses in test. (See "Freckle.App.Test.Http".)+--+-- The 'IO' instance does what you would expect, and can be used to either build+-- your own instances:+--+-- @+-- instance MonadIO m => MonadHttp (AppT m) where+-- httpLbs = liftIO . httpLbs+--+-- instance MonadHttp (HandlerFor App) where+-- httpLbs = liftIO . httpLbs+-- @+--+-- Or directly,+--+-- @+-- resp <- liftIO $ httpLbs ...+-- @+class Monad m => MonadHttp m where+ httpLbs :: Request -> m (Response BSL.ByteString)++instance MonadHttp IO where+ httpLbs = rateLimited HTTP.httpLbs++instance MonadHttp m => MonadHttp (MaybeT m) where+ httpLbs = lift . httpLbs++instance MonadHttp m => MonadHttp (ReaderT r m) where+ httpLbs = lift . httpLbs++instance (Monoid w, MonadHttp m) => MonadHttp (WriterT w m) where+ httpLbs = lift . httpLbs++instance MonadHttp m => MonadHttp (StateT s m) where+ httpLbs = lift . httpLbs++instance MonadHttp m => MonadHttp (ExceptT e m) where+ httpLbs = lift . httpLbs++instance MonadHttp m => MonadHttp (ValidateT e m) where+ httpLbs = lift . httpLbs++data HttpDecodeError = HttpDecodeError+ { hdeBody :: BSL.ByteString+ , hdeErrors :: NonEmpty String+ }+ deriving stock (Eq, Show)++instance Exception HttpDecodeError where+ displayException HttpDecodeError {..} =+ T.unpack $+ T.unlines $+ ["Error decoding HTTP Response:", "Raw body:", T.pack $ BSL8.unpack hdeBody]+ <> fromErrors hdeErrors+ where+ fromErrors = \case+ err NE.:| [] -> ["Error:", T.pack err]+ errs -> "Errors:" : map (bullet . T.pack) (NE.toList errs)+ bullet = (" • " <>)++-- | Make a request and parse the body as JSON+--+-- @+-- -- Throws, but only on a complete failure to perform the request+-- resp <- 'httpJson' $ 'parseRequest_' "https://example.com"+--+-- -- Safe access+-- 'getResponseBody' resp :: Either 'HttpDecodeError' a+--+-- -- Unsafe access (throws on Left)+-- 'getResponseBodyUnsafe' resp :: m a+-- @+httpJson+ :: (MonadHttp m, FromJSON a)+ => Request+ -> m (Response (Either HttpDecodeError a))+httpJson =+ httpDecode (first pure . Aeson.eitherDecode)+ . addAcceptHeader "application/json"++-- | Make a request and decode the body using the given function+--+-- This be used to request other formats, e.g. CSV.+httpDecode+ :: MonadHttp m+ => (BSL.ByteString -> Either (NonEmpty String) a)+ -> Request+ -> m (Response (Either HttpDecodeError a))+httpDecode decode req = do+ resp <- httpLbs req+ let body = getResponseBody resp+ pure $ first (HttpDecodeError body) . decode <$> resp++-- | Request all pages of a paginated endpoint into some 'Monoid'+--+-- For example,+--+-- Interact with a paginated endpoint where each page is a JSON list, combining+-- all the pages into one list (i.e. 'concat') and throw on any decoding errors:+--+-- @+-- 'httpPaginated' 'httpJson' 'getResponseBodyUnsafe' $ 'parseRequest_' "https://..."+-- @+--+-- This uses 'sourcePaginated', and so reads a @Link@ header. To do otherwise,+-- drop down to 'sourcePaginatedBy' directly.+--+-- The second argument is used to extract the data to combine out of the+-- response. This is particularly useful for 'Either' values, like you may get+-- from 'httpJson'. It lives in @m@ to support functions such as+-- 'getResponseBodyUnsafe'.+--+-- Decoding errors can be handled differently by adjusting what 'Monoid' you+-- convert each page's response into:+--+-- @+-- 'httpPaginated' 'httpJson' fromResponseLenient $ 'parseRequest_' "https://..."+--+-- fromResponseLenient+-- :: MonadLogger m+-- => Response (Either e [MyJsonThing])+-- -> m [MyJsonThing]+-- fromResponseLenient r = case getResponseBody r of+-- Left _ -> [] <$ logWarn "..."+-- Right a -> pure a+-- @+--+-- See "Freckle.Http.App.Paginate" to process requested pages in a streaming+-- fashion, or perform pagination based on somethign other than @Link@.+httpPaginated+ :: (MonadHttp m, Monoid b)+ => (Request -> m (Response a))+ -> (Response a -> m b)+ -> Request+ -> m b+httpPaginated runRequest getBody req =+ runConduit $ sourcePaginated runRequest req .| mapMC getBody .| foldC++addAcceptHeader :: ByteString -> Request -> Request+addAcceptHeader = addRequestHeader hAccept++addBearerAuthorizationHeader :: ByteString -> Request -> Request+addBearerAuthorizationHeader = addRequestHeader hAuthorization . ("Bearer " <>)++setRequestMethod :: StdMethod -> Request -> Request+setRequestMethod method req = req {HTTP.method = renderStdMethod method}++disableRequestDecompress :: Request -> Request+disableRequestDecompress req =+ req+ { HTTP.decompress = const False+ }++-- | Read an 'Either' response body, throwing any 'Left' as an exception+--+-- If you plan to use this function, and haven't built your decoding to handle+-- error response bodies too, you'll want to use 'setRequestCheckStatus' so that+-- you see status-code exceptions before 'HttpDecodeError's.+getResponseBodyUnsafe+ :: (MonadIO m, Exception e, HasCallStack)+ => Response (Either e a)+ -> m a+getResponseBodyUnsafe = either throwWithCallStack pure . getResponseBody++httpExceptionIsInformational :: HttpException -> Bool+httpExceptionIsInformational = filterStatusException statusIsInformational++httpExceptionIsRedirection :: HttpException -> Bool+httpExceptionIsRedirection = filterStatusException statusIsRedirection++httpExceptionIsClientError :: HttpException -> Bool+httpExceptionIsClientError = filterStatusException statusIsClientError++httpExceptionIsServerError :: HttpException -> Bool+httpExceptionIsServerError = filterStatusException statusIsServerError++filterStatusException :: (Status -> Bool) -> HttpException -> Bool+filterStatusException predicate = \case+ HttpExceptionRequest _ (StatusCodeException resp _) ->+ predicate $ getResponseStatus resp+ _ -> False
+ library/Freckle/App/Http/Cache.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE NoFieldSelectors #-}++-- | Cache HTTP responses like a CDN or browser would+module Freckle.App.Http.Cache+ ( HttpCacheSettings (..)+ , HttpCacheCodec (..)+ , HttpCache (..)+ , httpCached+ , CachedResponse (..)+ , PotentiallyGzipped+ ) where++import Prelude++import Blammo.Logging (Message (..), (.=))+import Control.Applicative ((<|>))+import Control.Exception.Annotated.UnliftIO (SomeException, displayException)+import Control.Monad (guard)+import Control.Monad.IO.Class (MonadIO)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as BSL+import Data.CaseInsensitive qualified as CI+import Data.Foldable (for_)+import Data.List.Extra (firstJust)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text.Encoding qualified as T+import Data.Text.Encoding.Error qualified as T+import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, parseTimeM)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Freckle.App.Http.Cache.Gzip+import Freckle.App.Http.Header+import Freckle.App.Memcached+import Network.HTTP.Client (Request, Response)+import Network.HTTP.Client qualified as HTTP+import Network.HTTP.Simple+ ( addRequestHeader+ , getRequestHeader+ , getResponseStatus+ )+import Network.HTTP.Types.Header+ ( HeaderName+ , hAge+ , hCacheControl+ , hETag+ , hExpires+ , hIfNoneMatch+ , hVary+ )+import Network.HTTP.Types.Status (Status, statusCode)+import Text.Read (readMaybe)++data HttpCacheSettings m t = HttpCacheSettings+ { shared :: Bool+ , cacheable :: Request -> Bool+ , defaultTTL :: CacheTTL+ , getCurrentTime :: m UTCTime+ , logDebug :: Message -> m ()+ , logWarn :: Message -> m ()+ , codec :: HttpCacheCodec t+ , cache :: HttpCache m t+ }++data HttpCacheCodec t = HttpCacheCodec+ { serialise :: CachedResponse -> t+ , deserialise :: Request -> t -> Either String CachedResponse+ }++data HttpCache m t = HttpCache+ { get :: CacheKey -> m (Either SomeException (Maybe t))+ , set :: CacheKey -> t -> m (Either SomeException ())+ , evict :: CacheKey -> m (Either SomeException ())+ }++data CachedResponse = CachedResponse+ { response :: Response (PotentiallyGzipped BSL.ByteString)+ , inserted :: UTCTime+ , ttl :: CacheTTL+ }+ deriving stock (Show)++isCachedResponseStale :: CachedResponse -> UTCTime -> Bool+isCachedResponseStale cached now =+ addUTCTime (fromIntegral cached.ttl) cached.inserted < now++-- Wrap a function from "Freckle.App.Http" with caching+--+-- Verify that the request is cacheable (e.g. a @GET@), then cache it at a+-- derived key (from URL and considering any @Vary@ headers). The response will+-- only be cached if @Cache-Control@ allows it. @Cache-Control@ is also used to+-- determine TTL (e.g. @max-age@)+--+-- - <https://developer.mozilla.org/en-US/docs/Web/HTTP/Caching#vary>+-- - <https://developer.mozilla.org/en-US/docs/Web/HTTP/Caching#fresh_and_stale_based_on_age>+--+-- If a cached response is stale, but it has an @ETag@ header, we will make the+-- request using @If-None-Match@ and still return (and retain) that cached+-- response if we receive a @304@ response.+--+-- - <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/ETag#caching_of_unchanged_resources>+--+httpCached+ :: forall m t+ . MonadIO m+ => HttpCacheSettings m t+ -> (Request -> m (Response BSL.ByteString))+ -> Request+ -> m (Response BSL.ByteString)+httpCached settings doHttp req =+ maybe (doHttp req) handleCachableRequest $ getCachableRequestKey settings req+ where+ handleCachableRequest key = do+ now <- settings.getCurrentTime+ result <- fromEx Nothing $ settings.cache.get key++ let tkey = T.decodeUtf8With T.lenientDecode $ fromCacheKey key++ case result of+ Nothing -> do+ settings.logDebug $ "Cache miss" :# ["key" .= tkey]+ writeCache now key =<< getResponse req+ Just val -> do+ settings.logDebug $ "Cache hit" :# ["key" .= tkey]+ case settings.codec.deserialise req val of+ Left err -> do+ settings.logWarn $ "Error deserialising" :# ["error" .= err]+ writeCache now key =<< getResponse req+ Right cresp | isCachedResponseStale cresp now -> do+ settings.logDebug $+ "Cached value stale"+ :# [ "key" .= tkey+ , "inserted" .= cresp.inserted+ , "ttl" .= fromCacheTTL cresp.ttl+ , "now" .= now+ ]+ case lookupHeader hETag cresp.response of+ Nothing -> do+ fromEx () $ settings.cache.evict key+ writeCache now key =<< getResponse req+ Just etag -> do+ settings.logDebug $+ "Retrying with If-None-Match"+ :# [ "key" .= tkey+ , "etag" .= T.decodeUtf8With T.lenientDecode etag+ ]+ resp <- getResponse $ addRequestHeader hIfNoneMatch etag req+ case statusCode (getResponseStatus resp) of+ 304 -> do+ settings.logDebug "ETag matched (304), retaining cached response"++ -- We want to rewrite the cache entry based on Cache-Control+ -- from base do now. Otherwise, we'll continue to treat it+ -- as stale and do this 304 dance every time. But we use the+ -- Cache-Control header from this response, in case it+ -- differs+ writeCache now key $ setCacheControlFrom resp cresp.response+ _ -> do+ settings.logDebug "ETag not matched, evicting cache"+ fromEx () $ settings.cache.evict key+ writeCache now key resp+ Right cresp -> gunzipResponseBody req cresp.response++ getResponse :: Request -> m (Response (PotentiallyGzipped BSL.ByteString))+ getResponse = requestPotentiallyGzipped doHttp++ writeCache+ :: UTCTime+ -> CacheKey+ -> Response (PotentiallyGzipped BSL.ByteString)+ -> m (Response BSL.ByteString)+ writeCache now key resp = do+ for_ (getCachableResponseTTL settings resp) $ \ttl -> do+ settings.logDebug $+ "Write cache"+ :# [ "key" .= T.decodeUtf8With T.lenientDecode (fromCacheKey key)+ , "ttl" .= fromCacheTTL ttl+ ]+ let cresp = CachedResponse {response = resp, inserted = now, ttl = ttl}+ fromEx () $ settings.cache.set key $ settings.codec.serialise cresp++ gunzipResponseBody req resp++ fromEx :: a -> m (Either SomeException a) -> m a+ fromEx a f = do+ result <- f+ case result of+ Left ex -> do+ settings.logWarn $ "Caching error" :# ["error" .= displayException ex]+ pure a+ Right v -> pure v++-- | Return a 'CacheKey' for a 'Request', if it's cacheable+--+-- A 'Request' is cacheable if all are true:+--+-- - The given predicate succeeds+-- - The method is @GET@+-- - A @Cache-Control@ header with @no-store@ is not present+--+-- If cacheable, the 'CacheKey' is built from: method, scheme, host, port, path,+-- query + any @Vary@ headers.+getCachableRequestKey+ :: HttpCacheSettings m t -> Request -> Maybe CacheKey+getCachableRequestKey settings req = do+ guard $ settings.cacheable req+ guard $ HTTP.method req == "GET"+ guard $ NoStore `notElem` requestHeaders.cacheControl+ guard $ not settings.shared || Private `notElem` requestHeaders.cacheControl+ pure $ md5CacheKey cacheKeyAttributes+ where+ requestHeaders = getRequestHeaders req++ cacheKeyAttributes =+ ( HTTP.method req+ , HTTP.secure req+ , HTTP.host req+ , HTTP.port req+ , HTTP.path req+ , HTTP.queryString req+ , concatMap (`getRequestHeader` req) requestHeaders.vary+ )++-- | Return a 'CacheTTL' for a 'Response', if it's cacheable+--+-- A 'Response' is cacheable if all are true:+--+-- - A @Cache-Control@ header with @no-store@ is not present+-- - If the cache is shared (first argument), a @Cache-Control@ header with+-- @private@ is not preset+-- - The response has a cacheable status code+--+-- If cacheable, the @Cache-Control[max-age]@, @Age@, and @Expires@ response+-- headers are used to compute the 'CacheTTL'.+getCachableResponseTTL+ :: HttpCacheSettings m t -> Response body -> Maybe CacheTTL+getCachableResponseTTL settings resp = do+ guard $ NoStore `notElem` responseHeaders.cacheControl+ guard $+ not settings.shared || Private `notElem` responseHeaders.cacheControl+ guard $ statusIsCacheable $ HTTP.responseStatus resp+ pure $ fromMaybe settings.defaultTTL $ responseHeadersToTTL responseHeaders+ where+ responseHeaders = getResponseHeaders resp++statusIsCacheable :: Status -> Bool+statusIsCacheable = (`elem` cacheableStatusCodes) . statusCode++-- | As per RFC 7231+--+-- <https://stackoverflow.com/a/39406969>+cacheableStatusCodes :: [Int]+cacheableStatusCodes =+ [ 200 -- OK+ , 203 -- Non-Authoritative Information+ , 204 -- No Content+ , 206 -- Partial Content+ , 300 -- Multiple Choices+ , 301 -- Moved Permanently+ , 404 -- Not Found+ , 405 -- Method Not Allowed+ , 410 -- Gone+ , 414 -- URI Too Long+ , 501 -- Not Implemented+ ]++newtype Seconds = Seconds {unwrap :: Int}+ deriving stock (Eq)+ deriving newtype (Num, Show, Read)++data CacheControl+ = Private+ | NoStore+ | MaxAge Seconds+ deriving stock (Eq, Show)++cacheControlMaxAge :: [CacheControl] -> Maybe Seconds+cacheControlMaxAge = firstJust $ \case+ MaxAge s -> Just s+ _ -> Nothing++readCacheControl :: ByteString -> Maybe CacheControl+readCacheControl = go . CI.foldCase+ where+ go = \case+ "private" -> Just Private+ "no-store" -> Just NoStore+ h | Just s <- BS8.stripPrefix "max-age=" h -> MaxAge <$> readMaybe (BS8.unpack s)+ _ -> Nothing++getCacheControl :: HasHeaders a => a -> [CacheControl]+getCacheControl = mapMaybe readCacheControl . getHeaderCsv hCacheControl++setCacheControlFrom :: Response a -> Response b -> Response b+setCacheControlFrom from to =+ to+ { HTTP.responseHeaders = toNonCCHeader <> fromCCHeader+ }+ where+ fromCCHeader = filter ((== hCacheControl) . fst) $ getHeaders from+ toNonCCHeader = filter ((/= hCacheControl) . fst) $ getHeaders to++data RequestHeaders = RequestHeaders+ { cacheControl :: [CacheControl]+ , vary :: [HeaderName]+ }++getRequestHeaders :: Request -> RequestHeaders+getRequestHeaders req =+ RequestHeaders+ { cacheControl = getCacheControl req+ , vary = map CI.mk $ concatMap splitHeader $ getRequestHeader hVary req+ }++data ResponseHeaders = ResponseHeaders+ { cacheControl :: [CacheControl]+ , age :: Seconds+ -- ^ Defaults to 0 if missing+ , expires :: Maybe UTCTime+ }++getResponseHeaders :: Response body -> ResponseHeaders+getResponseHeaders resp =+ ResponseHeaders+ { cacheControl = getCacheControl resp+ , age = fromMaybe 0 $ do+ h <- lookupHeader hAge resp+ readMaybe $ BS8.unpack h+ , expires = do+ h <- lookupHeader hExpires resp+ parseTimeM True defaultTimeLocale httpDateFormat $ BS8.unpack h+ }++-- | <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Date#syntax>+httpDateFormat :: String+httpDateFormat = "%a, %d %b %Y %H:%M:%S GMT"++responseHeadersToTTL :: ResponseHeaders -> Maybe CacheTTL+responseHeadersToTTL hs = cacheTTL . (.unwrap) <$> viaMaxAge <|> viaExpires+ where+ viaMaxAge = subtract hs.age <$> cacheControlMaxAge hs.cacheControl+ viaExpires = round . utcTimeToPOSIXSeconds <$> hs.expires
+ library/Freckle/App/Http/Cache/Gzip.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE NoFieldSelectors #-}++-- | Type and functions for handling gzipped HTTP responses+--+-- In order to optimize caching of responses in storage with size limitations,+-- we cache gzipped responses as-is. This requires disabling the automatic+-- decompression of @http-client@ and handling it ourselves.+--+-- The module makes that a type-enforced process:+--+-- - 'requestPotentiallyGzipped' is the only way to get a 'PotentiallyGzipped'+-- - Which is the type needed for the response field in 'CachedResponse'+-- - 'gunzipResponseBody' is the only way to erase 'PotentiallyGzipped'+-- - Which is what you actually need to return+module Freckle.App.Http.Cache.Gzip+ ( PotentiallyGzipped+ , requestPotentiallyGzipped+ , gunzipResponseBody+ ) where++import Prelude++import Codec.Serialise (Serialise)+import Control.Monad.IO.Class+import Data.ByteString.Lazy qualified as BSL+import Freckle.App.Http (disableRequestDecompress)+import Freckle.App.Http.Header+import Network.HTTP.Client (Request, Response)+import Network.HTTP.Client.Internal qualified as HTTP++newtype PotentiallyGzipped a = PotentiallyGzipped+ { unwrap :: a+ }+ deriving stock (Show, Eq)+ deriving newtype (Serialise)++-- | Run a request /without/ automatic 'decompress' and tag the @body@ type+requestPotentiallyGzipped+ :: Functor m+ => (Request -> m (Response body))+ -> Request+ -> m (Response (PotentiallyGzipped body))+requestPotentiallyGzipped doHttp =+ fmap (fmap PotentiallyGzipped) . doHttp . disableRequestDecompress++-- | Gunzip a 'PotentiallyGzipped' body, if necessary+gunzipResponseBody+ :: MonadIO m+ => Request+ -> Response (PotentiallyGzipped BSL.ByteString)+ -> m (Response BSL.ByteString)+gunzipResponseBody req resp+ | HTTP.needsGunzip req (getHeaders resp) = liftIO $ do+ body <- gunzipBody $ HTTP.responseBody resp+ pure $ body <$ resp+ | otherwise = pure $ (.unwrap) <$> resp++gunzipBody :: PotentiallyGzipped BSL.ByteString -> IO BSL.ByteString+gunzipBody body = do+ body1 <- HTTP.constBodyReader $ BSL.toChunks body.unwrap+ reader' <- HTTP.makeGzipReader body1+ BSL.fromChunks <$> HTTP.brConsume reader'
+ library/Freckle/App/Http/Cache/Memcached.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Freckle.App.Http.Cache.Memcached+ ( memcachedHttpCacheSettings+ , memcachedHttpCodec+ , memcachedHttpCache+ ) where++import Prelude++import Blammo.Logging (MonadLogger, logDebugNS, logWarnNS)+import Codec.Serialise (Serialise (..), deserialiseOrFail, serialise)+import Control.Exception.Annotated.UnliftIO (try)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (MonadReader)+import Data.Bifunctor (bimap)+import Data.ByteString.Lazy qualified as BSL+import Data.CaseInsensitive (CI)+import Data.CaseInsensitive qualified as CI+import Data.Time (UTCTime, getCurrentTime)+import Database.Memcache.Types (Value)+import Freckle.App.Http.Cache+import Freckle.App.Memcached+import Freckle.App.Memcached.Client qualified as Memcached+import GHC.Generics (Generic)+import Network.HTTP.Client (Request)+import Network.HTTP.Client.Internal qualified as HTTP+import Network.HTTP.Types.Header (ResponseHeaders)+import Network.HTTP.Types.Status (Status (..))+import Network.HTTP.Types.Version (HttpVersion (..))+import OpenTelemetry.Trace.Monad (MonadTracer (..))+import UnliftIO (MonadUnliftIO)++memcachedHttpCacheSettings+ :: ( MonadUnliftIO m+ , MonadLogger m+ , MonadTracer m+ , MonadReader env m+ , HasMemcachedClient env+ )+ => CacheTTL+ -- ^ Default TTL, used when @max-age@ is not present+ -> HttpCacheSettings m Value+memcachedHttpCacheSettings defaultTTL =+ HttpCacheSettings+ { shared = True+ , cacheable = const True+ , defaultTTL+ , getCurrentTime = liftIO getCurrentTime+ , logDebug = logDebugNS "http.cache"+ , logWarn = logWarnNS "http.cache"+ , codec = memcachedHttpCodec+ , cache = memcachedHttpCache+ }++memcachedHttpCodec :: HttpCacheCodec Value+memcachedHttpCodec =+ HttpCacheCodec+ { serialise = BSL.toStrict . serialise . fromResponse+ , deserialise = \req ->+ bimap show (toResponse req)+ . deserialiseOrFail+ . BSL.fromStrict+ }++memcachedHttpCache+ :: ( MonadUnliftIO m+ , MonadTracer m+ , MonadReader env m+ , HasMemcachedClient env+ )+ => HttpCache m Value+memcachedHttpCache =+ HttpCache+ { get = try . Memcached.get+ , set = \k v -> try $ Memcached.set k v 0+ , evict = try . Memcached.delete+ }++-- | Representation of 'CachedResponse' that can be given a 'Serialise' instance+--+-- In 'fromResponse' we need to flatten the 'Response' down and remove fields+-- that can't (or shouldn't) be cached, then restore them again later in+-- 'toResponse'.+data SerialiseResponse = SerialiseResponse+ { sresponseStatus :: Status+ , sresponseVersion :: HttpVersion+ , sresponseHeaders :: ResponseHeaders+ , sresponseBody :: PotentiallyGzipped BSL.ByteString+ , sresponseEarlyHints :: ResponseHeaders+ , sinserted :: UTCTime+ , sttl :: CacheTTL+ }+ deriving stock (Generic)+ deriving anyclass (Serialise)++{- FOURMOLU_DISABLE -}+-- Fourmolu has trouble with this bit of CPP++toResponse :: Request -> SerialiseResponse -> CachedResponse+toResponse req c = CachedResponse+ { response = HTTP.Response+ { HTTP.responseStatus = sresponseStatus c+ , HTTP.responseVersion = sresponseVersion c+ , HTTP.responseHeaders = sresponseHeaders c+ , HTTP.responseBody = sresponseBody c+ , HTTP.responseCookieJar = mempty+ , HTTP.responseClose' = HTTP.ResponseClose (pure ())+ , HTTP.responseOriginalRequest = req+#if MIN_VERSION_http_client(0,7,16)+ , HTTP.responseEarlyHints = sresponseEarlyHints c+#endif+ }+ , inserted = c.sinserted+ , ttl = c.sttl+ }++fromResponse :: CachedResponse -> SerialiseResponse+fromResponse cr =+ SerialiseResponse+ { sresponseStatus = HTTP.responseStatus r+ , sresponseVersion = HTTP.responseVersion r+ , sresponseHeaders = HTTP.responseHeaders r+ , sresponseBody = HTTP.responseBody r+#if MIN_VERSION_http_client(0,7,16)+ , sresponseEarlyHints = HTTP.responseEarlyHints r+#else+ , sresponseEarlyHints = []+#endif+ , sinserted = cr.inserted+ , sttl = cr.ttl+ }+ where+ r = cr.response++#if !MIN_VERSION_http_types(0,12,4)+deriving stock instance Generic HttpVersion++deriving stock instance Generic Status+#endif++{- FOURMOLU_ENABLE -}++deriving anyclass instance Serialise HttpVersion++deriving anyclass instance Serialise Status++instance (CI.FoldCase a, Serialise a) => Serialise (CI a) where+ encode = encode . CI.original+ decode = CI.mk <$> decode
+ library/Freckle/App/Http/Cache/State.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE NoFieldSelectors #-}++-- | HTTP caching via 'MonadState'+--+-- This module implements HTTP caching for simple use-cases, such as testing+-- "Freckle.App.Http.Cache" itself.+module Freckle.App.Http.Cache.State+ ( CachedResponse (..)+ , Cache (..)+ , HasCache (..)+ , stateHttpCacheSettings+ , stateHttpCacheCodec+ , stateHttpCache+ ) where++import Prelude++import Blammo.Logging (Message)+import Control.Lens (Lens', at, lens, use, (.=), (?=))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (ToLogStr (..), fromLogStr)+import Control.Monad.State (MonadState)+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Data.Text.Encoding.Error qualified as T+import Data.Text.IO qualified as T+import Data.Time (getCurrentTime)+import Freckle.App.Http.Cache+import Freckle.App.Memcached.CacheKey+import Freckle.App.Memcached.CacheTTL+import System.IO qualified as IO++newtype Cache = Cache+ { map :: HashMap CacheKey CachedResponse+ }+ deriving newtype (Semigroup, Monoid)++mapL :: Lens' Cache (HashMap CacheKey CachedResponse)+mapL = lens (.map) $ \x y -> x {map = y}++class HasCache env where+ cacheL :: Lens' env Cache++instance HasCache Cache where+ cacheL = id++stateHttpCacheSettings+ :: ( MonadIO m+ , MonadState s m+ , HasCache s+ )+ => HttpCacheSettings m CachedResponse+stateHttpCacheSettings =+ HttpCacheSettings+ { shared = False+ , cacheable = const True+ , defaultTTL = fiveMinuteTTL+ , getCurrentTime = liftIO getCurrentTime+ , logDebug = \_ -> pure ()+ , logWarn = liftIO . T.hPutStrLn IO.stderr . messageToText+ , codec = stateHttpCacheCodec+ , cache = stateHttpCache+ }++stateHttpCacheCodec :: HttpCacheCodec CachedResponse+stateHttpCacheCodec =+ HttpCacheCodec+ { serialise = id+ , deserialise = const Right+ }++stateHttpCache+ :: (MonadIO m, MonadState s m, HasCache s) => HttpCache m CachedResponse+stateHttpCache =+ HttpCache+ { get = \key -> fmap Right $ use $ cacheL . mapL . at key+ , set = \key resp -> fmap Right $ cacheL . mapL . at key ?= resp+ , evict = \key -> fmap Right $ cacheL . mapL . at key .= Nothing+ }++messageToText :: Message -> Text+messageToText = T.decodeUtf8With T.lenientDecode . fromLogStr . toLogStr
+ library/Freckle/App/Http/Header.hs view
@@ -0,0 +1,47 @@+module Freckle.App.Http.Header+ ( HasHeaders (..)+ , getHeaderCsv+ , lookupHeader++ -- * Utilities+ , splitHeader+ ) where++import Prelude++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS8+import Data.Char (isSpace)+import Data.Maybe (listToMaybe)+import Network.HTTP.Client (Request, Response, requestHeaders, responseHeaders)+import Network.HTTP.Simple (getRequestHeader, getResponseHeader)+import Network.HTTP.Types.Header (Header, HeaderName)++class HasHeaders a where+ getHeaders :: a -> [Header]++ getHeader :: HeaderName -> a -> [ByteString]+ getHeader h = map snd . filter ((== h) . fst) . getHeaders++instance HasHeaders [Header] where+ getHeaders = id++instance HasHeaders Request where+ getHeaders = requestHeaders+ getHeader = getRequestHeader++instance HasHeaders (Response body) where+ getHeaders = responseHeaders+ getHeader = getResponseHeader++getHeaderCsv :: HasHeaders a => HeaderName -> a -> [ByteString]+getHeaderCsv hn = concatMap splitHeader . getHeader hn++splitHeader :: ByteString -> [ByteString]+splitHeader = map trimSpace . BS8.split ','++trimSpace :: ByteString -> ByteString+trimSpace = BS8.dropWhile isSpace . BS8.dropWhileEnd isSpace++lookupHeader :: HasHeaders a => HeaderName -> a -> Maybe ByteString+lookupHeader h = listToMaybe . getHeader h
+ library/Freckle/App/Http/Paginate.hs view
@@ -0,0 +1,101 @@+-- | Streaming interface for paginated HTTP APIs+--+-- == Examples+--+-- Take an action on each page as it is requested:+--+-- @+-- let req = parseRequest_ "https://..."+--+-- runConduit+-- $ sourcePaginated httpJson req+-- .| mapM_C onEachPage+--+-- onEachPage :: Response (Either HttpDecodeError [MyJsonThing]) -> m ()+-- onEachPage = undefined+-- @+--+-- Take and action /and/ collect:+--+-- @+-- allPages <- runConduit+-- $ 'sourcePaginated' httpJson req+-- .| iterM onEachPage+-- .| sinkList+-- @+--+-- For APIs that do pagination not via @Link@, you can use 'sourcePaginatedBy'+--+-- @+-- data Page a = Page+-- { pData :: [a]+-- , pNext :: Int+-- }+--+-- instance FromJSON a => FromJSON (Item a) where+-- parseJSON = withObject "Page" $ \o -> Page+-- <$> o .: "data"+-- <*> o .: "next"+--+-- runConduit+-- $ 'sourcePaginatedBy' nextPage httpJson req+-- .| mapMC (fmap pData . 'getResponseBodyUnsafe')+-- .| foldC+--+-- nextPage+-- :: Request+-- -> Response (Either ('HttpDecodeError' String) (Page a))+-- -> Maybe Request+-- nextPage req resp = do+-- body <- hush $ getResponseBody resp+-- let next = C8.pack $ show $ pNext body+-- pure $ addToRequestQueryString [("next", Just next)] req+-- @+module Freckle.App.Http.Paginate+ ( sourcePaginated+ , sourcePaginatedBy+ ) where++import Prelude++import Conduit+import Control.Error.Util (hush)+import Data.Foldable (traverse_)+import Data.List (find)+import Data.Maybe (listToMaybe)+import Data.Text.Encoding (decodeUtf8)+import Network.HTTP.Link hiding (linkHeader)+import Network.HTTP.Simple+import Network.URI (URI)++-- | Stream pages of a paginated response, using @Link@ to find next pages+sourcePaginated+ :: Monad m+ => (Request -> m (Response body))+ -- ^ Run one request+ -> Request+ -- ^ Initial request+ -> ConduitT i (Response body) m ()+sourcePaginated = sourcePaginatedBy linkHeader++-- | Stream pages of a paginated response, using a custom /find next/+sourcePaginatedBy+ :: Monad m+ => (Request -> Response body -> Maybe Request)+ -- ^ How to get the next page from each request+ -> (Request -> m (Response body))+ -- ^ Run one request+ -> Request+ -- ^ Initial request+ -> ConduitT i (Response body) m ()+sourcePaginatedBy mNextRequest runRequest req = do+ resp <- lift $ runRequest req+ yield resp+ traverse_ (sourcePaginatedBy mNextRequest runRequest) $ mNextRequest req resp++linkHeader :: Request -> Response body -> Maybe Request+linkHeader _req resp = do+ header <- listToMaybe $ getResponseHeader "Link" resp+ links <- hush $ parseLinkHeader' @URI $ decodeUtf8 header+ uri <- href <$> find (((Rel, "next") `elem`) . linkParams) links+ parseRequest $ show uri
+ library/Freckle/App/Http/Retry.hs view
@@ -0,0 +1,101 @@+module Freckle.App.Http.Retry+ ( RetriesExhausted (..)+ , rateLimited+ , rateLimited'+ ) where++import Prelude++import Control.Exception.Annotated.UnliftIO (Exception (..), throwWithCallStack)+import Control.Monad (guard, unless)+import Control.Monad.IO.Class (MonadIO)+import Control.Retry+import Data.ByteString.Char8 qualified as BS8+import Data.Functor (void)+import Data.Maybe (listToMaybe)+import GHC.Stack (HasCallStack)+import Network.HTTP.Client (Request (..))+import Network.HTTP.Simple+import Network.HTTP.Types.Status (status429)+import Text.Read (readMaybe)++-- | Thrown if we exhaust our retries limit and still see a @429@+--+-- This typically means the API is not sending back accurate @Retry-In@ values+-- with 429 responses.+--+-- __Rationale__:+--+-- In order for 'rateLimited' to function in the case when the 'Request' is+-- using 'throwErrorStatusCodes' for 'checkResponse', we have to modify it to+-- not throw on 429s specifically. Otherwise, the first response would just+-- throw due to 4XX and never retry. However, in that case of someone expecting+-- invalid statuses to throw an exception, if we exhaust our retries and still+-- see a 429 at the end, an exception should be thrown.+--+-- Unfortunately, it's not possible to reuse the user-defined 'checkResponse' in+-- order to throw a uniform 'HttpException' in this case; so we throw this+-- ourselves instead.+data RetriesExhausted = RetriesExhausted+ { reLimit :: Int+ , reResponse :: Response ()+ }+ deriving stock (Show)++instance Exception RetriesExhausted where+ displayException RetriesExhausted {..} =+ "Retries exhaused after "+ <> show reLimit+ <> " attempts. Final response:\n"+ <> show reResponse++rateLimited+ :: MonadIO m => (Request -> m (Response body)) -> Request -> m (Response body)+rateLimited = rateLimited' 10++-- | 'rateLimited' but with configurable retry limit+rateLimited'+ :: MonadIO m+ => Int+ -> (Request -> m (Response body))+ -> Request+ -> m (Response body)+rateLimited' retryLimit f req = do+ resp <-+ retryingDynamic+ (limitRetries retryLimit)+ ( \_ ->+ pure+ . maybe DontRetry (ConsultPolicyOverrideDelay . microseconds)+ . getRetryAfter+ )+ (\_ -> f $ suppressRetryStatusError req)++ checkRetriesExhausted retryLimit resp++suppressRetryStatusError :: Request -> Request+suppressRetryStatusError req =+ req+ { checkResponse = \req' resp ->+ unless (getResponseStatus resp == status429) $+ originalCheckResponse req' resp+ }+ where+ originalCheckResponse = checkResponse req++checkRetriesExhausted+ :: (MonadIO m, HasCallStack) => Int -> Response body -> m (Response body)+checkRetriesExhausted retryLimit resp+ | getResponseStatus resp == status429 =+ throwWithCallStack $+ RetriesExhausted {reLimit = retryLimit, reResponse = void resp}+ | otherwise = pure resp++getRetryAfter :: Response body -> Maybe Int+getRetryAfter resp = do+ guard $ getResponseStatus resp == status429+ header <- listToMaybe $ getResponseHeader "Retry-After" resp+ readMaybe $ BS8.unpack header++microseconds :: Int -> Int+microseconds = (* 1000000)
+ library/Freckle/App/HttpSpec.hs view
@@ -0,0 +1,51 @@+module Freckle.App.HttpSpec+ ( spec+ ) where++import Prelude++import Control.Lens (to, (^?), _Left, _Right)+import Data.Aeson+import Data.Aeson.Lens+import Data.List.NonEmpty qualified as NE+import Freckle.App.Http+import Freckle.App.Test.Http+import Network.HTTP.Types.Status (status200)+import Test.Hspec++spec :: Spec+spec = do+ describe "httpJson" $ do+ stubs <- runIO $ loadHttpStubsDirectory "tests/files"++ it "fetches JSON via HTTP" $ do+ resp <-+ flip runHttpStubsT stubs+ . httpJson @_ @Value+ $ parseRequest_ "https://www.stackage.org/lts-17.10"++ getResponseStatus resp `shouldBe` status200+ getResponseBody resp+ ^? _Right+ . key "snapshot"+ . key "ghc"+ . _String+ `shouldBe` Just "8.10.4"++ it "places JSON parse errors in a Left body" $ do+ resp <-+ flip runHttpStubsT stubs+ . httpJson @_ @[()]+ $ parseRequest_ "https://www.stackage.org/lts-17.10"++ let expectedErrorMessages =+ [ "Error in $: expected [a], encountered Object"+ , "Error in $: parsing [] failed, expected Array, but encountered Object"+ ]++ getResponseStatus resp `shouldBe` status200+ getResponseBody resp+ ^? _Left+ . to hdeErrors+ . to NE.head+ `shouldSatisfy` maybe False (`elem` expectedErrorMessages)
+ library/Freckle/App/Test/Http.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoFieldSelectors #-}++-- | Implements stubbing of an HTTP request function+module Freckle.App.Test.Http+ ( -- $docs+ httpStubbed++ -- * Defining stubs+ , HttpStub (..)+ , httpStub+ , httpStubUrl++ -- * Stub modifiers+ , labelL+ , MatchRequest (..)+ , matchL++ -- * Response modifiers+ , statusL+ , headersL+ , bodyL++ -- * Response helpers+ , json++ -- * FileSystem stubs+ , loadHttpStubsDirectory++ -- * 'MonadHttp' instances++ -- ** For use with @DerivingVia@+ , HasHttpStubs (..)+ , ReaderHttpStubs (..)++ -- ** Concrete transformer+ , HttpStubsT+ , runHttpStubsT+ ) where++import Prelude++import Control.Applicative (asum)+import Control.Lens (Lens', lens, view, (.~), (<>~))+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)+import Data.Aeson (ToJSON, encode)+import Data.Bifunctor (bimap)+import Control.Monad(filterM)+import Data.ByteString.Lazy qualified as BSL+import Data.Either (partitionEithers)+import Data.Function ((&))+import Data.List (stripPrefix)+import Data.Maybe (mapMaybe)+import Data.String (IsString)+import Data.String qualified+import Data.Traversable (for)+import Freckle.App.Http (MonadHttp (..))+import Freckle.App.Test.Http.MatchRequest+import GHC.Stack (HasCallStack)+import Network.HTTP.Client (Request, Response)+import Network.HTTP.Client.Internal qualified as HTTP+import Network.HTTP.Types.Header (ResponseHeaders, hAccept, hContentType)+import Network.HTTP.Types.Status (Status, status200)+import Safe (headMay)+import System.Directory (doesFileExist)+import System.FilePath (addTrailingPathSeparator)+import System.FilePath.Glob (globDir1)++-- | Respond to a 'Request' with the first 'HttpStub' to match+--+-- If no stubs match, 'error' is used. If you'd rather experience a 404, add+-- a final stub for any request that does that:+--+-- @+-- stubs :: ['HttpStub']+-- stubs =+-- [ -- ...+-- , -- ...+-- , 'httpStub' \"Anything\" 'MatchAnything'+-- & 'statusL' .~ 'status404'+-- & 'bodyL' .~ \"Not found\"+-- ]+-- @+httpStubbed+ :: HasCallStack+ => [HttpStub]+ -> Request+ -> Response BSL.ByteString+httpStubbed stubs req =+ maybe (error errorMessage) (toResponse req) $ headMay matched+ where+ (unmatched, matched) =+ partitionEithers+ $ map+ ( \stub ->+ bimap (stub,) (const stub.response)+ $ matchRequest req stub.match+ )+ stubs++ errorMessage =+ "No stubs were found that matched:\n"+ <> show req+ <> "\n"+ <> concatMap (uncurry unmatchedMessage) unmatched++ unmatchedMessage stub err = "\n== " <> stub.label <> " ==\n" <> err++-- | Fields that can be defined for a response+data HttpStubResponse = HttpStubResponse+ { status :: Status+ , headers :: ResponseHeaders+ , body :: BSL.ByteString+ }++toResponse :: Request -> HttpStubResponse -> Response BSL.ByteString+toResponse req stub =+ HTTP.Response+ { HTTP.responseStatus = stub.status+ , HTTP.responseVersion = HTTP.requestVersion req+ , HTTP.responseHeaders = stub.headers+ , HTTP.responseBody = stub.body+ , HTTP.responseCookieJar = mempty+ , HTTP.responseClose' = HTTP.ResponseClose $ pure ()+ , HTTP.responseOriginalRequest = req+#if MIN_VERSION_http_client(0,7,16)+ , HTTP.responseEarlyHints = []+#endif+ }++rstatusL :: Lens' HttpStubResponse Status+rstatusL = lens (.status) $ \x y -> x {status = y}++rheadersL :: Lens' HttpStubResponse ResponseHeaders+rheadersL = lens (.headers) $ \x y -> x {headers = y}++rbodyL :: Lens' HttpStubResponse BSL.ByteString+rbodyL = lens (.body) $ \x y -> x {body = y}++data HttpStub = HttpStub+ { label :: String+ , match :: MatchRequest+ , response :: HttpStubResponse+ }++instance IsString HttpStub where+ fromString = httpStubUrl++labelL :: Lens' HttpStub String+labelL = lens (.label) $ \x y -> x {label = y}++matchL :: Lens' HttpStub MatchRequest+matchL = lens (.match) $ \x y -> x {match = y}++responseL :: Lens' HttpStub HttpStubResponse+responseL = lens (.response) $ \x y -> x {response = y}++-- | Respond 200 with empty body for matching requests+httpStub :: String -> MatchRequest -> HttpStub+httpStub label match = HttpStub {label, match, response}+ where+ response =+ HttpStubResponse+ { status = status200+ , headers = []+ , body = ""+ }++-- | Respond 200 with empty body for requests parsed from the given URL+httpStubUrl :: String -> HttpStub+httpStubUrl url = httpStub url $ matchRequestFromUrl url++statusL :: Lens' HttpStub Status+statusL = responseL . rstatusL++headersL :: Lens' HttpStub ResponseHeaders+headersL = responseL . rheadersL++bodyL :: Lens' HttpStub BSL.ByteString+bodyL = responseL . rbodyL++-- | Modify the stub to match JSON requests and respond with the given value+json :: ToJSON a => a -> HttpStub -> HttpStub+json a stub =+ stub+ & matchL <>~ MatchHeader (hAccept, "application/json")+ & headersL <>~ [(hContentType, "application/json")]+ & bodyL .~ encode a++-- | Load stubs from the filesystem+--+-- Within the given directory, files are expected to be named for scheme, then+-- host, then path/port/query.+--+-- Given,+--+-- @+-- files/+-- https/+-- www.example.com/+-- hello => "Hello"+-- world => "World"+-- http/+-- localhost:3000/+-- hello?world=1 => "Hello 2"+-- @+--+-- Then @'loadHttpStubsDirectory' "files"@ is equivalent to,+--+-- @+-- [ 'stubUrl' \"https:\/\/www.example.com\/hello\" & 'bodyL' .~ \"Hello\"+-- , 'stubUrl' \"https:\/\/www.example.com\/world\" & 'bodyL' .~ \"World\"+-- , 'stubUrl' \"http:\/\/localhost:3000\/hello?world=1\" & 'bodyL' .~ \"Hello 2\"+-- ]+-- @+--+-- NB. This function currently abuses the fact that @/@ within filenames is the+-- same for URLs, and so will not work on Windows. Patches welcome.+loadHttpStubsDirectory :: FilePath -> IO [HttpStub]+loadHttpStubsDirectory dir = do+ paths <- filterM doesFileExist =<< globDir1 "**/*" dir++ let pathUrls = mapMaybe (\p -> (,) p <$> toUrl p) paths++ for pathUrls $ \(path, url) -> do+ bs <- BSL.readFile path+ pure $ httpStubUrl url & bodyL .~ bs+ where+ toUrl p = do+ relative <- stripPrefix (addTrailingPathSeparator dir) p+ asum+ [ ("https://" <>) <$> stripPrefix "https/" relative+ , ("http://" <>) <$> stripPrefix "http/" relative+ ]++class HasHttpStubs env where+ httpStubsL :: Lens' env [HttpStub]++instance HasHttpStubs [HttpStub] where+ httpStubsL = id++newtype ReaderHttpStubs m a = ReaderHttpStubs {unwrap :: m a}+ deriving newtype (Functor, Applicative, Monad, MonadReader env)++instance (MonadReader env m, HasHttpStubs env) => MonadHttp (ReaderHttpStubs m) where+ httpLbs req = do+ stubs <- view httpStubsL+ pure $ httpStubbed stubs req++newtype HttpStubsT m a = HttpStubsT {unwrap :: ReaderT [HttpStub] m a}+ deriving newtype (Functor, Applicative, Monad, MonadReader [HttpStub])+ deriving (MonadHttp) via ReaderHttpStubs (HttpStubsT m)++runHttpStubsT :: HttpStubsT m a -> [HttpStub] -> m a+runHttpStubsT f = runReaderT f.unwrap++-- $docs+--+-- Stubbing is accomplished by holding a list of 'HttpStub' somewhere, which+-- defines how to respond to requests that match. The simplest way to do so+-- is to use the 'IsString' instance:+--+-- > stubs :: [HttpStub]+-- > stubs =+-- > [ "https://example.com"+-- > ]+--+-- You can now use,+--+-- @+-- 'httpStubbed' stubs :: Request -> Response ByteString+-- @+--+-- Anywhere you need an HTTP requesting function and it will respond 200 with an+-- empty body for any @GET@ requests made to this domain.+--+-- Stubbed responses can be modified through lenses:+--+-- > stubs :: [HttpStub]+-- > stubs =+-- > [ "https://example.com"+-- > & statusL .~ status400+-- > & bodyL .~ "Let's test a Bad Request"+-- > ]+--+-- The string is passed to 'parseRequest_', so anything valid there is valid+-- here, such as setting the method:+--+-- > data MyItem = MyItem+-- > { -- ...+-- > }+-- > deriving stock Generic+-- > deriving anyclass ToJSON+-- >+-- > stubs :: [HttpStub]+-- > stubs =+-- > [ "POST https://example.com/items"+-- > & json [MyItem]+-- > -- ^ Now matches requests with JSON in the Accept Header only+-- > -- Responds with Content-Type JSON+-- > -- Responds with a body of the JSON-encoded items+-- > ]+--+-- == 'MonadHttp'+--+-- Once we have the @stubs@, we can set up a 'MonadHttp' context that uses it:+--+-- > data TestApp = TestApp+-- > { appHttpStubs :: [HttpStubs]+-- > }+-- >+-- > -- Assume TestAppT is a ReaderT TestApp+-- > instance MonadHttp (TestAppT m a) where+-- > httpLbs req = do+-- > stubs <- asks appHttpStubs+-- > pure $ httpStubbed stubs req+--+-- Additionally, there are tools for @DerivingVia@ or running things in a+-- concrete 'HttpStubsT' stack.+--+-- == Handling Un-stubbed Requests+--+-- When no stubs match a given request, we call 'error' -- this seems uncouth,+-- but is actually the best possible behavior for the intended use-case in+-- (e.g.) HSpec:+--+-- +--+-- One other reasonable behavior would be to respond 404 to any un-matched+-- requests. This can be accomplished by adding a "match anything" stub at the+-- end:+--+-- > stubs :: [HttpStub]+-- > stubs =+-- > [ -- ...+-- > , -- ...+-- > , httpStub "Anything" MatchAnything+-- > & statusL .~ status404+-- > & bodyL .~ "Not found"+-- > ]
+ library/Freckle/App/Test/Http/MatchRequest.hs view
@@ -0,0 +1,187 @@+-- | 'Request' predicates for matching 'HttpStub's+--+-- == Usage+--+-- @+-- stubs :: ['HttpStub']+-- stubs =+-- [ \"https://example.com\"+-- & 'matchL' <>~ 'MatchMethod' \"POST\"+-- & 'matchL' <>~ 'MatchHeaders' [(hAccept, \"text/plain+csv\")]+-- & 'matchL' <>~ 'MatchBody' \"id,name\n42,Pat\n\"+-- & 'statusL' .~ 'status201'+-- & 'bodyL' .~ \"OK\n\"+-- ]+-- @+module Freckle.App.Test.Http.MatchRequest+ ( MatchRequest (..)+ , matchRequestFromUrl+ , matchRequest+ , showMatchRequest+ , showMatchRequestWithMismatches+ ) where++import Prelude++import Control.Applicative ((<|>))+import Control.Monad (guard)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as BSL+import Data.Foldable (toList)+import Data.List (isPrefixOf)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.List.NonEmpty qualified as NE+import Data.Maybe (catMaybes)+import Data.Semigroup.Foldable (fold1)+import Network.HTTP.Client (Request, RequestBody (..), parseRequest_)+import Network.HTTP.Client.Internal qualified as HTTP+import Network.HTTP.Types.Header (Header, RequestHeaders)+import Network.HTTP.Types.Method (Method)++data MatchRequest+ = MatchAnything+ | MatchAnd MatchRequest MatchRequest+ | MatchMethod Method+ | MatchSecure Bool+ | MatchHost ByteString+ | MatchPort Int+ | MatchPath ByteString+ | MatchQuery ByteString+ | MatchHeaders RequestHeaders+ | MatchHeader Header+ | MatchBody ByteString+ deriving stock (Show)++instance Semigroup MatchRequest where+ a <> b = MatchAnd a b++matchRequestFromUrl :: String -> MatchRequest+matchRequestFromUrl url =+ fold1 $ maybe id (<>) optionalMatches requiredMatches+ where+ req = parseRequest_ url++ method = HTTP.method req+ secure = HTTP.secure req+ host = HTTP.host req+ port = HTTP.port req+ path = HTTP.path req+ query = HTTP.queryString req+ headers = HTTP.requestHeaders req+ body = simplifyRequestBody req++ requiredMatches = MatchMethod method :| [MatchSecure secure, MatchPort port]++ optionalMatches =+ NE.nonEmpty $+ catMaybes+ [ MatchHost host <$ guard (host /= "")+ , MatchPath path <$ guard (hasExplicitPath secure host port url)+ , MatchQuery query <$ guard (query /= "")+ , MatchHeaders headers <$ guard (not $ null headers)+ , MatchBody body <$ guard (body /= "")+ ]++hasExplicitPath :: Bool -> ByteString -> Int -> String -> Bool+hasExplicitPath secure host port url =+ any+ (any ((`isPrefixOf` url) . toUrlPrefix))+ [ [Just port]+ , Nothing <$ guard (secure && port == 443)+ , Nothing <$ guard (not secure && port == 80)+ ]+ where+ toUrlPrefix mport =+ mconcat+ [ "http"+ , if secure then "s" else ""+ , "://"+ , BS8.unpack host+ , maybe "" ((":" <>) . show) mport+ , "/"+ ]++-- | Match a 'Request'+--+-- Success is @'Right' ()@, failure is a message in 'Left'.+matchRequest :: Request -> MatchRequest -> Either String ()+matchRequest req mr =+ maybe (Right ()) (Left . showMatchRequestWithMismatches mr) $+ buildMismatch req mr++showMatchRequest :: MatchRequest -> String+showMatchRequest mr =+ "MatchRequest {"+ <> concatMap (("\n " <>) . show) (flattenMatchRequest mr)+ <> "\n}"+ <> "\n"++showMatchRequestWithMismatches :: MatchRequest -> NonEmpty String -> String+showMatchRequestWithMismatches mr mismatches =+ showMatchRequest mr+ <> "\nMismatches {"+ <> concatMap ("\n " <>) (toList mismatches)+ <> "\n}"+ <> "\n"++flattenMatchRequest :: MatchRequest -> [MatchRequest]+flattenMatchRequest = \case+ MatchAnd a b -> flattenMatchRequest a <> flattenMatchRequest b+ x -> [x]++buildMismatch :: Request -> MatchRequest -> Maybe (NonEmpty String)+buildMismatch req = \case+ MatchAnything -> Nothing+ MatchAnd a b -> buildMismatch req a <|> buildMismatch req b+ MatchMethod m -> propMismatch "!=" (==) "method" m HTTP.method req+ MatchSecure s -> propMismatch "!=" (==) "secure" s HTTP.secure req+ MatchHost h -> propMismatch "!=" (==) "host" h HTTP.host req+ MatchPort p -> propMismatch "!=" (==) "port" p HTTP.port req+ MatchPath p -> propMismatch "!=" (==) "path" p (ensureLeadingSlash . HTTP.path) req+ MatchQuery q -> propMismatch "!=" (==) "query" q HTTP.queryString req+ MatchHeaders hs -> propMismatch "!=" (==) "headers" hs HTTP.requestHeaders req+ MatchHeader h -> propMismatch "not in" elem "header" h HTTP.requestHeaders req+ MatchBody bs -> propMismatch "!=" (==) "body" bs simplifyRequestBody req++propMismatch+ :: (Show a, Show b)+ => String+ -- ^ Label to show infix when comparison fails, e.g. "!="+ -> (a -> b -> Bool)+ -- ^ How to compare values+ -> String+ -- ^ Label for the property itself+ -> a+ -- ^ Value to compare to property+ -> (Request -> b)+ -- ^ Function to get property from 'Request'+ -> Request+ -> Maybe (NonEmpty String)+propMismatch opLabel op propLabel a f req+ | a `op` b = Nothing+ | otherwise = Just $ pure msg+ where+ b = f req+ msg =+ "✗ "+ <> propLabel+ <> ": "+ <> show a+ <> " "+ <> opLabel+ <> " "+ <> show b++simplifyRequestBody :: Request -> ByteString+simplifyRequestBody = go . HTTP.requestBody+ where+ go = \case+ RequestBodyLBS lbs -> BSL.toStrict lbs+ RequestBodyBS bs -> bs+ _ -> ""++ensureLeadingSlash :: ByteString -> ByteString+ensureLeadingSlash bs+ | Just ('/', _) <- BS8.uncons bs = bs+ | otherwise = BS8.cons '/' bs
+ package.yaml view
@@ -0,0 +1,112 @@+name: freckle-http+version: 0.0.0.0+maintainer: Freckle Education+category: Utils+github: freckle/freckle-app+synopsis: ...+description: Please see README.md++extra-doc-files:+ - README.md+ - CHANGELOG.md++extra-source-files:+ - package.yaml++language: GHC2021++ghc-options:+ - -fignore-optim-changes+ - -fwrite-ide-info+ - -Weverything+ - -Wno-all-missed-specialisations+ - -Wno-missing-exported-signatures # re-enables missing-signatures+ - -Wno-missing-import-lists+ - -Wno-missing-kind-signatures+ - -Wno-missing-local-signatures+ - -Wno-missing-safe-haskell-mode+ - -Wno-monomorphism-restriction+ - -Wno-prepositive-qualified-module+ - -Wno-safe+ - -Wno-unsafe++when:+ - condition: "impl(ghc >= 9.8)"+ ghc-options:+ - -Wno-missing-role-annotations+ - -Wno-missing-poly-kind-signatures++dependencies:+ - base < 5++default-extensions:+ - DataKinds+ - DeriveAnyClass+ - DerivingVia+ - DerivingStrategies+ - DuplicateRecordFields+ - GADTs+ - LambdaCase+ - NoImplicitPrelude+ - NoMonomorphismRestriction+ - OverloadedRecordDot+ - OverloadedStrings+ - RecordWildCards+ - TypeFamilies++library:+ source-dirs: library+ dependencies:+ - Glob+ - Blammo >= 2.0.0.0+ - aeson+ - annotated-exception+ - bytestring+ - case-insensitive+ - conduit+ - directory+ - errors+ - extra+ - filepath+ - freckle-memcached+ - hs-opentelemetry-api+ - hspec >= 2.8.1+ - http-client+ - http-conduit >= 2.3.5 # addToRequestQueryString+ - http-link-header+ - http-types+ - lens+ - lens-aeson+ - memcache+ - monad-logger+ - monad-validate+ - mtl+ - network-uri+ - retry >= 0.8.1.0 # retryingDynamic+ - safe+ - serialise+ - semigroupoids+ - text+ - time+ - transformers+ - unliftio+ - unordered-containers++tests:+ spec:+ main: Main.hs+ source-dirs: tests+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N"+ dependencies:+ - aeson+ - bytestring+ - freckle-http+ - hspec+ - hspec-expectations-json+ - hspec-expectations-lifted+ - http-types+ - lens+ - mtl+ - time+ - unordered-containers+ - zlib
+ tests/Freckle/App/Http/CacheSpec.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE NoFieldSelectors #-}++module Freckle.App.Http.CacheSpec+ ( spec+ ) where++import Prelude++import Codec.Compression.GZip qualified as GZip+import Control.Lens ((.~), (<>~))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.State (StateT, execStateT)+import Data.Aeson (FromJSON, eitherDecode)+import Data.ByteString.Lazy qualified as BSL+import Data.Foldable (for_)+import Data.Function ((&))+import Data.Functor (void)+import Data.HashMap.Strict qualified as HashMap+import Data.Time (addUTCTime, getCurrentTime)+import Freckle.App.Http+import Freckle.App.Http.Cache+import Freckle.App.Http.Cache.State+import Freckle.App.Test.Http+import Network.HTTP.Types.Header+ ( hAcceptEncoding+ , hAcceptLanguage+ , hAge+ , hCacheControl+ , hContentEncoding+ , hETag+ , hExpires+ , hIfNoneMatch+ , hVary+ )+import Network.HTTP.Types.Status+ ( status100+ , status304+ , status307+ , status400+ , status503+ )+import Test.Hspec (Spec, context, describe, it)+import Test.Hspec.Expectations.Json.Lifted (shouldMatchJson)+import Test.Hspec.Expectations.Lifted++type CacheSettings = HttpCacheSettings (StateT Cache IO) CachedResponse++spec :: Spec+spec = do+ describe "httpCached" $ do+ it "caches successful GET requests" $ do+ let+ stubs =+ [ "https://example.com/1" & bodyL .~ "Hello\n"+ , "https://example.com/2" & bodyL .~ "World\n"+ ]++ req1 = parseRequest_ "https://example.com/1"+ req2 = parseRequest_ "https://example.com/2"++ cache <- execCached $ do+ requestBodyCached settings stubs req1 `shouldReturn` "Hello\n"+ requestBodyCached settings stubs req2 `shouldReturn` "World\n"++ -- No stubs, so these would fail if not cached+ requestBodyCached settings [] req1 `shouldReturn` "Hello\n"+ requestBodyCached settings [] req2 `shouldReturn` "World\n"++ cache.map `shouldSatisfy` ((== 2) . HashMap.size)++ it "evicts stale caches" $ do+ let+ stubs =+ [ "https://example.com/1"+ & headersL <>~ [(hCacheControl, "max-age=2")]+ & bodyL .~ "Hi\n"+ ]++ -- On the request that we expect to evict, we'll use this so that we+ -- don't store a cache from that and we can observe the eviction.+ stubsNoStore =+ [ "https://example.com/1"+ & headersL <>~ [(hCacheControl, "no-store")]+ & bodyL .~ "Hi\n"+ ]++ req = parseRequest_ "https://example.com/1"++ cache <- execCached $ do+ requestBodyCached settings stubs req `shouldReturn` "Hi\n"++ -- Cached, no requests made+ requestBodyCached settings [] req `shouldReturn` "Hi\n"++ -- Expired, trigger eviction+ requestBodyCached settingsFuture stubsNoStore req `shouldReturn` "Hi\n"++ cache.map `shouldSatisfy` ((== 0) . HashMap.size)++ it "incorporates Vary headers into the cache key" $ do+ let+ stubs =+ [ "https://example.com/1"+ & matchL <>~ MatchHeader (hAcceptLanguage, "en")+ & bodyL .~ "Hello\n"+ , "https://example.com/1"+ & matchL <>~ MatchHeader (hAcceptLanguage, "es")+ & bodyL .~ "Hola\n"+ , "https://example.com/2"+ & matchL <>~ MatchHeader (hAcceptLanguage, "en")+ & bodyL .~ "World\n"+ , "https://example.com/2"+ & matchL <>~ MatchHeader (hAcceptLanguage, "es")+ & bodyL .~ "Mundo\n"+ ]++ reqEn1 =+ parseRequest_ "https://example.com/1"+ & addRequestHeader hAcceptLanguage "en"+ & addRequestHeader hVary "Accept, Accept-Language"+ reqEn2 =+ parseRequest_ "https://example.com/2"+ & addRequestHeader hAcceptLanguage "en"+ & addRequestHeader hVary "Accept, Accept-Language"+ reqEs1 =+ parseRequest_ "https://example.com/1"+ & addRequestHeader hAcceptLanguage "es"+ & addRequestHeader hVary "Accept, Accept-Language"+ reqEs2 =+ parseRequest_ "https://example.com/2"+ & addRequestHeader hAcceptLanguage "es"+ & addRequestHeader hVary "Accept, Accept-Language"++ cache <- execCached $ do+ requestBodyCached settings stubs reqEn1 `shouldReturn` "Hello\n"+ requestBodyCached settings stubs reqEn2 `shouldReturn` "World\n"+ requestBodyCached settings stubs reqEs1 `shouldReturn` "Hola\n"+ requestBodyCached settings stubs reqEs2 `shouldReturn` "Mundo\n"++ -- No stubs, so these would fail if not cached+ requestBodyCached settings [] reqEn1 `shouldReturn` "Hello\n"+ requestBodyCached settings [] reqEn2 `shouldReturn` "World\n"+ requestBodyCached settings [] reqEs1 `shouldReturn` "Hola\n"+ requestBodyCached settings [] reqEs2 `shouldReturn` "Mundo\n"++ cache.map `shouldSatisfy` ((== 4) . HashMap.size)++ context "compression" $ do+ it "caches gzipped responses as gzipped" $ do+ let+ gzipped = GZip.compress "Hi (zipped)\n"++ stubs =+ [ "https://example.com/1"+ & matchL <>~ MatchHeader (hAcceptEncoding, "gzip")+ & headersL <>~ [(hContentEncoding, "gzip")]+ & bodyL .~ gzipped+ , "https://example.com/1"+ & bodyL .~ "Hi (not zipped)\n"+ ]++ req =+ parseRequest_ "https://example.com/1"+ & addRequestHeader hVary "accept-encoding"+ reqGzipped =+ parseRequest_ "https://example.com/1"+ & addRequestHeader hVary "accept-encoding"+ & addRequestHeader hAcceptEncoding "gzip"+ reqGzippedAsIs =+ parseRequest_ "https://example.com/1"+ & addRequestHeader hVary "accept-encoding"+ & addRequestHeader hAcceptEncoding "gzip"+ & disableRequestDecompress++ cache <- execCached $ do+ requestBodyCached settings stubs req `shouldReturn` "Hi (not zipped)\n"+ requestBodyCached settings stubs reqGzipped `shouldReturn` "Hi (zipped)\n"+ requestBodyCached settings stubs reqGzippedAsIs `shouldReturn` gzipped++ cache.map `shouldSatisfy` ((== 2) . HashMap.size)++ -- We don't want to expose the constructor, but we do want to verify the+ -- cache contains the gzipped form.+ map (show . getResponseBody . (.response) . snd) (HashMap.toList cache.map)+ `shouldMatchList` [ "PotentiallyGzipped {unwrap = \"Hi (not zipped)\\n\"}" :: String+ , "PotentiallyGzipped {unwrap = " <> show gzipped <> "}"+ ]++ it "handles large gzip responses correctly" $ do+ bs <- BSL.readFile "tests/files/constructed-responses.gzip"+ val <- expectDecode $ GZip.decompress bs++ let+ stubs =+ [ "https://example.com/1"+ & matchL <>~ MatchHeader (hAcceptEncoding, "gzip")+ & headersL <>~ [(hContentEncoding, "gzip")]+ & bodyL .~ bs+ ]++ req =+ parseRequest_ "https://example.com/1"+ & addRequestHeader hVary "accept-encoding"+ & addRequestHeader hAcceptEncoding "gzip"++ void $ execCached $ do+ actual <- expectDecode =<< requestBodyCached settings stubs req+ actual `shouldMatchJson` val++ context "Handling ETag" $ do+ let etag = "W/\"99\""++ it "uses cached response and doesn't evict on 304 from If-None-Match" $ do+ let stubs =+ [ "https://example.com/1"+ & matchL <>~ MatchHeader (hIfNoneMatch, etag)+ & statusL .~ status304+ & bodyL .~ "<ignore me>\n"+ , "https://example.com/1"+ & headersL <>~ [(hCacheControl, "max-age=-1")]+ & headersL <>~ [(hETag, etag)]+ & bodyL .~ "Original body\n"+ ]++ cache <- execCached $ do+ let req = parseRequest_ "https://example.com/1"+ requestBodyCached settings stubs req `shouldReturn` "Original body\n"+ requestBodyCached settings stubs req `shouldReturn` "Original body\n"++ cache.map `shouldSatisfy` ((== 1) . HashMap.size)++ it "updates cached response on 304 from If-None-Match" $ do+ let stubs =+ [ "https://example.com/1"+ & matchL <>~ MatchHeader (hIfNoneMatch, etag)+ & statusL .~ status304+ & headersL <>~ [(hCacheControl, "max-age=120")]+ & bodyL .~ "<ignore me>\n"+ , "https://example.com/1"+ & headersL <>~ [(hCacheControl, "max-age=-1")]+ & headersL <>~ [(hETag, etag)]+ & bodyL .~ "Original body\n"+ ]++ cache <- execCached $ do+ let req = parseRequest_ "https://example.com/1"+ requestBodyCached settings stubs req `shouldReturn` "Original body\n"+ requestBodyCached settings stubs req `shouldReturn` "Original body\n"++ cache.map `shouldSatisfy` ((== 1) . HashMap.size)+ map (.ttl) (HashMap.elems cache.map) `shouldBe` [120]++ it "evicts a stale response after trying If-None-Match" $ do+ let stubs =+ [ "https://example.com/1"+ & matchL <>~ MatchHeader (hIfNoneMatch, etag)+ & headersL <>~ [(hCacheControl, "no-store")]+ & bodyL .~ "Newer body\n"+ , "https://example.com/1"+ & headersL <>~ [(hCacheControl, "max-age=-1")]+ & headersL <>~ [(hETag, etag)]+ & bodyL .~ "Original body\n"+ ]++ cache <- execCached $ do+ let req = parseRequest_ "https://example.com/1"+ requestBodyCached settings stubs req `shouldReturn` "Original body\n"+ requestBodyCached settings stubs req `shouldReturn` "Newer body\n"++ cache.map `shouldSatisfy` ((== 0) . HashMap.size)++ context "setting TTL" $ do+ let req = parseRequest_ "https://example.com"++ it "sets TTL based on max-age" $ do+ let stubs =+ [ "https://example.com"+ & headersL <>~ [(hCacheControl, "max-age=42")]+ ]++ cache <- execCached $ requestBodyCached settings stubs req+ map (.ttl) (HashMap.elems cache.map) `shouldBe` [42]++ it "sets TTL based on max-age + Age" $ do+ let stubs =+ [ "https://example.com"+ & headersL <>~ [(hAge, "78000"), (hCacheControl, "max-age=78250")]+ ]++ cache <- execCached $ requestBodyCached settings stubs req+ map (.ttl) (HashMap.elems cache.map) `shouldBe` [250]++ it "sets TTL based on Expires" $ do+ let+ expDate = "Wed, 21 Oct 2015 07:28:00 GMT"+ expSeconds = 1445412480 -- `date --date '{eDate}' +%s`+ stubs = ["https://example.com" & headersL <>~ [(hExpires, expDate)]]++ cache <- execCached $ requestBodyCached settings stubs req+ map (.ttl) (HashMap.elems cache.map) `shouldBe` [expSeconds]++ context "un-cacheable requests" $ do+ it "does not cache if told not to" $ do+ let req = parseRequest_ "https://example.com"+ cache <- execCached $ requestBodyCached settingsDisabled stubAnything req+ cache.map `shouldSatisfy` ((== 0) . HashMap.size)++ it "does not cache non-GET methods" $ do+ let req = parseRequest_ "POST https://example.com"+ cache <- execCached $ requestBodyCached settings stubAnything req+ cache.map `shouldSatisfy` ((== 0) . HashMap.size)++ it "does not cache no-store" $ do+ let req =+ parseRequest_ "https://example.com"+ & addRequestHeader hCacheControl "no-store"+ cache <- execCached $ requestBodyCached settings stubAnything req+ cache.map `shouldSatisfy` ((== 0) . HashMap.size)++ it "does not cache private in a shared cache" $ do+ let req =+ parseRequest_ "https://example.com"+ & addRequestHeader hCacheControl "private"+ cache <- execCached $ requestBodyCached settingsShared stubAnything req+ cache.map `shouldSatisfy` ((== 0) . HashMap.size)++ context "un-cacheable responses" $ do+ let req = parseRequest_ "https://example.com"++ it "does not cache no-store" $ do+ let stubs =+ [ "https://example.com"+ & headersL <>~ [(hCacheControl, "no-store, max-age=0, public")]+ ]++ cache <- execCached $ requestBodyCached settings stubs req+ cache.map `shouldSatisfy` ((== 0) . HashMap.size)++ it "does not cache private in a shared cache" $ do+ let stubs =+ [ "https://example.com"+ & headersL <>~ [(hCacheControl, "max-age=0, private")]+ ]++ cache <- execCached $ requestBodyCached settingsShared stubs req+ cache.map `shouldSatisfy` ((== 0) . HashMap.size)++ for_ [status100, status307, status400, status503] $ \s -> do+ it ("does not cache un-cacheable status " <> show (statusCode s)) $ do+ let stubs = ["https://example.com" & statusL .~ s]++ cache <- execCached $ requestBodyCached settingsShared stubs req+ cache.map `shouldSatisfy` ((== 0) . HashMap.size)++execCached :: StateT Cache IO a -> IO Cache+execCached = flip execStateT mempty++requestBodyCached+ :: CacheSettings+ -> [HttpStub]+ -> Request+ -> StateT Cache IO BSL.ByteString+requestBodyCached ss stubs req =+ getResponseBody <$> httpCached ss (pure . httpStubbed stubs) req++settings :: CacheSettings+settings = stateHttpCacheSettings++settingsDisabled :: CacheSettings+settingsDisabled =+ settings+ { cacheable = const False+ }++settingsShared :: CacheSettings+settingsShared =+ settings+ { shared = True+ }++settingsFuture :: CacheSettings+settingsFuture =+ settings+ { getCurrentTime = liftIO $ addUTCTime 5 <$> getCurrentTime+ }++stubAnything :: [HttpStub]+stubAnything = [httpStub "Anything" MatchAnything]++expectDecode :: (HasCallStack, MonadIO m, FromJSON a) => BSL.ByteString -> m a+expectDecode bs = case eitherDecode bs of+ Left err -> do+ expectationFailure $+ mconcat+ [ "Expected input to decode as JSON"+ , "\nInput: " <> show bs+ , "\nErrors: " <> err+ ]+ error "<unreachable>"+ Right a -> pure a
+ tests/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-}