freckle-app 1.19.0.0 → 1.20.0.0

raw patch · 30 files changed

+53/−3524 lines, 30 filesdep +freckle-httpdep +freckle-oteldep −directorydep −dotenvdep −errorsdep ~freckle-env

Dependencies added: freckle-http, freckle-otel

Dependencies removed: directory, dotenv, errors, filepath, hspec-expectations-json, http-conduit, http-link-header, lens-aeson, memcache, monad-logger, network-uri, pureMD5, retry, serialise, zlib

Dependency ranges changed: freckle-env

Files

• CHANGELOG.md +16/−0
• freckle-app.cabal +20/−54
• library/Freckle/App/Dotenv.hs +0/−62
• library/Freckle/App/Http.hs +0/−293
• library/Freckle/App/Http/Cache.hs +0/−335
• library/Freckle/App/Http/Cache/Gzip.hs +0/−63
• library/Freckle/App/Http/Cache/Memcached.hs +0/−146
• library/Freckle/App/Http/Cache/State.hs +0/−80
• library/Freckle/App/Http/Header.hs +0/−46
• library/Freckle/App/Http/Paginate.hs +0/−97
• library/Freckle/App/Http/Retry.hs +0/−95
• library/Freckle/App/Memcached.hs +0/−158
• library/Freckle/App/Memcached/CacheKey.hs +0/−49
• library/Freckle/App/Memcached/CacheTTL.hs +0/−39
• library/Freckle/App/Memcached/Client.hs +0/−135
• library/Freckle/App/Memcached/MD5.hs +0/−21
• library/Freckle/App/Memcached/Servers.hs +0/−109
• library/Freckle/App/OpenTelemetry.hs +0/−171
• library/Freckle/App/OpenTelemetry/Context.hs +0/−116
• library/Freckle/App/OpenTelemetry/Http.hs +0/−58
• library/Freckle/App/OpenTelemetry/ThreadContext.hs +0/−53
• library/Freckle/App/Test/Hspec/Runner.hs +2/−2
• library/Freckle/App/Test/Http.hs +0/−336
• library/Freckle/App/Test/Http/MatchRequest.hs +0/−182
• package.yaml +15/−25
• tests/Freckle/App/Http/CacheSpec.hs +0/−398
• tests/Freckle/App/HttpSpec.hs +0/−51
• tests/Freckle/App/Memcached/ServersSpec.hs +0/−84
• tests/Freckle/App/MemcachedSpec.hs +0/−110
• tests/Freckle/App/OpenTelemetry/ContextSpec.hs +0/−156

