diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/freckle-app.cabal b/freckle-app.cabal --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -1,6 +1,6 @@ cabal-version: 1.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 diff --git a/library/Configuration/Dotenv/Compat.hs b/library/Configuration/Dotenv/Compat.hs deleted file mode 100644 --- a/library/Configuration/Dotenv/Compat.hs +++ /dev/null @@ -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 diff --git a/library/Freckle/App.hs b/library/Freckle/App.hs --- a/library/Freckle/App.hs +++ b/library/Freckle/App.hs @@ -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 diff --git a/library/Freckle/App/Aeson.hs b/library/Freckle/App/Aeson.hs deleted file mode 100644 --- a/library/Freckle/App/Aeson.hs +++ /dev/null @@ -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) #-} diff --git a/library/Freckle/App/Bugsnag/MetaData.hs b/library/Freckle/App/Bugsnag/MetaData.hs --- a/library/Freckle/App/Bugsnag/MetaData.hs +++ b/library/Freckle/App/Bugsnag/MetaData.hs @@ -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' -- diff --git a/library/Freckle/App/Csv.hs b/library/Freckle/App/Csv.hs --- a/library/Freckle/App/Csv.hs +++ b/library/Freckle/App/Csv.hs @@ -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 diff --git a/library/Freckle/App/Database.hs b/library/Freckle/App/Database.hs --- a/library/Freckle/App/Database.hs +++ b/library/Freckle/App/Database.hs @@ -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' diff --git a/library/Freckle/App/Dotenv.hs b/library/Freckle/App/Dotenv.hs --- a/library/Freckle/App/Dotenv.hs +++ b/library/Freckle/App/Dotenv.hs @@ -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) diff --git a/library/Freckle/App/Ecs.hs b/library/Freckle/App/Ecs.hs --- a/library/Freckle/App/Ecs.hs +++ b/library/Freckle/App/Ecs.hs @@ -78,7 +78,7 @@ req <- mapEither (EcsMetadataErrorInvalidURI . displayException) $ parseRequest uri - resp <- httpJson req + resp <- liftIO $ httpJson req let status = getResponseStatus resp diff --git a/library/Freckle/App/Env.hs b/library/Freckle/App/Env.hs --- a/library/Freckle/App/Env.hs +++ b/library/Freckle/App/Env.hs @@ -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 diff --git a/library/Freckle/App/Http.hs b/library/Freckle/App/Http.hs --- a/library/Freckle/App/Http.hs +++ b/library/Freckle/App/Http.hs @@ -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 diff --git a/library/Freckle/App/Http/Paginate.hs b/library/Freckle/App/Http/Paginate.hs --- a/library/Freckle/App/Http/Paginate.hs +++ b/library/Freckle/App/Http/Paginate.hs @@ -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 diff --git a/library/Freckle/App/Memcached/Servers.hs b/library/Freckle/App/Memcached/Servers.hs --- a/library/Freckle/App/Memcached/Servers.hs +++ b/library/Freckle/App/Memcached/Servers.hs @@ -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 diff --git a/library/Freckle/App/Stats.hs b/library/Freckle/App/Stats.hs --- a/library/Freckle/App/Stats.hs +++ b/library/Freckle/App/Stats.hs @@ -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 -- diff --git a/library/Freckle/App/Test.hs b/library/Freckle/App/Test.hs --- a/library/Freckle/App/Test.hs +++ b/library/Freckle/App/Test.hs @@ -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 diff --git a/library/Freckle/App/Test/Http.hs b/library/Freckle/App/Test/Http.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Test/Http.hs @@ -0,0 +1,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" +-- > ] diff --git a/library/Freckle/App/Test/Http/MatchRequest.hs b/library/Freckle/App/Test/Http/MatchRequest.hs new file mode 100644 --- /dev/null +++ b/library/Freckle/App/Test/Http/MatchRequest.hs @@ -0,0 +1,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 diff --git a/library/Freckle/App/Yesod/Routes.hs b/library/Freckle/App/Yesod/Routes.hs --- a/library/Freckle/App/Yesod/Routes.hs +++ b/library/Freckle/App/Yesod/Routes.hs @@ -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 diff --git a/library/Network/HTTP/Link/Compat.hs b/library/Network/HTTP/Link/Compat.hs deleted file mode 100644 --- a/library/Network/HTTP/Link/Compat.hs +++ /dev/null @@ -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' diff --git a/library/Network/Wai/Middleware/Stats.hs b/library/Network/Wai/Middleware/Stats.hs --- a/library/Network/Wai/Middleware/Stats.hs +++ b/library/Network/Wai/Middleware/Stats.hs @@ -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 (..)) diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/tests/Freckle/App/HttpSpec.hs b/tests/Freckle/App/HttpSpec.hs --- a/tests/Freckle/App/HttpSpec.hs +++ b/tests/Freckle/App/HttpSpec.hs @@ -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" diff --git a/tests/Freckle/App/Memcached/ServersSpec.hs b/tests/Freckle/App/Memcached/ServersSpec.hs --- a/tests/Freckle/App/Memcached/ServersSpec.hs +++ b/tests/Freckle/App/Memcached/ServersSpec.hs @@ -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 diff --git a/tests/Freckle/App/Test/Http/MatchRequestSpec.hs b/tests/Freckle/App/Test/Http/MatchRequestSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Freckle/App/Test/Http/MatchRequestSpec.hs @@ -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`