diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ ## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-app-v1.19.0.0...main) +## [v1.12.0.0](https://github.com/freckle/freckle-app/compare/freckle-app-v1.19.0.0...freckle-app-v1.20.0.0) + +Changes affecting users: + +- Removed `Freckle.App.Memcached(.*)`; these modules have moved into the + `freckle-memcached` package. + +Changes that do not have to affect users: + +- Modules `Freckle.App(.Test?).Http(.*)` are now re-exports from the + `freckle-http` package. +- Modules `Freckle.App.OpenTelementry(.*)` are now re-exports from the + `freckle-otel` package. +- Module `Freckle.App.Dotenv` is now a re-export from the `freckle-env` + package. + ## [v1.19.0.0](https://github.com/freckle/freckle-app/compare/freckle-app-v1.18.2.0...freckle-app-v1.19.0.0) - Removed `Freckle.App.Kafka(.*)`; this is now available from the `freckle-kafka` diff --git a/freckle-app.cabal b/freckle-app.cabal --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -1,6 +1,6 @@ cabal-version: 1.22 name: freckle-app -version: 1.19.0.0 +version: 1.20.0.0 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -29,7 +29,6 @@ Freckle.App.Bugsnag.SqlError Freckle.App.Csv Freckle.App.Database - Freckle.App.Dotenv Freckle.App.Ecs Freckle.App.Exception Freckle.App.Exception.MonadThrow @@ -38,25 +37,7 @@ Freckle.App.Faktory.ProducerPool Freckle.App.Ghci Freckle.App.GlobalCache - 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.Json.Empty - Freckle.App.Memcached - Freckle.App.Memcached.CacheKey - Freckle.App.Memcached.CacheTTL - Freckle.App.Memcached.Client - Freckle.App.Memcached.MD5 - Freckle.App.Memcached.Servers - Freckle.App.OpenTelemetry - Freckle.App.OpenTelemetry.Context - Freckle.App.OpenTelemetry.Http - Freckle.App.OpenTelemetry.ThreadContext Freckle.App.Prelude Freckle.App.Random Freckle.App.Scientist @@ -65,8 +46,6 @@ Freckle.App.Test Freckle.App.Test.DocTest Freckle.App.Test.Hspec.Runner - Freckle.App.Test.Http - Freckle.App.Test.Http.MatchRequest Freckle.App.Test.Properties.JSON Freckle.App.Test.Properties.PathPiece Freckle.App.Test.Properties.PersistValue @@ -78,7 +57,21 @@ Network.Wai.Middleware.Stats Yesod.Core.Lens - reexported-modules: Freckle.App.Env + reexported-modules: + Freckle.App.Dotenv, + Freckle.App.Env, + 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_app default-language: GHC2021 @@ -116,16 +109,14 @@ containers >=0.6.5.1, cookie >=0.4.6, datadog >=0.3.0.0, - directory >=1.3.6.2, doctest >=0.20.1, - dotenv >=0.10.0.0, ekg-core >=0.1.1.7, - errors >=2.3.0, exceptions >=0.10.4, extra >=1.7.13, faktory >=1.1.2.4, - filepath >=1.4.2.2, - freckle-env >=0.0.0.0, + freckle-env >=0.0.1.1, + freckle-http >=0.0.0.0, + freckle-otel >=0.0.0.1, hashable >=1.4.2.0, hs-opentelemetry-api >=0.1.0.0, hs-opentelemetry-instrumentation-persistent >=0.1.0.0, @@ -136,18 +127,13 @@ hspec-expectations-lifted >=0.10.0, hspec-junit-formatter >=1.1.1.0, http-client >=0.7.13.1, - http-conduit >=2.3.5, - http-link-header >=1.2.1, http-types >=0.12.3, immortal >=0.3, lens >=5.1.1, - memcache >=0.3.0.1, monad-control >=1.0.3.1, - monad-logger >=0.3.40, monad-logger-aeson >=0.4.0.4, monad-validate >=1.3.0.0, mtl >=2.2.2, - network-uri >=2.6.4.2, nonempty-containers >=0.3.4.4, openapi3 >=3.2.3, path-pieces >=0.2.1, @@ -155,14 +141,11 @@ persistent-postgresql >=2.13.5.2, postgresql-simple >=0.6.4, primitive >=0.7.3.0, - pureMD5 >=2.1.4, resource-pool >=0.4.0.0, resourcet >=1.2.6, - retry >=0.8.1.0, safe >=0.3.19, scientist >=0.0.0.0, semigroupoids >=5.3.7, - serialise >=0.2.6.0, template-haskell >=2.18.0.0, text >=1.2.5.0, time >=1.11.1.1, @@ -218,11 +201,6 @@ Freckle.App.Bugsnag.MetaDataSpec Freckle.App.BugsnagSpec Freckle.App.CsvSpec - Freckle.App.Http.CacheSpec - Freckle.App.HttpSpec - Freckle.App.Memcached.ServersSpec - Freckle.App.MemcachedSpec - Freckle.App.OpenTelemetry.ContextSpec Freckle.App.Test.Http.MatchRequestSpec Freckle.App.Test.Properties.JSONSpec Freckle.App.Test.Properties.PathPieceSpec @@ -255,28 +233,16 @@ bytestring >=0.11.4.0, cassava >=0.5.3.0, conduit >=1.3.5, - errors >=2.3.0, freckle-app, - freckle-env >=0.0.0.0, hs-opentelemetry-api >=0.1.0.0, 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, - lens-aeson >=1.2.2, - memcache >=0.3.0.1, monad-validate >=1.3.0.0, - mtl >=2.2.2, nonempty-containers >=0.3.4.4, postgresql-simple >=0.6.4, - text >=1.2.5.0, - time >=1.11.1.1, - unordered-containers >=0.2.19.1, vector >=0.12.3.1, wai >=3.2.3, - wai-extra >=3.1.13.0, - zlib >=0.6.3.0 + wai-extra >=3.1.13.0 if impl(ghc >=9.8) ghc-options: diff --git a/library/Freckle/App/Dotenv.hs b/library/Freckle/App/Dotenv.hs deleted file mode 100644 --- a/library/Freckle/App/Dotenv.hs +++ /dev/null @@ -1,62 +0,0 @@ --- | Conventional @.env@ handling -module Freckle.App.Dotenv - ( load - , loadTest - , loadFile - ) where - -import Freckle.App.Prelude - -import Configuration.Dotenv qualified as Dotenv -import System.FilePath (takeDirectory, ()) -import UnliftIO.Directory (doesFileExist, getCurrentDirectory) - --- | Call 'loadFile' with @.env@ -load :: IO () -load = loadFile ".env" - --- | Call 'loadFile' with @.env.test@ -loadTest :: IO () -loadTest = loadFile ".env.test" - --- | An opinionated 'Configuration.Dotenv.loadFile' --- --- Additional behaviors: --- --- 1. Attempt to locate the file in parent directories too --- --- We, sadly, have a monorepository. So we need to locate a @.env@ file in --- parent directories when running tests in sub-directories. --- --- 2. Silently ignore no file found --- --- Since this is used by 'Freckle.App.Test.withApp', which we aim to use in --- every non-trivial project, we can't fail in projects that don't need or --- have a @.env(.test)@ file (such as this one!). --- --- 3. Use the @.env.example@ feature, but only if one exists alongside -loadFile :: FilePath -> IO () -loadFile = traverse_ go <=< locateInParents - where - go path = do - let examplePath = takeDirectory path ".env.example" - exampleExists <- doesFileExist examplePath - - void $ - Dotenv.loadFile $ - Dotenv.defaultConfig - { Dotenv.configPath = [path] - , Dotenv.configExamplePath = [examplePath | exampleExists] - } - -locateInParents :: FilePath -> IO (Maybe FilePath) -locateInParents path = go =<< getCurrentDirectory - where - go cwd = do - let absPath = cwd path - - exists <- doesFileExist absPath - - if exists - then pure $ Just absPath - else if cwd == "/" then pure Nothing else go $ takeDirectory cwd diff --git a/library/Freckle/App/Http.hs b/library/Freckle/App/Http.hs deleted file mode 100644 --- a/library/Freckle/App/Http.hs +++ /dev/null @@ -1,293 +0,0 @@ --- | 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 Freckle.App.Prelude - -import Conduit (foldC, mapMC, runConduit, (.|)) -import Control.Monad.Except (ExceptT) -import Control.Monad.State (StateT) -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.ByteString qualified as BS -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy.Char8 qualified as BSL8 -import Data.List.NonEmpty qualified as NE -import Freckle.App.Http.Paginate -import Freckle.App.Http.Retry -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 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 :: ByteString - , hdeErrors :: NonEmpty String - } - deriving stock (Eq, Show) - -instance Exception HttpDecodeError where - displayException HttpDecodeError {..} = - unlines $ - ["Error decoding HTTP Response:", "Raw body:", BSL8.unpack hdeBody] - <> fromErrors hdeErrors - where - fromErrors = \case - err NE.:| [] -> ["Error:", err] - errs -> "Errors:" : map bullet (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 - => (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 :: BS.ByteString -> Request -> Request -addAcceptHeader = addRequestHeader hAccept - -addBearerAuthorizationHeader :: BS.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 throwM 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 deleted file mode 100644 --- a/library/Freckle/App/Http/Cache.hs +++ /dev/null @@ -1,335 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE NoFieldSelectors #-} - --- | Cache HTTP responses like a CDN or browser would -module Freckle.App.Http.Cache - ( HttpCacheSettings (..) - , HttpCacheCodec (..) - , HttpCache (..) - , httpCached - , CachedResponse (..) - , PotentiallyGzipped - ) where - -import Freckle.App.Prelude - -import Blammo.Logging (Message (..), (.=)) -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.List.Extra (firstJust) -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Data.Time (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) - -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 = decodeUtf8With 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" .= decodeUtf8With 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" .= decodeUtf8With 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 <$> readMay (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 - readMay $ 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 deleted file mode 100644 --- a/library/Freckle/App/Http/Cache/Gzip.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# 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 Freckle.App.Prelude - -import Codec.Serialise (Serialise) -import Data.ByteString.Lazy (ByteString) -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 ByteString) - -> m (Response 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 ByteString -> IO 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 deleted file mode 100644 --- a/library/Freckle/App/Http/Cache/Memcached.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Freckle.App.Http.Cache.Memcached - ( memcachedHttpCacheSettings - , memcachedHttpCodec - , memcachedHttpCache - ) where - -import Freckle.App.Prelude - -import Blammo.Logging (MonadLogger, logDebugNS, logWarnNS) -import Codec.Serialise (Serialise (..), deserialiseOrFail, serialise) -import Data.ByteString.Lazy qualified as BSL -import Data.CaseInsensitive (CI) -import Data.CaseInsensitive qualified as CI -import Database.Memcache.Types (Value) -import Freckle.App.Http.Cache -import Freckle.App.Memcached -import Freckle.App.Memcached.Client qualified as Memcached -import Freckle.App.OpenTelemetry (MonadTracer) -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 (..)) - -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 deleted file mode 100644 --- a/library/Freckle/App/Http/Cache/State.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# 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 Freckle.App.Prelude - -import Blammo.Logging (Message) -import Control.Lens (Lens', at, lens, use, (.=), (?=)) -import Control.Monad.Logger (ToLogStr (..), fromLogStr) -import Control.Monad.State -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Data.Text.IO qualified as T -import Freckle.App.Http.Cache -import Freckle.App.Memcached.CacheKey -import Freckle.App.Memcached.CacheTTL -import System.IO (stderr) - -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 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 = decodeUtf8With lenientDecode . fromLogStr . toLogStr diff --git a/library/Freckle/App/Http/Header.hs b/library/Freckle/App/Http/Header.hs deleted file mode 100644 --- a/library/Freckle/App/Http/Header.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Freckle.App.Http.Header - ( HasHeaders (..) - , getHeaderCsv - , lookupHeader - - -- * Utilities - , splitHeader - ) where - -import Freckle.App.Prelude - -import Data.ByteString (ByteString) -import Data.ByteString.Char8 qualified as BS8 -import Data.Char (isSpace) -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 deleted file mode 100644 --- a/library/Freckle/App/Http/Paginate.hs +++ /dev/null @@ -1,97 +0,0 @@ --- | 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 Freckle.App.Prelude - -import Conduit -import Control.Error.Util (hush) -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 deleted file mode 100644 --- a/library/Freckle/App/Http/Retry.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Freckle.App.Http.Retry - ( RetriesExhausted (..) - , rateLimited - , rateLimited' - ) where - -import Freckle.App.Prelude - -import Control.Retry -import Data.ByteString.Char8 qualified as BS8 -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 = - throwM $ - 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/Memcached.hs b/library/Freckle/App/Memcached.hs deleted file mode 100644 --- a/library/Freckle/App/Memcached.hs +++ /dev/null @@ -1,158 +0,0 @@ --- | App-level caching backed by Memcached --- --- Usage: --- --- 1. Have a Reader-like monad stack over some @App@ --- 2. Set up that @App@ with 'HasMemcachedClient' --- 3. Give the value to cache a 'Cachable' instance --- 4. Use 'caching' --- --- To avoid 'Cachable', see 'cachingAs' and 'cachingAsJSON'. -module Freckle.App.Memcached - ( Cachable (..) - , caching - , cachingAs - , cachingAsJSON - , cachingAsCBOR - - -- * Re-exports - , module Freckle.App.Memcached.Client - , module Freckle.App.Memcached.CacheKey - , module Freckle.App.Memcached.CacheTTL - , module Freckle.App.Memcached.MD5 - ) where - -import Freckle.App.Prelude - -import Blammo.Logging -import Codec.Serialise (Serialise, deserialiseOrFail, serialise) -import Data.Aeson -import Data.ByteString (ByteString) -import Data.ByteString.Lazy qualified as BSL -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Freckle.App.Exception (annotatedExceptionMessage) -import Freckle.App.Memcached.CacheKey -import Freckle.App.Memcached.CacheTTL -import Freckle.App.Memcached.Client (HasMemcachedClient (..)) -import Freckle.App.Memcached.Client qualified as Memcached -import Freckle.App.Memcached.MD5 -import Freckle.App.OpenTelemetry - -class Cachable a where - toCachable :: a -> ByteString - fromCachable :: ByteString -> Either String a - -instance Cachable ByteString where - toCachable = id - fromCachable = Right - -instance Cachable BSL.ByteString where - toCachable = BSL.toStrict - fromCachable = Right . BSL.fromStrict - -instance Cachable Text where - toCachable = encodeUtf8 - fromCachable = Right . decodeUtf8With lenientDecode - -data CachingError - = CacheGetError SomeException - | CacheSetError SomeException - | CacheDeserializeError String - deriving stock (Show) - -instance Exception CachingError where - displayException = \case - CacheGetError ex -> "Unable to get: " <> displayException ex - CacheSetError ex -> "Unable to set: " <> displayException ex - CacheDeserializeError err -> "Unable to deserialize: " <> err - --- | Log any thrown 'CachingError's as warnings and return the given value -warnOnCachingError :: (MonadUnliftIO m, MonadLogger m) => a -> m a -> m a -warnOnCachingError val = - flip catch $ - (val <$) - . logWarnNS "caching" - . annotatedExceptionMessage @CachingError - --- | Memoize an action using Memcached and 'Cachable' -caching - :: ( MonadUnliftIO m - , MonadLogger m - , MonadTracer m - , MonadReader env m - , HasMemcachedClient env - , Cachable a - , HasCallStack - ) - => CacheKey - -> CacheTTL - -> m a - -> m a -caching = cachingAs fromCachable toCachable - --- | Like 'caching', but with explicit conversion functions -cachingAs - :: ( MonadUnliftIO m - , MonadLogger m - , MonadTracer m - , MonadReader env m - , HasMemcachedClient env - , HasCallStack - ) - => (ByteString -> Either String a) - -> (a -> ByteString) - -> CacheKey - -> CacheTTL - -> m a - -> m a -cachingAs from to key ttl f = do - mCached <- warnOnCachingError Nothing $ traverse cacheDeserialize =<< cacheGet - maybe store pure mCached - where - store = do - a <- f - a <$ warnOnCachingError () (cacheSet a) - - cacheGet = flip catch (throwM . CacheGetError) $ Memcached.get key - cacheSet a = flip catch (throwM . CacheSetError) $ Memcached.set key (to a) ttl - cacheDeserialize = either (throwM . CacheDeserializeError) pure . from - --- | Like 'caching', but de/serializing the value as JSON -cachingAsJSON - :: ( MonadUnliftIO m - , MonadLogger m - , MonadTracer m - , MonadReader env m - , HasMemcachedClient env - , FromJSON a - , ToJSON a - , HasCallStack - ) - => CacheKey - -> CacheTTL - -> m a - -> m a -cachingAsJSON = cachingAs eitherDecodeStrict encodeStrict - --- | Cache data in memcached in CBOR format -cachingAsCBOR - :: ( MonadUnliftIO m - , MonadLogger m - , MonadTracer m - , MonadReader env m - , HasMemcachedClient env - , Serialise a - , HasCallStack - ) - => CacheKey - -> CacheTTL - -> m a - -> m a -cachingAsCBOR = - cachingAs - (first show . deserialiseOrFail . BSL.fromStrict) - (BSL.toStrict . serialise) - -encodeStrict :: ToJSON a => a -> ByteString -encodeStrict = BSL.toStrict . encode diff --git a/library/Freckle/App/Memcached/CacheKey.hs b/library/Freckle/App/Memcached/CacheKey.hs deleted file mode 100644 --- a/library/Freckle/App/Memcached/CacheKey.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Freckle.App.Memcached.CacheKey - ( CacheKey - , cacheKey - , cacheKeyThrow - , fromCacheKey - ) where - -import Freckle.App.Prelude - -import Data.Char (isControl, isSpace) -import Data.Text qualified as T -import Database.Memcache.Types (Key) -import OpenTelemetry.Trace (ToAttribute (..)) - -newtype CacheKey = CacheKey Text - deriving stock (Show) - deriving newtype (Eq, Hashable) - -unCacheKey :: CacheKey -> Text -unCacheKey (CacheKey x) = x - -instance ToAttribute CacheKey where - toAttribute = toAttribute . unCacheKey - --- | Build a 'CacheKey', ensuring it's valid for Memcached --- --- --- --- @ --- Currently the length limit of a key is set at 250 characters (of course, --- normally clients wouldn't need to use such long keys); the key must not --- include control characters or whitespace. --- @ -cacheKey :: Text -> Either String CacheKey -cacheKey t - | T.length t > 250 = invalid "Must be fewer than 250 characters" - | T.any isControl t = invalid "Cannot contain control characters" - | T.any isSpace t = invalid "Cannot contain whitespace" - | otherwise = Right $ CacheKey t - where - invalid msg = - Left $ "Not a valid memcached key:\n " <> unpack t <> "\n\n" <> msg - --- | Build a 'CacheKey' and throw if invalid -cacheKeyThrow :: (MonadIO m, HasCallStack) => Text -> m CacheKey -cacheKeyThrow = either throwString pure . cacheKey - -fromCacheKey :: CacheKey -> Key -fromCacheKey = encodeUtf8 . unCacheKey diff --git a/library/Freckle/App/Memcached/CacheTTL.hs b/library/Freckle/App/Memcached/CacheTTL.hs deleted file mode 100644 --- a/library/Freckle/App/Memcached/CacheTTL.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Freckle.App.Memcached.CacheTTL - ( CacheTTL - , cacheTTL - , fromCacheTTL - , fiveMinuteTTL - ) where - -import Freckle.App.Prelude - -import Codec.Serialise (Serialise (..)) -import Data.Word (Word32) -import Database.Memcache.Types (Expiration) -import OpenTelemetry.Trace (ToAttribute (..)) - -newtype CacheTTL = CacheTTL Int - deriving stock (Show) - deriving newtype (Eq, Ord, Enum, Num, Real, Integral, Serialise) - -instance ToAttribute CacheTTL where - toAttribute (CacheTTL x) = toAttribute x - -cacheTTL :: Int -> CacheTTL -cacheTTL = CacheTTL - -fromCacheTTL :: CacheTTL -> Expiration -fromCacheTTL (CacheTTL i) - | i < fromIntegral minWord = minWord - | i > fromIntegral maxWord = maxWord - | otherwise = fromIntegral i - where - minWord :: Word32 - minWord = minBound - - maxWord :: Word32 - maxWord = maxBound - --- | Standard 5 minute time to live -fiveMinuteTTL :: CacheTTL -fiveMinuteTTL = cacheTTL $ 5 * 60 diff --git a/library/Freckle/App/Memcached/Client.hs b/library/Freckle/App/Memcached/Client.hs deleted file mode 100644 --- a/library/Freckle/App/Memcached/Client.hs +++ /dev/null @@ -1,135 +0,0 @@ -module Freckle.App.Memcached.Client - ( MemcachedClient (..) - , newMemcachedClient - , withMemcachedClient - , memcachedClientDisabled - , HasMemcachedClient (..) - , get - , set - , delete - ) where - -import Freckle.App.Prelude - -import Control.Lens (Lens', view, _1) -import Data.HashMap.Strict qualified as HashMap -import Database.Memcache.Client qualified as Memcache -import Database.Memcache.Types (Value, Version) -import Freckle.App.Memcached.CacheKey -import Freckle.App.Memcached.CacheTTL -import Freckle.App.Memcached.Servers -import Freckle.App.OpenTelemetry -import OpenTelemetry.Trace qualified as Trace -import UnliftIO.Exception (finally) -import Yesod.Core.Lens -import Yesod.Core.Types (HandlerData) - -data MemcachedClient - = MemcachedClient Memcache.Client - | MemcachedClientDisabled - -class HasMemcachedClient env where - memcachedClientL :: Lens' env MemcachedClient - -instance HasMemcachedClient MemcachedClient where - memcachedClientL = id - -instance HasMemcachedClient site => HasMemcachedClient (HandlerData child site) where - memcachedClientL = envL . siteL . memcachedClientL - -newMemcachedClient :: MonadIO m => MemcachedServers -> m MemcachedClient -newMemcachedClient servers = case toServerSpecs servers of - [] -> pure memcachedClientDisabled - specs -> liftIO $ MemcachedClient <$> Memcache.newClient specs Memcache.def - -withMemcachedClient - :: MonadUnliftIO m => MemcachedServers -> (MemcachedClient -> m a) -> m a -withMemcachedClient servers f = do - c <- newMemcachedClient servers - f c `finally` quitClient c - -memcachedClientDisabled :: MemcachedClient -memcachedClientDisabled = MemcachedClientDisabled - -get - :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env) - => CacheKey - -> m (Maybe Value) -get k = traced $ with $ \case - MemcachedClient mc -> liftIO $ view _1 <$$> Memcache.get mc (fromCacheKey k) - MemcachedClientDisabled -> pure Nothing - where - traced = - inSpan - "cache.get" - clientSpanArguments - { Trace.attributes = - HashMap.fromList - [ ("service.name", "memcached") - , ("key", Trace.toAttribute k) - ] - } - --- | Set a value to expire in the given seconds --- --- Pass @0@ to set a value that never expires. -set - :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env) - => CacheKey - -> Value - -> CacheTTL - -> m () -set k v expiration = traced $ with $ \case - MemcachedClient mc -> - void $ - liftIO $ - Memcache.set mc (fromCacheKey k) v 0 $ - fromCacheTTL - expiration - MemcachedClientDisabled -> pure () - where - traced = - inSpan - "cache.set" - clientSpanArguments - { Trace.attributes = - HashMap.fromList - [ ("service.name", "memcached") - , ("key", Trace.toAttribute k) - , ("value", byteStringToAttribute v) - , ("expiration", Trace.toAttribute expiration) - ] - } - --- | Delete a key -delete - :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env) - => CacheKey - -> m () -delete k = traced $ with $ \case - MemcachedClient mc -> void $ liftIO $ Memcache.delete mc (fromCacheKey k) bypassCAS - MemcachedClientDisabled -> pure () - where - traced = - inSpan - "cache.delete" - clientSpanArguments - { Trace.attributes = HashMap.fromList [("key", Trace.toAttribute k)] - } - -quitClient :: MonadIO m => MemcachedClient -> m () -quitClient = \case - MemcachedClient mc -> void $ liftIO $ Memcache.quit mc - MemcachedClientDisabled -> pure () - -with - :: (MonadReader env m, HasMemcachedClient env) - => (MemcachedClient -> m a) - -> m a -with f = do - c <- view memcachedClientL - f c - --- | The sentinal version @0@ means to not perform CAS checking -bypassCAS :: Version -bypassCAS = 0 diff --git a/library/Freckle/App/Memcached/MD5.hs b/library/Freckle/App/Memcached/MD5.hs deleted file mode 100644 --- a/library/Freckle/App/Memcached/MD5.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Freckle.App.Memcached.MD5 - ( md5CacheKey - , md5Key - , md5Text - ) where - -import Freckle.App.Prelude - -import Data.ByteString.Lazy qualified as BSL -import Data.Digest.Pure.MD5 qualified as Digest -import Freckle.App.Memcached.CacheKey - -md5CacheKey :: Show a => a -> CacheKey -md5CacheKey = either (error "md5 is always cacheable") id . cacheKey . md5Key - --- | Pack any showable into an md5 encoded text -md5Key :: Show a => a -> Text -md5Key = md5Text . pack . show - -md5Text :: Text -> Text -md5Text = pack . show . Digest.md5 . BSL.fromStrict . encodeUtf8 diff --git a/library/Freckle/App/Memcached/Servers.hs b/library/Freckle/App/Memcached/Servers.hs deleted file mode 100644 --- a/library/Freckle/App/Memcached/Servers.hs +++ /dev/null @@ -1,109 +0,0 @@ --- | Read a Memcached Servers value, to support ENV-based configuration --- --- Format: --- --- @ --- memcached://[user[:password]@]host][:port],... --- @ --- --- Usage with "Freckle.App.Env": --- --- @ --- -- Required --- Env.var (Env.eitherReader readMemcachedServers <=< Env.nonempty) "MEMCACHED_SERVERS" mempty --- --- -- Default to localhost:11211 --- Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" (Env.def defaultMemcachedServers) --- --- -- Default to disabled --- Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" (Env.def emptyMemcachedServers) --- @ -module Freckle.App.Memcached.Servers - ( MemcachedServers (..) - , defaultMemcachedServers - , emptyMemcachedServers - , readMemcachedServers - , toServerSpecs - ) where - -import Freckle.App.Prelude - -import Control.Error.Util (note) -import Data.Text qualified as T -import Database.Memcache.Client qualified as Memcache -import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI) - -newtype MemcachedServers = MemcachedServers - { unMemcachedServers :: [MemcachedServer] - } - -defaultMemcachedServers :: MemcachedServers -defaultMemcachedServers = MemcachedServers [defaultMemcachedServer] - -emptyMemcachedServers :: MemcachedServers -emptyMemcachedServers = MemcachedServers [] - -readMemcachedServers :: String -> Either String MemcachedServers -readMemcachedServers = - fmap MemcachedServers - . traverse (readMemcachedServer . unpack) - . filter (not . T.null) - . map T.strip - . T.splitOn "," - . pack - -toServerSpecs :: MemcachedServers -> [Memcache.ServerSpec] -toServerSpecs = map unMemcachedServer . unMemcachedServers - -newtype MemcachedServer = MemcachedServer - { unMemcachedServer :: Memcache.ServerSpec - } - -defaultMemcachedServer :: MemcachedServer -defaultMemcachedServer = MemcachedServer Memcache.def - -readMemcachedServer :: String -> Either String MemcachedServer -readMemcachedServer s = do - uri <- note ("Not a valid URI: " <> s) $ parseAbsoluteURI s - note "Must begin memcached://" $ guard $ uriScheme uri == "memcached:" - - let mAuth = uriAuthority uri - - pure - . MemcachedServer - . maybe id setHost mAuth - . maybe id setPort mAuth - . maybe id setAuth (readAuthentication . uriUserInfo =<< mAuth) - $ Memcache.def - -readAuthentication :: String -> Maybe Memcache.Authentication -readAuthentication = go . pack - where - go a = do - (u, p) <- second (T.drop 1) . T.breakOn ":" <$> T.stripSuffix "@" a - - guard $ not $ T.null u - guard $ not $ T.null p - - pure - Memcache.Auth - { Memcache.username = encodeUtf8 u - , Memcache.password = encodeUtf8 p - } - -setHost :: URIAuth -> Memcache.ServerSpec -> Memcache.ServerSpec -setHost auth ss = case uriRegName auth of - "" -> ss - rn -> ss {Memcache.ssHost = rn} - -setPort :: URIAuth -> Memcache.ServerSpec -> Memcache.ServerSpec -setPort auth ss = fromMaybe ss $ do - p <- case uriPort auth of - "" -> Nothing - (':' : p) -> Just p - p -> Just p - pure $ ss {Memcache.ssPort = p} - -setAuth - :: Memcache.Authentication -> Memcache.ServerSpec -> Memcache.ServerSpec -setAuth auth ss = ss {Memcache.ssAuth = auth} diff --git a/library/Freckle/App/OpenTelemetry.hs b/library/Freckle/App/OpenTelemetry.hs deleted file mode 100644 --- a/library/Freckle/App/OpenTelemetry.hs +++ /dev/null @@ -1,171 +0,0 @@ --- | Application tracing via --- --- @ --- data App = App --- { -- ... --- , appTracer :: Tracer --- } --- --- instance 'HasTracer' App where --- tracerL = lens appTracer $ \x y -> x { appTracer = y } --- --- loadApp f = do --- -- ... --- 'withTracerProvider' $ \tracerProvider -> do --- let appTracer = 'makeTracer' tracerProvider "my-app" 'tracerOptions' --- f App {..} --- @ --- --- You may need to do this even if you don't plan to manually trace things, in --- order to satisfy the 'MonadTracer' constraint required by functions like --- 'runDB'. If you don't need this feature, and don't plan on running an --- otel-collector, set @OTEL_TRACES_EXPORTER=none@ in the environment, which --- makes all tracing a no-op. --- --- In the future, it should be possible to use @OTEL_SDK_DISABLED@ for the same --- purpose. See . -module Freckle.App.OpenTelemetry - ( HasTracer (..) - , Tracer - - -- * Effects - , MonadTracer (..) - , inSpan - , SpanArguments (..) - , defaultSpanArguments - , serverSpanArguments - , clientSpanArguments - , producerSpanArguments - , consumerSpanArguments - - -- * Querying - , getCurrentTraceId - , getCurrentSpanContext - - -- * Ids - , TraceId - , traceIdToHex - , SpanId - , spanIdToHex - - -- * Attributes - , ToAttribute (..) - , addCurrentSpanAttributes - - -- * Setup - , withTracerProvider - - -- ** 'Tracer' - , makeTracer - , tracerOptions - - -- ** Utilities - , byteStringToAttribute - , attributeValueLimit - ) where - -import Freckle.App.Prelude - -import Data.ByteString (ByteString) -import Data.Text qualified as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import OpenTelemetry.Context (lookupSpan) -import OpenTelemetry.Context.ThreadLocal (getContext) -import OpenTelemetry.Trace hiding (inSpan) -import OpenTelemetry.Trace.Core (getSpanContext) -import OpenTelemetry.Trace.Core qualified as Trace (SpanContext (..)) -import OpenTelemetry.Trace.Id - ( Base (..) - , SpanId - , TraceId - , spanIdBaseEncodedText - , traceIdBaseEncodedText - ) -import OpenTelemetry.Trace.Monad -import UnliftIO.Exception (bracket) - --- | 'defaultSpanArguments' with 'kind' set to 'Server' --- --- Indicates that the span covers server-side handling of a synchronous RPC or --- other remote request. This span is the child of a remote @Client@ span that --- was expected to wait for a response. -serverSpanArguments :: SpanArguments -serverSpanArguments = defaultSpanArguments {kind = Server} - --- | 'defaultSpanArguments' with 'kind' set to 'Kind' --- --- Indicates that the span describes a synchronous request to some remote --- service. This span is the parent of a remote @Server@ span and waits for its --- response. -clientSpanArguments :: SpanArguments -clientSpanArguments = defaultSpanArguments {kind = Client} - --- | 'defaultSpanArguments' with 'kind' set to 'Producer' --- --- Indicates that the span describes the parent of an asynchronous request. This --- parent span is expected to end before the corresponding child @Producer@ --- span, possibly even before the child span starts. In messaging scenarios with --- batching, tracing individual messages requires a new @Producer@ span per --- message to be created. -producerSpanArguments :: SpanArguments -producerSpanArguments = defaultSpanArguments {kind = Producer} - --- | 'defaultSpanArguments' with 'kind' set to 'Consumer' --- --- Indicates that the span describes the child of an asynchronous @Producer@ --- request. -consumerSpanArguments :: SpanArguments -consumerSpanArguments = defaultSpanArguments {kind = Consumer} - -withTracerProvider :: MonadUnliftIO m => (TracerProvider -> m a) -> m a -withTracerProvider = - bracket - (liftIO initializeGlobalTracerProvider) - (liftIO . shutdownTracerProvider) - -getCurrentTraceId :: MonadIO m => m (Maybe TraceId) -getCurrentTraceId = fmap Trace.traceId <$> getCurrentSpanContext - -getCurrentSpanContext :: MonadIO m => m (Maybe SpanContext) -getCurrentSpanContext = withCurrentSpan getSpanContext - -addCurrentSpanAttributes :: MonadIO m => HashMap Text Attribute -> m () -addCurrentSpanAttributes attrs = void $ withCurrentSpan (`addAttributes` attrs) - -withCurrentSpan :: MonadIO m => (Span -> m b) -> m (Maybe b) -withCurrentSpan f = do - mSpan <- lookupSpan <$> getContext - traverse f mSpan - -traceIdToHex :: TraceId -> Text -traceIdToHex = traceIdBaseEncodedText Base16 - -spanIdToHex :: SpanId -> Text -spanIdToHex = spanIdBaseEncodedText Base16 - --- | Convert a 'ByteString' to an 'Attribute' safely --- --- - Decodes it as UTF-8 leniently, --- - Truncates to fit within 'attributeValueLimit' -byteStringToAttribute :: ByteString -> Attribute -byteStringToAttribute = - toAttribute - . truncateText attributeValueLimit - . decodeUtf8With lenientDecode - --- | Character limit for 'Attribute' values --- --- OTel the spec doesn't specify a limit, but says that SDKs should decide --- some limit. It's not clear what the Haskell SDK does, if anything. New --- Relic applies a limit of 4095 characters on all metrics it handles, --- including those coming from OTel. Seems reasonable enough. --- --- -attributeValueLimit :: Int -attributeValueLimit = 4095 - -truncateText :: Int -> Text -> Text -truncateText l t - | T.length t <= l = t - | otherwise = T.take (l - 3) t <> "..." diff --git a/library/Freckle/App/OpenTelemetry/Context.hs b/library/Freckle/App/OpenTelemetry/Context.hs deleted file mode 100644 --- a/library/Freckle/App/OpenTelemetry/Context.hs +++ /dev/null @@ -1,116 +0,0 @@ -module Freckle.App.OpenTelemetry.Context - ( HasHeaders (..) - , CustomTraceContext (..) - , extractContext - , injectContext - , processWithContext - ) where - -import Freckle.App.Prelude - -import Control.Error.Util (hush) -import Control.Lens (Lens', lens, (&), (.~), (^.)) -import Control.Monad.Catch (MonadMask) -import Data.Aeson (FromJSON, ToJSON) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import Data.CaseInsensitive qualified as CI -import Faktory.Job (Job, custom, jobOptions) -import Faktory.Job.Custom (fromCustom, toCustom) -import Faktory.JobOptions (JobOptions (..)) -import Freckle.App.OpenTelemetry - ( MonadTracer (..) - , SpanArguments - , inSpan - ) -import Freckle.App.OpenTelemetry.ThreadContext (withTraceContext) -import Network.HTTP.Client (Request, requestHeaders) -import Network.HTTP.Simple (setRequestHeaders) -import Network.HTTP.Types.Header (Header) -import OpenTelemetry.Context (Context) -import OpenTelemetry.Context.ThreadLocal (attachContext, getContext) -import OpenTelemetry.Propagator (Propagator, extract, inject) -import OpenTelemetry.Trace.Core - ( getTracerProviderPropagators - , getTracerTracerProvider - ) - -class HasHeaders a where - headersL :: Lens' a [Header] - -instance HasHeaders [Header] where - headersL = id - -instance HasHeaders Request where - headersL = lens requestHeaders $ \req hs -> setRequestHeaders hs req - -instance HasHeaders (Job a) where - headersL = optionsL . customTraceContextL . headersL - -optionsL :: Lens' (Job a) JobOptions -optionsL = lens jobOptions $ \x y -> x {jobOptions = y} - -customTraceContextL :: Lens' JobOptions CustomTraceContext -customTraceContextL = lens get set - where - get jo = fromMaybe mempty $ hush . fromCustom =<< joCustom jo - set jo = (jo <>) . custom . toCustom - --- | A type that can be stored as the @custom@ field of a Faktory 'Job' -newtype CustomTraceContext = CustomTraceContext - { traceHeaders :: [(Text, Text)] - } - deriving stock (Generic) - deriving newtype (Semigroup, Monoid) - deriving anyclass (FromJSON, ToJSON) - -instance HasHeaders CustomTraceContext where - headersL = lens (map encode . traceHeaders) $ \x y -> x {traceHeaders = map decode y} - -encode :: (Text, Text) -> (CI ByteString, ByteString) -encode = bimap (CI.mk . encodeUtf8) encodeUtf8 - -decode :: (CI ByteString, ByteString) -> (Text, Text) -decode = bimap (decodeUtf8 . CI.original) decodeUtf8 - --- | Update our trace context from that extracted from the given item's headers -extractContext - :: (MonadIO m, MonadTracer m, HasHeaders a) => a -> m () -extractContext a = do - context <- getContext - propagator <- getPropagator - updatedContext <- extract propagator (a ^. headersL) context - void $ attachContext updatedContext - --- | Inject our trace context into the given item's headers -injectContext - :: (MonadIO m, MonadTracer m, HasHeaders a) => a -> m a -injectContext a = do - context <- getContext - propagator <- getPropagator - headers <- inject propagator context $ a ^. headersL - pure $ a & headersL .~ headers - -getPropagator :: MonadTracer m => m (Propagator Context [Header] [Header]) -getPropagator = - getTracerProviderPropagators . getTracerTracerProvider <$> getTracer - --- | Process an item (a request, a Job, etc) in a top-level span and context -processWithContext - :: ( MonadUnliftIO m - , MonadMask m - , MonadTracer m - , HasHeaders a - , HasCallStack - ) - => Text - -- ^ Span name - -> SpanArguments - -> a - -> (a -> m b) - -> m b -processWithContext name args a f = do - extractContext a - inSpan name args $ do - a' <- injectContext a - withTraceContext $ f a' diff --git a/library/Freckle/App/OpenTelemetry/Http.hs b/library/Freckle/App/OpenTelemetry/Http.hs deleted file mode 100644 --- a/library/Freckle/App/OpenTelemetry/Http.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Freckle.App.OpenTelemetry.Http - ( httpSpanName - , httpSpanArguments - , httpAttributes - , httpResponseAttributes - ) where - -import Freckle.App.Prelude - -import Data.CaseInsensitive qualified as CI -import Data.HashMap.Strict qualified as HashMap -import Data.Text qualified as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Freckle.App.OpenTelemetry - ( SpanArguments (..) - , byteStringToAttribute - , clientSpanArguments - ) -import Network.HTTP.Client (Request, Response) -import Network.HTTP.Client qualified as HTTP -import Network.HTTP.Types.Status (statusCode) -import OpenTelemetry.Attributes (Attribute, ToAttribute (..)) - -httpSpanName :: Request -> Text -httpSpanName req = - decodeUtf8With lenientDecode $ HTTP.method req <> " " <> HTTP.path req - -httpSpanArguments :: Request -> SpanArguments -httpSpanArguments req = clientSpanArguments {attributes = httpAttributes req} - -httpAttributes :: Request -> HashMap Text Attribute -httpAttributes req = - HashMap.fromList - [ ("service.name", byteStringToAttribute $ HTTP.host req) - , ("resource.name", toAttribute $ httpSpanName req) - , ("http.host", byteStringToAttribute $ HTTP.host req) - , ("http.method", byteStringToAttribute $ HTTP.method req) - , ("http.path", byteStringToAttribute $ HTTP.path req) - , ("http.query", byteStringToAttribute $ HTTP.queryString req) - ] - -httpResponseAttributes :: Response body -> HashMap Text Attribute -httpResponseAttributes resp = statusAttr <> foldMap (uncurry headerAttr) (HTTP.responseHeaders resp) - where - statusAttr = - HashMap.singleton "http.status_code" - . toAttribute - . statusCode - $ HTTP.responseStatus resp - - headerAttr k = HashMap.singleton (headerAttrKey k) . byteStringToAttribute - - headerAttrKey = - ("http.response.headers." <>) - . T.toLower - . decodeUtf8With lenientDecode - . CI.original diff --git a/library/Freckle/App/OpenTelemetry/ThreadContext.hs b/library/Freckle/App/OpenTelemetry/ThreadContext.hs deleted file mode 100644 --- a/library/Freckle/App/OpenTelemetry/ThreadContext.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module Freckle.App.OpenTelemetry.ThreadContext - ( withTraceContext - ) where - -import Freckle.App.Prelude - -import Blammo.Logging (MonadMask, withThreadContext) -import Data.Aeson ((.=)) -import Data.Aeson.Key qualified as Key -import Data.Aeson.Types (Pair) -import Freckle.App.OpenTelemetry (getCurrentSpanContext) -import OpenTelemetry.Trace.Core (SpanContext (..)) -import OpenTelemetry.Trace.Id - ( Base (..) - , spanIdBaseEncodedText - , traceIdBaseEncodedText - ) -import OpenTelemetry.Trace.TraceState (Key (..), TraceState (..), Value (..)) - --- | Add tracing context values to the logging context --- --- Values are encoded to 'Base16' (i.e. hex). -withTraceContext :: (MonadIO m, MonadMask m) => m a -> m a -withTraceContext f = do - mSpanContext <- getCurrentSpanContext - - case mSpanContext of - Nothing -> f - Just sc -> withThreadContext (toThreadContext sc) f - -toThreadContext :: SpanContext -> [Pair] -toThreadContext SpanContext {traceId, spanId, traceState} = - [ "trace_id" .= traceIdBaseEncodedText Base16 traceId - , "span_id" .= spanIdBaseEncodedText Base16 spanId - , "trace_state" .= traceStatePairs - ] - where - traceStatePairs :: [Pair] - traceStatePairs = map traceStatePair $ unTraceState traceState - - traceStatePair :: (Key, Value) -> Pair - traceStatePair = uncurry (.=) . bimap (Key.fromText . unKey) unValue - -unTraceState :: TraceState -> [(Key, Value)] -unTraceState (TraceState x) = x - -unKey :: Key -> Text -unKey (Key x) = x - -unValue :: Value -> Text -unValue (Value x) = x diff --git a/library/Freckle/App/Test/Hspec/Runner.hs b/library/Freckle/App/Test/Hspec/Runner.hs --- a/library/Freckle/App/Test/Hspec/Runner.hs +++ b/library/Freckle/App/Test/Hspec/Runner.hs @@ -17,8 +17,8 @@ , setJUnitConfigSourcePathPrefix ) import Test.Hspec.JUnit.Config.Env (envJUnitConfig) -import qualified Test.Hspec.JUnit.Formatter as JUnit (add) -import qualified Test.Hspec.JUnit.Formatter.Env as JUnit (whenEnabled) +import Test.Hspec.JUnit.Formatter qualified as JUnit (add) +import Test.Hspec.JUnit.Formatter.Env qualified as JUnit (whenEnabled) import Test.Hspec.Runner ( Config , Path diff --git a/library/Freckle/App/Test/Http.hs b/library/Freckle/App/Test/Http.hs deleted file mode 100644 --- a/library/Freckle/App/Test/Http.hs +++ /dev/null @@ -1,336 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE TupleSections #-} -{-# 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 Freckle.App.Prelude - -import Control.Lens (Lens', lens, view, (&), (.~), (<>~)) -import Control.Monad (filterM) -import Control.Monad.Reader (runReaderT) -import Data.Aeson (ToJSON, encode) -import Data.ByteString.Lazy qualified as BSL -import Data.List (stripPrefix) -import Data.String (IsString (..)) -import Freckle.App.Http (MonadHttp (..)) -import Freckle.App.Test.Http.MatchRequest -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 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 deleted file mode 100644 --- a/library/Freckle/App/Test/Http/MatchRequest.hs +++ /dev/null @@ -1,182 +0,0 @@ --- | '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 Freckle.App.Prelude - -import Data.ByteString (ByteString) -import Data.ByteString.Char8 qualified as BS8 -import Data.ByteString.Lazy qualified as BSL -import Data.List (isPrefixOf) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as NE -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 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: freckle-app -version: 1.19.0.0 +version: 1.20.0.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app @@ -55,7 +55,19 @@ library: source-dirs: library reexported-modules: + - Freckle.App.Dotenv - Freckle.App.Env + - 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 dependencies: - Blammo >= 2.0.0.0 - Blammo-wai @@ -76,16 +88,14 @@ - containers - cookie - datadog - - directory - doctest - - dotenv - ekg-core - - errors - exceptions - extra - faktory - - filepath - freckle-env + - freckle-http + - freckle-otel - hashable - hs-opentelemetry-api - hs-opentelemetry-instrumentation-persistent @@ -96,18 +106,13 @@ - hspec-expectations-lifted - hspec-junit-formatter >= 1.1.1.0 # Test.Hspec.JUnit.Formatter - http-client - - http-conduit >= 2.3.5 # addToRequestQueryString - - http-link-header - http-types - immortal - lens - - memcache - monad-control - - monad-logger - monad-logger-aeson - monad-validate - mtl - - network-uri - nonempty-containers - openapi3 - path-pieces @@ -115,14 +120,11 @@ - persistent-postgresql - postgresql-simple - primitive - - pureMD5 - resource-pool >= 0.4.0.0 # defaultPoolConfig, etc - resourcet - - retry >= 0.8.1.0 # retryingDynamic - safe - scientist - semigroupoids - - serialise - template-haskell - text - time @@ -152,28 +154,16 @@ - bytestring - cassava - conduit - - errors - freckle-app - - freckle-env - hs-opentelemetry-api - hspec - - hspec-expectations-json - - hspec-expectations-lifted - http-types - - lens - - lens-aeson - - memcache - monad-validate - - mtl - nonempty-containers - postgresql-simple - - text - - time - - unordered-containers - vector - wai - wai-extra - - zlib doctest: main: Main.hs diff --git a/tests/Freckle/App/Http/CacheSpec.hs b/tests/Freckle/App/Http/CacheSpec.hs deleted file mode 100644 --- a/tests/Freckle/App/Http/CacheSpec.hs +++ /dev/null @@ -1,398 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE NoFieldSelectors #-} - -module Freckle.App.Http.CacheSpec - ( spec - ) where - -import Freckle.App.Prelude - -import Codec.Compression.GZip qualified as GZip -import Control.Lens ((&), (.~), (<>~)) -import Control.Monad.State (StateT, execStateT) -import Data.Aeson (FromJSON, eitherDecode) -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy qualified as BSL -import Data.HashMap.Strict qualified as HashMap -import Data.Time (addUTCTime) -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\"}" - , "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 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) => 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/Freckle/App/HttpSpec.hs b/tests/Freckle/App/HttpSpec.hs deleted file mode 100644 --- a/tests/Freckle/App/HttpSpec.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Freckle.App.HttpSpec - ( spec - ) where - -import Freckle.App.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/tests/Freckle/App/Memcached/ServersSpec.hs b/tests/Freckle/App/Memcached/ServersSpec.hs deleted file mode 100644 --- a/tests/Freckle/App/Memcached/ServersSpec.hs +++ /dev/null @@ -1,84 +0,0 @@ -module Freckle.App.Memcached.ServersSpec - ( spec - ) where - -import Freckle.App.Prelude - -import Control.Error.Util (hush) -import Data.Either (isLeft, isRight) -import Database.Memcache.Client qualified as Memcache -import Freckle.App.Memcached.Servers -import Freckle.App.Test - -spec :: Spec -spec = do - describe "readMemcachedServers" $ do - it "requires the correct prefix" $ example $ do - void (readMemcachedServers "http://") `shouldSatisfy` isLeft - void (readMemcachedServers "memcached://") `shouldSatisfy` isRight - - it "treats an empty value as none" $ example $ do - readServerSpecs "" `shouldBe` Just [] - - it "treats an empty prefixed value as default" $ example $ do - readServerSpecs "memcached://" `shouldBe` Just [Memcache.def] - - it "can set host" $ example $ do - let mServer = readServerSpec "memcached://my-host" - - fmap Memcache.ssHost mServer `shouldBe` Just "my-host" - fmap Memcache.ssPort mServer `shouldBe` Just "11211" - fmap Memcache.ssAuth mServer `shouldBe` Just Memcache.NoAuth - - it "can set port" $ example $ do - let mServer = readServerSpec "memcached://:11212" - - fmap Memcache.ssHost mServer `shouldBe` Just defaultHost - fmap Memcache.ssPort mServer `shouldBe` Just "11212" - fmap Memcache.ssAuth mServer `shouldBe` Just Memcache.NoAuth - - it "can set auth" $ example $ do - let mServer = readServerSpec "memcached://user:password@" - - fmap Memcache.ssHost mServer `shouldBe` Just defaultHost - fmap Memcache.ssPort mServer `shouldBe` Just "11211" - fmap Memcache.ssAuth mServer - `shouldBe` Just (Memcache.Auth "user" "password") - - it "refuses user-less or password-less auth" $ example $ do - let - mAuth1 = Memcache.ssAuth <$> readServerSpec "memcached://user:@" - mAuth2 = Memcache.ssAuth <$> readServerSpec "memcached://:password@" - - mAuth1 `shouldBe` Just Memcache.NoAuth - mAuth2 `shouldBe` Just Memcache.NoAuth - - it "can set lots at once" $ example $ do - let mServer = readServerSpec "memcached://user:password@my-host:11212" - - fmap Memcache.ssHost mServer `shouldBe` Just "my-host" - fmap Memcache.ssPort mServer `shouldBe` Just "11212" - fmap Memcache.ssAuth mServer - `shouldBe` Just (Memcache.Auth "user" "password") - - it "can do all of this for a list of servers" $ example $ do - let mServerSpecs = - readServerSpecs - "memcached://a-host,memcached://b-host:11212,memcached://u:p@:11213" - - fmap (map Memcache.ssHost) mServerSpecs - `shouldBe` Just ["a-host", "b-host", defaultHost] - fmap (map Memcache.ssPort) mServerSpecs - `shouldBe` Just ["11211", "11212", "11213"] - fmap (map Memcache.ssAuth) mServerSpecs - `shouldBe` Just - [Memcache.NoAuth, Memcache.NoAuth, Memcache.Auth "u" "p"] - -readServerSpec :: String -> Maybe Memcache.ServerSpec -readServerSpec = headMay <=< readServerSpecs - -readServerSpecs :: String -> Maybe [Memcache.ServerSpec] -readServerSpecs = fmap toServerSpecs . hush . readMemcachedServers - -defaultHost :: String -defaultHost = Memcache.ssHost Memcache.def diff --git a/tests/Freckle/App/MemcachedSpec.hs b/tests/Freckle/App/MemcachedSpec.hs deleted file mode 100644 --- a/tests/Freckle/App/MemcachedSpec.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Freckle.App.MemcachedSpec - ( spec - ) where - -import Freckle.App.Test - -import Blammo.Logging.LogSettings -import Blammo.Logging.Logger -import Control.Lens (lens, to, (^?)) -import Data.Aeson (Value (..)) -import Data.Aeson.Lens -import Data.List.NonEmpty qualified as NE -import Data.Text qualified as T -import Freckle.App.Env qualified as Env -import Freckle.App.Memcached -import Freckle.App.Memcached.Client (MemcachedClient, withMemcachedClient) -import Freckle.App.Memcached.Client qualified as Memcached -import Freckle.App.Memcached.Servers -import Freckle.App.OpenTelemetry - -data ExampleValue - = A - | B - | C - deriving stock (Eq, Show) - -instance Cachable ExampleValue where - toCachable = \case - A -> "A" - B -> "Broken" - C -> "C" - - fromCachable = \case - "A" -> Right A - "B" -> Right B - "C" -> Right C - x -> Left $ "invalid: " <> show x - -data App = App - { appMemcachedClient :: MemcachedClient - , appLogger :: Logger - , appTracer :: Tracer - } - -instance HasMemcachedClient App where - memcachedClientL = - lens appMemcachedClient $ \x y -> x {appMemcachedClient = y} - -instance HasLogger App where - loggerL = lens appLogger $ \x y -> x {appLogger = y} - -instance HasTracer App where - tracerL = lens appTracer $ \x y -> x {appTracer = y} - -loadApp :: (App -> IO a) -> IO a -loadApp f = do - servers <- - Env.parse id $ - Env.var - (Env.eitherReader readMemcachedServers) - "MEMCACHED_SERVERS" - (Env.def defaultMemcachedServers) - appLogger <- newTestLogger defaultLogSettings - withTracerProvider $ \tp -> do - let appTracer = makeTracer tp "freckle-app" tracerOptions - withMemcachedClient servers $ \appMemcachedClient -> do - f App {..} - -spec :: Spec -spec = withApp loadApp $ do - describe "caching" $ do - it "caches the given action by key using Cachable" $ appExample $ do - k <- cacheKeyThrow "A" - - val <- caching k (cacheTTL 5) $ pure A - mbs <- Memcached.get k - - val `shouldBe` A - mbs `shouldBe` Just "A" - - it "logs, but doesn't fail, on deserialization errors" $ appExample $ do - k <- cacheKeyThrow "B" - - val0 <- caching k (cacheTTL 5) $ pure B -- set - val1 <- caching k (cacheTTL 5) $ pure B -- get will fail - mbs <- Memcached.get k - - val0 `shouldBe` B - val1 `shouldBe` B - mbs `shouldBe` Just "Broken" - - msgs <- getLoggedMessagesLenient - let Just LoggedMessage {..} = NE.last <$> NE.nonEmpty msgs - Object loggedMessageMeta ^? key "error" . key "message" . _String - `shouldBe` Just "Unable to deserialize: invalid: \"Broken\"" - - -- This assertion is far too brittle, but can be useful to un-comment if - -- you intend to work on this logic specifically - -- Object loggedMessageMeta ^? key "error" . key "stack" . _String . to T.lines - -- `shouldBe` Just - -- [ "CallStack (from HasCallStack):" - -- , " throwM, called at library/Freckle/App/Memcached.hs:121:30 in freckle-app-1.10.8.0-1ebuZKUCQVI9sAWTLATGfO:Freckle.App.Memcached" - -- , " cachingAs, called at library/Freckle/App/Memcached.hs:92:11 in freckle-app-1.10.8.0-1ebuZKUCQVI9sAWTLATGfO:Freckle.App.Memcached" - -- , " caching, called at tests/Freckle/App/MemcachedSpec.hs:87:15 in main:Freckle.App.MemcachedSpec" - -- ] - Object loggedMessageMeta - ^? key "error" . key "stack" . _String . to T.lines - `shouldSatisfy` maybe False (not . null) diff --git a/tests/Freckle/App/OpenTelemetry/ContextSpec.hs b/tests/Freckle/App/OpenTelemetry/ContextSpec.hs deleted file mode 100644 --- a/tests/Freckle/App/OpenTelemetry/ContextSpec.hs +++ /dev/null @@ -1,156 +0,0 @@ -module Freckle.App.OpenTelemetry.ContextSpec - ( spec - ) where - -import Freckle.App.Test - -import Blammo.Logging -import Blammo.Logging.Logger (newTestLogger) -import Control.Lens (lens) -import Data.Text qualified as T -import Freckle.App.OpenTelemetry -import Freckle.App.OpenTelemetry.Context -import Network.HTTP.Types.Header (Header) -import OpenTelemetry.Trace.Core qualified as Trace - -data App = App - { appLogger :: Logger - , appTracer :: Tracer - } - -instance HasLogger App where - loggerL = lens appLogger $ \x y -> x {appLogger = y} - -instance HasTracer App where - tracerL = lens appTracer $ \x y -> x {appTracer = y} - -loadApp :: (App -> IO ()) -> IO () -loadApp f = do - appLogger <- newTestLogger defaultLogSettings - - withTracerProvider $ \tracerProvider -> do - let appTracer = makeTracer tracerProvider "app" tracerOptions - f App {..} - -spec :: Spec -spec = withApp loadApp $ do - describe "injectContext" $ do - it "sets request headers from existing context" $ appExample $ do - inSpan "example" defaultSpanArguments $ do - spanContext <- assertCurrentSpanContext - - let expectedTraceParent = - toTraceParent - (traceIdToHex $ Trace.traceId spanContext) - (spanIdToHex $ Trace.spanId spanContext) - - injectContext ([] :: [Header]) - `shouldReturn` [ ("traceparent", encodeUtf8 expectedTraceParent) - , ("tracestate", "") - ] - - describe "extractContext" $ do - it "sets the context from the headers" $ appExample $ do - let - traceId = "fba7cd19bff3ef866a599d6f6a85baef" - spanId = "5747fd6b144f4009" - - headers :: [Header] - headers = - [ ("traceparent", encodeUtf8 $ toTraceParent traceId spanId) - , ("tracestate", "") - ] - - extractContext headers - - spanContext <- assertCurrentSpanContext - traceIdToHex (Trace.traceId spanContext) `shouldBe` traceId - spanIdToHex (Trace.spanId spanContext) `shouldBe` spanId - - it "does nothing with no headers" $ appExample $ do - getCurrentSpanContext `shouldReturn` Nothing - - extractContext ([] :: [Header]) - - getCurrentSpanContext `shouldReturn` Nothing - - describe "processWithContext" $ do - it "creates a child-span context" $ appExample $ do - inSpan "example" defaultSpanArguments $ do - outerSpanContext <- assertCurrentSpanContext - - let - traceId = traceIdToHex $ Trace.traceId outerSpanContext - spanId = spanIdToHex $ Trace.spanId outerSpanContext - - headers :: [Header] - headers = - [ ("traceparent", encodeUtf8 $ toTraceParent traceId spanId) - , ("tracestate", "") - ] - - processWithContext "loop" defaultSpanArguments headers $ \_ -> do - innerSpanContext <- assertCurrentSpanContext - - -- Ideally we'd assert the inner span's parent is the outer span, but - -- the library doesn't expose the necessary functionality. All we can - -- do is assert it's a fresh span of the same trace. - Trace.traceId innerSpanContext `shouldBe` Trace.traceId outerSpanContext - Trace.spanId innerSpanContext `shouldNotBe` Trace.spanId outerSpanContext - - it "sets the current context back into the headers" $ appExample $ do - inSpan "example" defaultSpanArguments $ do - let - traceId = "fba7cd19bff3ef866a599d6f6a85baef" - spanId = "5747fd6b144f4009" - - headers :: [Header] - headers = - [ ("traceparent", encodeUtf8 $ toTraceParent traceId spanId) - , ("tracestate", "") - ] - - processWithContext "loop" defaultSpanArguments headers $ \headers' -> do - spanContext <- assertCurrentSpanContext - - let headerTraceParent = do - bs <- lookup "traceparent" headers' - fromTraceParent $ decodeUtf8 bs - - fmap fst headerTraceParent `shouldBe` Just traceId - fmap snd headerTraceParent - `shouldBe` Just (spanIdToHex $ Trace.spanId spanContext) - - it "sets a fresh context back into the headers" $ appExample $ do - inSpan "example" defaultSpanArguments $ do - let - headers :: [Header] - headers = [] - - processWithContext "loop" defaultSpanArguments headers $ \headers' -> do - spanContext <- assertCurrentSpanContext - - let headerTraceParent = do - bs <- lookup "traceparent" headers' - fromTraceParent $ decodeUtf8 bs - - fmap fst headerTraceParent - `shouldBe` Just (traceIdToHex $ Trace.traceId spanContext) - fmap snd headerTraceParent - `shouldBe` Just (spanIdToHex $ Trace.spanId spanContext) - -assertCurrentSpanContext :: (MonadIO m, HasCallStack) => m Trace.SpanContext -assertCurrentSpanContext = - getCurrentSpanContext >>= \case - Nothing -> expectationFailure "Expect there to be a SpanContext" - Just spanContext -> pure spanContext - -toTraceParent :: Text -> Text -> Text -toTraceParent traceId spanId = "00-" <> traceId <> "-" <> spanId <> "-00" - -fromTraceParent :: Text -> Maybe (Text, Text) -fromTraceParent a = do - b <- T.stripPrefix "00-" a - c <- T.stripSuffix "-00" b - [traceId, spanId] <- Just $ T.splitOn "-" c - pure (traceId, spanId)