@@ -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`

@@ -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:

@@ -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

@@ -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

@@ -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@)------ - <https://developer.mozilla.org/en-US/docs/Web/HTTP/Caching#vary>--- - <https://developer.mozilla.org/en-US/docs/Web/HTTP/Caching#fresh_and_stale_based_on_age>------ If a cached response is stale, but it has an @ETag@ header, we will make the--- request using @If-None-Match@ and still return (and retain) that cached--- response if we receive a @304@ response.------ - <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/ETag#caching_of_unchanged_resources>----httpCached-  :: forall m t-   . MonadIO m-  => HttpCacheSettings m t-  -> (Request -> m (Response BSL.ByteString))-  -> Request-  -> m (Response BSL.ByteString)-httpCached settings doHttp req =-  maybe (doHttp req) handleCachableRequest $ getCachableRequestKey settings req- where-  handleCachableRequest key = do-    now <- settings.getCurrentTime-    result <- fromEx Nothing $ settings.cache.get key--    let tkey = 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------ <https://stackoverflow.com/a/39406969>-cacheableStatusCodes :: [Int]-cacheableStatusCodes =-  [ 200 -- OK-  , 203 -- Non-Authoritative Information-  , 204 -- No Content-  , 206 -- Partial Content-  , 300 -- Multiple Choices-  , 301 -- Moved Permanently-  , 404 -- Not Found-  , 405 -- Method Not Allowed-  , 410 -- Gone-  , 414 -- URI Too Long-  , 501 -- Not Implemented-  ]--newtype Seconds = Seconds {unwrap :: Int}-  deriving stock (Eq)-  deriving newtype (Num, Show, Read)--data CacheControl-  = Private-  | NoStore-  | MaxAge Seconds-  deriving stock (Eq, Show)--cacheControlMaxAge :: [CacheControl] -> Maybe Seconds-cacheControlMaxAge = firstJust $ \case-  MaxAge s -> Just s-  _ -> Nothing--readCacheControl :: ByteString -> Maybe CacheControl-readCacheControl = go . CI.foldCase- where-  go = \case-    "private" -> Just Private-    "no-store" -> Just NoStore-    h | Just s <- BS8.stripPrefix "max-age=" h -> MaxAge <$> 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-    }---- | <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Date#syntax>-httpDateFormat :: String-httpDateFormat = "%a, %d %b %Y %H:%M:%S GMT"--responseHeadersToTTL :: ResponseHeaders -> Maybe CacheTTL-responseHeadersToTTL hs = cacheTTL . (.unwrap) <$> viaMaxAge <|> viaExpires- where-  viaMaxAge = subtract hs.age <$> cacheControlMaxAge hs.cacheControl-  viaExpires = round . utcTimeToPOSIXSeconds <$> hs.expires

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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------ <https://github.com/memcached/memcached/blob/master/doc/protocol.txt#L41>------ @--- 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

@@ -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

@@ -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

@@ -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

@@ -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}

@@ -1,171 +0,0 @@--- | Application tracing via <https://opentelemetry.io/>------ @--- 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 <https://github.com/iand675/hs-opentelemetry/issues/60>.-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.------ <https://docs.newrelic.com/docs/more-integrations/open-source-telemetry-integrations/opentelemetry/best-practices/opentelemetry-best-practices-attributes/>-attributeValueLimit :: Int-attributeValueLimit = 4095--truncateText :: Int -> Text -> Text-truncateText l t-  | T.length t <= l = t-  | otherwise = T.take (l - 3) t <> "..."

@@ -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'

@@ -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

@@ -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

@@ -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

@@ -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"--- >   ]

@@ -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

@@ -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

@@ -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 .~ "<ignore me>\n"-              , "https://example.com/1"-                  & headersL <>~ [(hCacheControl, "max-age=-1")]-                  & headersL <>~ [(hETag, etag)]-                  & bodyL .~ "Original body\n"-              ]--        cache <- execCached $ do-          let req = parseRequest_ "https://example.com/1"-          requestBodyCached settings stubs req `shouldReturn` "Original body\n"-          requestBodyCached settings stubs req `shouldReturn` "Original body\n"--        cache.map `shouldSatisfy` ((== 1) . HashMap.size)--      it "updates cached response on 304 from If-None-Match" $ do-        let stubs =-              [ "https://example.com/1"-                  & matchL <>~ MatchHeader (hIfNoneMatch, etag)-                  & statusL .~ status304-                  & headersL <>~ [(hCacheControl, "max-age=120")]-                  & bodyL .~ "<ignore me>\n"-              , "https://example.com/1"-                  & headersL <>~ [(hCacheControl, "max-age=-1")]-                  & headersL <>~ [(hETag, etag)]-                  & bodyL .~ "Original body\n"-              ]--        cache <- execCached $ do-          let req = parseRequest_ "https://example.com/1"-          requestBodyCached settings stubs req `shouldReturn` "Original body\n"-          requestBodyCached settings stubs req `shouldReturn` "Original body\n"--        cache.map `shouldSatisfy` ((== 1) . HashMap.size)-        map (.ttl) (HashMap.elems cache.map) `shouldBe` [120]--      it "evicts a stale response after trying If-None-Match" $ do-        let stubs =-              [ "https://example.com/1"-                  & matchL <>~ MatchHeader (hIfNoneMatch, etag)-                  & headersL <>~ [(hCacheControl, "no-store")]-                  & bodyL .~ "Newer body\n"-              , "https://example.com/1"-                  & headersL <>~ [(hCacheControl, "max-age=-1")]-                  & headersL <>~ [(hETag, etag)]-                  & bodyL .~ "Original body\n"-              ]--        cache <- execCached $ do-          let req = parseRequest_ "https://example.com/1"-          requestBodyCached settings stubs req `shouldReturn` "Original body\n"-          requestBodyCached settings stubs req `shouldReturn` "Newer body\n"--        cache.map `shouldSatisfy` ((== 0) . HashMap.size)--    context "setting TTL" $ do-      let req = parseRequest_ "https://example.com"--      it "sets TTL based on max-age" $ do-        let stubs =-              [ "https://example.com"-                  & headersL <>~ [(hCacheControl, "max-age=42")]-              ]--        cache <- execCached $ requestBodyCached settings stubs req-        map (.ttl) (HashMap.elems cache.map) `shouldBe` [42]--      it "sets TTL based on max-age + Age" $ do-        let stubs =-              [ "https://example.com"-                  & headersL <>~ [(hAge, "78000"), (hCacheControl, "max-age=78250")]-              ]--        cache <- execCached $ requestBodyCached settings stubs req-        map (.ttl) (HashMap.elems cache.map) `shouldBe` [250]--      it "sets TTL based on Expires" $ do-        let-          expDate = "Wed, 21 Oct 2015 07:28:00 GMT"-          expSeconds = 1445412480 -- `date --date '{eDate}' +%s`-          stubs = ["https://example.com" & headersL <>~ [(hExpires, expDate)]]--        cache <- execCached $ requestBodyCached settings stubs req-        map (.ttl) (HashMap.elems cache.map) `shouldBe` [expSeconds]--    context "un-cacheable requests" $ do-      it "does not cache if told not to" $ do-        let req = parseRequest_ "https://example.com"-        cache <- execCached $ requestBodyCached settingsDisabled stubAnything req-        cache.map `shouldSatisfy` ((== 0) . HashMap.size)--      it "does not cache non-GET methods" $ do-        let req = parseRequest_ "POST https://example.com"-        cache <- execCached $ requestBodyCached settings stubAnything req-        cache.map `shouldSatisfy` ((== 0) . HashMap.size)--      it "does not cache no-store" $ do-        let req =-              parseRequest_ "https://example.com"-                & addRequestHeader hCacheControl "no-store"-        cache <- execCached $ requestBodyCached settings stubAnything req-        cache.map `shouldSatisfy` ((== 0) . HashMap.size)--      it "does not cache private in a shared cache" $ do-        let req =-              parseRequest_ "https://example.com"-                & addRequestHeader hCacheControl "private"-        cache <- execCached $ requestBodyCached settingsShared stubAnything req-        cache.map `shouldSatisfy` ((== 0) . HashMap.size)--    context "un-cacheable responses" $ do-      let req = parseRequest_ "https://example.com"--      it "does not cache no-store" $ do-        let stubs =-              [ "https://example.com"-                  & headersL <>~ [(hCacheControl, "no-store, max-age=0, public")]-              ]--        cache <- execCached $ requestBodyCached settings stubs req-        cache.map `shouldSatisfy` ((== 0) . HashMap.size)--      it "does not cache private in a shared cache" $ do-        let stubs =-              [ "https://example.com"-                  & headersL <>~ [(hCacheControl, "max-age=0, private")]-              ]--        cache <- execCached $ requestBodyCached settingsShared stubs req-        cache.map `shouldSatisfy` ((== 0) . HashMap.size)--      for_ [status100, status307, status400, status503] $ \s -> do-        it ("does not cache un-cacheable status " <> show (statusCode s)) $ do-          let stubs = ["https://example.com" & statusL .~ s]--          cache <- execCached $ requestBodyCached settingsShared stubs req-          cache.map `shouldSatisfy` ((== 0) . HashMap.size)--execCached :: StateT Cache IO a -> IO Cache-execCached = flip execStateT mempty--requestBodyCached-  :: CacheSettings-  -> [HttpStub]-  -> Request-  -> StateT Cache IO 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 "<unreachable>"-  Right a -> pure a

@@ -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)

@@ -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

@@ -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)

@@ -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)