Skip to content

Commit

Permalink
fix cache-control header parsing for JWK (fix hasura#3655) (hasura#3676)
Browse files Browse the repository at this point in the history 
write a proper parser according to the RFC
https://tools.ietf.org/html/rfc7234#section-5.2
  • Loading branch information
@ecthiender @polRk
ecthiender authored and polRk committed Feb 12, 2020
1 parent 6bb287a commit 879b365
Show file tree
Hide file tree
Showing 5 changed files with 222 additions and 25 deletions.
4 changes: 4 additions & 0 deletions server/graphql-engine.cabal
View file
Expand Up @@ -207,6 +207,9 @@ library
, Control.Monad.Stateless
, Control.Monad.Unique

-- exposed for tests
, Data.Parser.CacheControl

, Hasura.Prelude
, Hasura.App
, Hasura.Db
Expand Down Expand Up @@ -413,6 +416,7 @@ test-suite graphql-engine-tests
hs-source-dirs: src-test
main-is: Main.hs
other-modules:
Data.Parser.CacheControlSpec
Hasura.IncrementalSpec
Hasura.RQL.MetadataSpec
Hasura.Server.MigrateSpec
Expand Down
168 changes: 168 additions & 0 deletions server/src-lib/Data/Parser/CacheControl.hs
View file
@@ -0,0 +1,168 @@
{-| Functions related to parsing @Cache-Control@ header as defined in
https://tools.ietf.org/html/rfc7234#section-5.2
To get @max-age@/@s-maxage@ from @Cache-Control@ header, use 'parseMaxAge'. If you need to check
other directives use 'parseCacheControl'.
Rules which starts with @obs-@ is not required to implement because they are maked as "obsolete" as
per https://tools.ietf.org/html/rfc7230#section-1.2
-}

module Data.Parser.CacheControl
( CacheControl
, CacheControlDirective (..)
, parseCacheControl
, parseMaxAge
)
where

import Hasura.Prelude

import Hasura.Server.Utils (fmapL)

import qualified Data.Attoparsec.Text as AT
import qualified Data.Text as T


type CacheControl = [CacheControlDirective]

data CacheControlDirective
= CCDOnlyToken !Text
| CCDTokenWithVal !Text !Text
deriving (Show, Eq)

-- | Tries to parse the @max-age@ or @s-maxage@ present in the value of @Cache-Control@ header
parseMaxAge :: Integral a => Text -> Either String a
parseMaxAge t = do
cc <- parseCacheControl t
case find checkMaxAgeToken cc of
Nothing -> Left parseErr
Just d -> case d of
CCDOnlyToken _ -> Left parseErr
CCDTokenWithVal _ val -> fmapL (const parseErr) $ AT.parseOnly AT.decimal val
where
parseErr = "could not find max-age/s-maxage"
checkMaxAgeToken = \case
CCDOnlyToken token -> token == "max-age" || token == "s-maxage"
CCDTokenWithVal token _ -> token == "max-age" || token == "s-maxage"


-- | Parses a @Cache-Control@ header and returns a list of directives
parseCacheControl :: Text -> Either String CacheControl
parseCacheControl = AT.parseOnly cacheControlParser

-- ABNF: cache-control = *( "," OWS) cache-directive *( OWS "," [OWS cache-directive])
-- https://tools.ietf.org/html/rfc7234#appendix-C
cacheControlParser :: AT.Parser CacheControl
cacheControlParser = do
void $ AT.many' ("," *> optionalWhitespaceParser)
cd <- cacheDirectiveParser
cds <- AT.many' $ optionalWhitespaceParser *> "," *> AT.option Nothing (pure <$> optionalDirective)
return $ cd : catMaybes cds
where
optionalDirective = optionalWhitespaceParser *> cacheDirectiveParser

-- ABNF: OWS = *( SP / HTAB ) ; optional whitespace
-- https://tools.ietf.org/html/rfc7230#section-3.2.3
optionalWhitespaceParser :: AT.Parser (Maybe Char)
optionalWhitespaceParser = AT.option Nothing (pure <$> AT.space)

-- ABNF: cache-directive = token [ "=" ( token / quoted-string ) ]
-- https://tools.ietf.org/html/rfc7230#section-3.2.6
cacheDirectiveParser :: AT.Parser CacheControlDirective
cacheDirectiveParser = tokenWithValue <|> onlyToken
where
onlyToken = CCDOnlyToken <$> tokenParser
tokenWithValue = do
tok <- tokenParser
AT.char '='
val <- tokenParser <|> quotedStringParser
return $ CCDTokenWithVal tok val

-- ABNF: 1*tchar
-- https://tools.ietf.org/html/rfc7230#section-3.2.6
tokenParser :: AT.Parser Text
tokenParser = T.pack <$> AT.many1 tcharParser

-- ABNF: tchar = "!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "^" / "_" / "`" / "|"
-- / "~" / DIGIT / ALPHA ; any VCHAR, except delimiters
-- https://tools.ietf.org/html/rfc7230#section-3.2.6
tcharParser :: AT.Parser Char
tcharParser = AT.char '!'
<|> AT.char '#'
<|> AT.char '$'
<|> AT.char '%'
<|> AT.char '&'
<|> AT.char '\''
<|> AT.char '*'
<|> AT.char '+'
<|> AT.char '-'
<|> AT.char '.'
<|> AT.char '^'
<|> AT.char '_'
<|> AT.char '`'
<|> AT.char '|'
<|> AT.char '~'
<|> AT.digit
<|> AT.letter

-- ABNF: DQUOTE = %x22 ; " (Double Quote)
-- https://tools.ietf.org/html/rfc5234#appendix-B.1
dquoteParser :: AT.Parser Char
dquoteParser = AT.char '"'

-- ABNF: VCHAR = %x21-7E ; visible (printing) characters
-- https://tools.ietf.org/html/rfc5234#appendix-B.1
vcharParser :: AT.Parser Char
vcharParser = AT.anyChar

-- ABNF: quoted-string = DQUOTE *( qdtext / quoted-pair ) DQUOTE
-- https://tools.ietf.org/html/rfc7230#section-3.2.6
quotedStringParser :: AT.Parser Text
quotedStringParser =
dquoteParser *> fmap T.pack (AT.many' (qdTextParser <|> quotedPairParser)) <* dquoteParser

-- ABNF: quoted-pair = "\" ( HTAB / SP / VCHAR / obs-text )
-- https://tools.ietf.org/html/rfc7230#section-3.2.6
quotedPairParser :: AT.Parser Char
quotedPairParser =
AT.string "\\" *> (AT.space <|> vcharParser)

-- ABNF: qdtext = HTAB / SP / %x21 / %x23-5B / %x5D-7E / obs-text
-- https://tools.ietf.org/html/rfc7230#section-3.2.6
qdTextParser :: AT.Parser Char
qdTextParser = AT.space
<|> AT.char '!' -- %x21
-- skip %x22 as it is '"'
<|> AT.char '#' -- %x23
<|> AT.char '$' -- %x24
<|> AT.char '%' -- %x25
<|> AT.char '&' -- %x26
<|> AT.char '\'' -- %x27 single quote
<|> AT.char '(' -- %x28
<|> AT.char ')' -- %x29
<|> AT.char '*' -- %x2A
<|> AT.char '+' -- %x2B
<|> AT.char ',' -- %x2C
<|> AT.char '-' -- %x2D
<|> AT.char '.' -- %x2E
<|> AT.char '/' -- %x2F
<|> AT.digit -- %x30-39
<|> AT.char ':' -- %x3A
<|> AT.char ';' -- %x3B
<|> AT.char '<' -- %x3C
<|> AT.char '=' -- %x3D
<|> AT.char '>' -- %x3E
<|> AT.char '?' -- %x3F
<|> AT.char '@' -- %x40
<|> AT.letter -- %x41-5A / %x61-7A
<|> AT.char '[' -- %x5B
-- skip %x5C as it is '\'
<|> AT.char ']' -- %x5D
<|> AT.char '^' -- %x5E
<|> AT.char '_' -- %x5F
<|> AT.char '`' -- %x60
<|> AT.char '{' -- %x7B
<|> AT.char '|' -- %x7C
<|> AT.char '}' -- %x7D
<|> AT.char '~' -- %x7E
11 changes: 3 additions & 8 deletions server/src-lib/Hasura/Server/Auth/JWT.hs
View file
Expand Up @@ -14,8 +14,8 @@ import Control.Exception (try)
import Control.Lens
import Control.Monad (when)
import Data.IORef (IORef, modifyIORef, readIORef)

import Data.List (find)
import Data.Parser.CacheControl (parseMaxAge)
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime,
getCurrentTime)
import Data.Time.Format (defaultTimeLocale, parseTimeM)
Expand All @@ -34,7 +34,6 @@ import qualified Crypto.JWT as Jose
import qualified Data.Aeson as A
import qualified Data.Aeson.Casing as A
import qualified Data.Aeson.TH as A
import qualified Data.Attoparsec.Text as AT
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.CaseInsensitive as CI
Expand Down Expand Up @@ -174,15 +173,11 @@ updateJwkRef (Logger logger) manager url jwkRef = do
return $ diffUTCTime expires currTime

getTimeFromCacheControlHeader header =
case parseCacheControlHeader $ bsToTxt header of
case parseCacheControlHeader (bsToTxt header) of
Left e -> logAndThrow e Nothing
Right maxAge -> return $ Just $ fromInteger maxAge

parseCacheControlHeader =
fmapL (const parseCacheControlErr) . AT.parseOnly cacheControlHeaderParser

cacheControlHeaderParser :: AT.Parser Integer
cacheControlHeaderParser = ("s-maxage=" <|> "max-age=") *> AT.decimal
parseCacheControlHeader = fmapL (const parseCacheControlErr) . parseMaxAge

parseCacheControlErr =
"Failed parsing Cache-Control header from JWK response. Could not find max-age or s-maxage"
Expand Down
28 changes: 28 additions & 0 deletions server/src-test/Data/Parser/CacheControlSpec.hs
View file
@@ -0,0 +1,28 @@
module Data.Parser.CacheControlSpec (spec) where

import Hasura.Prelude

import qualified Data.Parser.CacheControl as CCP

import Test.Hspec


spec :: Spec
spec = do
describe "successfully parse cache-control header" $ do
it "parses max-age=5" $ do
let header = "public, must-revalidate, max-age=5, no-transform"
CCP.parseMaxAge @Integer header `shouldBe` Right 5

it "parses s-maxage=5" $ do
let header = "public, must-revalidate, s-maxage=5, no-transform"
CCP.parseMaxAge @Integer header `shouldBe` Right 5

describe "parse cache-control header fails" $ do
it "doesn't have max-age; fails parsing max-age" $ do
let header = "public, must-revalidate, no-transform"
CCP.parseMaxAge @Integer header `shouldBe` Left "could not find max-age/s-maxage"

it "max-age value is wrong; fails parsing max-age" $ do
let header = "public, max-age=\"abcd\" must-revalidate, no-transform"
CCP.parseMaxAge @Integer header `shouldBe` Left "could not find max-age/s-maxage"
36 changes: 19 additions & 17 deletions server/src-test/Main.hs
View file
Expand Up @@ -3,30 +3,31 @@ module Main (main) where
import Hasura.Prelude

import Control.Concurrent.MVar
import Control.Natural ((:~>) (..))
import Data.Time.Clock (getCurrentTime)
import Control.Natural ((:~>) (..))
import Data.Time.Clock (getCurrentTime)
import Options.Applicative
import System.Environment (getEnvironment)
import System.Exit (exitFailure)
import System.Environment (getEnvironment)
import System.Exit (exitFailure)
import Test.Hspec

import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Database.PG.Query as Q
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import qualified Test.Hspec.Runner as Hspec
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Database.PG.Query as Q
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import qualified Test.Hspec.Runner as Hspec

import Hasura.Db (PGExecCtx (..))
import Hasura.RQL.Types (SQLGenCtx (..), adminUserInfo)
import Hasura.Db (PGExecCtx (..))
import Hasura.RQL.Types (SQLGenCtx (..), adminUserInfo)
import Hasura.RQL.Types.Run
import Hasura.Server.Init (RawConnInfo, mkConnInfo, mkRawConnInfo,
parseRawConnInfo, runWithEnv)
import Hasura.Server.Init (RawConnInfo, mkConnInfo, mkRawConnInfo,
parseRawConnInfo, runWithEnv)
import Hasura.Server.Migrate

import qualified Hasura.IncrementalSpec as IncrementalSpec
import qualified Hasura.RQL.MetadataSpec as MetadataSpec
import qualified Hasura.Server.MigrateSpec as MigrateSpec
import qualified Data.Parser.CacheControlSpec as CacheControlParser
import qualified Hasura.IncrementalSpec as IncrementalSpec
import qualified Hasura.RQL.MetadataSpec as MetadataSpec
import qualified Hasura.Server.MigrateSpec as MigrateSpec

data TestSuites
= AllSuites !RawConnInfo
Expand All @@ -47,6 +48,7 @@ main = parseArgs >>= \case

unitSpecs :: Spec
unitSpecs = do
describe "Data.Parser.CacheControl" CacheControlParser.spec
describe "Hasura.Incremental" IncrementalSpec.spec
describe "Hasura.RQL.Metadata" MetadataSpec.spec

Expand Down

0 comments on commit 879b365

Please sign in to comment.