{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}

-- | Type and functions for handling gzipped HTTP responses
--
-- In order to optimize caching of responses in storage with size limitations,
-- we cache gzipped responses as-is. This requires disabling the automatic
-- decompression of @http-client@ and handling it ourselves.
--
-- The module makes that a type-enforced process:
--
-- - 'requestPotentiallyGzipped' is the only way to get a 'PotentiallyGzipped'
-- - Which is the type needed for the response field in 'CachedResponse'
-- - 'gunzipResponseBody' is the only way to erase 'PotentiallyGzipped'
-- - Which is what you actually need to return
module Freckle.App.Http.Cache.Gzip
  ( PotentiallyGzipped
  , requestPotentiallyGzipped
  , gunzipResponseBody
  ) where

import Freckle.App.Prelude

import Codec.Serialise (Serialise)
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as BSL
import Freckle.App.Http (disableRequestDecompress)
import Freckle.App.Http.Header
import Network.HTTP.Client (Request, Response)
import Network.HTTP.Client.Internal qualified as HTTP

newtype PotentiallyGzipped a = PotentiallyGzipped
  { forall a. PotentiallyGzipped a -> a
unwrap :: a
  }
  deriving stock (Int -> PotentiallyGzipped a -> ShowS
[PotentiallyGzipped a] -> ShowS
PotentiallyGzipped a -> String
(Int -> PotentiallyGzipped a -> ShowS)
-> (PotentiallyGzipped a -> String)
-> ([PotentiallyGzipped a] -> ShowS)
-> Show (PotentiallyGzipped a)
forall a. Show a => Int -> PotentiallyGzipped a -> ShowS
forall a. Show a => [PotentiallyGzipped a] -> ShowS
forall a. Show a => PotentiallyGzipped a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> PotentiallyGzipped a -> ShowS
showsPrec :: Int -> PotentiallyGzipped a -> ShowS
$cshow :: forall a. Show a => PotentiallyGzipped a -> String
show :: PotentiallyGzipped a -> String
$cshowList :: forall a. Show a => [PotentiallyGzipped a] -> ShowS
showList :: [PotentiallyGzipped a] -> ShowS
Show, PotentiallyGzipped a -> PotentiallyGzipped a -> Bool
(PotentiallyGzipped a -> PotentiallyGzipped a -> Bool)
-> (PotentiallyGzipped a -> PotentiallyGzipped a -> Bool)
-> Eq (PotentiallyGzipped a)
forall a.
Eq a =>
PotentiallyGzipped a -> PotentiallyGzipped a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
PotentiallyGzipped a -> PotentiallyGzipped a -> Bool
== :: PotentiallyGzipped a -> PotentiallyGzipped a -> Bool
$c/= :: forall a.
Eq a =>
PotentiallyGzipped a -> PotentiallyGzipped a -> Bool
/= :: PotentiallyGzipped a -> PotentiallyGzipped a -> Bool
Eq)
  deriving newtype ([PotentiallyGzipped a] -> Encoding
PotentiallyGzipped a -> Encoding
(PotentiallyGzipped a -> Encoding)
-> (forall s. Decoder s (PotentiallyGzipped a))
-> ([PotentiallyGzipped a] -> Encoding)
-> (forall s. Decoder s [PotentiallyGzipped a])
-> Serialise (PotentiallyGzipped a)
forall s. Decoder s [PotentiallyGzipped a]
forall s. Decoder s (PotentiallyGzipped a)
forall a. Serialise a => [PotentiallyGzipped a] -> Encoding
forall a. Serialise a => PotentiallyGzipped a -> Encoding
forall a s. Serialise a => Decoder s [PotentiallyGzipped a]
forall a s. Serialise a => Decoder s (PotentiallyGzipped a)
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: forall a. Serialise a => PotentiallyGzipped a -> Encoding
encode :: PotentiallyGzipped a -> Encoding
$cdecode :: forall a s. Serialise a => Decoder s (PotentiallyGzipped a)
decode :: forall s. Decoder s (PotentiallyGzipped a)
$cencodeList :: forall a. Serialise a => [PotentiallyGzipped a] -> Encoding
encodeList :: [PotentiallyGzipped a] -> Encoding
$cdecodeList :: forall a s. Serialise a => Decoder s [PotentiallyGzipped a]
decodeList :: forall s. Decoder s [PotentiallyGzipped a]
Serialise)

