2019-09-19 15:54:40 +03:00
|
|
|
module Hasura.Server.Compression
|
2021-09-24 01:56:37 +03:00
|
|
|
( compressResponse,
|
|
|
|
CompressionType (..),
|
|
|
|
compressionTypeToTxt,
|
2019-09-19 15:54:40 +03:00
|
|
|
)
|
|
|
|
where
|
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
import Codec.Compression.GZip qualified as GZ
|
|
|
|
import Data.ByteString.Lazy qualified as BL
|
|
|
|
import Data.Text qualified as T
|
|
|
|
import Hasura.Prelude
|
|
|
|
import Hasura.Server.Utils (gzipHeader)
|
|
|
|
import Network.HTTP.Types.Header qualified as NH
|
2019-09-19 15:54:40 +03:00
|
|
|
|
|
|
|
data CompressionType
|
|
|
|
= CTGZip
|
|
|
|
deriving (Show, Eq)
|
|
|
|
|
2020-10-27 16:53:49 +03:00
|
|
|
compressionTypeToTxt :: CompressionType -> Text
|
2021-09-24 01:56:37 +03:00
|
|
|
compressionTypeToTxt CTGZip = "gzip"
|
2019-09-19 15:54:40 +03:00
|
|
|
|
2021-09-24 01:56:37 +03:00
|
|
|
compressResponse ::
|
|
|
|
NH.RequestHeaders ->
|
|
|
|
BL.ByteString ->
|
|
|
|
(BL.ByteString, Maybe NH.Header, Maybe CompressionType)
|
2019-09-19 15:54:40 +03:00
|
|
|
compressResponse reqHeaders unCompressedResp =
|
|
|
|
let compressionTypeM = getRequestedCompression reqHeaders
|
|
|
|
appendCompressionType (res, headerM) = (res, headerM, compressionTypeM)
|
2019-10-05 10:20:50 +03:00
|
|
|
gzipCompressionParams =
|
2021-09-24 01:56:37 +03:00
|
|
|
GZ.defaultCompressParams {GZ.compressLevel = GZ.compressionLevel 1}
|
|
|
|
in appendCompressionType $ case compressionTypeM of
|
|
|
|
Just CTGZip -> (GZ.compressWith gzipCompressionParams unCompressedResp, Just gzipHeader)
|
|
|
|
Nothing -> (unCompressedResp, Nothing)
|
2019-09-19 15:54:40 +03:00
|
|
|
|
|
|
|
getRequestedCompression :: NH.RequestHeaders -> Maybe CompressionType
|
|
|
|
getRequestedCompression reqHeaders
|
|
|
|
| "gzip" `elem` acceptEncodingVals = Just CTGZip
|
2021-09-24 01:56:37 +03:00
|
|
|
| otherwise = Nothing
|
2019-09-19 15:54:40 +03:00
|
|
|
where
|
2021-09-24 01:56:37 +03:00
|
|
|
acceptEncodingVals =
|
|
|
|
concatMap (splitHeaderVal . snd) $
|
|
|
|
filter (\h -> fst h == NH.hAcceptEncoding) reqHeaders
|
2019-09-19 15:54:40 +03:00
|
|
|
splitHeaderVal bs = map T.strip $ T.splitOn "," $ bsToTxt bs
|