diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# freckle-http diff --git a/freckle-http.cabal b/freckle-http.cabal new file mode 100644 --- /dev/null +++ b/freckle-http.cabal @@ -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 diff --git a/library/Freckle/App/Http.hs b/library/Freckle/App/Http.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http.hs @@ -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 diff --git a/library/Freckle/App/Http/Cache.hs b/library/Freckle/App/Http/Cache.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Cache.hs @@ -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@) +-- +-- - +-- - +-- +-- 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. +-- +-- - +-- +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 +-- +-- +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 + } + +-- | +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 diff --git a/library/Freckle/App/Http/Cache/Gzip.hs b/library/Freckle/App/Http/Cache/Gzip.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Cache/Gzip.hs @@ -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' diff --git a/library/Freckle/App/Http/Cache/Memcached.hs b/library/Freckle/App/Http/Cache/Memcached.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Cache/Memcached.hs @@ -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 diff --git a/library/Freckle/App/Http/Cache/State.hs b/library/Freckle/App/Http/Cache/State.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Cache/State.hs @@ -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 diff --git a/library/Freckle/App/Http/Header.hs b/library/Freckle/App/Http/Header.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Header.hs @@ -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 diff --git a/library/Freckle/App/Http/Paginate.hs b/library/Freckle/App/Http/Paginate.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Paginate.hs @@ -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 diff --git a/library/Freckle/App/Http/Retry.hs b/library/Freckle/App/Http/Retry.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Http/Retry.hs @@ -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) diff --git a/library/Freckle/App/HttpSpec.hs b/library/Freckle/App/HttpSpec.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/HttpSpec.hs @@ -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) diff --git a/library/Freckle/App/Test/Http.hs b/library/Freckle/App/Test/Http.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Test/Http.hs @@ -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: +-- +-- ![Error screenshot](https://files.pbrisbin.com/screenshots/screenshot.281851.png) +-- +-- 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" +-- > ] diff --git a/library/Freckle/App/Test/Http/MatchRequest.hs b/library/Freckle/App/Test/Http/MatchRequest.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Test/Http/MatchRequest.hs @@ -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 diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -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 diff --git a/tests/Freckle/App/Http/CacheSpec.hs b/tests/Freckle/App/Http/CacheSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Freckle/App/Http/CacheSpec.hs @@ -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 .~ "\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 .~ "\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 "" + Right a -> pure a diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-}