freckle-app 1.14.0.0 → 1.15.0.0

raw patch · 25 files changed

+937/−357 lines, 25 filesdep +directorydep ~Blammodep ~QuickCheckdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: directory

Dependency ranges changed: Blammo, QuickCheck, aeson, annotated-exception, autodocodec, base, bytestring, cassava, conduit, conduit-extra, cookie, datadog, doctest, dotenv, extra, filepath, hashable, hspec, http-client, lens, lens-aeson, monad-logger-aeson, monad-validate, network-uri, openapi3, persistent, persistent-postgresql, resourcet, serialise, template-haskell, text, time, typed-process, unliftio, unliftio-core, unordered-containers, wai-extra, yaml, yesod-core, yesod-test

API changes (from Hackage documentation)

Files

• CHANGELOG.md +42/−1
• freckle-app.cabal +82/−89
• library/Configuration/Dotenv/Compat.hs +0/−12
• library/Freckle/App.hs +5/−7
• library/Freckle/App/Aeson.hs +0/−26
• library/Freckle/App/Bugsnag/MetaData.hs +2/−2
• library/Freckle/App/Csv.hs +10/−1
• library/Freckle/App/Database.hs +15/−14
• library/Freckle/App/Dotenv.hs +1/−1
• library/Freckle/App/Ecs.hs +1/−1
• library/Freckle/App/Env.hs +0/−26
• library/Freckle/App/Http.hs +107/−64
• library/Freckle/App/Http/Paginate.hs +5/−4
• library/Freckle/App/Memcached/Servers.hs +2/−12
• library/Freckle/App/Stats.hs +5/−3
• library/Freckle/App/Test.hs +1/−26
• library/Freckle/App/Test/Http.hs +336/−0
• library/Freckle/App/Test/Http/MatchRequest.hs +182/−0
• library/Freckle/App/Yesod/Routes.hs +1/−10
• library/Network/HTTP/Link/Compat.hs +0/−28
• library/Network/Wai/Middleware/Stats.hs +1/−1
• package.yaml +9/−9
• tests/Freckle/App/HttpSpec.hs +10/−5
• tests/Freckle/App/Memcached/ServersSpec.hs +5/−15
• tests/Freckle/App/Test/Http/MatchRequestSpec.hs +115/−0

