282 lines
11 KiB
Haskell
282 lines
11 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
module SpecHelper where
|
|
|
|
import qualified Data.Aeson as JSON
|
|
import qualified Data.ByteString.Base64 as B64 (decodeLenient)
|
|
import qualified Data.ByteString.Char8 as BS
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.Set as S
|
|
import qualified Jose.Jwa as JWT
|
|
import qualified Jose.Jws as JWT
|
|
import qualified Jose.Jwt as JWT
|
|
|
|
import Control.Lens ((^?))
|
|
import Data.Aeson ((.=))
|
|
import Data.CaseInsensitive (CI (..), original)
|
|
import Data.List (lookup)
|
|
import Data.List.NonEmpty (fromList)
|
|
import Data.Scientific (toRealFloat)
|
|
import Data.String (String)
|
|
import Data.Time.Clock.POSIX (getPOSIXTime)
|
|
import Network.Wai (Application)
|
|
import Network.Wai.Test (SResponse (simpleBody, simpleHeaders, simpleStatus))
|
|
import System.IO.Unsafe (unsafePerformIO)
|
|
import Text.Regex.TDFA ((=~))
|
|
|
|
import PostgREST.Config (AppConfig (..),
|
|
LogLevel (..),
|
|
OpenAPIMode (..),
|
|
Verbosity (..),
|
|
defaultRoleJSPathKey,
|
|
parseSecret)
|
|
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..))
|
|
|
|
import Data.Aeson.Lens
|
|
import Network.HTTP.Types
|
|
import Test.Hspec
|
|
import Test.Hspec.Wai
|
|
|
|
import Protolude hiding (get, toS)
|
|
import Protolude.Conv (toS)
|
|
|
|
filterAndMatchCT :: BS.ByteString -> MatchHeader
|
|
filterAndMatchCT val = MatchHeader $ \headers _ ->
|
|
case filter (\(n,_) -> n == hContentType) headers of
|
|
[(_,v)] -> if v == val
|
|
then Nothing
|
|
else Just $ "missing value:" <> toS val <> "\n"
|
|
_ -> Just "unexpected header: zero or multiple headers present\n"
|
|
|
|
matchContentTypeJson :: MatchHeader
|
|
matchContentTypeJson =
|
|
filterAndMatchCT "application/json; charset=utf-8"
|
|
|
|
matchContentTypeSingular :: MatchHeader
|
|
matchContentTypeSingular =
|
|
filterAndMatchCT "application/vnd.pgrst.object+json; charset=utf-8"
|
|
|
|
matchCTArrayStrip :: MatchHeader
|
|
matchCTArrayStrip =
|
|
filterAndMatchCT "application/vnd.pgrst.array+json;nulls=stripped; charset=utf-8"
|
|
|
|
matchCTSingularStrip :: MatchHeader
|
|
matchCTSingularStrip =
|
|
filterAndMatchCT "application/vnd.pgrst.object+json;nulls=stripped; charset=utf-8"
|
|
|
|
matchHeaderValuePresent :: HeaderName -> BS.ByteString -> MatchHeader
|
|
matchHeaderValuePresent name val = MatchHeader $ \headers _ ->
|
|
case lookup name headers of
|
|
Just hdr -> if val `BS.isInfixOf` hdr then Nothing else Just $ "missing header value: " <> toS val <> "\n"
|
|
Nothing -> Just $ "missing header: " <> toS (original name) <> "\n"
|
|
|
|
matchHeaderAbsent :: HeaderName -> MatchHeader
|
|
matchHeaderAbsent name = MatchHeader $ \headers _body ->
|
|
case lookup name headers of
|
|
Just _ -> Just $ "unexpected header: " <> toS (original name) <> "\n"
|
|
Nothing -> Nothing
|
|
|
|
-- | Matches Server-Timing header has a well-formed metric with the given name
|
|
matchServerTimingHasTiming :: String -> MatchHeader
|
|
matchServerTimingHasTiming metric = MatchHeader $ \headers _body ->
|
|
case lookup "Server-Timing" headers of
|
|
Just hdr -> if hdr =~ (metric <> ";dur=[[:digit:]]+.[[:digit:]]+")
|
|
then Nothing
|
|
else Just $ "missing metric: " <> metric <> "\n"
|
|
Nothing -> Just "missing Server-Timing header\n"
|
|
|
|
parseServerTimingHeader :: [Header] -> M.Map BS.ByteString Double
|
|
parseServerTimingHeader [] = M.empty
|
|
parseServerTimingHeader (h:hs) =
|
|
case h of
|
|
("Server-Timing", timingHeader) ->
|
|
let
|
|
timings = BS.split ',' timingHeader
|
|
in
|
|
M.fromList $ mapMaybe splitEachTiming timings
|
|
_ -> parseServerTimingHeader hs
|
|
where
|
|
splitEachTiming :: ByteString -> Maybe (BS.ByteString, Double)
|
|
splitEachTiming t =
|
|
case BS.split ';' t of
|
|
[name, durationText] ->
|
|
case BS.split '=' durationText of
|
|
[_, duration] -> (name,) <$> readMaybe (BS.unpack duration)
|
|
_ -> Nothing
|
|
_ -> Nothing
|
|
|
|
validateOpenApiResponse :: [Header] -> WaiSession () ()
|
|
validateOpenApiResponse headers = do
|
|
r <- request methodGet "/" headers ""
|
|
liftIO $
|
|
let respStatus = simpleStatus r in
|
|
respStatus `shouldSatisfy`
|
|
\s -> s == Status { statusCode = 200, statusMessage="OK" }
|
|
liftIO $
|
|
let respHeaders = simpleHeaders r in
|
|
respHeaders `shouldSatisfy`
|
|
\hs -> ("Content-Type", "application/openapi+json; charset=utf-8") `elem` hs
|
|
Just body <- pure $ JSON.decode (simpleBody r)
|
|
Just schema <- liftIO $ JSON.decode <$> BL.readFile "test/spec/fixtures/openapi.json"
|
|
let args :: M.Map Text JSON.Value
|
|
args = M.fromList
|
|
[ ( "schema", schema )
|
|
, ( "data", body ) ]
|
|
hdrs = acceptHdrs "application/json"
|
|
request methodPost "/rpc/validate_json_schema" hdrs (JSON.encode args)
|
|
`shouldRespondWith` "true"
|
|
{ matchStatus = 200
|
|
, matchHeaders = []
|
|
}
|
|
|
|
type SpecWithConfig = (AppConfig -> SpecWith ((), Application) -> Spec) -> Spec
|
|
|
|
baseCfg :: AppConfig
|
|
baseCfg = let secret = encodeUtf8 "reallyreallyreallyreallyverysafe" in
|
|
AppConfig {
|
|
configAppSettings = [ ("app.settings.app_host", "localhost") , ("app.settings.external_api_secret", "0123456789abcdef") ]
|
|
, configClientErrorVerbosity = Verbose
|
|
, configDbAggregates = False
|
|
, configDbAnonRole = Just "postgrest_test_anonymous"
|
|
, configDbChannel = mempty
|
|
, configDbChannelEnabled = True
|
|
, configDbExtraSearchPath = []
|
|
, configDbHoistedTxSettings = ["default_transaction_isolation","plan_filter.statement_cost_limit","statement_timeout"]
|
|
, configDbMaxRows = Nothing
|
|
, configDbPlanEnabled = False
|
|
, configDbPoolSize = 10
|
|
, configDbPoolAcquisitionTimeout = 10
|
|
, configDbPoolMaxLifetime = 1800
|
|
, configDbPoolMaxIdletime = 600
|
|
, configDbPoolAutomaticRecovery = True
|
|
, configDbPreRequest = Just $ QualifiedIdentifier "test" "switch_role"
|
|
, configDbPreparedStatements = True
|
|
, configDbRootSpec = Nothing
|
|
, configDbSchemas = fromList ["test"]
|
|
, configDbConfig = False
|
|
, configDbPreConfig = Nothing
|
|
, configDbTimezoneEnabled = True
|
|
, configDbUri = "postgresql://"
|
|
, configFilePath = Nothing
|
|
, configJWKS = rightToMaybe $ parseSecret secret
|
|
, configJwtAudience = Nothing
|
|
, configJwtRoleClaimKey = defaultRoleJSPathKey -- $.role
|
|
, configJwtSecret = Just secret
|
|
, configJwtSecretIsBase64 = False
|
|
, configJwtCacheMaxEntries = 10
|
|
, configLogLevel = LogCrit
|
|
, configLogQuery = False
|
|
, configOpenApiMode = OAFollowPriv
|
|
, configOpenApiSecurityActive = False
|
|
, configOpenApiServerProxyUri = Nothing
|
|
, configServerCorsAllowedOrigins = []
|
|
, configServerHost = "localhost"
|
|
, configServerPort = 3000
|
|
, configServerReusePort = False
|
|
, configServerTraceHeader = Nothing
|
|
, configServerUnixSocket = Nothing
|
|
, configServerUnixSocketMode = 432
|
|
, configUrlUseLegacyTargetNames = True
|
|
, configDbTxAllowOverride = True
|
|
, configDbTxRollbackAll = True
|
|
, configAdminServerHost = "localhost"
|
|
, configAdminServerPort = Nothing
|
|
, configAdminServerUnixSocket = Nothing
|
|
, configAdminServerUnixSocketMode = 432
|
|
, configRoleSettings = mempty
|
|
, configRoleIsoLvl = mempty
|
|
, configInternalSCQuerySleepFst = Nothing
|
|
, configInternalSCQuerySleepSnd = Nothing
|
|
, configServerTimingEnabled = True
|
|
}
|
|
|
|
rangeHdrs :: ByteRange -> [Header]
|
|
rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]
|
|
|
|
rangeHdrsWithCount :: ByteRange -> [Header]
|
|
rangeHdrsWithCount r = ("Prefer", "count=exact") : rangeHdrs r
|
|
|
|
acceptHdrs :: BS.ByteString -> [Header]
|
|
acceptHdrs mime = [(hAccept, mime)]
|
|
|
|
planHdr :: Header
|
|
planHdr = (hAccept, "application/vnd.pgrst.plan+json")
|
|
|
|
rangeUnit :: Header
|
|
rangeUnit = ("Range-Unit" :: CI BS.ByteString, "items")
|
|
|
|
matchHeader :: CI BS.ByteString -> BS.ByteString -> [Header] -> Bool
|
|
matchHeader name valRegex headers =
|
|
maybe False (=~ valRegex) $ lookup name headers
|
|
|
|
noBlankHeader :: [Header] -> Bool
|
|
noBlankHeader = notElem mempty
|
|
|
|
noProfileHeader :: [Header] -> Bool
|
|
noProfileHeader headers = isNothing $ find ((== "Content-Profile") . fst) headers
|
|
|
|
notZeroContentLength :: [Header] -> Bool
|
|
notZeroContentLength headers = maybe False (/= "0") $ lookup hContentLength headers
|
|
|
|
authHeader :: BS.ByteString -> BS.ByteString -> Header
|
|
authHeader typ creds =
|
|
(hAuthorization, typ <> " " <> creds)
|
|
|
|
authHeaderJWT :: BS.ByteString -> Header
|
|
authHeaderJWT = authHeader "Bearer"
|
|
|
|
generateSecret :: ByteString
|
|
generateSecret = B64.decodeLenient "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU="
|
|
|
|
generateJWT :: BL.ByteString -> ByteString
|
|
generateJWT claims =
|
|
either mempty JWT.unJwt $ JWT.hmacEncode JWT.HS256 generateSecret (BL.toStrict claims)
|
|
|
|
generateJWTWithSecret :: BL.ByteString -> ByteString -> ByteString
|
|
generateJWTWithSecret claims secret =
|
|
either mempty JWT.unJwt $ JWT.hmacEncode JWT.HS256 secret (BL.toStrict claims)
|
|
|
|
-- | Tests whether the text can be parsed as a json object containing
|
|
-- the key "message", and optional keys "details", "hint", "code",
|
|
-- and no extraneous keys
|
|
isErrorFormat :: BL.ByteString -> Bool
|
|
isErrorFormat s =
|
|
"message" `S.member` keys &&
|
|
S.null (S.difference keys validKeys)
|
|
where
|
|
obj = JSON.decode s :: Maybe (M.Map Text JSON.Value)
|
|
keys = maybe S.empty M.keysSet obj
|
|
validKeys = S.fromList ["message", "details", "hint", "code"]
|
|
|
|
planCost :: SResponse -> Float
|
|
planCost resp =
|
|
let res = simpleBody resp ^? nth 0 . key "Plan" . key "Total Cost" in
|
|
-- big value in case parsing fails
|
|
fromMaybe 1_000_000_000.0 $ unbox =<< res
|
|
where
|
|
unbox :: JSON.Value -> Maybe Float
|
|
unbox (JSON.Number n) = Just $ toRealFloat n
|
|
unbox _ = Nothing
|
|
|
|
data TiobePlsRow = TiobePlsRow {
|
|
name' :: Text,
|
|
rank :: Int
|
|
} deriving (Show)
|
|
|
|
instance JSON.ToJSON TiobePlsRow where
|
|
toJSON (TiobePlsRow name'' rank') = JSON.object ["name" .= name'', "rank" .= rank']
|
|
|
|
getInsertDataForTiobePlsTable :: Int -> BL.ByteString
|
|
getInsertDataForTiobePlsTable rows =
|
|
JSON.encode $ fromList $ [TiobePlsRow {name' = nm, rank = rk} | (nm,rk) <- nameRankList]
|
|
where
|
|
nameRankList = [("Lang " <> show i, i) | i <- [20..(rows+20)] ] :: [(Text, Int)]
|
|
|
|
readFixtureFile :: FilePath -> BL.ByteString
|
|
readFixtureFile file = unsafePerformIO $ BL.readFile $ "test/spec/fixtures/" <> file
|
|
|
|
relativeSeconds :: Integer -> IO Integer
|
|
relativeSeconds s = do
|
|
currTime <- getPOSIXTime
|
|
return $ floor currTime + s
|