freckle-http 0.3.0.0 → 0.3.0.1

raw patch · 12 files changed

+79/−67 lines, 12 filesdep ~freckle-memcacheddep ~freckle-preludePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: freckle-memcached, freckle-prelude

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−1
• freckle-http.cabal +6/−6
• library/Freckle/App/Http.hs +9/−7
• library/Freckle/App/Http/Cache.hs +9/−9
• library/Freckle/App/Http/Cache/Gzip.hs +1/−1
• library/Freckle/App/Http/Cache/Memcached.hs +8/−6
• library/Freckle/App/Http/Cache/State.hs +6/−4
• library/Freckle/App/Http/Retry.hs +5/−5
• library/Freckle/App/Test/Http.hs +20/−19
• library/Freckle/App/Test/Http/MatchRequest.hs +4/−4
• package.yaml +2/−2
• tests/Freckle/App/Http/CacheSpec.hs +4/−3

@@ -1,4 +1,8 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-http-v0.3.0.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-http/compare/v0.3.0.1...main)++## [v0.3.0.1](https://github.com/freckle/freckle-http/tree/v0.3.0.1)++Metadata change only; moved to new source repository.  ## [v0.3.0.0](https://github.com/freckle/freckle-app/compare/freckle-http-v0.2.0.0...freckle-http-v0.3.0.0) 

@@ -1,11 +1,11 @@ cabal-version:      1.18 name:               freckle-http-version:            0.3.0.0+version:            0.3.0.1 license:            MIT license-file:       LICENSE maintainer:         Freckle Education-homepage:           https://github.com/freckle/freckle-app#readme-bug-reports:        https://github.com/freckle/freckle-app/issues+homepage:           https://github.com/freckle/freckle-http#readme+bug-reports:        https://github.com/freckle/freckle-http/issues synopsis:           Toolkit for making HTTP requests description:        Please see README.md category:           HTTP@@ -17,7 +17,7 @@  source-repository head     type:     git-    location: https://github.com/freckle/freckle-app+    location: https://github.com/freckle/freckle-http  library     exposed-modules:@@ -62,7 +62,7 @@         errors >=2.3.0,         extra >=1.7.13,         filepath >=1.4.2.2,-        freckle-memcached >=0.0.0.2,+        freckle-memcached >=0.0.0.1,         hs-opentelemetry-api >=0.1.0.0,         http-client >=0.7.13.1,         http-conduit >=2.3.5,@@ -118,7 +118,7 @@         base >=4.16.4.0 && <5,         bytestring >=0.11.4.0,         freckle-http,-        freckle-prelude >=0.0.4.0,+        freckle-prelude >=0.0.4.1,         hspec >=2.8.1,         hspec-expectations-json >=1.0.0.7,         hspec-expectations-lifted >=0.10.0,

@@ -153,7 +153,7 @@ instance MonadHttp m => MonadHttp (ReaderT r m) where   httpLbs = lift . httpLbs -instance (Monoid w, MonadHttp m) => MonadHttp (WriterT w m) where+instance (MonadHttp m, Monoid w) => MonadHttp (WriterT w m) where   httpLbs = lift . httpLbs  instance MonadHttp m => MonadHttp (StateT s m) where@@ -173,10 +173,10 @@  instance Exception HttpDecodeError where   displayException HttpDecodeError {..} =-    T.unpack $-      T.unlines $-        ["Error decoding HTTP Response:", "Raw body:", T.pack $ BSL8.unpack hdeBody]-          <> fromErrors hdeErrors+    T.unpack+      $ T.unlines+      $ ["Error decoding HTTP Response:", "Raw body:", T.pack $ BSL8.unpack hdeBody]+        <> fromErrors hdeErrors    where     fromErrors = \case       err NE.:| [] -> ["Error:", T.pack err]@@ -196,7 +196,8 @@ -- 'getResponseBodyUnsafe' resp :: m a -- @ httpJson-  :: (MonadHttp m, FromJSON a)+  :: forall m a+   . (FromJSON a, MonadHttp m)   => Request   -> m (Response (Either HttpDecodeError a)) httpJson =@@ -282,7 +283,8 @@ -- error response bodies too, you'll want to use 'setRequestCheckStatus' so that -- you see status-code exceptions before 'HttpDecodeError's. getResponseBodyUnsafe-  :: (MonadIO m, Exception e, HasCallStack)+  :: forall m e a+   . (Exception e, HasCallStack, MonadIO m)   => Response (Either e a)   -> m a getResponseBodyUnsafe = either throwWithCallStack pure . getResponseBody