@@ -1,4 +1,45 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.14.0.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.15.0.0...main)++## [v1.15.0.0](https://github.com/freckle/freckle-app/compare/v1.14.0.0...v1.15.0.0)++- Support `aeson-2.2`+- Support `http-client-0.7.16`++- Drop support for GHC < 9.2, add CI for GHC 9.8++  **BREAKING**. Things may still compile, but we've stopped testing with+  resolvers lower than `lts-20`. Accordingly, `CPP` branches supporting+  dependencies from below that resolver were also removed, and the following+  minimum bounds were raised:++  - `aeson > 2.0`+  - `dotenv > 0.10`+  - `envparse > 0.5`+  - `http-link-header >1.2`+  - `mecache > 0.3.0`+  - `template-haskell > 2.18.0`++- Introduce `MonadHttp`++  **BREAKING**. `Freckle.App.Http` now uses a custom `MonadHttp` class instead+  of `MonadIO`. This allows customizing the behavior of HTTP centrally for your+  entire application stack, including stubbing HTTP requests in tests.++  An `IO` instance exists, so users can either add:++  ```hs+  instance MonadHttp AppM where+    httpLbs = liftIO httpLbs+  ```++  Or replace call-sites,++  ```diff+  - resp <- httpLbs req+  + resp <- liftIO $ httpLbs req+  ```++  To maintain behavior across this upgrade.  ## [v1.14.0.0](https://github.com/freckle/freckle-app/compare/v1.13.0.1...v1.14.0.1) 

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               freckle-app-version:            1.14.0.0+version:            1.15.0.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -21,9 +21,7 @@  library     exposed-modules:-        Configuration.Dotenv.Compat         Freckle.App-        Freckle.App.Aeson         Freckle.App.Async         Freckle.App.Bugsnag         Freckle.App.Bugsnag.HttpException@@ -63,13 +61,14 @@         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.Yesod         Freckle.App.Wai         Freckle.App.Yesod         Freckle.App.Yesod.Routes-        Network.HTTP.Link.Compat         Network.Wai.Middleware.Cors         Network.Wai.Middleware.OpenTelemetry         Network.Wai.Middleware.Stats@@ -88,42 +87,44 @@         TypeApplications TypeFamilies      ghc-options:-        -fignore-optim-changes -Weverything -Wno-all-missed-specialisations-        -Wno-missing-exported-signatures -Wno-missing-import-lists-        -Wno-missing-local-signatures -Wno-monomorphism-restriction-        -Wno-safe -Wno-unsafe+        -fignore-optim-changes -fwrite-ide-info -Weverything+        -Wno-all-missed-specialisations -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-local-signatures+        -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction+        -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe      build-depends:-        Blammo >=1.0.2.2,+        Blammo >=1.1.2.0,         Glob >=0.10.2,         MonadRandom >=0.5.3,-        QuickCheck >=2.14.2,-        aeson >=1.5.6.0,-        annotated-exception >=0.2.0.5,-        autodocodec >=0.2.2.0,+        QuickCheck >=2.14.3,+        aeson >=2.0.3.0,+        annotated-exception >=0.2.0.4,+        autodocodec >=0.2.0.3,         autodocodec-openapi3 >=0.2.1.1,         aws-xray-client-persistent >=0.1.0.5,         aws-xray-client-wai >=0.1.0.2,-        base >=4.14.3.0 && <5,+        base >=4.16.4.0 && <5,         bcp47 >=0.2.0.6,         bugsnag >=1.1.0.0,-        bytestring >=0.10.12.0,+        bytestring >=0.11.4.0,         case-insensitive >=1.2.1.0,-        cassava >=0.5.2.0,-        conduit >=1.3.4.2,-        conduit-extra >=1.3.5,+        cassava >=0.5.3.0,+        conduit >=1.3.5,+        conduit-extra >=1.3.6,         containers >=0.6.5.1,-        cookie >=0.4.5,-        datadog >=0.2.5.0,-        doctest >=0.17,-        dotenv >=0.8.0.7,+        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,         envparse >=0.5.0,         errors >=2.3.0,         exceptions >=0.10.4,-        extra >=1.7.9,-        filepath >=1.4.2.1,-        hashable >=1.3.0.0,+        extra >=1.7.13,+        filepath >=1.4.2.2,+        hashable >=1.4.2.0,         hs-opentelemetry-api >=0.1.0.0,         hs-opentelemetry-instrumentation-persistent >=0.1.0.0,         hs-opentelemetry-instrumentation-wai >=0.1.0.0,@@ -133,60 +134,56 @@         hspec-core >=2.8.1,         hspec-expectations-lifted >=0.10.0,         hspec-junit-formatter >=1.1.0.1,-        http-client >=0.6.4.1,+        http-client >=0.7.13.1,         http-conduit >=2.3.5,         http-link-header >=1.2.1,         http-types >=0.12.3,         hw-kafka-client >=4.0.3 && <5.0.0,         immortal >=0.3,-        lens >=4.19.2,+        lens >=5.1.1,         memcache >=0.3.0.1,         monad-control >=1.0.3.1,-        monad-logger-aeson >=0.3.0.2,-        monad-validate >=1.2.0.1,+        monad-logger-aeson >=0.4.0.4,+        monad-validate >=1.3.0.0,         mtl >=2.2.2,-        network-uri >=2.6.4.1,+        network-uri >=2.6.4.2,         nonempty-containers >=0.3.4.4,-        openapi3 >=3.1.0,+        openapi3 >=3.2.3,         path-pieces >=0.2.1,-        persistent >=2.13.3.0,-        persistent-postgresql >=2.13.4.0,+        persistent >=2.13.3.5,+        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.4.3,+        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.4.0,-        template-haskell >=2.16.0.0,-        text >=1.2.4.1,-        time >=1.9.3,+        serialise >=0.2.6.0,+        template-haskell >=2.18.0.0,+        text >=1.2.5.0,+        time >=1.11.1.1,         transformers >=0.5.6.2,         transformers-base >=0.4.6,-        typed-process >=0.2.8.0,-        unliftio >=0.2.21.0,-        unliftio-core >=0.2.0.1,-        unordered-containers >=0.2.16.0,+        typed-process >=0.2.11.0,+        unliftio >=0.2.25.0,+        unliftio-core >=0.2.1.0,+        unordered-containers >=0.2.19.1,         vector >=0.12.3.1,         wai >=3.2.3,-        wai-extra >=3.1.8,-        yaml >=0.11.8.0,-        yesod-core >=1.6.21.0,-        yesod-test >=1.6.12+        wai-extra >=3.1.13.0,+        yaml >=0.11.11.1,+        yesod-core >=1.6.24.2,+        yesod-test >=1.6.15 +    if impl(ghc >=9.8)+        ghc-options: -Wno-missing-role-annotations+     if impl(ghc >=9.2)         ghc-options: -Wno-missing-kind-signatures -    if impl(ghc >=8.10)-        ghc-options:-            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module--    if impl(ghc >=8.8)-        ghc-options: -fwrite-ide-info- test-suite doctest     type:               exitcode-stdio-1.0     main-is:            Main.hs@@ -203,25 +200,22 @@         TypeApplications TypeFamilies      ghc-options:-        -fignore-optim-changes -Weverything -Wno-all-missed-specialisations-        -Wno-missing-exported-signatures -Wno-missing-import-lists-        -Wno-missing-local-signatures -Wno-monomorphism-restriction-        -Wno-safe -Wno-unsafe+        -fignore-optim-changes -fwrite-ide-info -Weverything+        -Wno-all-missed-specialisations -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-local-signatures+        -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction+        -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe      build-depends:-        base >=4.14.3.0 && <5,+        base >=4.16.4.0 && <5,         freckle-app +    if impl(ghc >=9.8)+        ghc-options: -Wno-missing-role-annotations+     if impl(ghc >=9.2)         ghc-options: -Wno-missing-kind-signatures -    if impl(ghc >=8.10)-        ghc-options:-            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module--    if impl(ghc >=8.8)-        ghc-options: -fwrite-ide-info- test-suite spec     type:               exitcode-stdio-1.0     main-is:            Main.hs@@ -233,6 +227,7 @@         Freckle.App.HttpSpec         Freckle.App.Memcached.ServersSpec         Freckle.App.MemcachedSpec+        Freckle.App.Test.Http.MatchRequestSpec         Freckle.App.Test.Properties.JSONSpec         Freckle.App.Test.Properties.PathPieceSpec         Freckle.App.WaiSpec@@ -250,41 +245,39 @@         TypeApplications TypeFamilies      ghc-options:-        -fignore-optim-changes -Weverything -Wno-all-missed-specialisations-        -Wno-missing-exported-signatures -Wno-missing-import-lists-        -Wno-missing-local-signatures -Wno-monomorphism-restriction-        -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N+        -fignore-optim-changes -fwrite-ide-info -Weverything+        -Wno-all-missed-specialisations -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-local-signatures+        -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction+        -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded+        -rtsopts -with-rtsopts=-N      build-depends:-        Blammo >=1.0.2.2,-        QuickCheck >=2.14.2,-        aeson >=1.5.6.0,-        base >=4.14.3.0 && <5,+        Blammo >=1.1.2.0,+        QuickCheck >=2.14.3,+        aeson >=2.0.3.0,+        base >=4.16.4.0 && <5,         bugsnag >=1.1.0.0,-        bytestring >=0.10.12.0,-        cassava >=0.5.2.0,-        conduit >=1.3.4.2,+        bytestring >=0.11.4.0,+        cassava >=0.5.3.0,+        conduit >=1.3.5,         errors >=2.3.0,         freckle-app,-        hspec >=2.9.3,+        hspec >=2.9.7,         http-types >=0.12.3,-        lens >=4.19.2,-        lens-aeson >=1.1.3,+        lens >=5.1.1,+        lens-aeson >=1.2.2,         memcache >=0.3.0.1,-        monad-validate >=1.2.0.1,+        monad-validate >=1.3.0.0,         nonempty-containers >=0.3.4.4,         postgresql-simple >=0.6.4,-        text >=1.2.4.1,+        text >=1.2.5.0,         vector >=0.12.3.1,         wai >=3.2.3,-        wai-extra >=3.1.8+        wai-extra >=3.1.13.0 +    if impl(ghc >=9.8)+        ghc-options: -Wno-missing-role-annotations+     if impl(ghc >=9.2)         ghc-options: -Wno-missing-kind-signatures--    if impl(ghc >=8.10)-        ghc-options:-            -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module--    if impl(ghc >=8.8)-        ghc-options: -fwrite-ide-info