-- | Run a request /without/ automatic 'decompress' and tag the @body@ type
requestPotentiallyGzipped
  :: Functor m
  => (Request -> m (Response body))
  -> Request
  -> m (Response (PotentiallyGzipped body))
requestPotentiallyGzipped :: forall (m :: * -> *) body.
Functor m =>
(Request -> m (Response body))
-> Request -> m (Response (PotentiallyGzipped body))
requestPotentiallyGzipped Request -> m (Response body)
doHttp =
  (Response body -> Response (PotentiallyGzipped body))
-> m (Response body) -> m (Response (PotentiallyGzipped body))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((body -> PotentiallyGzipped body)
-> Response body -> Response (PotentiallyGzipped body)
forall a b. (a -> b) -> Response a -> Response b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap body -> PotentiallyGzipped body
forall a. a -> PotentiallyGzipped a
PotentiallyGzipped) (m (Response body) -> m (Response (PotentiallyGzipped body)))
-> (Request -> m (Response body))
-> Request
-> m (Response (PotentiallyGzipped body))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> m (Response body)
doHttp (Request -> m (Response body))
-> (Request -> Request) -> Request -> m (Response body)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
disableRequestDecompress

-- | Gunzip a 'PotentiallyGzipped' body, if necessary
gunzipResponseBody
  :: MonadIO m
  => Request
  -> Response (PotentiallyGzipped ByteString)
  -> m (Response ByteString)
gunzipResponseBody :: forall (m :: * -> *).
MonadIO m =>
Request
-> Response (PotentiallyGzipped ByteString)
-> m (Response ByteString)
gunzipResponseBody Request
req Response (PotentiallyGzipped ByteString)
resp
  | Request -> [Header] -> Bool
HTTP.needsGunzip Request
req (Response (PotentiallyGzipped ByteString) -> [Header]
forall a. HasHeaders a => a -> [Header]
getHeaders Response (PotentiallyGzipped ByteString)
resp) = IO (Response ByteString) -> m (Response ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ do
      ByteString
body <- PotentiallyGzipped ByteString -> IO ByteString
gunzipBody (PotentiallyGzipped ByteString -> IO ByteString)
-> PotentiallyGzipped ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Response (PotentiallyGzipped ByteString)
-> PotentiallyGzipped ByteString
forall body. Response body -> body
HTTP.responseBody Response (PotentiallyGzipped ByteString)
resp
      Response ByteString -> IO (Response ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response ByteString -> IO (Response ByteString))
-> Response ByteString -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
body ByteString
-> Response (PotentiallyGzipped ByteString) -> Response ByteString
forall a b. a -> Response b -> Response a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Response (PotentiallyGzipped ByteString)
resp
  | Bool
otherwise = Response ByteString -> m (Response ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response ByteString -> m (Response ByteString))
-> Response ByteString -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ (.unwrap) (PotentiallyGzipped ByteString -> ByteString)
-> Response (PotentiallyGzipped ByteString) -> Response ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response (PotentiallyGzipped ByteString)
resp

gunzipBody :: PotentiallyGzipped ByteString -> IO ByteString
gunzipBody :: PotentiallyGzipped ByteString -> IO ByteString
gunzipBody PotentiallyGzipped ByteString
body = do
  BodyReader
body1 <- [ByteString] -> IO BodyReader
HTTP.constBodyReader ([ByteString] -> IO BodyReader) -> [ByteString] -> IO BodyReader
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BSL.toChunks PotentiallyGzipped ByteString
body.unwrap
  BodyReader
reader <- BodyReader -> IO BodyReader
HTTP.makeGzipReader BodyReader
body1
  [ByteString] -> ByteString
BSL.fromChunks ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BodyReader -> IO [ByteString]
HTTP.brConsume BodyReader
reader