@@ -126,8 +126,8 @@             settings.logWarn $ "Error deserialising" :# ["error" .= err]             writeCache now key =<< getResponse req           Right cresp | isCachedResponseStale cresp now -> do-            settings.logDebug $-              "Cached value stale"+            settings.logDebug+              $ "Cached value stale"                 :# [ "key" .= tkey                    , "inserted" .= cresp.inserted                    , "ttl" .= fromCacheTTL cresp.ttl@@ -138,8 +138,8 @@                 fromEx () $ settings.cache.evict key                 writeCache now key =<< getResponse req               Just etag -> do-                settings.logDebug $-                  "Retrying with If-None-Match"+                settings.logDebug+                  $ "Retrying with If-None-Match"                     :# [ "key" .= tkey                        , "etag" .= T.decodeUtf8With T.lenientDecode etag                        ]@@ -170,8 +170,8 @@     -> m (Response BSL.ByteString)   writeCache now key resp = do     for_ (getCachableResponseTTL settings resp) $ \ttl -> do-      settings.logDebug $-        "Write cache"+      settings.logDebug+        $ "Write cache"           :# [ "key" .= T.decodeUtf8With T.lenientDecode (fromCacheKey key)              , "ttl" .= fromCacheTTL ttl              ]@@ -235,8 +235,8 @@   :: HttpCacheSettings m t -> Response body -> Maybe CacheTTL getCachableResponseTTL settings resp = do   guard $ NoStore `notElem` responseHeaders.cacheControl-  guard $-    not settings.shared || Private `notElem` responseHeaders.cacheControl+  guard+    $ not settings.shared || Private `notElem` responseHeaders.cacheControl   guard $ statusIsCacheable $ HTTP.responseStatus resp   pure $ fromMaybe settings.defaultTTL $ responseHeadersToTTL responseHeaders  where@@ -265,7 +265,7 @@  newtype Seconds = Seconds {unwrap :: Int}   deriving stock (Eq)-  deriving newtype (Num, Show, Read)+  deriving newtype (Num, Read, Show)  data CacheControl   = Private

@@ -31,7 +31,7 @@ newtype PotentiallyGzipped a = PotentiallyGzipped   { unwrap :: a   }-  deriving stock (Show, Eq)+  deriving stock (Eq, Show)   deriving newtype (Serialise)  -- | Run a request /without/ automatic 'decompress' and tag the @body@ type