@@ -1,12 +0,0 @@-{-# LANGUAGE CPP #-}--module Configuration.Dotenv.Compat-  ( module X-  ) where--import Configuration.Dotenv as X--#if !MIN_VERSION_dotenv(0,6,0)--- The Config type was here in older versions-import Configuration.Dotenv.Types as X-#endif

@@ -184,12 +184,12 @@ import Blammo.Logging import Control.Lens (view) import Control.Monad.Catch (MonadCatch, MonadThrow)-import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.Reader import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT) import Freckle.App.Database import qualified Freckle.App.Database.XRay as XRay+import Freckle.App.Http (MonadHttp (..)) import Freckle.App.OpenTelemetry import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) @@ -219,6 +219,7 @@     , Applicative     , Monad     , MonadIO+    , MonadUnliftIO     , MonadThrow     , MonadCatch     , MonadMask@@ -228,12 +229,6 @@     , MonadReader app     ) --- Just copies ReaderT's definition. This can be newtype-derived in GHC 8.10+,--- but we do it by hand while we want to support older.-instance MonadUnliftIO m => MonadUnliftIO (AppT app m) where-  withRunInIO inner = AppT $ withRunInIO $ \run -> inner $ run . unAppT-  {-# INLINE withRunInIO #-}- instance PrimMonad m => PrimMonad (AppT app m) where   type PrimState (AppT app m) = PrimState m @@ -244,6 +239,9 @@   --   primitive = AppT . lift . lift . lift . primitive   {-# INLINE primitive #-}++instance MonadIO m => MonadHttp (AppT app m) where+  httpLbs = liftIO . httpLbs  instance (Monad m, HasTracer app) => MonadTracer (AppT app m) where   getTracer = view tracerL

