{-# LANGUAGE TemplateHaskellQuotes #-}

module Hasura.Server.Utils
  ( APIVersion (..),
    DeprecatedEnvVars (..),
    EnvVarsMovedToMetadata (..),
    adminSecretHeader,
    commonClientHeadersIgnored,
    cryptoHash,
    deprecatedAccessKeyHeader,
    deprecatedEnvVars,
    englishList,
    envVarsMovedToMetadata,
    executeJSONPath,
    filterHeaders,
    fmapL,
    generateFingerprint,
    getRequestHeader,
    gzipHeader,
    httpExceptToJSON,
    isReqUserId,
    isSessionVariable,
    jsonHeader,
    makeReasonMessage,
    mkClientHeadersForward,
    mkSetCookieHeaders,
    parseConnLifeTime,
    parseStringAsBool,
    quoteRegex,
    readIsoLevel,
    redactSensitiveHeader,
    requestIdHeader,
    sqlHeader,
    useBackendOnlyPermissionsHeader,
    userIdHeader,
    userRoleHeader,
    sessionVariablePrefix,
  )
where

import Control.Lens ((^..))
import Crypto.Hash qualified as Crypto
import Data.Aeson
import Data.Aeson qualified as J
import Data.Aeson.Internal
import Data.ByteArray (convert)
import Data.ByteString qualified as B
import Data.ByteString.Base16 qualified as Base16
import Data.ByteString.Lazy qualified as BL
import Data.CaseInsensitive qualified as CI
import Data.Char
import Data.HashSet qualified as Set
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Data.Text.Extended
import Data.Time
import Data.UUID qualified as UUID
import Data.UUID.V4 qualified as UUID
import Data.Vector qualified as V
import Database.PG.Query qualified as Q
import Hasura.Base.Instances ()
import Hasura.Prelude
import Language.Haskell.TH.Syntax (Q, TExp)
import Network.HTTP.Client qualified as HC
import Network.HTTP.Types qualified as HTTP
import Network.Wreq qualified as Wreq
import Text.Regex.TDFA qualified as TDFA
import Text.Regex.TDFA.ReadRegex qualified as TDFA
import Text.Regex.TDFA.TDFA qualified as TDFA

jsonHeader :: HTTP.Header
jsonHeader :: Header
jsonHeader = (HeaderName
"Content-Type", ByteString
"application/json; charset=utf-8")

sqlHeader :: HTTP.Header
sqlHeader :: Header
sqlHeader = (HeaderName
"Content-Type", ByteString
"application/sql; charset=utf-8")

gzipHeader :: HTTP.Header
gzipHeader :: Header
gzipHeader = (HeaderName
"Content-Encoding", ByteString
"gzip")

userRoleHeader :: IsString a => a
userRoleHeader :: a
userRoleHeader = a
"x-hasura-role"

deprecatedAccessKeyHeader :: IsString a => a
deprecatedAccessKeyHeader :: a
deprecatedAccessKeyHeader = a
"x-hasura-access-key"

adminSecretHeader :: IsString a => a
adminSecretHeader :: a
adminSecretHeader = a
"x-hasura-admin-secret"

userIdHeader :: IsString a => a
userIdHeader :: a
userIdHeader = a
"x-hasura-user-id"

requestIdHeader :: IsString a => a
requestIdHeader :: a
requestIdHeader = a
"x-request-id"

useBackendOnlyPermissionsHeader :: IsString a => a
useBackendOnlyPermissionsHeader :: a
useBackendOnlyPermissionsHeader = a
"x-hasura-use-backend-only-permissions"

getRequestHeader :: HTTP.HeaderName -> [HTTP.Header] -> Maybe B.ByteString
getRequestHeader :: HeaderName -> [Header] -> Maybe ByteString
getRequestHeader HeaderName
hdrName [Header]
hdrs = Header -> ByteString
forall a b. (a, b) -> b
snd (Header -> ByteString) -> Maybe Header -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Header
mHeader
  where
    mHeader :: Maybe Header
mHeader = (Header -> Bool) -> [Header] -> Maybe Header
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Header
h -> Header -> HeaderName
forall a b. (a, b) -> a
fst Header
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hdrName) [Header]
hdrs