@@ -33,11 +33,12 @@ import UnliftIO (MonadUnliftIO)  memcachedHttpCacheSettings-  :: ( MonadUnliftIO m+  :: forall m env+   . ( HasMemcachedClient env      , MonadLogger m-     , MonadTracer m      , MonadReader env m-     , HasMemcachedClient env+     , MonadTracer m+     , MonadUnliftIO m      )   => CacheTTL   -- ^ Default TTL, used when @max-age@ is not present@@ -65,10 +66,11 @@     }  memcachedHttpCache-  :: ( MonadUnliftIO m-     , MonadTracer m+  :: forall m env+   . ( HasMemcachedClient env      , MonadReader env m-     , HasMemcachedClient env+     , MonadTracer m+     , MonadUnliftIO m      )   => HttpCache m Value memcachedHttpCache =

@@ -34,7 +34,7 @@ newtype Cache = Cache   { map :: HashMap CacheKey CachedResponse   }-  deriving newtype (Semigroup, Monoid)+  deriving newtype (Monoid, Semigroup)  mapL :: Lens' Cache (HashMap CacheKey CachedResponse) mapL = lens (.map) $ \x y -> x {map = y}@@ -46,9 +46,10 @@   cacheL = id  stateHttpCacheSettings-  :: ( MonadIO m+  :: forall m s+   . ( HasCache s+     , MonadIO m      , MonadState s m-     , HasCache s      )   => HttpCacheSettings m CachedResponse stateHttpCacheSettings =@@ -71,7 +72,8 @@     }  stateHttpCache-  :: (MonadIO m, MonadState s m, HasCache s) => HttpCache m CachedResponse+  :: forall m s+   . (HasCache s, MonadIO m, MonadState s m) => HttpCache m CachedResponse stateHttpCache =   HttpCache     { get = \key -> fmap Right $ use $ cacheL . mapL . at key

@@ -77,18 +77,18 @@ suppressRetryStatusError req =   req     { checkResponse = \req' resp ->-        unless (getResponseStatus resp == status429) $-          originalCheckResponse req' resp+        unless (getResponseStatus resp == status429)+          $ originalCheckResponse req' resp     }  where   originalCheckResponse = checkResponse req  checkRetriesExhausted-  :: (MonadIO m, HasCallStack) => Int -> Response body -> m (Response body)+  :: (HasCallStack, MonadIO m) => Int -> Response body -> m (Response body) checkRetriesExhausted retryLimit resp   | getResponseStatus resp == status429 =-      throwWithCallStack $-        RetriesExhausted {reLimit = retryLimit, reResponse = void resp}+      throwWithCallStack+        $ RetriesExhausted {reLimit = retryLimit, reResponse = void resp}   | otherwise = pure resp  getRetryAfter :: Response body -> Maybe Int

@@ -29,7 +29,7 @@   , loadHttpStubsDirectory      -- * Exception-  , NoStubsMatched(..)+  , NoStubsMatched (..)      -- * 'MonadHttp' instances @@ -46,12 +46,13 @@  import Control.Applicative (asum) import Control.Exception (Exception (..))-import Control.Lens (Lens', lens, view,  (.~), (<>~))+import Control.Exception.Annotated.UnliftIO (throwWithCallStack)+import Control.Lens (Lens', lens, view, (.~), (<>~))+import Control.Monad (filterM)+import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) import Data.Aeson (ToJSON, encode) import Data.Bifunctor (bimap)-import Control.Monad(filterM)-import Control.Monad.IO.Class (MonadIO) import Data.ByteString.Lazy qualified as BSL import Data.Either (partitionEithers) import Data.Function ((&))@@ -60,7 +61,6 @@ import Data.String (IsString) import Data.String qualified import Data.Traversable (for)-import Control.Exception.Annotated.UnliftIO (throwWithCallStack) import Freckle.App.Http (MonadHttp (..)) import Freckle.App.Test.Http.MatchRequest import GHC.Stack (HasCallStack)@@ -89,13 +89,13 @@ --   ] -- @ httpStubbed-  :: (MonadIO m, HasCallStack)+  :: (HasCallStack, MonadIO m)   => [HttpStub]   -> Request   -> m (Response BSL.ByteString) httpStubbed stubs req =   maybe-    (throwWithCallStack NoStubsMatched{req, unmatched})+    (throwWithCallStack NoStubsMatched {req, unmatched})     (pure . toResponse req)     $ headMay matched  where@@ -116,17 +116,15 @@ instance Show NoStubsMatched where   show = displayException - instance Exception NoStubsMatched where   displayException NoStubsMatched {req, unmatched} =     "No stubs were found that matched:\n"-    <> show req-    <> "\n"-    <> (-      if length unmatched < 4-        then concatMap (uncurry unmatchedMessage) unmatched-        else "\nNumber of stubs: " <> show (length unmatched)-    )+      <> show req+      <> "\n"+      <> ( if length unmatched < 4+             then concatMap (uncurry unmatchedMessage) unmatched+             else "\nNumber of stubs: " <> show (length unmatched)+         )    where     unmatchedMessage stub err = "\n== " <> stub.label <> " ==\n" <> err @@ -264,16 +262,19 @@   httpStubsL = id  newtype ReaderHttpStubs m a = ReaderHttpStubs {unwrap :: m a}-  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader env)+  deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader env) -instance (MonadReader env m, HasHttpStubs env, MonadIO m) => MonadHttp (ReaderHttpStubs m) where+instance+  (HasHttpStubs env, MonadIO m, MonadReader env m)+  => MonadHttp (ReaderHttpStubs m)+  where   httpLbs req = do     stubs <- view httpStubsL     httpStubbed stubs req  newtype HttpStubsT m a = HttpStubsT {unwrap :: ReaderT [HttpStub] m a}-  deriving newtype (Functor, Applicative, Monad, MonadReader [HttpStub])-  deriving (MonadIO, MonadHttp) via ReaderHttpStubs (HttpStubsT m)+  deriving newtype (Applicative, Functor, Monad, MonadReader [HttpStub])+  deriving (MonadHttp, MonadIO) via ReaderHttpStubs (HttpStubsT m)  runHttpStubsT :: HttpStubsT m a -> [HttpStub] -> m a runHttpStubsT f = runReaderT f.unwrap

@@ -73,8 +73,8 @@   requiredMatches = MatchMethod method :| [MatchSecure secure, MatchPort port]    optionalMatches =-    NE.nonEmpty $-      catMaybes+    NE.nonEmpty+      $ catMaybes         [ MatchHost host <$ guard (host /= "")         , MatchPath path <$ guard (hasExplicitPath secure host port url)         , MatchQuery query <$ guard (query /= "")@@ -106,8 +106,8 @@ -- 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+  maybe (Right ()) (Left . showMatchRequestWithMismatches mr)+    $ buildMismatch req mr  showMatchRequest :: MatchRequest -> String showMatchRequest mr =

@@ -1,8 +1,8 @@ name: freckle-http-version: 0.3.0.0+version: 0.3.0.1 maintainer: Freckle Education category: HTTP-github: freckle/freckle-app+github: freckle/freckle-http synopsis: Toolkit for making HTTP requests description: Please see README.md 

@@ -388,11 +388,12 @@ stubAnything :: [HttpStub] stubAnything = [httpStub "Anything" MatchAnything] -expectDecode :: (HasCallStack, MonadIO m, FromJSON a) => BSL.ByteString -> m a+expectDecode+  :: forall m a. (FromJSON a, HasCallStack, MonadIO m) => BSL.ByteString -> m a expectDecode bs = case eitherDecode bs of   Left err -> do-    expectationFailure $-      mconcat+    expectationFailure+      $ mconcat         [ "Expected input to decode as JSON"         , "\nInput:  " <> show bs         , "\nErrors: " <> err