@@ -1,26 +0,0 @@-{-# LANGUAGE CPP #-}---- | Compatibility module for "Data.Aeson" 1.x vs 2.0------ This should be its own package, but the obvious name (@aeson-compat@) is--- taken by something old and unrelated. I think that's why no one is doing it--- yet, including us.-module Freckle.App.Aeson-  ( module X-  ) where--import Prelude---- Blammo provides a lot in its module-import Data.Aeson.Compat as X---- But it doesn't expose the whole interface we need, so we'll add this too-#if MIN_VERSION_aeson(2,0,0)-import Data.Aeson.KeyMap as X-#else-import Data.HashMap.Strict as X-#endif---- Ignored twice because HLint changes the name in some version-{-# ANN module ("HLint: ignore Avoid restricted alias" :: String) #-}-{-# ANN module ("HLint: ignore Avoid restricted qualification" :: String) #-}

@@ -18,9 +18,9 @@ import Blammo.Logging (myThreadContext) import Control.Lens (Lens', lens, to, view, (<>~)) import Data.Aeson (Value (..))+import qualified Data.Aeson.KeyMap as KeyMap import Data.Bugsnag (Event (..)) import Data.String (fromString)-import qualified Freckle.App.Aeson as Aeson import Freckle.App.Stats (HasStatsClient (..), tagsL) import Network.Bugsnag (BeforeNotify, updateEvent) import Network.Bugsnag.MetaData@@ -48,7 +48,7 @@  collectMetaDataFromThreadContext :: MonadIO m => m MetaData collectMetaDataFromThreadContext =-  liftIO $ metaData "context" . Aeson.toList <$> myThreadContext+  liftIO $ metaData "context" . KeyMap.toList <$> myThreadContext  -- | Merge 'MetaData' into the 'Event' --

@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}  -- | Stream, parse, and validate CSVs --@@ -196,7 +197,15 @@   toEncoding = csvExceptionPairs (pairs . mconcat) toEncoding  csvExceptionPairs-  :: KeyValue kv => ([kv] -> r) -> (a -> r) -> CsvException a -> r+#if MIN_VERSION_aeson(2,2,0)+  :: KeyValue e kv+#else+  :: KeyValue kv+#endif+  => ([kv] -> r)+  -> (a -> r)+  -> CsvException a+  -> r csvExceptionPairs done extend = \case   CsvMissingColumn column ->     done

@@ -55,8 +55,8 @@   , runSqlPool   , runSqlPoolWithExtensibleHooks   )+import Database.Persist.SqlBackend.Internal.SqlPoolHooks (SqlPoolHooks (..)) import Database.Persist.SqlBackend.SqlPoolHooks-import Database.Persist.SqlBackend.Internal.SqlPoolHooks(SqlPoolHooks(..)) import Database.PostgreSQL.Simple   ( Connection   , Only (..)@@ -116,8 +116,8 @@ makePostgresPool :: (MonadUnliftIO m, MonadLoggerIO m) => m SqlPool makePostgresPool = do   conf <- liftIO $ do-    postgresPasswordSource <- Env.parse id $ Env.kept envPostgresPasswordSource-    Env.parse id $ Env.kept $ envParseDatabaseConf postgresPasswordSource+    postgresPasswordSource <- Env.parse id envPostgresPasswordSource+    Env.parse id $ envParseDatabaseConf postgresPasswordSource   makePostgresPoolWith conf  -- | Run a Database action with connection stats and tracing@@ -159,17 +159,18 @@     -- might catch the exception that we need to worry about, so in the case of     -- an exception, runAfter would not be executed.     -- So, this appears to be the intended interpretation.-    hooks' = hooks-      { runBefore = \conn mi -> do-          Stats.incGauge gauge-          runBefore hooks conn mi-      , runAfter = \conn mi -> do-          Stats.decGauge gauge-          runAfter hooks conn mi-      , runOnException = \conn mi e -> do-          Stats.decGauge gauge-          runOnException hooks conn mi e-      }+    hooks' =+      hooks+        { runBefore = \conn mi -> do+            Stats.incGauge gauge+            runBefore hooks conn mi+        , runAfter = \conn mi -> do+            Stats.decGauge gauge+            runAfter hooks conn mi+        , runOnException = \conn mi e -> do+            Stats.decGauge gauge+            runOnException hooks conn mi e+        }   Stats.withGauge Stats.dbEnqueuedAndProcessing $     inSpan "runDB" clientSpanArguments $       runSqlPoolWithExtensibleHooks action pool Nothing hooks'

@@ -7,7 +7,7 @@  import Freckle.App.Prelude -import qualified Configuration.Dotenv.Compat as Dotenv+import qualified Configuration.Dotenv as Dotenv import System.FilePath (takeDirectory, (</>)) import UnliftIO.Directory (doesFileExist, getCurrentDirectory) 

@@ -78,7 +78,7 @@   req <-     mapEither (EcsMetadataErrorInvalidURI . displayException) $       parseRequest uri-  resp <- httpJson req+  resp <- liftIO $ httpJson req    let status = getResponseStatus resp 

@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- -- | Parse the shell environment for configuration -- -- A minor extension of [envparse](https://hackage.haskell.org/package/envparse).@@ -29,7 +27,6 @@      -- * Extensions   , Timeout (..)-  , kept   , eitherReader   , time   , keyValues@@ -46,8 +43,6 @@ import Data.Time (defaultTimeLocale, parseTimeM) import Env hiding (flag) import qualified Env-import Env.Internal.Free (hoistAlt)-import Env.Internal.Parser (Parser (..), VarF (..)) import qualified Prelude as Unsafe (read)  -- | Designates the value of a parameter when a flag is not provided.@@ -82,26 +77,6 @@ flag :: Off a -> On a -> String -> Mod Flag a -> Parser Error a flag (Off f) (On t) n m = Env.flag f t n m --- | Modify a 'Parser' so variables are never removed after reading------ In @envparse-0.4@, read variables are removed from the environment by--- default. This is often problematic (e.g. in tests that repeatedly load an app--- and re-read the environment), and the security benefits are minor. This--- function will make them all behave as if @keep@ was used.------ In @envparse-0.5@, the default is reversed and @sensitive@ can be used to--- explicitly unset read variables, and so this function will instead make them--- all behave as if @sensitive@ was /not/ used.-kept :: Parser e a -> Parser e a-kept = Parser . hoistAlt go . unParser- where-  go v =-#if MIN_VERSION_envparse(0,5,0)-    v { varfSensitive = False }-#else-    v { varfKeep = True }-#endif- -- | Create a 'Reader' from a simple parser function -- -- This is a building-block for other 'Reader's@@ -160,7 +135,6 @@ -- -- >>> var (splitOnParse @Error ',' nonempty) "X" mempty `parsePure` [("X", ",,")] -- Left [("X",EmptyError)]--- splitOnParse :: Char -> Reader e a -> Reader e [a] splitOnParse c p = traverse p <=< splitOn c 

@@ -1,61 +1,20 @@--- | Centralized module for making HTTP requests from the backend+-- | Centralized module for making HTTP requests -- -- These functions: -- -- - Do not throw exceptions on non-200 -- - May throw for other 'HttpException' cases (e.g. 'ConnectionTimeout')--- - Handle 429-@Retry-In@ for you -- - Capture decoding failures with 'Either' values as the 'Response' body------ == Examples------ Make request, retry on 429s, 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--- @------ 'httpLbs' can be used to get a raw response (without risk of decoding--- errors), and 'httpDecode' can be used to supply your own decoding function--- (e.g. for CSV).------ Interact with a paginated endpoint that uses @Link@, combining all the pages--- monoidally (e.g. concat) and throwing on any decoding errors.------ @--- 'httpPaginated' 'httpJson' 'getResponseBodyUnsafe' $ 'parseRequest_' "https://..."--- @------ 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@.+-- - Handle 429-@Retry-In@ for you (if using an 'IO'-based instance) module Freckle.App.Http-  ( httpJson+  ( MonadHttp (..)++    -- * Decoding responses+  , httpJson   , HttpDecodeError (..)   , httpDecode-  , httpLbs-  , httpNoBody++    -- * Pagination   , httpPaginated   , sourcePaginated @@ -116,6 +75,11 @@ 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 qualified Data.Aeson as Aeson import qualified Data.ByteString as BS@@ -138,6 +102,52 @@   , 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@@ -155,18 +165,31 @@       errs -> "Errors:" : map bullet (NE.toList errs)     bullet = (" • " <>) --- | Request and decode a response as JSON+-- | 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-  :: (MonadIO m, FromJSON a)+  :: (MonadHttp m, FromJSON a)   => Request   -> m (Response (Either HttpDecodeError a)) httpJson =   httpDecode (first pure . Aeson.eitherDecode)     . addAcceptHeader "application/json" --- | Request and decode a response+-- | Make a request and decode the body using the given function+--+-- This be used to request other formats, e.g. CSV. httpDecode-  :: MonadIO m+  :: MonadHttp m   => (ByteString -> Either (NonEmpty String) a)   -> Request   -> m (Response (Either HttpDecodeError a))@@ -175,24 +198,44 @@   let body = getResponseBody resp   pure $ first (HttpDecodeError body) . decode <$> resp --- | Request a lazy 'ByteString', handling 429 retries-httpLbs :: MonadIO m => Request -> m (Response ByteString)-httpLbs = rateLimited httpLBS---- | Make a Request ignoring the response, but handling 429 retries-httpNoBody :: MonadIO m => Request -> m (Response ())-httpNoBody = rateLimited HTTP.httpNoBody---- | Request all pages of a paginated endpoint into a big list+-- | 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'.+-- 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-  :: (MonadIO m, Monoid b)+  :: (MonadHttp m, Monoid b)   => (Request -> m (Response a))   -> (Response a -> m b)   -> Request

@@ -60,12 +60,13 @@  import Conduit import Control.Error.Util (hush)-import Network.HTTP.Link.Compat hiding (linkHeader)+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-  :: MonadIO m+  :: Monad m   => (Request -> m (Response body))   -- ^ Run one request   -> Request@@ -75,7 +76,7 @@  -- | Stream pages of a paginated response, using a custom /find next/ sourcePaginatedBy-  :: MonadIO m+  :: Monad m   => (Request -> Response body -> Maybe Request)   -- ^ How to get the next page from each request   -> (Request -> m (Response body))@@ -91,6 +92,6 @@ linkHeader :: Request -> Response body -> Maybe Request linkHeader _req resp = do   header <- listToMaybe $ getResponseHeader "Link" resp-  links <- hush $ parseLinkURI $ decodeUtf8 header+  links <- hush $ parseLinkHeader' @URI $ decodeUtf8 header   uri <- href <$> find (((Rel, "next") `elem`) . linkParams) links   parseRequest $ show uri

@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- -- | Read a Memcached Servers value, to support ENV-based configuration -- -- Format:@@ -102,17 +100,9 @@ setPort auth ss = fromMaybe ss $ do   p <- case uriPort auth of     "" -> Nothing-    (':' : p) -> fromPort p-    p -> fromPort p+    (':' : p) -> Just p+    p -> Just p   pure $ ss {Memcache.ssPort = p}- where-#if MIN_VERSION_memcache(0,3,0)-  -- ssPort is a ServiceName, which is a String-  fromPort = Just-#else-  -- ssPort is a PortNumber, which we need to Read-  fromPort = readMay-#endif  setAuth   :: Memcache.Authentication -> Memcache.ServerSpec -> Memcache.ServerSpec

@@ -2,7 +2,8 @@  -- | An intentionally-leaky StatsD interface to Datadog module Freckle.App.Stats-  ( StatsSettings+  ( -- $docs+    StatsSettings   , defaultStatsSettings   , setStatsSettingsTags   , envParseStatsSettings@@ -316,8 +317,9 @@     , ("task_version", ectmRevision)     ] --- $usage--- Usage:+-- $docs+--+-- == Usage -- -- - Use 'envParseStatsSettings' to configure things --

@@ -7,7 +7,6 @@   ( AppExample (..)   , appExample   , withApp-  , withAppSql   , beforeSql   , expectationFailure   , pending@@ -40,7 +39,6 @@ import Control.Monad.Catch (ExitCase (..), MonadCatch, MonadThrow, mask) import qualified Control.Monad.Catch import qualified Control.Monad.Fail as Fail-import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Primitive import Control.Monad.Random (MonadRandom (..)) import Control.Monad.Reader@@ -78,23 +76,13 @@     , MonadBaseControl IO     , MonadCatch     , MonadIO+    , MonadUnliftIO     , MonadReader app     , MonadThrow     , MonadLogger     , Fail.MonadFail     ) --- We could derive this in newer versions of unliftio-core, but defining it by--- hand supports a few resolvers back, without CPP. This is just a copy of the--- ReaderT instance,------ https://hackage.haskell.org/package/unliftio-core-0.2.0.1/docs/src/Control.Monad.IO.Unlift.html#line-64----instance MonadUnliftIO (AppExample app) where-  {-# INLINE withRunInIO #-}-  withRunInIO inner =-    AppExample $ withRunInIO $ \run -> inner (run . unAppExample)- instance MonadMask (AppExample app) where   mask = UnliftIO.mask   uninterruptibleMask = UnliftIO.uninterruptibleMask@@ -160,19 +148,6 @@ -- use any @'MonadReader' app@ (including 'runDB', if the app 'HasSqlPool'). withApp :: ((app -> IO ()) -> IO ()) -> SpecWith app -> Spec withApp run = beforeAll Dotenv.loadTest . Hspec.aroundAll run---- | 'withApp', with custom DB 'Pool' initialization------ Runs the given function on the pool before every spec item. For example, to--- truncate tables.-withAppSql-  :: HasSqlPool app-  => SqlPersistT IO a-  -> ((app -> IO ()) -> IO ())-  -> SpecWith app-  -> Spec-withAppSql f run = withApp run . beforeSql f-{-# DEPRECATED withAppSql "Replace `withAppSql f g` with `withApp g . beforeSql f`" #-}  -- | Run the given SQL action before every spec item beforeSql :: HasSqlPool app => SqlPersistT IO a -> SpecWith app -> SpecWith app

@@ -0,0 +1,336 @@+{-# 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 qualified Data.ByteString.Lazy 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 qualified Network.HTTP.Client.Internal 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"+-- >   ]

@@ -0,0 +1,182 @@+-- | '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 qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL+import Data.List (isPrefixOf)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Network.HTTP.Client (Request, RequestBody (..), parseRequest_)+import qualified Network.HTTP.Client.Internal 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 ((`isPrefixOf` url) . toUrlPrefix) $+    concat+      [ [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,3 @@-{-# LANGUAGE CPP #-}- module Freckle.App.Yesod.Routes   ( mkRouteNameCaseExp   ) where@@ -37,19 +35,12 @@   matches <- fold <$> traverse mkMatches children   pure     [ TH.Match-        (conP constName paramVars)+        (TH.ConP constName [] paramVars)         (TH.NormalB $ TH.CaseE (TH.VarE caseVar) matches)         []     ]  where   constName = TH.mkName name--conP :: TH.Name -> [TH.Pat] -> TH.Pat-#if MIN_VERSION_template_haskell(2,18,0)-conP x = TH.ConP x []-#else-conP = TH.ConP-#endif  isDynamic :: Piece a -> Bool isDynamic = \case

@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}--module Network.HTTP.Link.Compat-  ( Link-  , linkURI-  , parseLinkURI-  , module Network.HTTP.Link-  )-where--import Prelude--import Data.Text (Text)-import Network.HTTP.Link hiding (Link)-import qualified Network.HTTP.Link as HTTP-import Network.URI (URI)--#if MIN_VERSION_http_link_header(1,2,0)-type Link = HTTP.Link URI-#else-type Link = HTTP.Link-#endif--linkURI :: URI -> [(LinkParam, Text)] -> Link-linkURI = HTTP.Link--parseLinkURI :: Text -> Either String [Link]-parseLinkURI = parseLinkHeader'

@@ -9,7 +9,7 @@ import Control.Lens ((^.)) import Control.Monad.Reader (runReaderT) import Data.Aeson ((.=))-import qualified Freckle.App.Aeson as Key+import qualified Data.Aeson.Key as Key import Freckle.App.Stats (HasStatsClient (..), tagsL) import qualified Freckle.App.Stats as Stats import Network.HTTP.Types.Status (Status (..))

@@ -1,5 +1,5 @@ name: freckle-app-version: 1.14.0.0+version: 1.15.0.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -15,26 +15,25 @@  ghc-options:   - -fignore-optim-changes+  - -fwrite-ide-info   - -Weverything   - -Wno-all-missed-specialisations   - -Wno-missing-exported-signatures # re-enables missing-signatures   - -Wno-missing-import-lists   - -Wno-missing-local-signatures+  - -Wno-missing-safe-haskell-mode   - -Wno-monomorphism-restriction+  - -Wno-prepositive-qualified-module   - -Wno-safe   - -Wno-unsafe  when:+  - condition: "impl(ghc >= 9.8)"+    ghc-options:+      - -Wno-missing-role-annotations   - condition: "impl(ghc >= 9.2)"     ghc-options:       - -Wno-missing-kind-signatures-  - condition: "impl(ghc >= 8.10)"-    ghc-options:-      - -Wno-missing-safe-haskell-mode-      - -Wno-prepositive-qualified-module-  - condition: "impl(ghc >= 8.8)"-    ghc-options:-      - -fwrite-ide-info  dependencies:   - base < 5@@ -80,7 +79,7 @@     - aws-xray-client-persistent     - aws-xray-client-wai     - bcp47-    - bugsnag+    - bugsnag >= 1.1.0.0 # Network.Bugsnag.MetaData     - bytestring     - case-insensitive     - cassava@@ -89,6 +88,7 @@     - containers     - cookie     - datadog+    - directory     - doctest     - dotenv     - ekg-core

@@ -2,23 +2,27 @@   ( spec   ) where -import Prelude+import Freckle.App.Prelude  import Control.Lens (to, (^?), _Left, _Right) import Data.Aeson import Data.Aeson.Lens import qualified Data.List.NonEmpty 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 <--        httpJson @_ @Value $-          parseRequest_ "https://www.stackage.org/lts-17.10"+        flip runHttpStubsT stubs+          . httpJson @_ @Value+          $ parseRequest_ "https://www.stackage.org/lts-17.10"        getResponseStatus resp `shouldBe` status200       getResponseBody resp@@ -30,8 +34,9 @@      it "places JSON parse errors in a Left body" $ do       resp <--        httpJson @_ @[()] $-          parseRequest_ "https://www.stackage.org/lts-17.10"+        flip runHttpStubsT stubs+          . httpJson @_ @[()]+          $ parseRequest_ "https://www.stackage.org/lts-17.10"        let expectedErrorMessages =             [ "Error in $: expected [a], encountered Object"

@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Freckle.App.Memcached.ServersSpec   ( spec   ) where@@ -29,21 +27,21 @@       let mServer = readServerSpec "memcached://my-host"        fmap Memcache.ssHost mServer `shouldBe` Just "my-host"-      fmap (portServiceName . Memcache.ssPort) mServer `shouldBe` Just "11211"+      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 (portServiceName . Memcache.ssPort) mServer `shouldBe` Just "11212"+      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 (portServiceName . Memcache.ssPort) mServer `shouldBe` Just "11211"+      fmap Memcache.ssPort mServer `shouldBe` Just "11211"       fmap Memcache.ssAuth mServer         `shouldBe` Just (Memcache.Auth "user" "password") @@ -59,7 +57,7 @@       let mServer = readServerSpec "memcached://user:password@my-host:11212"        fmap Memcache.ssHost mServer `shouldBe` Just "my-host"-      fmap (portServiceName . Memcache.ssPort) mServer `shouldBe` Just "11212"+      fmap Memcache.ssPort mServer `shouldBe` Just "11212"       fmap Memcache.ssAuth mServer         `shouldBe` Just (Memcache.Auth "user" "password") @@ -70,7 +68,7 @@        fmap (map Memcache.ssHost) mServerSpecs         `shouldBe` Just ["a-host", "b-host", defaultHost]-      fmap (map (portServiceName . Memcache.ssPort)) mServerSpecs+      fmap (map Memcache.ssPort) mServerSpecs         `shouldBe` Just ["11211", "11212", "11213"]       fmap (map Memcache.ssAuth) mServerSpecs         `shouldBe` Just@@ -84,11 +82,3 @@  defaultHost :: String defaultHost = Memcache.ssHost Memcache.def--#if MIN_VERSION_memcache(0,3,0)-portServiceName :: String -> String-portServiceName = id-#else-portServiceName :: Show a => a -> String-portServiceName = show-#endif

@@ -0,0 +1,115 @@+module Freckle.App.Test.Http.MatchRequestSpec+  ( spec+  ) where++import Freckle.App.Prelude++import Freckle.App.Http+  ( Request+  , addAcceptHeader+  , addRequestHeader+  , parseRequest_+  , setRequestPath+  )+import Freckle.App.Test.Http.MatchRequest+import Network.HTTP.Types.Header (hAccept)+import Test.Hspec++spec :: Spec+spec = do+  describe "matchRequestFromUrl" $ do+    context "matching complete requests" $ do+      let+        url = "https://localhost:3000/hello?world"+        mr = matchRequestFromUrl url++      it "matches the same request" $ do+        mr `shouldMatchRequest` parseRequest_ url++      it "matches on path, even if built relative" $ do+        let req = parseRequest_ "https://localhost:3000/world?world"+        mr `shouldMatchRequest` setRequestPath "hello" req++      it "matches on method" $ do+        mr `shouldNotMatchRequest` parseRequest_ ("POST " <> url)++      it "matches on scheme" $ do+        mr `shouldNotMatchRequest` parseRequest_ "http://localhost:3000/hello?world"++      it "matches on host" $ do+        mr `shouldNotMatchRequest` parseRequest_ "https://localhost2:3000/hello?world"++      it "matches on port" $ do+        mr `shouldNotMatchRequest` parseRequest_ "https://localhost:3001/hello?world"++      it "matches on path" $ do+        mr `shouldNotMatchRequest` parseRequest_ "https://localhost:3000/world?world"++      it "matches on query" $ do+        mr `shouldNotMatchRequest` parseRequest_ "https://localhost:3000/hello?wut"++    it "can match on everything unspecified" $ do+      let mr = matchRequestFromUrl "https://"++      mr `shouldMatchRequest` parseRequest_ "https://example.com"+      mr `shouldMatchRequest` parseRequest_ "https://example.com/"+      mr `shouldMatchRequest` parseRequest_ "https://example.com/foo"+      mr `shouldMatchRequest` parseRequest_ "https://example.com/bar"++    it "can match any path" $ do+      let mr = matchRequestFromUrl "https://example.com"++      mr `shouldMatchRequest` parseRequest_ "https://example.com"+      mr `shouldMatchRequest` parseRequest_ "https://example.com/"+      mr `shouldMatchRequest` parseRequest_ "https://example.com/foo"+      mr `shouldMatchRequest` parseRequest_ "https://example.com/bar"++    it "can match the root path explicitly" $ do+      let mr = matchRequestFromUrl "https://example.com/"++      mr `shouldMatchRequest` parseRequest_ "https://example.com/"+      mr `shouldMatchRequest` parseRequest_ "https://example.com"+      mr `shouldNotMatchRequest` parseRequest_ "https://example.com/foo"+      mr `shouldNotMatchRequest` parseRequest_ "https://example.com/bar"++    context "matching headers" $ do+      let+        url = "https://example.com/"+        accept = "text/plain"+        hasNoHeaders = parseRequest_ url+        hasOnlyTheHeader = addAcceptHeader accept hasNoHeaders+        hasExtraHeaders = addRequestHeader "User-Agent" "me" hasOnlyTheHeader++      it "can match headers exactly" $ do+        let mr = matchRequestFromUrl url <> MatchHeaders [(hAccept, accept)]++        mr `shouldMatchRequest` hasOnlyTheHeader+        mr `shouldNotMatchRequest` hasExtraHeaders+        mr `shouldNotMatchRequest` hasNoHeaders++      it "can match headers-include" $ do+        let mr = matchRequestFromUrl url <> MatchHeader (hAccept, accept)++        mr `shouldMatchRequest` hasOnlyTheHeader+        mr `shouldMatchRequest` hasExtraHeaders+        mr `shouldNotMatchRequest` hasNoHeaders++shouldMatchRequest :: HasCallStack => MatchRequest -> Request -> IO ()+mr `shouldMatchRequest` req = do+  case matchRequest req mr of+    Left err -> do+      let preamble = unlines ["Expected to match request, but did not", "", show req]+      expectationFailure $ preamble <> err+    Right () -> pure ()++infix 1 `shouldMatchRequest`++shouldNotMatchRequest :: HasCallStack => MatchRequest -> Request -> IO ()+mr `shouldNotMatchRequest` req = do+  case matchRequest req mr of+    Left {} -> pure ()+    Right () -> do+      let preamble = unlines ["Expected to NOT match request, but did", "", show req]+      expectationFailure $ preamble <> showMatchRequest mr++infix 1 `shouldNotMatchRequest`