parseStringAsBool :: String -> Either String Bool
parseStringAsBool :: String -> Either String Bool
parseStringAsBool String
t
  | (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
truthVals = Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
True
  | (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
falseVals = Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
False
  | Bool
otherwise = String -> Either String Bool
forall a b. a -> Either a b
Left String
errMsg
  where
    truthVals :: [String]
truthVals = [String
"true", String
"t", String
"yes", String
"y"]
    falseVals :: [String]
falseVals = [String
"false", String
"f", String
"no", String
"n"]

    errMsg :: String
errMsg =
      String
" Not a valid boolean text. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"True values are "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
truthVals
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and  False values are "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
falseVals
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". All values are case insensitive"

{- NOTE: Something like this is not safe in the presence of caching. The only
    way for metaprogramming to depend on some external data and recompile
    properly is via addDependentFile and to include that file in the
    extra-source-files in the cabal file (see: https://github.com/haskell/cabal/issues/4746).
    Leaving this here commented in order to document that fact and also in case
    there's a way forward in the future.

-- Run a shell script during compile time
runScript :: FilePath -> Q (TExp String)
runScript file = do
  fp <- makeRelativeToProject file
  TH.addDependentFile fp
  fileContent <- TH.runIO $ TI.readFile fp
  (exitCode, stdOut, stdErr) <-
    TH.runIO $
      readProcessWithExitCode "/bin/sh" [] $ T.unpack fileContent
  when (exitCode /= ExitSuccess) $
    fail $
      "Running shell script " ++ fp ++ " failed with exit code : "
        ++ show exitCode
        ++ " and with error : "
        ++ stdErr
  [||stdOut||]
-}

-- | Quotes a regex using Template Haskell so syntax errors can be reported at compile-time.
quoteRegex :: TDFA.CompOption -> TDFA.ExecOption -> String -> Q (TExp TDFA.Regex)
quoteRegex :: CompOption -> ExecOption -> String -> Q (TExp Regex)
quoteRegex CompOption
compOption ExecOption
execOption String
regexText = do
  (Pattern, (GroupIndex, DoPa))
regex <- String -> Either ParseError (Pattern, (GroupIndex, DoPa))
TDFA.parseRegex String
regexText Either ParseError (Pattern, (GroupIndex, DoPa))
-> (ParseError -> Q (Pattern, (GroupIndex, DoPa)))
-> Q (Pattern, (GroupIndex, DoPa))
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` (String -> Q (Pattern, (GroupIndex, DoPa))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Pattern, (GroupIndex, DoPa)))
-> (ParseError -> String)
-> ParseError
-> Q (Pattern, (GroupIndex, DoPa))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show)
  [||TDFA.patternToRegex regex compOption execOption||]

fmapL :: (a -> a') -> Either a b -> Either a' b
fmapL :: (a -> a') -> Either a b -> Either a' b
fmapL a -> a'
fn (Left a
e) = a' -> Either a' b
forall a b. a -> Either a b
Left (a -> a'
fn a
e)
fmapL a -> a'
_ (Right b
x) = b -> Either a' b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x

generateFingerprint :: IO Text
generateFingerprint :: IO Text
generateFingerprint = UUID -> Text
UUID.toText (UUID -> Text) -> IO UUID -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
UUID.nextRandom

-- json representation of HTTP exception
httpExceptToJSON :: HC.HttpException -> Value
httpExceptToJSON :: HttpException -> Value
httpExceptToJSON HttpException
e = case HttpException
e of
  HC.HttpExceptionRequest Request
x HttpExceptionContent
c ->
    let reqObj :: Value
reqObj =
          [Pair] -> Value
object
            [ Key
"host" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
bsToTxt (Request -> ByteString
HC.host Request
x),
              Key
"port" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= GroupIndex -> String
forall a. Show a => a -> String
show (Request -> GroupIndex
HC.port Request
x),
              Key
"secure" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Request -> Bool
HC.secure Request
x,
              Key
"path" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
bsToTxt (Request -> ByteString
HC.path Request
x),
              Key
"method" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
bsToTxt (Request -> ByteString
HC.method Request
x),
              Key
"proxy" Key -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Proxy -> Text
showProxy (Proxy -> Text) -> Maybe Proxy -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Maybe Proxy
HC.proxy Request
x),
              Key
"redirectCount" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= GroupIndex -> String
forall a. Show a => a -> String
show (Request -> GroupIndex
HC.redirectCount Request
x),
              Key
"responseTimeout" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ResponseTimeout -> String
forall a. Show a => a -> String
show (Request -> ResponseTimeout
HC.responseTimeout Request
x),
              Key
"requestVersion" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> String
forall a. Show a => a -> String
show (Request -> HttpVersion
HC.requestVersion Request
x)
            ]
        msg :: String
msg = HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
c
     in [Pair] -> Value
object [Key
"request" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
reqObj, Key
"message" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
msg]
  HttpException
_ -> String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ HttpException -> String
forall a. Show a => a -> String
show HttpException
e
  where
    showProxy :: Proxy -> Text
showProxy (HC.Proxy ByteString
h GroupIndex
p) =
      Text
"host: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
bsToTxt ByteString
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" port: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupIndex -> Text
forall a. Show a => a -> Text
tshow GroupIndex
p

-- ignore the following request headers from the client
commonClientHeadersIgnored :: (IsString a) => [a]
commonClientHeadersIgnored :: [a]
commonClientHeadersIgnored =
  [ a
"Content-Length",
    a
"Content-MD5",
    a
"User-Agent",
    a
"Host",
    a
"Origin",
    a
"Referer",
    a
"Accept",
    a
"Accept-Encoding",
    a
"Accept-Language",
    a
"Accept-Datetime",
    a
"Cache-Control",
    a
"Connection",
    a
"DNT",
    a
"Content-Type"
  ]

sessionVariablePrefix :: Text
sessionVariablePrefix :: Text
sessionVariablePrefix = Text
"x-hasura-"

isSessionVariable :: Text -> Bool
isSessionVariable :: Text -> Bool
isSessionVariable = Text -> Text -> Bool
T.isPrefixOf Text
sessionVariablePrefix (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower

isReqUserId :: Text -> Bool
isReqUserId :: Text -> Bool
isReqUserId = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"req_user_id") (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower

mkClientHeadersForward :: [HTTP.Header] -> [HTTP.Header]
mkClientHeadersForward :: [Header] -> [Header]
mkClientHeadersForward [Header]
reqHeaders =
  [Header]
xForwardedHeaders [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> ([Header] -> [Header]
forall b. [(HeaderName, b)] -> [(HeaderName, b)]
filterSessionVariables ([Header] -> [Header])
-> ([Header] -> [Header]) -> [Header] -> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Header] -> [Header]
filterRequestHeaders) [Header]
reqHeaders
  where
    filterSessionVariables :: [(HeaderName, b)] -> [(HeaderName, b)]
filterSessionVariables = ((HeaderName, b) -> Bool) -> [(HeaderName, b)] -> [(HeaderName, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
k, b
_) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
isSessionVariable (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
bsToTxt (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
k)
    xForwardedHeaders :: [Header]
xForwardedHeaders = ((Header -> Maybe Header) -> [Header] -> [Header])
-> [Header] -> (Header -> Maybe Header) -> [Header]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Header -> Maybe Header) -> [Header] -> [Header]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe [Header]
reqHeaders ((Header -> Maybe Header) -> [Header])
-> (Header -> Maybe Header) -> [Header]
forall a b. (a -> b) -> a -> b
$ \(HeaderName
hdrName, ByteString
hdrValue) ->
      case HeaderName
hdrName of
        HeaderName
"Host" -> Header -> Maybe Header
forall a. a -> Maybe a
Just (HeaderName
"X-Forwarded-Host", ByteString
hdrValue)
        HeaderName
"User-Agent" -> Header -> Maybe Header
forall a. a -> Maybe a
Just (HeaderName
"X-Forwarded-User-Agent", ByteString
hdrValue)
        HeaderName
_ -> Maybe Header
forall a. Maybe a
Nothing

mkSetCookieHeaders :: Wreq.Response a -> HTTP.ResponseHeaders
mkSetCookieHeaders :: Response a -> [Header]
mkSetCookieHeaders Response a
resp =
  (ByteString -> Header) -> [ByteString] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map (HeaderName
headerName,) ([ByteString] -> [Header]) -> [ByteString] -> [Header]
forall a b. (a -> b) -> a -> b
$ Response a
resp Response a
-> Getting (Endo [ByteString]) (Response a) ByteString
-> [ByteString]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. HeaderName -> Traversal' (Response a) ByteString
forall body. HeaderName -> Traversal' (Response body) ByteString
Wreq.responseHeader HeaderName
headerName
  where
    headerName :: HeaderName
headerName = HeaderName
"Set-Cookie"

filterRequestHeaders :: [HTTP.Header] -> [HTTP.Header]
filterRequestHeaders :: [Header] -> [Header]
filterRequestHeaders =
  HashSet HeaderName -> [Header] -> [Header]
filterHeaders (HashSet HeaderName -> [Header] -> [Header])
-> HashSet HeaderName -> [Header] -> [Header]
forall a b. (a -> b) -> a -> b
$ [HeaderName] -> HashSet HeaderName
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList [HeaderName]
forall a. IsString a => [a]
commonClientHeadersIgnored

filterHeaders :: Set.HashSet HTTP.HeaderName -> [HTTP.Header] -> [HTTP.Header]
filterHeaders :: HashSet HeaderName -> [Header] -> [Header]
filterHeaders HashSet HeaderName
list = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(HeaderName
n, ByteString
_) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HeaderName
n HeaderName -> HashSet HeaderName -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet HeaderName
list)

-- | The version integer
data APIVersion
  = VIVersion1
  | VIVersion2
  deriving (GroupIndex -> APIVersion -> String -> String
[APIVersion] -> String -> String
APIVersion -> String
(GroupIndex -> APIVersion -> String -> String)
-> (APIVersion -> String)
-> ([APIVersion] -> String -> String)
-> Show APIVersion
forall a.
(GroupIndex -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [APIVersion] -> String -> String
$cshowList :: [APIVersion] -> String -> String
show :: APIVersion -> String
$cshow :: APIVersion -> String
showsPrec :: GroupIndex -> APIVersion -> String -> String
$cshowsPrec :: GroupIndex -> APIVersion -> String -> String
Show, APIVersion -> APIVersion -> Bool
(APIVersion -> APIVersion -> Bool)
-> (APIVersion -> APIVersion -> Bool) -> Eq APIVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: APIVersion -> APIVersion -> Bool
$c/= :: APIVersion -> APIVersion -> Bool
== :: APIVersion -> APIVersion -> Bool
$c== :: APIVersion -> APIVersion -> Bool
Eq)

instance ToJSON APIVersion where
  toJSON :: APIVersion -> Value
toJSON APIVersion
VIVersion1 = GroupIndex -> Value
forall a. ToJSON a => a -> Value
toJSON @Int GroupIndex
1
  toJSON APIVersion
VIVersion2 = GroupIndex -> Value
forall a. ToJSON a => a -> Value
toJSON @Int GroupIndex
2

instance FromJSON APIVersion where
  parseJSON :: Value -> Parser APIVersion
parseJSON Value
v = do
    GroupIndex
verInt :: Int <- Value -> Parser GroupIndex
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    case GroupIndex
verInt of
      GroupIndex
1 -> APIVersion -> Parser APIVersion
forall (m :: * -> *) a. Monad m => a -> m a
return APIVersion
VIVersion1
      GroupIndex
2 -> APIVersion -> Parser APIVersion
forall (m :: * -> *) a. Monad m => a -> m a
return APIVersion
VIVersion2
      GroupIndex
i -> String -> Parser APIVersion
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser APIVersion) -> String -> Parser APIVersion
forall a b. (a -> b) -> a -> b
$ String
"expected 1 or 2, encountered " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GroupIndex -> String
forall a. Show a => a -> String
show GroupIndex
i

englishList :: Text -> NonEmpty Text -> Text
englishList :: Text -> NonEmpty Text -> Text
englishList Text
joiner = \case
  Text
one :| [] -> Text
one
  Text
one :| [Text
two] -> Text
one Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
joiner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
two
  NonEmpty Text
several ->
    let Text
final :| [Text]
initials = NonEmpty Text -> NonEmpty Text
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty Text
several
     in [Text] -> Text
forall t (f :: * -> *). (ToTxt t, Foldable f) => f t -> Text
commaSeparated ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
initials) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
joiner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
final

makeReasonMessage :: [a] -> (a -> Text) -> Text
makeReasonMessage :: [a] -> (a -> Text) -> Text
makeReasonMessage [a]
errors a -> Text
showError =
  case [a]
errors of
    [a
singleError] -> Text
"because " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
showError a
singleError
    [a]
_ ->
      Text
"for the following reasons:\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines
          ((a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"  • " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
showError) [a]
errors)

executeJSONPath :: JSONPath -> Value -> IResult Value
executeJSONPath :: JSONPath -> Value -> IResult Value
executeJSONPath JSONPath
jsonPath = (Value -> Parser Value) -> Value -> IResult Value
forall a b. (a -> Parser b) -> a -> IResult b
iparse (JSONPath -> Value -> Parser Value
valueParser JSONPath
jsonPath)
  where
    valueParser :: JSONPath -> Value -> Parser Value
valueParser JSONPath
path Value
value = case JSONPath
path of
      [] -> Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value
      (JSONPathElement
pathElement : JSONPath
remaining) ->
        JSONPathElement -> Value -> Parser Value
parseWithPathElement JSONPathElement
pathElement Value
value
          Parser Value -> (Value -> Parser Value) -> Parser Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Parser Value -> JSONPathElement -> Parser Value
forall a. Parser a -> JSONPathElement -> Parser a
<?> JSONPathElement
pathElement) (Parser Value -> Parser Value)
-> (Value -> Parser Value) -> Value -> Parser Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSONPath -> Value -> Parser Value
valueParser JSONPath
remaining)
      where
        parseWithPathElement :: JSONPathElement -> Value -> Parser Value
parseWithPathElement = \case
          Key Key
k -> String -> (Object -> Parser Value) -> Value -> Parser Value
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Object" (Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
k)
          Index GroupIndex
i ->
            String -> (Array -> Parser Value) -> Value -> Parser Value
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray String
"Array" ((Array -> Parser Value) -> Value -> Parser Value)
-> (Array -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$
              Parser Value
-> (Value -> Parser Value) -> Maybe Value -> Parser Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Array index out of range") Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> Parser Value)
-> (Array -> Maybe Value) -> Array -> Parser Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Array -> GroupIndex -> Maybe Value
forall a. Vector a -> GroupIndex -> Maybe a
V.!? GroupIndex
i)

sha1 :: BL.ByteString -> B.ByteString
sha1 :: ByteString -> ByteString
sha1 = (ByteArrayAccess (Digest SHA1), ByteArray ByteString) =>
Digest SHA1 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert @_ @B.ByteString (Digest SHA1 -> ByteString)
-> (ByteString -> Digest SHA1) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashAlgorithm SHA1 => ByteString -> Digest SHA1
forall a. HashAlgorithm a => ByteString -> Digest a
Crypto.hashlazy @Crypto.SHA1

cryptoHash :: J.ToJSON a => a -> B.ByteString
cryptoHash :: a -> ByteString
cryptoHash = ByteString -> ByteString
Base16.encode (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
sha1 (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode

readIsoLevel :: String -> Either String Q.TxIsolation
readIsoLevel :: String -> Either String TxIsolation
readIsoLevel String
isoS =
  case String
isoS of
    String
"read-committed" -> TxIsolation -> Either String TxIsolation
forall (m :: * -> *) a. Monad m => a -> m a
return TxIsolation
Q.ReadCommitted
    String
"repeatable-read" -> TxIsolation -> Either String TxIsolation
forall (m :: * -> *) a. Monad m => a -> m a
return TxIsolation
Q.RepeatableRead
    String
"serializable" -> TxIsolation -> Either String TxIsolation
forall (m :: * -> *) a. Monad m => a -> m a
return TxIsolation
Q.Serializable
    String
_ -> String -> Either String TxIsolation
forall a b. a -> Either a b
Left String
"Only expecting read-committed / repeatable-read / serializable"

parseConnLifeTime :: Maybe NominalDiffTime -> Maybe NominalDiffTime
parseConnLifeTime :: Maybe NominalDiffTime -> Maybe NominalDiffTime
parseConnLifeTime = \case
  Maybe NominalDiffTime
Nothing -> NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
600 -- Not set by user; use the default timeout
  Just NominalDiffTime
0 -> Maybe NominalDiffTime
forall a. Maybe a
Nothing -- user wants to disable PG_CONN_LIFETIME
  Just NominalDiffTime
n -> NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
n -- user specified n seconds lifetime

-- | The environment variables that were moved to metadata. These environment
-- variables are available if a v1 hasura project is run an v2 hasura server.
-- These environment variables are marked as deprecated only when the v1 hasura
-- project is migrated to v2 project.
newtype EnvVarsMovedToMetadata = EnvVarsMovedToMetadata {EnvVarsMovedToMetadata -> [String]
unEnvVarsMovedToMetadata :: [String]}
  deriving (GroupIndex -> EnvVarsMovedToMetadata -> String -> String
[EnvVarsMovedToMetadata] -> String -> String
EnvVarsMovedToMetadata -> String
(GroupIndex -> EnvVarsMovedToMetadata -> String -> String)
-> (EnvVarsMovedToMetadata -> String)
-> ([EnvVarsMovedToMetadata] -> String -> String)
-> Show EnvVarsMovedToMetadata
forall a.
(GroupIndex -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [EnvVarsMovedToMetadata] -> String -> String
$cshowList :: [EnvVarsMovedToMetadata] -> String -> String
show :: EnvVarsMovedToMetadata -> String
$cshow :: EnvVarsMovedToMetadata -> String
showsPrec :: GroupIndex -> EnvVarsMovedToMetadata -> String -> String
$cshowsPrec :: GroupIndex -> EnvVarsMovedToMetadata -> String -> String
Show)

-- | These env vars are completely deprecated
newtype DeprecatedEnvVars = DeprecatedEnvVars {DeprecatedEnvVars -> [String]
unDeprecatedEnvVars :: [String]}
  deriving (GroupIndex -> DeprecatedEnvVars -> String -> String
[DeprecatedEnvVars] -> String -> String
DeprecatedEnvVars -> String
(GroupIndex -> DeprecatedEnvVars -> String -> String)
-> (DeprecatedEnvVars -> String)
-> ([DeprecatedEnvVars] -> String -> String)
-> Show DeprecatedEnvVars
forall a.
(GroupIndex -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DeprecatedEnvVars] -> String -> String
$cshowList :: [DeprecatedEnvVars] -> String -> String
show :: DeprecatedEnvVars -> String
$cshow :: DeprecatedEnvVars -> String
showsPrec :: GroupIndex -> DeprecatedEnvVars -> String -> String
$cshowsPrec :: GroupIndex -> DeprecatedEnvVars -> String -> String
Show)

envVarsMovedToMetadata :: EnvVarsMovedToMetadata
envVarsMovedToMetadata :: EnvVarsMovedToMetadata
envVarsMovedToMetadata =
  [String] -> EnvVarsMovedToMetadata
EnvVarsMovedToMetadata
    [ String
"HASURA_GRAPHQL_NO_OF_RETRIES",
      String
"HASURA_GRAPHQL_PG_CONNECTIONS",
      String
"HASURA_GRAPHQL_PG_TIMEOUT",
      String
"HASURA_GRAPHQL_PG_CONN_LIFETIME",
      String
"HASURA_GRAPHQL_PG_POOL_TIMEOUT",
      String
"HASURA_GRAPHQL_USE_PREPARED_STATEMENTS",
      String
"HASURA_GRAPHQL_TX_ISOLATION",
      String
"HASURA_GRAPHQL_CONNECTIONS_PER_READ_REPLICA"
    ]

deprecatedEnvVars :: DeprecatedEnvVars
deprecatedEnvVars :: DeprecatedEnvVars
deprecatedEnvVars =
  [String] -> DeprecatedEnvVars
DeprecatedEnvVars
    [ String
"HASURA_GRAPHQL_PG_STRIPES",
      String
"HASURA_GRAPHQL_QUERY_PLAN_CACHE_SIZE",
      String
"HASURA_GRAPHQL_STRIPES_PER_READ_REPLICA"
    ]

sensitiveHeaders :: HashSet HTTP.HeaderName
sensitiveHeaders :: HashSet HeaderName
sensitiveHeaders =
  [HeaderName] -> HashSet HeaderName
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList
    [ HeaderName
"Authorization",
      HeaderName
"Cookie"
    ]

redactSensitiveHeader :: HTTP.Header -> HTTP.Header
redactSensitiveHeader :: Header -> Header
redactSensitiveHeader (HeaderName
headerName, ByteString
value) = (HeaderName
headerName, if HeaderName
headerName HeaderName -> HashSet HeaderName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` HashSet HeaderName
sensitiveHeaders then ByteString
"<REDACTED>" else ByteString
value)