1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-21 14:31:55 +03:00
graphql-engine/server/src-lib/Hasura/Server/Cors.hs
Samir Talwar 342391f39d Upgrade Ormolu to v0.5.
This upgrades the version of Ormolu required by the HGE repository to v0.5.0.1, and reformats all code accordingly.

Ormolu v0.5 reformats code that uses infix operators. This is mostly useful, adding newlines and indentation to make it clear which operators are applied first, but in some cases, it's unpleasant. To make this easier on the eyes, I had to do the following:

* Add a few fixity declarations (search for `infix`)
* Add parentheses to make precedence clear, allowing Ormolu to keep everything on one line
* Rename `relevantEq` to `(==~)` in  and set it to `infix 4`
* Add a few _.ormolu_ files (thanks to @hallettj for helping me get started), mostly for Autodocodec operators that don't have explicit fixity declarations

In general, I think these changes are quite reasonable. They mostly affect indentation.

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6675
GitOrigin-RevId: cd47d87f1d089fb0bc9dcbbe7798dbceedcd7d83
2022-11-02 20:55:13 +00:00

173 lines
5.0 KiB
Haskell

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TemplateHaskell #-}
-- | CORS (Cross Origin Resource Sharing) related configuration
module Hasura.Server.Cors
( CorsConfig (..),
CorsPolicy (..),
parseOrigin,
readCorsDomains,
mkDefaultCorsPolicy,
isCorsDisabled,
Domains (..),
inWildcardList,
)
where
import Control.Applicative (optional)
import Data.Aeson ((.:))
import Data.Aeson qualified as J
import Data.Aeson.TH qualified as J
import Data.Attoparsec.Text qualified as AT
import Data.Char qualified as C
import Data.HashSet qualified as Set
import Data.Text qualified as T
import Hasura.Prelude
import Hasura.Server.Utils (fmapL)
data DomainParts = DomainParts
{ wdScheme :: !Text,
wdHost :: !Text, -- the hostname part (without the *.)
wdPort :: !(Maybe Int)
}
deriving (Show, Eq, Generic, Hashable)
$(J.deriveJSON hasuraJSON ''DomainParts)
data Domains = Domains
{ dmFqdns :: !(Set.HashSet Text),
dmWildcards :: !(Set.HashSet DomainParts)
}
deriving (Show, Eq)
$(J.deriveJSON hasuraJSON ''Domains)
data CorsConfig
= CCAllowAll
| CCAllowedOrigins Domains
| CCDisabled Bool -- should read cookie?
deriving (Show, Eq)
instance J.ToJSON CorsConfig where
toJSON c = case c of
CCDisabled wsrc -> toJ True J.Null (Just wsrc)
CCAllowAll -> toJ False (J.String "*") Nothing
CCAllowedOrigins d -> toJ False (J.toJSON d) Nothing
where
toJ :: Bool -> J.Value -> Maybe Bool -> J.Value
toJ dis origs mWsRC =
J.object
[ "disabled" J..= dis,
"ws_read_cookie" J..= mWsRC,
"allowed_origins" J..= origs
]
instance J.FromJSON CorsConfig where
parseJSON = J.withObject "cors config" \o -> do
let parseAllowAll "*" = pure CCAllowAll
parseAllowAll _ = fail "unexpected string"
o .: "disabled" >>= \case
True -> CCDisabled <$> o .: "ws_read_cookie"
False ->
o .: "allowed_origins" >>= \v ->
J.withText "origins" parseAllowAll v
<|> CCAllowedOrigins <$> J.parseJSON v
isCorsDisabled :: CorsConfig -> Bool
isCorsDisabled = \case
CCDisabled _ -> True
_ -> False
readCorsDomains :: String -> Either String CorsConfig
readCorsDomains str
| str == "*" = pure CCAllowAll
| otherwise = do
let domains = map T.strip $ T.splitOn "," (T.pack str)
pDomains <- mapM parseOptWildcardDomain domains
let (fqdns, wcs) = (lefts pDomains, rights pDomains)
return $ CCAllowedOrigins $ Domains (Set.fromList fqdns) (Set.fromList wcs)
data CorsPolicy = CorsPolicy
{ cpConfig :: !CorsConfig,
cpMethods :: ![Text],
cpMaxAge :: !Int
}
deriving (Show, Eq)
mkDefaultCorsPolicy :: CorsConfig -> CorsPolicy
mkDefaultCorsPolicy cfg =
CorsPolicy
{ cpConfig = cfg,
cpMethods = ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"],
cpMaxAge = 1728000
}
inWildcardList :: Domains -> Text -> Bool
inWildcardList (Domains _ wildcards) origin =
any (`Set.member` wildcards) $ parseOrigin origin
-- | Parsers for wildcard domains
runParser :: AT.Parser a -> Text -> Either String a
runParser = AT.parseOnly
parseOrigin :: Text -> Either String DomainParts
parseOrigin = runParser originParser
originParser :: AT.Parser DomainParts
originParser =
domainParser (Just ignoreSubdomain)
where
ignoreSubdomain = do
s <- AT.takeTill (== '.')
void $ AT.char '.'
return s
parseOptWildcardDomain :: Text -> Either String (Either Text DomainParts)
parseOptWildcardDomain d =
fmapL (const errMsg) $ runParser optWildcardDomainParser d
where
optWildcardDomainParser :: AT.Parser (Either Text DomainParts)
optWildcardDomainParser =
Right <$> wildcardDomainParser <|> Left <$> fqdnParser
errMsg = "invalid domain: '" <> T.unpack d <> "'. " <> helpMsg
helpMsg =
"All domains should have scheme + (optional wildcard) host + "
<> "(optional port)"
wildcardDomainParser :: AT.Parser DomainParts
wildcardDomainParser = domainParser $ Just (AT.string "*" *> AT.string ".")
fqdnParser :: AT.Parser Text
fqdnParser = do
(DomainParts scheme host port) <- domainParser Nothing
let sPort = maybe "" (\p -> ":" <> tshow p) port
return $ scheme <> host <> sPort
domainParser :: Maybe (AT.Parser Text) -> AT.Parser DomainParts
domainParser parser = do
scheme <- schemeParser
forM_ parser void
host <- hostPortParser
port <- optional portParser
return $ DomainParts scheme host port
where
schemeParser :: AT.Parser Text
schemeParser = do
-- supports a custom URI scheme, rather than just http:// or https:// (see OSS #5818)
scheme <- AT.takeWhile1 (\x -> C.isAlphaNum x || elem x ['+', '.', '-'])
sep <- AT.string "://"
return $ scheme <> sep
hostPortParser :: AT.Parser Text
hostPortParser = hostWithPortParser <|> AT.takeText
hostWithPortParser :: AT.Parser Text
hostWithPortParser = do
h <- AT.takeWhile1 (/= ':')
void $ AT.char ':'
return h
portParser :: AT.Parser Int
portParser = AT.decimal