refactor: Split up Types.hs and logically organize modules (#1793)

This commit is contained in:
Remo Rechkemmer
2021-04-11 18:28:01 +02:00
committed by GitHub
parent 8c44410ce0
commit f99fd6cbad
37 changed files with 1496 additions and 1008 deletions
+25 -10
View File
@@ -30,17 +30,18 @@ import System.CPUTime (getCPUTime)
import System.IO (BufferMode (..), hSetBuffering)
import Text.Printf (hPrintf)
import PostgREST.App (postgrest)
import PostgREST.App (postgrest)
import PostgREST.Config
import PostgREST.DbStructure (getDbStructure, getPgVersion)
import PostgREST.Error (PgError (PgError), checkIsFatal,
errorPayload)
import PostgREST.Statements (dbSettingsStatement)
import PostgREST.Types (ConnectionStatus (..), DbStructure,
PgVersion (..), SCacheStatus (..),
minimumPgVersion)
import Protolude hiding (hPutStrLn, head, toS)
import Protolude.Conv (toS)
import PostgREST.DbStructure (DbStructure, getDbStructure,
getPgVersion)
import PostgREST.DbStructure.PgVersion (PgVersion (..),
minimumPgVersion)
import PostgREST.Error (PgError (PgError),
checkIsFatal, errorPayload)
import PostgREST.Query.Statements (dbSettingsStatement)
import Protolude hiding (hPutStrLn, head, toS)
import Protolude.Conv (toS)
#ifndef mingw32_HOST_OS
@@ -48,6 +49,20 @@ import System.Posix.Signals
import UnixSocket
#endif
-- | Current database connection status data ConnectionStatus
data ConnectionStatus
= NotConnected
| Connected PgVersion
| FatalConnectionError Text
deriving (Eq)
-- | Schema cache status
data SCacheStatus
= SCLoaded
| SCOnRetry
| SCFatalFail
-- | This is where everything starts.
main :: IO ()
main = do
+18 -10
View File
@@ -34,24 +34,32 @@ library
default-extensions: OverloadedStrings
NoImplicitPrelude
hs-source-dirs: src
exposed-modules: PostgREST.ApiRequest
PostgREST.App
exposed-modules: PostgREST.App
PostgREST.Auth
PostgREST.Config
PostgREST.DbRequestBuilder
PostgREST.Config.JSPath
PostgREST.Config.Proxy
PostgREST.ContentType
PostgREST.DbStructure
PostgREST.DbStructure.Identifiers
PostgREST.DbStructure.PgVersion
PostgREST.DbStructure.Proc
PostgREST.DbStructure.Relation
PostgREST.DbStructure.Table
PostgREST.Error
PostgREST.GucHeader
PostgREST.Middleware
PostgREST.OpenAPI
PostgREST.Parsers
PostgREST.QueryBuilder
PostgREST.Statements
PostgREST.Query.QueryBuilder
PostgREST.Query.SqlFragment
PostgREST.Query.Statements
PostgREST.RangeQuery
PostgREST.Types
PostgREST.Request.ApiRequest
PostgREST.Request.DbRequestBuilder
PostgREST.Request.Parsers
PostgREST.Request.Preferences
PostgREST.Request.Types
other-modules: Paths_postgrest
PostgREST.Private.Common
PostgREST.Private.ProxyUri
PostgREST.Private.QueryFragment
build-depends: base >= 4.9 && < 4.15
, HTTP >= 4000.3.7 && < 4000.4
, Ranged-sets >= 0.3 && < 0.5
+43 -23
View File
@@ -30,23 +30,43 @@ import qualified Network.HTTP.Types.Status as HTTP
import qualified Network.HTTP.Types.URI as HTTP
import qualified Network.Wai as Wai
import qualified PostgREST.ApiRequest as ApiRequest
import qualified PostgREST.Auth as Auth
import qualified PostgREST.DbRequestBuilder as ReqBuilder
import qualified PostgREST.DbStructure as DbStructure
import qualified PostgREST.Error as Error
import qualified PostgREST.Middleware as Middleware
import qualified PostgREST.OpenAPI as OpenAPI
import qualified PostgREST.QueryBuilder as QueryBuilder
import qualified PostgREST.RangeQuery as RangeQuery
import qualified PostgREST.Statements as Statements
import qualified PostgREST.Auth as Auth
import qualified PostgREST.DbStructure as DbStructure
import qualified PostgREST.Error as Error
import qualified PostgREST.Middleware as Middleware
import qualified PostgREST.OpenAPI as OpenAPI
import qualified PostgREST.Query.QueryBuilder as QueryBuilder
import qualified PostgREST.Query.Statements as Statements
import qualified PostgREST.RangeQuery as RangeQuery
import qualified PostgREST.Request.ApiRequest as ApiRequest
import qualified PostgREST.Request.DbRequestBuilder as ReqBuilder
import PostgREST.ApiRequest (Action (..), ApiRequest (..),
InvokeMethod (..), Target (..))
import PostgREST.Config (AppConfig (..))
import PostgREST.Error (Error)
import PostgREST.Config (AppConfig (..),
LogLevel (..))
import PostgREST.ContentType (ContentType (..))
import PostgREST.DbStructure (DbStructure (..),
tablePKCols)
import PostgREST.DbStructure.Identifiers (FieldName,
QualifiedIdentifier (..),
Schema)
import PostgREST.DbStructure.Proc (ProcDescription (..),
ProcVolatility (..))
import PostgREST.DbStructure.Table (Table (..))
import PostgREST.Error (Error)
import PostgREST.GucHeader (GucHeader,
addHeadersIfNotIncluded,
unwrapGucHeader)
import PostgREST.Request.ApiRequest (Action (..),
ApiRequest (..),
InvokeMethod (..),
Target (..))
import PostgREST.Request.Preferences (PreferCount (..),
PreferParameters (..),
PreferRepresentation (..))
import PostgREST.Request.Types (ReadRequest, fstFieldNames)
import PostgREST.Types
import qualified PostgREST.ContentType as ContentType
import qualified PostgREST.DbStructure.Proc as Proc
import Protolude hiding (Handler, toS)
import Protolude.Conv (toS)
@@ -123,7 +143,7 @@ postgrestResponse conf@AppConfig{..} maybeDbStructure pool time req = do
Just ct ->
return ct
Nothing ->
throwError . Error.ContentTypeError $ map toMime iAccepts
throwError . Error.ContentTypeError $ map ContentType.toMime iAccepts
let
handleReq apiReq =
@@ -352,9 +372,9 @@ handleInvoke invMethod proc context@RequestContext{..} = do
identifier =
QualifiedIdentifier
(pdSchema proc)
(fromMaybe (pdName proc) $ procTableName proc)
(fromMaybe (pdName proc) $ Proc.procTableName proc)
returnsSingle (ApiRequest.TargetProc target _) = procReturnsSingle target
returnsSingle (ApiRequest.TargetProc target _) = Proc.procReturnsSingle target
returnsSingle _ = False
req <- readRequest identifier context
@@ -367,7 +387,7 @@ handleInvoke invMethod proc context@RequestContext{..} = do
(returnsSingle iTarget)
(QueryBuilder.requestToCallProcQuery
(QualifiedIdentifier (pdSchema proc) (pdName proc))
(specifiedProcArgs iColumns proc)
(Proc.specifiedProcArgs iColumns proc)
iPayload
(returnsScalar iTarget)
iPreferParameters
@@ -405,7 +425,7 @@ handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure
return $
Wai.responseLBS HTTP.status200
(toHeader CTOpenAPI : maybeToList (profileHeader apiRequest))
(ContentType.toHeader CTOpenAPI : maybeToList (profileHeader apiRequest))
(if headersOnly then mempty else toS body)
txMode :: ApiRequest -> SQL.Mode
@@ -491,7 +511,7 @@ shouldCount preferCount =
preferCount == Just ExactCount || preferCount == Just EstimatedCount
returnsScalar :: ApiRequest.Target -> Bool
returnsScalar (TargetProc proc _) = procReturnsScalar proc
returnsScalar (TargetProc proc _) = Proc.procReturnsScalar proc
returnsScalar _ = False
readRequest :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m ReadRequest
@@ -503,7 +523,7 @@ readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure ap
contentTypeHeaders :: RequestContext -> [HTTP.Header]
contentTypeHeaders RequestContext{..} =
toHeader ctxContentType : maybeToList (profileHeader ctxApiRequest)
ContentType.toHeader ctxContentType : maybeToList (profileHeader ctxApiRequest)
requestContentTypes :: AppConfig -> ApiRequest -> [ContentType]
requestContentTypes conf ApiRequest{..} =
@@ -542,7 +562,7 @@ binaryField RequestContext{..} readReq
rawContentTypes :: AppConfig -> [ContentType]
rawContentTypes AppConfig{..} =
(decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]
(ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]
profileHeader :: ApiRequest -> Maybe HTTP.Header
profileHeader ApiRequest{..} =
+6 -3
View File
@@ -11,7 +11,11 @@ In the test suite there is an example of simple login function that can be used
very simple authentication system inside the PostgreSQL database.
-}
{-# LANGUAGE RecordWildCards #-}
module PostgREST.Auth (containsRole, jwtClaims, JWTClaims) where
module PostgREST.Auth
( containsRole
, jwtClaims
, JWTClaims
) where
import qualified Crypto.JWT as JWT
import qualified Data.Aeson as JSON
@@ -23,9 +27,8 @@ import Control.Monad.Except (liftEither)
import Data.Either.Combinators (mapLeft)
import Data.Time.Clock (UTCTime)
import PostgREST.Config (AppConfig (..))
import PostgREST.Config (AppConfig (..), JSPath, JSPathExp (..))
import PostgREST.Error (Error (..))
import PostgREST.Types (JSPath, JSPathExp (..))
import Protolude
+54 -43
View File
@@ -24,9 +24,11 @@ Other hardcoded options such as the minimum version number also belong here.
module PostgREST.Config
( prettyVersion
, docsVersion
, LogLevel(..)
, CLI (..)
, Command (..)
, AppConfig (..)
, Proxy(..)
, configDbPoolTimeout'
, dumpAppConfig
, Environment
@@ -36,6 +38,10 @@ module PostgREST.Config
, readDbUriFile
, readSecretFile
, parseSecret
, JSPath
, JSPathExp(..)
, isMalformedProxyUri
, toURI
) where
import qualified Crypto.JOSE.Types as JOSE
@@ -46,6 +52,9 @@ import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS
import qualified Data.Configurator as C
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified GHC.Show (show)
import Control.Lens (preview)
import Control.Monad (fail)
@@ -56,31 +65,25 @@ import Data.List (lookup)
import Data.List.NonEmpty (fromList, toList)
import Data.Maybe (fromJust)
import Data.Scientific (floatingOrInteger)
import Data.Text (dropEnd, dropWhileEnd, filter,
intercalate, pack, replace, splitOn,
strip, stripPrefix, take, toLower,
toTitle, unpack)
import Data.Version (versionBranch)
import Development.GitRev (gitHash)
import Numeric (readOct, showOct)
import Options.Applicative (Parser, customExecParser, flag,
footer, fullDesc, help, helper, info,
infoOption, long, metavar, prefs,
progDesc, short, showHelpOnEmpty,
showHelpOnError, strArgument)
import Paths_postgrest (version)
import System.Environment (getEnvironment)
import System.Posix.Types (FileMode)
import Text.Heredoc (str)
import Control.Applicative
import Data.Monoid
import Options.Applicative hiding (str)
import Text.Heredoc (str)
import PostgREST.Config.JSPath (JSPath, JSPathExp (..), pRoleClaimKey)
import PostgREST.Config.Proxy (Proxy (..), isMalformedProxyUri,
toURI)
import PostgREST.Parsers (pRoleClaimKey)
import PostgREST.Private.ProxyUri (isMalformedProxyUri)
import PostgREST.Types (JSPath, JSPathExp (..),
LogLevel (..))
import Protolude hiding (concat, filter, hPutStrLn,
intercalate, null, replace, take,
toList, toLower, toS, toTitle,
(<>))
import Protolude.Conv (toS)
import Protolude hiding (Proxy, toList, toS)
import Protolude.Conv (toS)
-- | Command line interface options
data CLI = CLI
@@ -128,19 +131,27 @@ configDbPoolTimeout' :: (Fractional a) => AppConfig -> a
configDbPoolTimeout' =
fromRational . toRational . configDbPoolTimeout
data LogLevel = LogCrit | LogError | LogWarn | LogInfo
instance Show LogLevel where
show LogCrit = "crit"
show LogError = "error"
show LogWarn = "warn"
show LogInfo = "info"
-- | User friendly version number
prettyVersion :: Text
prettyVersion =
intercalate "." (map show $ versionBranch version) <> gitRev
T.intercalate "." (map show $ versionBranch version) <> gitRev
where
gitRev =
if $(gitHash) == "UNKNOWN"
then mempty
else " (" <> take 7 $(gitHash) <> ")"
else " (" <> T.take 7 $(gitHash) <> ")"
-- | Version number used in docs
docsVersion :: Text
docsVersion = "v" <> dropEnd 1 (dropWhileEnd (/= '.') prettyVersion)
docsVersion = "v" <> T.dropEnd 1 (T.dropWhileEnd (/= '.') prettyVersion)
-- | Read command line interface options. Also prints help.
readCLIShowHelp :: Environment -> IO CLI
@@ -280,36 +291,36 @@ dumpAppConfig conf =
pgrstSettings = (\(k, v) -> (k, v conf)) <$>
[("db-anon-role", q . configDbAnonRole)
,("db-channel", q . configDbChannel)
,("db-channel-enabled", toLower . show . configDbChannelEnabled)
,("db-extra-search-path", q . intercalate "," . configDbExtraSearchPath)
,("db-channel-enabled", T.toLower . show . configDbChannelEnabled)
,("db-extra-search-path", q . T.intercalate "," . configDbExtraSearchPath)
,("db-max-rows", maybe "\"\"" show . configDbMaxRows)
,("db-pool", show . configDbPoolSize)
,("db-pool-timeout", show . configDbPoolTimeout)
,("db-pre-request", q . fromMaybe mempty . configDbPreRequest)
,("db-prepared-statements", toLower . show . configDbPreparedStatements)
,("db-prepared-statements", T.toLower . show . configDbPreparedStatements)
,("db-root-spec", q . fromMaybe mempty . configDbRootSpec)
,("db-schemas", q . intercalate "," . toList . configDbSchemas)
,("db-config", q . toLower . show . configDbConfig)
,("db-schemas", q . T.intercalate "," . toList . configDbSchemas)
,("db-config", q . T.toLower . show . configDbConfig)
,("db-tx-end", q . showTxEnd)
,("db-uri", q . configDbUri)
,("jwt-aud", toS . encode . maybe "" toJSON . configJwtAudience)
,("jwt-role-claim-key", q . intercalate mempty . fmap show . configJwtRoleClaimKey)
,("jwt-role-claim-key", q . T.intercalate mempty . fmap show . configJwtRoleClaimKey)
,("jwt-secret", q . toS . showJwtSecret)
,("jwt-secret-is-base64", toLower . show . configJwtSecretIsBase64)
,("jwt-secret-is-base64", T.toLower . show . configJwtSecretIsBase64)
,("log-level", q . show . configLogLevel)
,("openapi-server-proxy-uri", q . fromMaybe mempty . configOpenApiServerProxyUri)
,("raw-media-types", q . toS . B.intercalate "," . configRawMediaTypes)
,("server-host", q . configServerHost)
,("server-port", show . configServerPort)
,("server-unix-socket", q . maybe mempty pack . configServerUnixSocket)
,("server-unix-socket-mode", q . pack . showSocketMode)
,("server-unix-socket", q . maybe mempty T.pack . configServerUnixSocket)
,("server-unix-socket-mode", q . T.pack . showSocketMode)
]
-- quote all app.settings
appSettings = second q <$> configAppSettings conf
-- quote strings and replace " with \"
q s = "\"" <> replace "\"" "\\\"" s <> "\""
q s = "\"" <> T.replace "\"" "\\\"" s <> "\""
showTxEnd c = case (configDbTxRollbackAll c, configDbTxAllowOverride c) of
( False, False ) -> "commit"
@@ -384,7 +395,7 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
<*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types")
<*> (fromMaybe "!4" <$> optString "server-host")
<*> (fromMaybe 3000 <$> optInt "server-port")
<*> (fmap unpack <$> optString "server-unix-socket")
<*> (fmap T.unpack <$> optString "server-unix-socket")
<*> parseSocketFileMode "server-unix-socket-mode"
parseDbUri :: C.Key -> C.Parser C.Config Text
@@ -397,11 +408,11 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
let secStr = encodeUtf8 sec
secFile = fromMaybe secStr secretFile
-- replace because the JWT is actually base64url encoded which must be turned into just base64 before decoding.
replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="
replaceUrlChars = T.replace "_" "/" . T.replace "-" "+" . T.replace "." "="
willBeFile = isPrefixOf "@" (toS secStr) && isNothing secretFile
in
if isB64 && not willBeFile -- don't decode in bas64 if the secret will be a file or it will err. The secFile will be filled with the file contents in a later stage.
then case B64.decode $ encodeUtf8 $ strip $ replaceUrlChars $ decodeUtf8 secFile of
then case B64.decode . encodeUtf8 . T.strip . replaceUrlChars $ decodeUtf8 secFile of
Left errMsg -> fail errMsg
Right bs -> pure $ Just bs
else pure $ Just secFile
@@ -411,14 +422,14 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
where
addFromEnv f = M.toList $ M.union fromEnv $ M.fromList f
fromEnv = M.mapKeys fromJust $ M.filterWithKey (\k _ -> isJust k) $ M.mapKeys normalize env
normalize k = ("app.settings." <>) <$> stripPrefix "PGRST_APP_SETTINGS_" (toS k)
normalize k = ("app.settings." <>) <$> T.stripPrefix "PGRST_APP_SETTINGS_" (toS k)
parseSocketFileMode :: C.Key -> C.Parser C.Config FileMode
parseSocketFileMode k =
optString k >>= \case
Nothing -> pure 432 -- return default 660 mode if no value was provided
Just fileModeText ->
case (readOct . unpack) fileModeText of
case readOct $ T.unpack fileModeText of
[] ->
fail "Invalid server-unix-socket-mode: not an octal"
(fileMode, _):_ ->
@@ -437,7 +448,7 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
parseJwtAudience k =
optString k >>= \case
Nothing -> pure Nothing -- no audience in config file
Just aud -> case preview stringOrUri (unpack aud) of
Just aud -> case preview stringOrUri (T.unpack aud) of
Nothing -> fail "Invalid Jwt audience. Check your configuration."
aud' -> pure aud'
@@ -510,7 +521,7 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
dashToUnderscore c = c
envVarName = "PGRST_" <> (toUpper . dashToUnderscore <$> toS key)
reloadableDbSetting =
let dbSettingName = pack $ dashToUnderscore <$> toS key in
let dbSettingName = T.pack $ dashToUnderscore <$> toS key in
if dbSettingName `notElem` [
"server_host", "server_port", "server_unix_socket", "server_unix_socket_mode", "log_level",
"db_anon_role", "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_pool_timeout", "db_config"]
@@ -530,14 +541,14 @@ readAppConfig dbSettings env optPath dbUriFile secretFile = do
coerceBool (C.Bool b) = Just b
coerceBool (C.String s) =
-- parse all kinds of text: True, true, TRUE, "true", ...
case readMaybe . toS $ toTitle $ filter isAlpha $ toS s of
case readMaybe . toS $ T.toTitle $ T.filter isAlpha $ toS s of
Just b -> Just b
-- numeric instead?
Nothing -> (> 0) <$> (readMaybe $ toS s :: Maybe Integer)
coerceBool _ = Nothing
splitOnCommas :: C.Value -> [Text]
splitOnCommas (C.String s) = strip <$> splitOn "," s
splitOnCommas (C.String s) = T.strip <$> T.splitOn "," s
splitOnCommas _ = []
{-|
@@ -562,13 +573,13 @@ type Environment = M.Map [Char] Text
readEnvironment :: IO Environment
readEnvironment = getEnvironment <&> pgrst
where
pgrst env = M.filterWithKey (\k _ -> "PGRST_" `isPrefixOf` k) $ M.map pack $ M.fromList env
pgrst env = M.filterWithKey (\k _ -> "PGRST_" `isPrefixOf` k) $ M.map T.pack $ M.fromList env
-- | Read the JWT secret from a file if configJwtSecret is actually a filepath(has @ as its prefix).
-- | To check if the JWT secret is provided is in fact a file path, it must be decoded as 'Text' to be processed.
readSecretFile :: Maybe B.ByteString -> IO (Maybe B.ByteString)
readSecretFile mSecret =
case (stripPrefix "@" . decodeUtf8) =<< mSecret of
case (T.stripPrefix "@" . decodeUtf8) =<< mSecret of
Nothing -> return Nothing
Just filename -> Just . chomp <$> BS.readFile (toS filename)
where
@@ -576,6 +587,6 @@ readSecretFile mSecret =
-- | Read database uri from a separate file if `db-uri` is a filepath.
readDbUriFile :: Text -> IO (Maybe Text)
readDbUriFile dbUri = case stripPrefix "@" dbUri of
readDbUriFile dbUri = case T.stripPrefix "@" dbUri of
Nothing -> return Nothing
Just filename -> Just . strip <$> readFile (toS filename)
Just filename -> Just . T.strip <$> readFile (toS filename)
+59
View File
@@ -0,0 +1,59 @@
{-|
Module : PostgREST.Types
Description : PostgREST common types and functions used by the rest of the modules
-}
{-# LANGUAGE DuplicateRecordFields #-}
module PostgREST.Config.JSPath
( JSPath
, JSPathExp(..)
, pRoleClaimKey
) where
import qualified Text.ParserCombinators.Parsec as P
import Data.Either.Combinators (mapLeft)
import Text.ParserCombinators.Parsec ((<?>))
import Text.Read (read)
import qualified GHC.Show (show)
import Protolude hiding (toS)
import Protolude.Conv (toS)
-- | full jspath, e.g. .property[0].attr.detail
type JSPath = [JSPathExp]
-- | jspath expression, e.g. .property, .property[0] or ."property-dash"
data JSPathExp
= JSPKey Text
| JSPIdx Int
instance Show JSPathExp where
-- TODO: this needs to be quoted properly for special chars
show (JSPKey k) = "." <> show k
show (JSPIdx i) = "[" <> show i <> "]"
-- Used for the config value "role-claim-key"
pRoleClaimKey :: Text -> Either Text JSPath
pRoleClaimKey selStr =
mapLeft show $ P.parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)
pJSPath :: P.Parser JSPath
pJSPath = toJSPath <$> (period *> pPath `P.sepBy` period <* P.eof)
where
toJSPath :: [(Text, Maybe Int)] -> JSPath
toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx))
period = P.char '.' <?> "period (.)"
pPath :: P.Parser (Text, Maybe Int)
pPath = (,) <$> pJSPKey <*> P.optionMaybe pJSPIdx
pJSPKey :: P.Parser Text
pJSPKey = toS <$> P.many1 (P.alphaNum <|> P.oneOf "_$@") <|> pQuotedValue <?> "attribute name [a..z0..9_$@])"
pJSPIdx :: P.Parser Int
pJSPIdx = P.char '[' *> (read <$> P.many1 P.digit) <* P.char ']' <?> "array index [0..n]"
pQuotedValue :: P.Parser Text
pQuotedValue = toS <$> (P.char '"' *> P.many (P.noneOf "\"") <* P.char '"')
@@ -3,10 +3,11 @@
Module : PostgREST.Private.ProxyUri
Description : Proxy Uri validator
-}
module PostgREST.Private.ProxyUri (
isMalformedProxyUri
, toURI
) where
module PostgREST.Config.Proxy
( Proxy(..)
, isMalformedProxyUri
, toURI
) where
import Data.Maybe (fromJust)
import Data.Text (pack, toLower)
@@ -16,6 +17,13 @@ import Protolude hiding (Proxy, dropWhile, get, intercalate,
toLower, toS, (&))
import Protolude.Conv (toS)
data Proxy = Proxy
{ proxyScheme :: Text
, proxyHost :: Text
, proxyPort :: Integer
, proxyPath :: Text
}
{-|
Test whether a proxy uri is malformed or not.
A valid proxy uri should be an absolute uri without query and user info,
+64
View File
@@ -0,0 +1,64 @@
{-# LANGUAGE DuplicateRecordFields #-}
module PostgREST.ContentType
( ContentType(..)
, toHeader
, toMime
, decodeContentType
) where
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS (c2w)
import Network.HTTP.Types.Header (Header, hContentType)
import Protolude
-- | Enumeration of currently supported response content types
data ContentType
= CTApplicationJSON
| CTSingularJSON
| CTTextCSV
| CTTextPlain
| CTOpenAPI
| CTUrlEncoded
| CTOctetStream
| CTAny
| CTOther ByteString
deriving (Eq)
-- | Convert from ContentType to a full HTTP Header
toHeader :: ContentType -> Header
toHeader ct = (hContentType, toMime ct <> charset)
where
charset = case ct of
CTOctetStream -> mempty
CTOther _ -> mempty
_ -> "; charset=utf-8"
-- | Convert from ContentType to a ByteString representing the mime type
toMime :: ContentType -> ByteString
toMime CTApplicationJSON = "application/json"
toMime CTTextCSV = "text/csv"
toMime CTTextPlain = "text/plain"
toMime CTOpenAPI = "application/openapi+json"
toMime CTSingularJSON = "application/vnd.pgrst.object+json"
toMime CTUrlEncoded = "application/x-www-form-urlencoded"
toMime CTOctetStream = "application/octet-stream"
toMime CTAny = "*/*"
toMime (CTOther ct) = ct
-- | Convert from ByteString to ContentType. Warning: discards MIME parameters
decodeContentType :: BS.ByteString -> ContentType
decodeContentType ct =
case BS.takeWhile (/= BS.c2w ';') ct of
"application/json" -> CTApplicationJSON
"text/csv" -> CTTextCSV
"text/plain" -> CTTextPlain
"application/openapi+json" -> CTOpenAPI
"application/vnd.pgrst.object+json" -> CTSingularJSON
"application/vnd.pgrst.object" -> CTSingularJSON
"application/x-www-form-urlencoded" -> CTUrlEncoded
"application/octet-stream" -> CTOctetStream
"*/*" -> CTAny
ct' -> CTOther ct'
+78 -12
View File
@@ -8,6 +8,8 @@ The schema cache is necessary for resource embedding, foreign keys are used for
These queries are executed once at startup or when PostgREST is reloaded.
-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -16,14 +18,18 @@ These queries are executed once at startup or when PostgREST is reloaded.
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module PostgREST.DbStructure (
getDbStructure
, accessibleTables
, accessibleProcs
, schemaDescription
, getPgVersion
) where
module PostgREST.DbStructure
( DbStructure(..)
, getDbStructure
, accessibleTables
, accessibleProcs
, schemaDescription
, getPgVersion
, tableCols
, tablePKCols
) where
import qualified Data.Aeson as JSON
import qualified Data.HashMap.Strict as M
import qualified Data.List as L
import qualified Hasql.Decoders as HD
@@ -35,13 +41,52 @@ import qualified Hasql.Transaction as HT
import Contravariant.Extras (contrazip2)
import Data.Set as S (fromList)
import Data.Text (split)
import Protolude hiding (toS)
import Protolude.Conv (toS)
import Protolude.Unsafe (unsafeHead)
import Text.InterpolatedString.Perl6 (q)
import PostgREST.Private.Common
import PostgREST.Types
import PostgREST.DbStructure.Identifiers (QualifiedIdentifier (..),
Schema, TableName)
import PostgREST.DbStructure.PgVersion (PgVersion (..))
import PostgREST.DbStructure.Proc (PgArg (..), PgType (..),
ProcDescription (..),
ProcVolatility (..),
ProcsMap, RetType (..))
import PostgREST.DbStructure.Relation (Cardinality (..),
ForeignKey (..), Link (..),
PrimaryKey (..),
Relation (..))
import PostgREST.DbStructure.Table (Column (..), Table (..))
import Protolude hiding (toS)
import Protolude.Conv (toS)
import Protolude.Unsafe (unsafeHead)
data DbStructure = DbStructure
{ dbTables :: [Table]
, dbColumns :: [Column]
, dbRelations :: [Relation]
, dbPrimaryKeys :: [PrimaryKey]
, dbProcs :: ProcsMap
, pgVersion :: PgVersion
}
deriving (Generic, JSON.ToJSON)
-- TODO Table could hold references to all its Columns
tableCols :: DbStructure -> Schema -> TableName -> [Column]
tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs
-- TODO Table could hold references to all its PrimaryKeys
tablePKCols :: DbStructure -> Schema -> TableName -> [Text]
tablePKCols dbs tSchema tName = pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs)
-- | The source table column a view column refers to
type SourceColumn = (Column, ViewColumn)
type ViewColumn = Column
-- | A SQL query that can be executed independently
type SqlQuery = ByteString
getDbStructure :: [Schema] -> [Schema] -> PgVersion -> Bool -> HT.Transaction DbStructure
getDbStructure schemas extraSearchPath pgVer prepared = do
@@ -839,3 +884,24 @@ getPgVersion = H.statement mempty $ H.Statement sql HE.noParams versionRow False
where
sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')"
versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text
param :: HE.Value a -> HE.Params a
param = HE.param . HE.nonNullable
arrayParam :: HE.Value a -> HE.Params [a]
arrayParam = param . HE.foldableArray . HE.nonNullable
compositeArrayColumn :: HD.Composite a -> HD.Row [a]
compositeArrayColumn = arrayColumn . HD.composite
compositeField :: HD.Value a -> HD.Composite a
compositeField = HD.field . HD.nonNullable
column :: HD.Value a -> HD.Row a
column = HD.column . HD.nonNullable
nullableColumn :: HD.Value a -> HD.Row (Maybe a)
nullableColumn = HD.column . HD.nullable
arrayColumn :: HD.Value a -> HD.Row [a]
arrayColumn = column . HD.listArray . HD.nonNullable
+28
View File
@@ -0,0 +1,28 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module PostgREST.DbStructure.Identifiers
( QualifiedIdentifier(..)
, Schema
, TableName
, FieldName
) where
import qualified Data.Aeson as JSON
import Protolude
-- | Represents a pg identifier with a prepended schema name "schema.table".
-- When qiSchema is "", the schema is defined by the pg search_path.
data QualifiedIdentifier = QualifiedIdentifier
{ qiSchema :: Schema
, qiName :: TableName
}
deriving (Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)
instance Hashable QualifiedIdentifier
type Schema = Text
type TableName = Text
type FieldName = Text
+60
View File
@@ -0,0 +1,60 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module PostgREST.DbStructure.PgVersion
( PgVersion(..)
, minimumPgVersion
, pgVersion95
, pgVersion96
, pgVersion100
, pgVersion109
, pgVersion110
, pgVersion112
, pgVersion114
, pgVersion121
, pgVersion130
) where
import qualified Data.Aeson as JSON
import Protolude
data PgVersion = PgVersion
{ pgvNum :: Int32
, pgvName :: Text
}
deriving (Eq, Generic, JSON.ToJSON)
instance Ord PgVersion where
(PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2
-- | Tells the minimum PostgreSQL version required by this version of PostgREST
minimumPgVersion :: PgVersion
minimumPgVersion = pgVersion95
pgVersion95 :: PgVersion
pgVersion95 = PgVersion 90500 "9.5"
pgVersion96 :: PgVersion
pgVersion96 = PgVersion 90600 "9.6"
pgVersion100 :: PgVersion
pgVersion100 = PgVersion 100000 "10"
pgVersion109 :: PgVersion
pgVersion109 = PgVersion 100009 "10.9"
pgVersion110 :: PgVersion
pgVersion110 = PgVersion 110000 "11.0"
pgVersion112 :: PgVersion
pgVersion112 = PgVersion 110002 "11.2"
pgVersion114 :: PgVersion
pgVersion114 = PgVersion 110004 "11.4"
pgVersion121 :: PgVersion
pgVersion121 = PgVersion 120001 "12.1"
pgVersion130 :: PgVersion
pgVersion130 = PgVersion 130000 "13.0"
+120
View File
@@ -0,0 +1,120 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module PostgREST.DbStructure.Proc
( PgArg(..)
, PgType(..)
, ProcDescription(..)
, ProcVolatility(..)
, ProcsMap
, RetType(..)
, findProc
, procReturnsScalar
, procReturnsSingle
, procTableName
, specifiedProcArgs
) where
import qualified Data.Aeson as JSON
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import PostgREST.DbStructure.Identifiers (FieldName,
QualifiedIdentifier (..),
Schema, TableName)
import Protolude
data PgArg = PgArg
{ pgaName :: Text
, pgaType :: Text
, pgaReq :: Bool
, pgaVar :: Bool
}
deriving (Eq, Ord, Generic, JSON.ToJSON)
data PgType
= Scalar
| Composite QualifiedIdentifier
deriving (Eq, Ord, Generic, JSON.ToJSON)
data RetType
= Single PgType
| SetOf PgType
deriving (Eq, Ord, Generic, JSON.ToJSON)
data ProcVolatility
= Volatile
| Stable
| Immutable
deriving (Eq, Ord, Generic, JSON.ToJSON)
data ProcDescription = ProcDescription
{ pdSchema :: Schema
, pdName :: Text
, pdDescription :: Maybe Text
, pdArgs :: [PgArg]
, pdReturnType :: RetType
, pdVolatility :: ProcVolatility
, pdHasVariadic :: Bool
}
deriving (Eq, Generic, JSON.ToJSON)
-- Order by least number of args in the case of overloaded functions
instance Ord ProcDescription where
ProcDescription schema1 name1 des1 args1 rt1 vol1 hasVar1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2 hasVar2
| schema1 == schema2 && name1 == name2 && length args1 < length args2 = LT
| schema2 == schema2 && name1 == name2 && length args1 > length args2 = GT
| otherwise = (schema1, name1, des1, args1, rt1, vol1, hasVar1) `compare` (schema2, name2, des2, args2, rt2, vol2, hasVar2)
-- | A map of all procs, all of which can be overloaded(one entry will have more than one ProcDescription).
-- | It uses a HashMap for a faster lookup.
type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]
{-|
Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it.
An overloaded function can have a different volatility or even a different return type.
Ideally, handling overloaded functions should be left to pg itself. But we need to know certain proc attributes in advance.
-}
findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> ProcDescription
findProc qi payloadKeys paramsAsSingleObject allProcs = fromMaybe fallback bestMatch
where
-- instead of passing Maybe ProcDescription around, we create a fallback description here when we can't find a matching function
-- args is empty, but because "specifiedProcArgs" will fill the missing arguments with default type text, this is not a problem
fallback = ProcDescription (qiSchema qi) (qiName qi) Nothing mempty (SetOf $ Composite $ QualifiedIdentifier mempty "record") Volatile False
bestMatch =
case M.lookup qi allProcs of
Nothing -> Nothing
Just [proc] -> Just proc -- if it's not an overloaded function then immediately get the ProcDescription
Just procs -> find matches procs -- Handle overloaded functions case
matches proc =
if paramsAsSingleObject
-- if the arg is not of json type let the db give the err
then length (pdArgs proc) == 1
else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc)
{-|
Search the procedure parameters by matching them with the specified keys.
If the key doesn't match a parameter, a parameter with a default type "text" is assumed.
-}
specifiedProcArgs :: S.Set FieldName -> ProcDescription -> [PgArg]
specifiedProcArgs keys proc =
(\k -> fromMaybe (PgArg k "text" True False) (find ((==) k . pgaName) (pdArgs proc))) <$> S.toList keys
procReturnsScalar :: ProcDescription -> Bool
procReturnsScalar proc = case proc of
ProcDescription{pdReturnType = (Single Scalar)} -> True
ProcDescription{pdReturnType = (SetOf Scalar)} -> True
_ -> False
procReturnsSingle :: ProcDescription -> Bool
procReturnsSingle proc = case proc of
ProcDescription{pdReturnType = (Single _)} -> True
_ -> False
procTableName :: ProcDescription -> Maybe TableName
procTableName proc = case pdReturnType proc of
SetOf (Composite qi) -> Just $ qiName qi
Single (Composite qi) -> Just $ qiName qi
_ -> Nothing
+76
View File
@@ -0,0 +1,76 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module PostgREST.DbStructure.Relation
( Cardinality(..)
, Constraint
, ForeignKey(..)
, Link(..)
, PrimaryKey(..)
, Relation(..)
, isSelfReference
) where
import qualified Data.Aeson as JSON
import PostgREST.DbStructure.Table (Column (..), ForeignKey (..),
Table (..))
import qualified GHC.Show (show)
import Protolude
-- | "Relation"ship between two tables.
--
-- The order of the relColumns and relFColumns should be maintained to get the
-- join conditions right.
--
-- TODO merge relColumns and relFColumns to a tuple or Data.Bimap
data Relation = Relation
{ relTable :: Table
, relColumns :: [Column]
, relFTable :: Table
, relFColumns :: [Column]
, relType :: Cardinality
, relLink :: Link -- ^ Constraint on O2M/M2O, Junction for M2M Cardinality
}
deriving (Eq, Generic, JSON.ToJSON)
type ConstraintName = Text
-- | Junction table on an M2M relationship
data Link
= Constraint
{ constName :: ConstraintName }
| Junction
{ junTable :: Table
, junLink1 :: Link
, junCols1 :: [Column]
, junLink2 :: Link
, junCols2 :: [Column]
}
deriving (Eq, Generic, JSON.ToJSON)
data PrimaryKey = PrimaryKey
{ pkTable :: Table
, pkName :: Text
}
deriving (Generic, JSON.ToJSON)
-- | The relationship
-- [cardinality](https://en.wikipedia.org/wiki/Cardinality_(data_modeling)).
-- TODO: missing one-to-one
data Cardinality
= O2M -- ^ one-to-many, previously known as Parent
| M2O -- ^ many-to-one, previously known as Child
| M2M -- ^ many-to-many, previously known as Many
deriving (Eq, Generic, JSON.ToJSON)
instance Show Cardinality where
show O2M = "o2m"
show M2O = "m2o"
show M2M = "m2m"
isSelfReference :: Relation -> Bool
isSelfReference r = relTable r == relFTable r
+58
View File
@@ -0,0 +1,58 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module PostgREST.DbStructure.Table
( Column(..)
, ForeignKey(..)
, Table(..)
, tableQi
) where
import qualified Data.Aeson as JSON
import PostgREST.DbStructure.Identifiers (FieldName,
QualifiedIdentifier (..),
Schema, TableName)
import Protolude
data Table = Table
{ tableSchema :: Schema
, tableName :: TableName
, tableDescription :: Maybe Text
, tableInsertable :: Bool
}
deriving (Show, Ord, Generic, JSON.ToJSON)
instance Eq Table where
Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
tableQi :: Table -> QualifiedIdentifier
tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n
newtype ForeignKey = ForeignKey
{ fkCol :: Column }
deriving (Eq, Ord, Generic, JSON.ToJSON)
data Column = Column
{ colTable :: Table
, colName :: FieldName
, colDescription :: Maybe Text
, colNullable :: Bool
, colType :: Text
, colMaxLen :: Maybe Int32
, colDefault :: Maybe Text
, colEnum :: [Text]
, colFK :: Maybe ForeignKey
}
deriving (Ord, Generic, JSON.ToJSON)
instance Eq Column where
Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
data PrimaryKey = PrimaryKey
{ pkTable :: Table
, pkName :: Text
}
deriving (Generic, JSON.ToJSON)
+26 -21
View File
@@ -5,15 +5,15 @@ Description : PostgREST error HTTP responses
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE RecordWildCards #-}
module PostgREST.Error (
errorResponseFor
, ApiRequestError(..)
, PgError(..)
, Error(..)
, errorPayload
, checkIsFatal
, singularityError
) where
module PostgREST.Error
( errorResponseFor
, ApiRequestError(..)
, PgError(..)
, Error(..)
, errorPayload
, checkIsFatal
, singularityError
) where
import qualified Data.Aeson as JSON
import qualified Data.Text as T
@@ -24,11 +24,16 @@ import qualified Network.HTTP.Types.Status as HT
import Data.Aeson ((.=))
import Network.Wai (Response, responseLBS)
import Network.HTTP.Types.Header
import Network.HTTP.Types.Header (Header)
import PostgREST.Types
import Protolude hiding (toS)
import Protolude.Conv (toS, toSL)
import PostgREST.ContentType (ContentType (..))
import qualified PostgREST.ContentType as ContentType
import PostgREST.DbStructure.Relation (Link (..), Relation (..))
import PostgREST.DbStructure.Table (Column (..), Table (..))
import Protolude hiding (toS)
import Protolude.Conv (toS, toSL)
class (JSON.ToJSON a) => PgrstError a where
@@ -67,7 +72,7 @@ instance PgrstError ApiRequestError where
status AmbiguousRelBetween{} = HT.status300
status (UnacceptableSchema _) = HT.status406
headers _ = [toHeader CTApplicationJSON]
headers _ = [ContentType.toHeader CTApplicationJSON]
instance JSON.ToJSON ApiRequestError where
toJSON (ParseRequestError message details) = JSON.object [
@@ -120,8 +125,8 @@ instance PgrstError PgError where
headers err =
if status err == HT.status401
then [toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
else [toHeader CTApplicationJSON]
then [ContentType.toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
else [ContentType.toHeader CTApplicationJSON]
instance JSON.ToJSON PgError where
toJSON (PgError _ usageError) = JSON.toJSON usageError
@@ -249,11 +254,11 @@ instance PgrstError Error where
status (PgErr err) = status err
status (ApiRequestError err) = status err
headers (SingularityError _) = [toHeader CTSingularJSON]
headers (JwtTokenInvalid m) = [toHeader CTApplicationJSON, invalidTokenHeader m]
headers (SingularityError _) = [ContentType.toHeader CTSingularJSON]
headers (JwtTokenInvalid m) = [ContentType.toHeader CTApplicationJSON, invalidTokenHeader m]
headers (PgErr err) = headers err
headers (ApiRequestError err) = headers err
headers _ = [toHeader CTApplicationJSON]
headers _ = [ContentType.toHeader CTApplicationJSON]
instance JSON.ToJSON Error where
toJSON GucHeadersError = JSON.object [
@@ -261,7 +266,7 @@ instance JSON.ToJSON Error where
toJSON GucStatusError = JSON.object [
"message" .= ("response.status guc must be a valid status code" :: Text)]
toJSON (BinaryFieldError ct) = JSON.object [
"message" .= ((toS (toMime ct) <> " requested but more than one column was selected") :: Text)]
"message" .= ((toS (ContentType.toMime ct) <> " requested but more than one column was selected") :: Text)]
toJSON ConnectionLostError = JSON.object [
"message" .= ("Database connection lost. Retrying the connection." :: Text)]
@@ -274,7 +279,7 @@ instance JSON.ToJSON Error where
"message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)]
toJSON (SingularityError n) = JSON.object [
"message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),
"details" .= T.unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]]
"details" .= T.unwords ["Results contain", show n, "rows,", toS (ContentType.toMime CTSingularJSON), "requires 1 row"]]
toJSON JwtTokenMissing = JSON.object [
"message" .= ("Server lacks JWT secret" :: Text)]
+37
View File
@@ -0,0 +1,37 @@
module PostgREST.GucHeader
( GucHeader
, unwrapGucHeader
, addHeadersIfNotIncluded
) where
import qualified Data.Aeson as JSON
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as M
import Network.HTTP.Types.Header (Header)
import Protolude hiding (toS)
import Protolude.Conv (toS)
{-|
Custom guc header, it's obtained by parsing the json in a:
`SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'
-}
newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
instance JSON.FromJSON GucHeader where
parseJSON (JSON.Object o) = case headMay (M.toList o) of
Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (CI.mk $ toS k, toS s)
| otherwise -> mzero
_ -> mzero
parseJSON _ = mzero
unwrapGucHeader :: GucHeader -> Header
unwrapGucHeader (GucHeader (k, v)) = (k, v)
-- | Add headers not already included to allow the user to override them instead of duplicating them
addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header]
addHeadersIfNotIncluded newHeaders initialHeaders =
filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
initialHeaders
+68 -64
View File
@@ -12,50 +12,49 @@ module PostgREST.Middleware
, optionalRollback
) where
import qualified Hasql.Decoders as HD
import qualified Hasql.DynamicStatements.Statement as H
import PostgREST.Private.Common
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Char8 as BS
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T
import qualified Hasql.Decoders as HD
import qualified Hasql.DynamicStatements.Snippet as H hiding
(sql)
import qualified Hasql.DynamicStatements.Statement as H
import qualified Hasql.Transaction as H
import qualified Network.HTTP.Types.Header as HTTP
import qualified Network.Wai as Wai
import qualified Network.Wai.Logger as Wai
import qualified Network.Wai.Middleware.Cors as Wai
import qualified Network.Wai.Middleware.Gzip as Wai
import qualified Network.Wai.Middleware.RequestLogger as Wai
import qualified Network.Wai.Middleware.Static as Wai
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Char8 as BS
import qualified Data.CaseInsensitive as CI
import Data.Function (id)
import qualified Data.HashMap.Strict as M
import Data.List (lookup)
import Data.Scientific (FPFormat (..),
formatScientific,
isInteger)
import qualified Data.Text as T
import qualified Hasql.Transaction as H
import qualified Network.HTTP.Types.Header as HTTP
import Network.HTTP.Types.Status (Status, status400,
status500, statusCode)
import qualified Network.Wai as Wai
import Network.Wai.Logger (showSockAddr)
import System.Log.FastLogger (toLogStr)
import Data.Function (id)
import Data.List (lookup)
import Data.Scientific (FPFormat (..), formatScientific,
isInteger)
import Network.HTTP.Types.Status (Status, status400, status500,
statusCode)
import System.IO.Unsafe (unsafePerformIO)
import System.Log.FastLogger (toLogStr)
import Network.Wai
import Network.Wai.Middleware.Cors (CorsResourcePolicy (..),
cors)
import Network.Wai.Middleware.Gzip (def, gzip)
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Static (only, staticPolicy)
import PostgREST.Config (AppConfig (..), LogLevel (..))
import PostgREST.Error (Error, errorResponseFor)
import PostgREST.GucHeader (addHeadersIfNotIncluded)
import PostgREST.Query.SqlFragment (intercalateSnippet,
unknownLiteral)
import PostgREST.Request.ApiRequest (ApiRequest (..))
import qualified PostgREST.Types as Types
import PostgREST.Request.Preferences
import PostgREST.ApiRequest (ApiRequest (..))
import PostgREST.Config (AppConfig (..))
import PostgREST.Error (Error, errorResponseFor)
import PostgREST.QueryBuilder (setConfigLocal)
import PostgREST.Types (LogLevel (..))
import Protolude hiding (head, toS)
import Protolude.Conv (toS)
import System.IO.Unsafe (unsafePerformIO)
import Protolude hiding (head, toS)
import Protolude.Conv (toS)
-- | Runs local(transaction scoped) GUCs for every request, plus the pre-request function
runPgLocals :: AppConfig -> M.HashMap Text JSON.Value ->
(ApiRequest -> ExceptT Error H.Transaction Response) ->
ApiRequest -> ExceptT Error H.Transaction Response
(ApiRequest -> ExceptT Error H.Transaction Wai.Response) ->
ApiRequest -> ExceptT Error H.Transaction Wai.Response
runPgLocals conf claims app req = do
lift $ H.statement mempty $ H.dynamicallyParameterized
("select " <> intercalateSnippet ", " (searchPathSql : roleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql))
@@ -78,11 +77,16 @@ runPgLocals conf claims app req = do
setConfigLocal mempty ("search_path", schemas)
preReqSql = (\f -> "select " <> toS f <> "();") <$> configDbPreRequest conf
-- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
setConfigLocal :: Text -> (Text, Text) -> H.Snippet
setConfigLocal prefix (k, v) =
"set_config(" <> unknownLiteral (prefix <> k) <> ", " <> unknownLiteral v <> ", true)"
-- | Log in apache format. Only requests that have a status greater than minStatus are logged.
-- | There's no way to filter logs in the apache format on wai-extra: https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html#t:OutputFormat.
-- | So here we copy wai-logger apacheLogStr function: https://github.com/kazu-yamamoto/logger/blob/a4f51b909a099c51af7a3f75cf16e19a06f9e257/wai-logger/Network/Wai/Logger/Apache.hs#L45
-- | TODO: Add the ability to filter apache logs on wai-extra and remove this function.
pgrstFormat :: Status -> OutputFormatter
pgrstFormat :: Status -> Wai.OutputFormatter
pgrstFormat minStatus date req status responseSize =
if status < minStatus
then mempty
@@ -90,55 +94,55 @@ pgrstFormat minStatus date req status responseSize =
<> " - - ["
<> toLogStr date
<> "] \""
<> toLogStr (requestMethod req)
<> toLogStr (Wai.requestMethod req)
<> " "
<> toLogStr (rawPathInfo req <> rawQueryString req)
<> toLogStr (Wai.rawPathInfo req <> Wai.rawQueryString req)
<> " "
<> toLogStr (show (httpVersion req)::Text)
<> toLogStr (show (Wai.httpVersion req)::Text)
<> "\" "
<> toLogStr (show (statusCode status)::Text)
<> " "
<> toLogStr (maybe "-" show responseSize::Text)
<> " \""
<> toLogStr (fromMaybe mempty $ requestHeaderReferer req)
<> toLogStr (fromMaybe mempty $ Wai.requestHeaderReferer req)
<> "\" \""
<> toLogStr (fromMaybe mempty $ requestHeaderUserAgent req)
<> toLogStr (fromMaybe mempty $ Wai.requestHeaderUserAgent req)
<> "\"\n"
where
getSourceFromSocket = BS.pack . showSockAddr . remoteHost
getSourceFromSocket = BS.pack . Wai.showSockAddr . Wai.remoteHost
pgrstMiddleware :: LogLevel -> Application -> Application
pgrstMiddleware :: LogLevel -> Wai.Application -> Wai.Application
pgrstMiddleware logLevel =
logger
. gzip def
. cors corsPolicy
. staticPolicy (only [("favicon.ico", "static/favicon.ico")])
. Wai.gzip Wai.def
. Wai.cors corsPolicy
. Wai.staticPolicy (Wai.only [("favicon.ico", "static/favicon.ico")])
where
logger = case logLevel of
LogCrit -> id
LogError -> unsafePerformIO $ mkRequestLogger def { outputFormat = CustomOutputFormat $ pgrstFormat status500}
LogWarn -> unsafePerformIO $ mkRequestLogger def { outputFormat = CustomOutputFormat $ pgrstFormat status400}
LogInfo -> logStdout
LogError -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status500}
LogWarn -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status400}
LogInfo -> Wai.logStdout
defaultCorsPolicy :: CorsResourcePolicy
defaultCorsPolicy = CorsResourcePolicy Nothing
defaultCorsPolicy :: Wai.CorsResourcePolicy
defaultCorsPolicy = Wai.CorsResourcePolicy Nothing
["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing
(Just $ 60*60*24) False False True
-- | CORS policy to be used in by Wai Cors middleware
corsPolicy :: Request -> Maybe CorsResourcePolicy
corsPolicy :: Wai.Request -> Maybe Wai.CorsResourcePolicy
corsPolicy req = case lookup "origin" headers of
Just origin -> Just defaultCorsPolicy {
corsOrigins = Just ([origin], True)
, corsRequestHeaders = "Authentication":accHeaders
, corsExposedHeaders = Just [
Wai.corsOrigins = Just ([origin], True)
, Wai.corsRequestHeaders = "Authentication" : accHeaders
, Wai.corsExposedHeaders = Just [
"Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
, "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
]
}
Nothing -> Nothing
where
headers = requestHeaders req
headers = Wai.requestHeaders req
accHeaders = case lookup "access-control-request-headers" headers of
Just hdrs -> map (CI.mk . toS . T.strip . toS) $ BS.split ',' hdrs
Nothing -> []
@@ -164,15 +168,15 @@ optionalRollback AppConfig{..} ApiRequest{..} transaction = do
return $ Wai.mapResponseHeaders preferenceApplied resp
where
shouldCommit =
configDbTxAllowOverride && iPreferTransaction == Just Types.Commit
configDbTxAllowOverride && iPreferTransaction == Just Commit
shouldRollback =
configDbTxAllowOverride && iPreferTransaction == Just Types.Rollback
configDbTxAllowOverride && iPreferTransaction == Just Rollback
preferenceApplied
| shouldCommit =
Types.addHeadersIfNotIncluded
[(HTTP.hPreferenceApplied, BS.pack (show Types.Commit))]
addHeadersIfNotIncluded
[(HTTP.hPreferenceApplied, BS.pack (show Commit))]
| shouldRollback =
Types.addHeadersIfNotIncluded
[(HTTP.hPreferenceApplied, BS.pack (show Types.Rollback))]
addHeadersIfNotIncluded
[(HTTP.hPreferenceApplied, BS.pack (show Rollback))]
| otherwise =
identity
+46 -44
View File
@@ -9,32 +9,34 @@ import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as LBS
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet.InsOrd as Set
import qualified Data.Text as T
import Control.Arrow ((&&&))
import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)
import Data.Maybe (fromJust)
import Data.String (IsString (..))
import Data.Text (append, breakOn, dropWhile, init,
intercalate, pack, tail, toLower,
unpack)
import Network.URI (URI (..), URIAuth (..))
import Control.Lens
import Control.Lens (at, (.~), (?~))
import Data.Swagger
import PostgREST.ApiRequest (ContentType (..))
import PostgREST.Config (AppConfig (..), docsVersion,
prettyVersion)
import PostgREST.Private.ProxyUri (isMalformedProxyUri, toURI)
import PostgREST.Types (Column (..), DbStructure (..),
ForeignKey (..), PgArg (..),
PrimaryKey (..),
ProcDescription (..), Proxy (..),
Table (..), tableCols, tableName,
tablePKCols, tableSchema, toMime)
import Protolude hiding (Proxy, dropWhile, get,
intercalate, toLower, toS, (&))
import Protolude.Conv (toS)
import PostgREST.Config (AppConfig (..), Proxy (..),
docsVersion,
isMalformedProxyUri,
prettyVersion, toURI)
import PostgREST.DbStructure (DbStructure (..), tableCols,
tablePKCols)
import PostgREST.DbStructure.Proc (PgArg (..),
ProcDescription (..))
import PostgREST.DbStructure.Relation (PrimaryKey (..))
import PostgREST.DbStructure.Table (Column (..), ForeignKey (..),
Table (..))
import PostgREST.ContentType
import Protolude hiding (Proxy, get, toS)
import Protolude.Conv (toS)
encode :: AppConfig -> DbStructure -> [Table] -> Maybe Text -> HashMap.HashMap k [ProcDescription] -> LBS.ByteString
encode conf dbStructure tables schemaDescription procs =
@@ -47,7 +49,7 @@ encode conf dbStructure tables schemaDescription procs =
(dbPrimaryKeys dbStructure)
makeMimeList :: [ContentType] -> MimeList
makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
makeMimeList cs = MimeList $ fmap (fromString . toS . toMime) cs
toSwaggerType :: Text -> SwaggerType t
toSwaggerType "character varying" = SwaggerString
@@ -68,15 +70,15 @@ makeTableDef pks (t, cs, _) =
(tn, (mempty :: Schema)
& description .~ tableDescription t
& type_ ?~ SwaggerObject
& properties .~ fromList (map (makeProperty pks) cs)
& required .~ map colName (filter (not . colNullable) cs))
& properties .~ fromList (fmap (makeProperty pks) cs)
& required .~ fmap colName (filter (not . colNullable) cs))
makeProperty :: [PrimaryKey] -> Column -> (Text, Referenced Schema)
makeProperty pks c = (colName c, Inline s)
where
e = if null $ colEnum c then Nothing else JSON.decode $ JSON.encode $ colEnum c
fk ForeignKey{fkCol=Column{colTable=Table{tableName=a}, colName=b}} =
intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]
T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]
pk :: Bool
pk = any (\p -> pkTable p == colTable c && pkName p == colName c) pks
n = catMaybes
@@ -86,7 +88,7 @@ makeProperty pks c = (colName c, Inline s)
]
d =
if length n > 1 then
Just $ append (maybe "" (`append` "\n\n") $ colDescription c) (intercalate "\n" n)
Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription c) (T.intercalate "\n" n)
else
colDescription c
s =
@@ -103,8 +105,8 @@ makeProcSchema pd =
(mempty :: Schema)
& description .~ pdDescription pd
& type_ ?~ SwaggerObject
& properties .~ fromList (map makeProcProperty (pdArgs pd))
& required .~ map pgaName (filter pgaReq (pdArgs pd))
& properties .~ fromList (fmap makeProcProperty (pdArgs pd))
& required .~ fmap pgaName (filter pgaReq (pdArgs pd))
makeProcProperty :: PgArg -> (Text, Referenced Schema)
makeProcProperty (PgArg n t _ _) = (n, Inline s)
@@ -203,7 +205,7 @@ makeObjectBody tn =
makeRowFilter :: Text -> Column -> (Text, Param)
makeRowFilter tn c =
(intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)
(T.intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)
& name .~ colName c
& description .~ colDescription c
& required ?~ False
@@ -213,21 +215,21 @@ makeRowFilter tn c =
& format ?~ colType c))
makeRowFilters :: Text -> [Column] -> [(Text, Param)]
makeRowFilters tn = map (makeRowFilter tn)
makeRowFilters tn = fmap (makeRowFilter tn)
makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
makePathItem (t, cs, _) = ("/" ++ T.unpack tn, p $ tableInsertable t)
where
-- Use first line of table description as summary; rest as description (if present)
-- We strip leading newlines from description so that users can include a blank line between summary and description
(tSum, tDesc) = fmap fst &&& fmap (dropWhile (=='\n') . snd) $
breakOn "\n" <$> tableDescription t
(tSum, tDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
T.breakOn "\n" <$> tableDescription t
tOp = (mempty :: Operation)
& tags .~ Set.fromList [tn]
& summary .~ tSum
& description .~ mfilter (/="") tDesc
getOp = tOp
& parameters .~ map ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"])
& parameters .~ fmap ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"])
& at 206 ?~ "Partial Content"
& at 200 ?~ Inline ((mempty :: Response)
& description .~ "OK"
@@ -237,20 +239,20 @@ makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
)
)
postOp = tOp
& parameters .~ map ref ["body." <> tn, "select", "preferReturn"]
& parameters .~ fmap ref ["body." <> tn, "select", "preferReturn"]
& at 201 ?~ "Created"
patchOp = tOp
& parameters .~ map ref (rs <> ["body." <> tn, "preferReturn"])
& parameters .~ fmap ref (rs <> ["body." <> tn, "preferReturn"])
& at 204 ?~ "No Content"
deletOp = tOp
& parameters .~ map ref (rs <> ["preferReturn"])
& parameters .~ fmap ref (rs <> ["preferReturn"])
& at 204 ?~ "No Content"
pr = (mempty :: PathItem) & get ?~ getOp
pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp
p False = pr
p True = pw
tn = tableName t
rs = [ intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]
rs = [ T.intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]
ref = Ref . Reference
makeProcPathItem :: ProcDescription -> (FilePath, PathItem)
@@ -258,8 +260,8 @@ makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)
where
-- Use first line of proc description as summary; rest as description (if present)
-- We strip leading newlines from description so that users can include a blank line between summary and description
(pSum, pDesc) = fmap fst &&& fmap (dropWhile (=='\n') . snd) $
breakOn "\n" <$> pdDescription pd
(pSum, pDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
T.breakOn "\n" <$> pdDescription pd
postOp = (mempty :: Operation)
& summary .~ pSum
& description .~ mfilter (/="") pDesc
@@ -282,7 +284,7 @@ makeRootPathItem = ("/", p)
makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem
makePathItems pds ti = fromList $ makeRootPathItem :
map makePathItem ti ++ map makeProcPathItem pds
fmap makePathItem ti ++ fmap makeProcPathItem pds
escapeHostName :: Text -> Text
escapeHostName "*" = "0.0.0.0"
@@ -294,7 +296,7 @@ escapeHostName h = h
postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger
postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
& basePath ?~ unpack b
& basePath ?~ T.unpack b
& schemes ?~ [s']
& info .~ ((mempty :: Info)
& version .~ prettyVersion
@@ -304,14 +306,14 @@ postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
& description ?~ "PostgREST Documentation"
& url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/api.html"))
& host .~ h'
& definitions .~ fromList (map (makeTableDef pks) ti)
& definitions .~ fromList (makeTableDef pks <$> ti)
& parameters .~ fromList (makeParamDefs ti)
& paths .~ makePathItems pds ti
& produces .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
& consumes .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
where
s' = if s == "http" then Http else Https
h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p))
h' = Just $ Host (T.unpack $ escapeHostName h) (Just (fromInteger p))
d = fromMaybe "This is a dynamic API generated by PostgREST" sd
pickProxy :: Maybe Text -> Maybe Proxy
@@ -329,19 +331,19 @@ pickProxy proxy
}
where
uri = toURI $ fromJust proxy
scheme = init $ toLower $ pack $ uriScheme uri
scheme = T.init $ T.toLower $ T.pack $ uriScheme uri
path URI {uriPath = ""} = "/"
path URI {uriPath = p} = p
path' = pack $ path uri
path' = T.pack $ path uri
authority = fromJust $ uriAuthority uri
host' = pack $ uriRegName authority
host' = T.pack $ uriRegName authority
port' = uriPort authority
readPort = fromMaybe 80 . readMaybe
port'' :: Integer
port'' = case (port', scheme) of
("", "http") -> 80
("", "https") -> 443
_ -> readPort $ unpack $ tail $ pack port'
_ -> readPort $ T.unpack $ T.tail $ T.pack port'
proxyUri :: AppConfig -> (Text, Text, Integer, Text)
proxyUri AppConfig{..} =
@@ -1,22 +1,18 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|
Module : PostgREST.QueryBuilder
Module : PostgREST.Query.QueryBuilder
Description : PostgREST SQL queries generating functions.
This module provides functions to consume data types that
represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment
to produce SqlQuery type outputs.
-}
module PostgREST.QueryBuilder (
readRequestToQuery
module PostgREST.Query.QueryBuilder
( readRequestToQuery
, mutateRequestToQuery
, readRequestToCountQuery
, requestToCallProcQuery
, limitedQuery
, setConfigLocal
) where
import qualified Data.ByteString.Char8 as BS
@@ -25,12 +21,20 @@ import qualified Hasql.DynamicStatements.Snippet as H
import Data.Tree (Tree (..))
import Data.Maybe
import PostgREST.Private.Common
import PostgREST.Private.QueryFragment
import PostgREST.Types
import Protolude hiding (cast, intercalate,
replace)
import PostgREST.DbStructure.Identifiers (FieldName,
QualifiedIdentifier (..))
import PostgREST.DbStructure.Proc (PgArg (..))
import PostgREST.DbStructure.Relation (Cardinality (..),
Relation (..))
import PostgREST.DbStructure.Table (Table (..))
import PostgREST.Request.ApiRequest (PayloadJSON (..))
import PostgREST.Request.Preferences (PreferParameters (..),
PreferResolution (..))
import PostgREST.Query.SqlFragment
import PostgREST.Request.Types
import Protolude
readRequestToQuery :: ReadRequest -> H.Snippet
readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) =
@@ -175,8 +179,3 @@ readRequestToCountQuery (Node (Select{from=qi, where_=logicForest}, _) _) =
limitedQuery :: H.Snippet -> Maybe Integer -> H.Snippet
limitedQuery query maxRows = query <> H.sql (maybe mempty (\x -> " LIMIT " <> BS.pack (show x)) maxRows)
-- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
setConfigLocal :: Text -> (Text, Text) -> H.Snippet
setConfigLocal prefix (k, v) =
"set_config(" <> unknownLiteral (prefix <> k) <> ", " <> unknownLiteral v <> ", true)"
@@ -1,42 +1,106 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : PostgREST.Private.QueryFragment
Module : PostgREST.Query.SqlFragment
Description : Helper functions for PostgREST.QueryBuilder.
Any function that outputs a SqlFragment should be in this module.
-}
module PostgREST.Private.QueryFragment where
module PostgREST.Query.SqlFragment
( noLocationF
, SqlFragment
, asBinaryF
, asCsvF
, asJsonF
, asJsonSingleF
, countF
, fromQi
, ftsOperators
, jsonPlaceHolder
, limitOffsetF
, locationF
, normalizedBody
, operators
, pgFmtColumn
, pgFmtIdent
, pgFmtJoinCondition
, pgFmtLogicTree
, pgFmtOrderTerm
, pgFmtSelectItem
, responseHeadersF
, responseStatusF
, returningF
, selectBody
, sourceCTEName
, unknownLiteral
, intercalateSnippet
) where
import qualified Data.ByteString.Char8 as BS (intercalate,
pack, unwords)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
import Data.Maybe
import qualified Data.Text as T (intercalate,
isInfixOf, map,
null, replace,
takeWhile,
toLower)
import qualified Data.Text as T
import qualified Hasql.DynamicStatements.Snippet as H
import PostgREST.RangeQuery (NonnegRange,
allRange,
rangeLimit,
rangeOffset)
import PostgREST.Types
import Protolude hiding (cast,
intercalate,
replace, toLower,
toS)
import Protolude.Conv (toS)
import Text.InterpolatedString.Perl6 (qc)
import qualified Hasql.Encoders as HE
import qualified Hasql.Encoders as HE
import PostgREST.Private.Common
import Data.Foldable (foldr1)
import Text.InterpolatedString.Perl6 (qc)
import PostgREST.DbStructure.Identifiers (FieldName,
QualifiedIdentifier (..))
import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion96)
import PostgREST.RangeQuery (NonnegRange, allRange,
rangeLimit, rangeOffset)
import PostgREST.Request.Types (Alias, Field, Filter (..),
JoinCondition (..),
JsonOperand (..),
JsonOperation (..),
JsonPath, LogicTree (..),
OpExpr (..), Operation (..),
OrderTerm (..), SelectItem)
import Protolude hiding (cast, toS)
import Protolude.Conv (toS)
-- | A part of a SQL query that cannot be executed independently
type SqlFragment = ByteString
noLocationF :: SqlFragment
noLocationF = "array[]::text[]"
sourceCTEName :: SqlFragment
sourceCTEName = "pgrst_source"
operators :: HM.HashMap Text SqlFragment
operators = HM.union (HM.fromList [
("eq", "="),
("gte", ">="),
("gt", ">"),
("lte", "<="),
("lt", "<"),
("neq", "<>"),
("like", "LIKE"),
("ilike", "ILIKE"),
("in", "IN"),
("is", "IS"),
("cs", "@>"),
("cd", "<@"),
("ov", "&&"),
("sl", "<<"),
("sr", ">>"),
("nxr", "&<"),
("nxl", "&>"),
("adj", "-|-")]) ftsOperators
ftsOperators :: HM.HashMap Text SqlFragment
ftsOperators = HM.fromList [
("fts", "@@ to_tsquery"),
("plfts", "@@ plainto_tsquery"),
("phfts", "@@ phraseto_tsquery"),
("wfts", "@@ websearch_to_tsquery")
]
-- |
-- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads
-- Otherwise we'd have to use json_populate_record for json objects and json_populate_recordset for json arrays
@@ -245,9 +309,13 @@ currentSettingF setting =
-- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
"nullif(current_setting(" <> pgFmtLit setting <> ", true), '')"
-- Hasql Snippet utilitarians
-- Hasql Snippet utilities
unknownEncoder :: ByteString -> H.Snippet
unknownEncoder = H.encoderAndParam (HE.nonNullable HE.unknown)
unknownLiteral :: Text -> H.Snippet
unknownLiteral = unknownEncoder . encodeUtf8
intercalateSnippet :: ByteString -> [H.Snippet] -> H.Snippet
intercalateSnippet _ [] = mempty
intercalateSnippet frag snippets = foldr1 (\a b -> a <> H.sql frag <> b) snippets
@@ -1,6 +1,6 @@
{-# LANGUAGE QuasiQuotes #-}
{-|
Module : PostgREST.Statements
Module : PostgREST.Query.Statements
Description : PostgREST single SQL statements.
This module constructs single SQL statements that can be parametrized and prepared.
@@ -10,38 +10,41 @@ This module constructs single SQL statements that can be parametrized and prepar
TODO: Currently, createReadStatement is not using prepared statements. See https://github.com/PostgREST/postgrest/issues/718.
-}
module PostgREST.Statements (
createWriteStatement
module PostgREST.Query.Statements
( createWriteStatement
, createReadStatement
, callProcStatement
, createExplainStatement
, dbSettingsStatement
) where
import Control.Lens ((^?))
import Data.Aeson as JSON
import qualified Data.Aeson.Lens as L
import qualified Data.ByteString.Char8 as BS
import Data.Maybe
import Data.Text.Read (decimal)
import qualified Hasql.Decoders as HD
import qualified Hasql.Encoders as HE
import qualified Hasql.Statement as H
import Network.HTTP.Types.Status
import PostgREST.Error
import PostgREST.Private.Common
import PostgREST.Private.QueryFragment
import PostgREST.Types
import Protolude hiding (cast,
replace, toS)
import Protolude.Conv (toS)
) where
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Lens as L
import qualified Data.ByteString.Char8 as BS
import qualified Hasql.Decoders as HD
import qualified Hasql.DynamicStatements.Snippet as H
import qualified Hasql.DynamicStatements.Statement as H
import qualified Hasql.Encoders as HE
import qualified Hasql.Statement as H
import Control.Lens ((^?))
import Data.Maybe (fromJust)
import Data.Text.Read (decimal)
import Network.HTTP.Types.Status (Status)
import Text.InterpolatedString.Perl6 (q)
import PostgREST.DbStructure.PgVersion (PgVersion)
import PostgREST.Error (Error (..))
import PostgREST.GucHeader (GucHeader)
import PostgREST.DbStructure.Identifiers (FieldName)
import PostgREST.Query.SqlFragment
import PostgREST.Request.Preferences
import Protolude hiding (toS)
import Protolude.Conv (toS)
{-| The generic query result format used by API responses. The location header
is represented as a list of strings containing variable bindings like
@"k1=eq.42"@, or the empty list if there is no location header.
@@ -216,3 +219,12 @@ dbSettingsStatement = H.Statement sql HE.noParams decodeSettings False
order by key, setdatabase desc;
|]
decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text
column :: HD.Value a -> HD.Row a
column = HD.column . HD.nonNullable
nullableColumn :: HD.Value a -> HD.Row (Maybe a)
nullableColumn = HD.column . HD.nullable
arrayColumn :: HD.Value a -> HD.Row [a]
arrayColumn = column . HD.listArray . HD.nonNullable
@@ -1,20 +1,21 @@
{-|
Module : PostgREST.ApiRequest
Module : PostgREST.Request.ApiRequest
Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
module PostgREST.ApiRequest (
ApiRequest(..)
, InvokeMethod(..)
, ContentType(..)
, Action(..)
, Target(..)
, mutuallyAgreeable
, userApiRequest
) where
module PostgREST.Request.ApiRequest
( ApiRequest(..)
, InvokeMethod(..)
, ContentType(..)
, Action(..)
, Target(..)
, PayloadJSON(..)
, mutuallyAgreeable
, userApiRequest
) where
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
@@ -32,6 +33,7 @@ import Data.Aeson.Types (emptyArray, emptyObject)
import Data.List (last, lookup, partition)
import Data.List.NonEmpty (head)
import Data.Maybe (fromJust)
import Data.Ranged.Boundaries (Boundary (..))
import Data.Ranged.Ranges (Range (..), emptyRange,
rangeIntersection)
import Network.HTTP.Base (urlEncodeVars)
@@ -42,20 +44,48 @@ import Network.Wai (Request (..))
import Network.Wai.Parse (parseHttpAccept)
import Web.Cookie (parseCookiesText)
import PostgREST.ContentType (ContentType (..))
import PostgREST.DbStructure (DbStructure (..))
import PostgREST.DbStructure.Identifiers (FieldName,
QualifiedIdentifier (..),
Schema)
import PostgREST.DbStructure.Proc (PgArg (..),
ProcDescription (..),
findProc)
import PostgREST.Error (ApiRequestError (..))
import PostgREST.Query.SqlFragment (ftsOperators, operators)
import PostgREST.RangeQuery (NonnegRange, allRange,
rangeGeq, rangeLimit,
rangeOffset, rangeRequested,
restrictRange)
import PostgREST.Request.Parsers (pRequestColumns)
import PostgREST.Request.Preferences (PreferCount (..),
PreferParameters (..),
PreferRepresentation (..),
PreferResolution (..),
PreferTransaction (..))
import Data.Ranged.Boundaries
import qualified PostgREST.ContentType as ContentType
import Protolude hiding (head, toS)
import Protolude.Conv (toS)
import PostgREST.Error (ApiRequestError (..))
import PostgREST.Parsers (pRequestColumns)
import PostgREST.RangeQuery (NonnegRange, allRange, rangeGeq,
rangeLimit, rangeOffset, rangeRequested,
restrictRange)
import PostgREST.Types
import Protolude hiding (head, toS)
import Protolude.Conv (toS)
type RequestBody = BL.ByteString
data PayloadJSON
= ProcessedJSON -- ^ Cached attributes of a JSON payload
{ pjRaw :: BL.ByteString
-- ^ This is the raw ByteString that comes from the request body. We
-- cache this instead of an Aeson Value because it was detected that for
-- large payloads the encoding had high memory usage, see
-- https://github.com/PostgREST/postgrest/pull/1005 for more details
, pjKeys :: S.Set Text
-- ^ Keys of the object or if it's an array these keys are guaranteed to
-- be the same across all its objects
}
| RawJSON { pjRaw :: BL.ByteString }
data InvokeMethod = InvHead | InvGet | InvPost deriving Eq
-- | Types of things a user wants to do to tables/views/procs
data Action = ActionCreate | ActionRead{isHead :: Bool}
@@ -143,7 +173,7 @@ userApiRequest confSchemas rootSpec dbStructure req reqBody
, iTarget = target
, iRange = ranges
, iTopLevelRange = topLevelRange
, iAccepts = maybe [CTAny] (map decodeContentType . parseHttpAccept) $ lookupHeader "accept"
, iAccepts = maybe [CTAny] (map ContentType.decodeContentType . parseHttpAccept) $ lookupHeader "accept"
, iPayload = relevantPayload
, iPreferRepresentation = representation
, iPreferParameters = if | hasPrefer (show SingleObject) -> Just SingleObject
@@ -202,7 +232,7 @@ userApiRequest confSchemas rootSpec dbStructure req reqBody
isTargetingDefaultSpec = case target of
TargetDefaultSpec _ -> True
_ -> False
contentType = decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"
contentType = ContentType.decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"
columns
| action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)
| otherwise = Nothing
@@ -236,7 +266,7 @@ userApiRequest confSchemas rootSpec dbStructure req reqBody
let paramsMap = M.fromList $ (toS *** JSON.String . toS) <$> urlEncodedBody in
Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (M.keys paramsMap)
ct ->
Left $ toS $ "Content-Type not acceptable: " <> toMime ct
Left $ toS $ "Content-Type not acceptable: " <> ContentType.toMime ct
topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows
action =
case method of
@@ -1,21 +1,25 @@
{-|
Module : PostgREST.DbRequestBuilder
Module : PostgREST.Request.DbRequestBuilder
Description : PostgREST database request builder
This module is in charge of building an intermediate representation(ReadRequest, MutateRequest) between the HTTP request and the final resulting SQL query.
This module is in charge of building an intermediate
representation(ReadRequest, MutateRequest) between the HTTP request and the
final resulting SQL query.
A query tree is built in case of resource embedding. By inferring the relationship between tables, join conditions are added for every embedded resource.
A query tree is built in case of resource embedding. By inferring the
relationship between tables, join conditions are added for every embedded
resource.
-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module PostgREST.DbRequestBuilder (
readRequest
, mutateRequest
, returningCols
) where
module PostgREST.Request.DbRequestBuilder
( readRequest
, mutateRequest
, returningCols
) where
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
@@ -24,16 +28,31 @@ import Control.Arrow ((***))
import Data.Either.Combinators (mapLeft)
import Data.List (delete)
import Data.Text (isInfixOf)
import Data.Tree (Tree (..))
import Control.Applicative
import Data.Tree
import PostgREST.DbStructure.Identifiers (FieldName,
QualifiedIdentifier (..),
Schema, TableName)
import PostgREST.DbStructure.Relation (Cardinality (..), Link (..),
Relation (..))
import PostgREST.DbStructure.Table (Column (..), Table (..),
tableQi)
import PostgREST.Error (ApiRequestError (..),
Error (..))
import PostgREST.Query.SqlFragment (sourceCTEName)
import PostgREST.RangeQuery (NonnegRange, allRange,
restrictRange)
import PostgREST.Request.ApiRequest (Action (..),
ApiRequest (..),
PayloadJSON (..))
import PostgREST.ApiRequest (Action (..), ApiRequest (..))
import PostgREST.Error (ApiRequestError (..), Error (..))
import PostgREST.Parsers
import PostgREST.RangeQuery (NonnegRange, allRange, restrictRange)
import PostgREST.Types
import Protolude hiding (from)
import PostgREST.Request.Parsers
import PostgREST.Request.Preferences
import PostgREST.Request.Types
import qualified PostgREST.DbStructure.Relation as Relation
import Protolude hiding (from)
-- | Builds the ReadRequest tree on a number of stages.
-- | Adds filters, order, limits on its respective nodes.
@@ -50,23 +69,27 @@ readRequest schema rootTableName maxRows allRels apiRequest =
(rootName, rootRels) = rootWithRels schema rootTableName allRels (iAction apiRequest)
-- Get the root table name with its relationships according to the Action type.
-- This is done because of the shape of the final SQL Query. The mutation cases are wrapped in a WITH {sourceCTEName}(see Statements.hs).
-- So we need a FROM {sourceCTEName} instead of FROM {tableName}.
-- This is done because of the shape of the final SQL Query. The mutation cases
-- are wrapped in a WITH {sourceCTEName}(see Statements.hs). So we need a FROM
-- {sourceCTEName} instead of FROM {tableName}.
rootWithRels :: Schema -> TableName -> [Relation] -> Action -> (QualifiedIdentifier, [Relation])
rootWithRels schema rootTableName allRels action = case action of
ActionRead _ -> (QualifiedIdentifier schema rootTableName, allRels) -- normal read case
_ -> (QualifiedIdentifier mempty _sourceCTEName, mapMaybe toSourceRel allRels ++ allRels) -- mutation cases and calling proc
where
_sourceCTEName = decodeUtf8 sourceCTEName
-- To enable embedding in the sourceCTEName cases we need to replace the foreign key tableName in the Relation
-- with {sourceCTEName}. This way findRel can find relationships with sourceCTEName.
-- To enable embedding in the sourceCTEName cases we need to replace the
-- foreign key tableName in the Relation with {sourceCTEName}. This way
-- findRel can find relationships with sourceCTEName.
toSourceRel :: Relation -> Maybe Relation
toSourceRel r@Relation{relTable=t}
| rootTableName == tableName t = Just $ r {relTable=t {tableName=_sourceCTEName}}
| otherwise = Nothing
-- Build the initial tree with a Depth attribute so when a self join occurs we can differentiate the parent and child tables by having
-- an alias like "table_depth", this is related to http://github.com/PostgREST/postgrest/issues/987.
-- Build the initial tree with a Depth attribute so when a self join occurs we
-- can differentiate the parent and child tables by having an alias like
-- "table_depth", this is related to
-- http://github.com/PostgREST/postgrest/issues/987.
initReadRequest :: QualifiedIdentifier -> [Tree SelectItem] -> ReadRequest
initReadRequest rootQi =
foldr (treeEntry rootDepth) initial
@@ -114,10 +137,12 @@ addRels schema allRels parentNode (Node (query@Select{from=tbl}, (nodeName, _, a
updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
updateForest rq = addRels schema allRels rq `traverse` forest
-- Finds a relationship between an origin and a target in the request: /origin?select=target(*)
-- If more than one relationship is found then the request is ambiguous and we return an error.
-- In that case the request can be disambiguated by adding precision to the target or by using a hint: /origin?select=target!hint(*)
-- The elements will be matched according to these rules:
-- Finds a relationship between an origin and a target in the request:
-- /origin?select=target(*) If more than one relationship is found then the
-- request is ambiguous and we return an error. In that case the request can
-- be disambiguated by adding precision to the target or by using a hint:
-- /origin?select=target!hint(*) The elements will be matched according to
-- these rules:
-- origin = table / view
-- target = table / view / constraint / column-from-origin
-- hint = table / view / constraint / column-from-origin / column-from-target
@@ -128,11 +153,14 @@ findRel schema allRels origin target hint =
[] -> Left $ NoRelBetween origin target
[r] -> Right r
rs ->
-- Return error if more than one relationship is found, unless we're in a self reference case.
-- Return error if more than one relationship is found, unless we're in a
-- self reference case.
--
-- Here we handle a self reference relationship to not cause a breaking change:
-- In a self reference we get two relationships with the same foreign key and relTable/relFtable but with different cardinalities(m2o/o2m)
-- We output the O2M rel, the M2O rel can be obtained by using the origin column as an embed hint.
-- Here we handle a self reference relationship to not cause a breaking
-- change: In a self reference we get two relationships with the same
-- foreign key and relTable/relFtable but with different
-- cardinalities(m2o/o2m) We output the O2M rel, the M2O rel can be
-- obtained by using the origin column as an embed hint.
let [rel0, rel1] = take 2 rs in
if length rs == 2 && relLink rel0 == relLink rel1 && relTable rel0 == relTable rel1 && relFTable rel0 == relFTable rel1
then note (NoRelBetween origin target) (find (\r -> relType r == O2M) rs)
@@ -189,7 +217,7 @@ addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_
Just r -> Node (augmentQuery r, nodeProps) <$> updatedForest
Nothing -> Node node <$> updatedForest
where
newAlias = case isSelfReference <$> rel of
newAlias = case Relation.isSelfReference <$> rel of
Just True
| depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased
| otherwise -> Nothing
@@ -217,9 +245,10 @@ getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, ta
JoinCondition (maybe qi1 (QualifiedIdentifier mempty) previousAlias, colName c)
(maybe qi2 (QualifiedIdentifier mempty) newAlias, colName fc)
-- On mutation and calling proc cases we wrap the target table in a WITH {sourceCTEName}
-- if this happens remove the schema `FROM "schema"."{sourceCTEName}"` and use only the
-- `FROM "{sourceCTEName}"`. If the schema remains the FROM would be invalid.
-- On mutation and calling proc cases we wrap the target table in a WITH
-- {sourceCTEName} if this happens remove the schema `FROM
-- "schema"."{sourceCTEName}"` and use only the `FROM "{sourceCTEName}"`.
-- If the schema remains the FROM would be invalid.
removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == decodeUtf8 sourceCTEName then mempty else schema) tbl
@@ -318,16 +347,19 @@ mutateRequest schema tName apiRequest pkCols readReq = mapLeft ApiRequestError $
returningCols :: ReadRequest -> [FieldName] -> [FieldName]
returningCols rr@(Node _ forest) pkCols
-- if * is part of the select, we must not add pk or fk columns manually - otherwise those would be selected and output twice
-- if * is part of the select, we must not add pk or fk columns manually -
-- otherwise those would be selected and output twice
| "*" `elem` fldNames = ["*"]
| otherwise = returnings
where
fldNames = fstFieldNames rr
-- Without fkCols, when a mutateRequest to /projects?select=name,clients(name) occurs, the RETURNING SQL part would be
-- `RETURNING name`(see QueryBuilder).
-- This would make the embedding fail because the following JOIN would need the "client_id" column from projects.
-- So this adds the foreign key columns to ensure the embedding succeeds, result would be `RETURNING name, client_id`.
-- This also works for the other relType's.
-- Without fkCols, when a mutateRequest to
-- /projects?select=name,clients(name) occurs, the RETURNING SQL part would
-- be `RETURNING name`(see QueryBuilder). This would make the embedding
-- fail because the following JOIN would need the "client_id" column from
-- projects. So this adds the foreign key columns to ensure the embedding
-- succeeds, result would be `RETURNING name, client_id`. This also works
-- for the other relType's.
fkCols = concat $ mapMaybe (\case
Node (_, (_, Just Relation{relColumns=cols, relType=relTyp}, _, _, _)) _ -> case relTyp of
O2M -> Just cols
@@ -335,10 +367,13 @@ returningCols rr@(Node _ forest) pkCols
M2M -> Just cols
_ -> Nothing
) forest
-- However if the "client_id" is present, e.g. mutateRequest to /projects?select=client_id,name,clients(name)
-- we would get `RETURNING client_id, name, client_id` and then we would produce the "column reference \"client_id\" is ambiguous"
-- error from PostgreSQL. So we deduplicate with Set:
-- We are adding the primary key columns as well to make sure, that a proper location header can always be built for INSERT/POST
-- However if the "client_id" is present, e.g. mutateRequest to
-- /projects?select=client_id,name,clients(name) we would get `RETURNING
-- client_id, name, client_id` and then we would produce the "column
-- reference \"client_id\" is ambiguous" error from PostgreSQL. So we
-- deduplicate with Set: We are adding the primary key columns as well to
-- make sure, that a proper location header can always be built for
-- INSERT/POST
returnings = S.toList . S.fromList $ fldNames ++ (colName <$> fkCols) ++ pkCols
-- Traditional filters(e.g. id=eq.1) are added as root nodes of the LogicTree
@@ -1,30 +1,54 @@
{-|
Module : PostgREST.Parsers
Module : PostgREST.Request.Parsers
Description : PostgREST parser combinators
This module is in charge of parsing all the querystring values in an url, e.g. the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`.
-}
module PostgREST.Parsers where
module PostgREST.Request.Parsers
( pColumns
, pLogicPath
, pLogicSingleVal
, pLogicTree
, pOrder
, pOrderTerm
, pRequestColumns
, pRequestFilter
, pRequestLogicTree
, pRequestOnConflict
, pRequestOrder
, pRequestRange
, pRequestSelect
, pSingleVal
, pTreePath
) where
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import Data.Either.Combinators (mapLeft)
import Data.Foldable (foldl1)
import Data.List (init, last)
import Data.Text (intercalate, replace, strip)
import Text.Read (read)
import Data.Either.Combinators (mapLeft)
import Data.Foldable (foldl1)
import Data.List (init, last)
import Data.Text (intercalate, replace, strip)
import Data.Tree (Tree (..))
import Text.Parsec.Error (errorMessages,
showErrorMessages)
import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser,
anyChar, between, char, digit,
eof, errorPos, letter,
lookAhead, many1, noneOf,
notFollowedBy, oneOf, option,
optionMaybe, parse, sepBy1,
string, try, (<?>))
import Data.Tree
import Text.Parsec.Error
import Text.ParserCombinators.Parsec hiding (many, (<|>))
import PostgREST.DbStructure.Identifiers (FieldName)
import PostgREST.Error (ApiRequestError (ParseRequestError))
import PostgREST.Query.SqlFragment (ftsOperators, operators)
import PostgREST.RangeQuery (NonnegRange)
import PostgREST.Error (ApiRequestError (ParseRequestError))
import PostgREST.RangeQuery (NonnegRange)
import PostgREST.Types
import Protolude hiding (intercalate, option, replace, toS,
try)
import Protolude.Conv (toS)
import PostgREST.Request.Types
import Protolude hiding (intercalate, option, replace, toS, try)
import Protolude.Conv (toS)
pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]
pRequestSelect selStr =
@@ -250,23 +274,3 @@ mapError = mapLeft translateError
message = show $ errorPos e
details = strip $ replace "\n" " " $ toS
$ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
-- Used for the config value "role-claim-key"
pRoleClaimKey :: Text -> Either Text JSPath
pRoleClaimKey selStr =
mapLeft show $ parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)
pJSPath :: Parser JSPath
pJSPath = toJSPath <$> (period *> pPath `sepBy` period <* eof)
where
toJSPath :: [(Text, Maybe Int)] -> JSPath
toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx))
period = char '.' <?> "period (.)"
pPath :: Parser (Text, Maybe Int)
pPath = (,) <$> pJSPKey <*> optionMaybe pJSPIdx
pJSPKey :: Parser Text
pJSPKey = toS <$> many1 (alphaNum <|> oneOf "_$@") <|> pQuotedValue <?> "attribute name [a..z0..9_$@])"
pJSPIdx :: Parser Int
pJSPIdx = char '[' *> (read <$> many1 digit) <* char ']' <?> "array index [0..n]"
+54
View File
@@ -0,0 +1,54 @@
module PostgREST.Request.Preferences where
import GHC.Show
import Protolude
data PreferResolution
= MergeDuplicates
| IgnoreDuplicates
instance Show PreferResolution where
show MergeDuplicates = "resolution=merge-duplicates"
show IgnoreDuplicates = "resolution=ignore-duplicates"
-- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2
data PreferRepresentation
= Full -- ^ Return the body plus the Location header(in case of POST).
| HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
| None -- ^ Return nothing from the mutated data.
deriving Eq
instance Show PreferRepresentation where
show Full = "return=representation"
show None = "return=minimal"
show HeadersOnly = mempty
data PreferParameters
= SingleObject -- ^ Pass all parameters as a single json object to a stored procedure
| MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure
deriving Eq
instance Show PreferParameters where
show SingleObject = "params=single-object"
show MultipleObjects = "params=multiple-objects"
data PreferCount
= ExactCount -- ^ exact count(slower)
| PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.
| EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
deriving Eq
instance Show PreferCount where
show ExactCount = "count=exact"
show PlannedCount = "count=planned"
show EstimatedCount = "count=estimated"
data PreferTransaction
= Commit -- Commit transaction - the default.
| Rollback -- Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
deriving Eq
instance Show PreferTransaction where
show Commit = "tx=commit"
show Rollback = "tx=rollback"
+211
View File
@@ -0,0 +1,211 @@
{-# LANGUAGE DuplicateRecordFields #-}
module PostgREST.Request.Types
( Alias
, Depth
, EmbedHint
, EmbedPath
, Field
, Filter(..)
, JoinCondition(..)
, JsonOperand(..)
, JsonOperation(..)
, JsonPath
, ListVal
, LogicOperator(..)
, LogicTree(..)
, MutateQuery(..)
, MutateRequest
, NodeName
, OpExpr(..)
, Operation (..)
, OrderDirection(..)
, OrderNulls(..)
, OrderTerm(..)
, ReadNode
, ReadQuery(..)
, ReadRequest
, SelectItem
, SingleVal
, fstFieldNames
) where
import qualified Data.ByteString.Lazy as BL
import qualified Data.Set as S
import Data.Tree (Tree (..))
import qualified GHC.Show (show)
import PostgREST.DbStructure.Identifiers (FieldName,
QualifiedIdentifier)
import PostgREST.DbStructure.Relation (Relation)
import PostgREST.RangeQuery (NonnegRange)
import PostgREST.Request.Preferences (PreferResolution)
import Protolude
type ReadRequest = Tree ReadNode
type MutateRequest = MutateQuery
type ReadNode =
(ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe EmbedHint, Depth))
type NodeName = Text
type Depth = Integer
data ReadQuery = Select
{ select :: [SelectItem]
, from :: QualifiedIdentifier
-- ^ A table alias is used in case of self joins
, fromAlias :: Maybe Alias
-- ^ Only used for Many to Many joins. Parent and Child joins use explicit joins.
, implicitJoins :: [QualifiedIdentifier]
, where_ :: [LogicTree]
, joinConditions :: [JoinCondition]
, order :: [OrderTerm]
, range_ :: NonnegRange
}
deriving (Eq)
data JoinCondition =
JoinCondition
(QualifiedIdentifier, FieldName)
(QualifiedIdentifier, FieldName)
deriving (Eq)
data OrderTerm = OrderTerm
{ otTerm :: Field
, otDirection :: Maybe OrderDirection
, otNullOrder :: Maybe OrderNulls
}
deriving (Eq)
data OrderDirection
= OrderAsc
| OrderDesc
deriving (Eq)
instance Show OrderDirection where
show OrderAsc = "ASC"
show OrderDesc = "DESC"
data OrderNulls
= OrderNullsFirst
| OrderNullsLast
deriving (Eq)
instance Show OrderNulls where
show OrderNullsFirst = "NULLS FIRST"
show OrderNullsLast = "NULLS LAST"
data MutateQuery
= Insert
{ in_ :: QualifiedIdentifier
, insCols :: S.Set FieldName
, insBody :: Maybe BL.ByteString
, onConflict :: Maybe (PreferResolution, [FieldName])
, where_ :: [LogicTree]
, returning :: [FieldName]
}
| Update
{ in_ :: QualifiedIdentifier
, updCols :: S.Set FieldName
, updBody :: Maybe BL.ByteString
, where_ :: [LogicTree]
, returning :: [FieldName]
}
| Delete
{ in_ :: QualifiedIdentifier
, where_ :: [LogicTree]
, returning :: [FieldName]
}
-- | This type will hold information about which particular 'Relation' between
-- two tables to choose when there are multiple ones.
-- Specifically, it will contain the name of the foreign key or the join table
-- in many to many relations.
type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint)
type Field = (FieldName, JsonPath)
type Cast = Text
type Alias = Text
-- | Disambiguates an embedding operation when there's multiple relationships
-- between two tables. Can be the name of a foreign key constraint, column
-- name or the junction in an m2m relationship.
type EmbedHint = Text
-- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path
-- ["clients", "projects"]
type EmbedPath = [Text]
-- | Json path operations as specified in
-- https://www.postgresql.org/docs/current/static/functions-json.html
type JsonPath = [JsonOperation]
-- | Represents the single arrow `->` or double arrow `->>` operators
data JsonOperation
= JArrow { jOp :: JsonOperand }
| J2Arrow { jOp :: JsonOperand }
deriving (Eq)
-- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text
-- because we reuse our escaping functons and let pg do the casting with
-- '1'::int
data JsonOperand
= JKey { jVal :: Text }
| JIdx { jVal :: Text }
deriving (Eq)
-- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d))
fstFieldNames :: ReadRequest -> [FieldName]
fstFieldNames (Node (sel, _) _) =
fst . (\(f, _, _, _) -> f) <$> select sel
-- | Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
--
-- And
-- / \
-- name.eq.N Or
-- / \
-- id.eq.1 id.eq.2
data LogicTree
= Expr Bool LogicOperator [LogicTree]
| Stmnt Filter
deriving (Eq)
data LogicOperator
= And
| Or
deriving Eq
instance Show LogicOperator where
show And = "AND"
show Or = "OR"
data Filter = Filter
{ field :: Field
, opExpr :: OpExpr
}
deriving (Eq)
data OpExpr =
OpExpr Bool Operation
deriving (Eq)
data Operation
= Op Operator SingleVal
| In ListVal
| Fts Operator (Maybe Language) SingleVal
deriving (Eq)
type Operator = Text
type Language = Text
-- | Represents a single value in a filter, e.g. id=eq.singleval
type SingleVal = Text
-- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3)
type ListVal = [Text]
-580
View File
@@ -1,580 +0,0 @@
{-|
Module : PostgREST.Types
Description : PostgREST common types and functions used by the rest of the modules
-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
module PostgREST.Types where
import Control.Lens.Getter (view)
import Control.Lens.Tuple (_1)
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS (c2w)
import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import qualified GHC.Show
import Network.HTTP.Types.Header (Header, hContentType)
import Data.Tree
import PostgREST.RangeQuery (NonnegRange)
import Protolude hiding (toS)
import Protolude.Conv (toS)
-- | Enumeration of currently supported response content types
data ContentType = CTApplicationJSON | CTSingularJSON
| CTTextCSV | CTTextPlain
| CTOpenAPI | CTUrlEncoded | CTOctetStream
| CTAny | CTOther ByteString deriving (Eq)
-- | Convert from ContentType to a full HTTP Header
toHeader :: ContentType -> Header
toHeader ct = (hContentType, toMime ct <> charset)
where
charset = case ct of
CTOctetStream -> mempty
CTOther _ -> mempty
_ -> "; charset=utf-8"
-- | Convert from ContentType to a ByteString representing the mime type
toMime :: ContentType -> ByteString
toMime CTApplicationJSON = "application/json"
toMime CTTextCSV = "text/csv"
toMime CTTextPlain = "text/plain"
toMime CTOpenAPI = "application/openapi+json"
toMime CTSingularJSON = "application/vnd.pgrst.object+json"
toMime CTUrlEncoded = "application/x-www-form-urlencoded"
toMime CTOctetStream = "application/octet-stream"
toMime CTAny = "*/*"
toMime (CTOther ct) = ct
-- | Convert from ByteString to ContentType. Warning: discards MIME parameters
decodeContentType :: BS.ByteString -> ContentType
decodeContentType ct = case BS.takeWhile (/= BS.c2w ';') ct of
"application/json" -> CTApplicationJSON
"text/csv" -> CTTextCSV
"text/plain" -> CTTextPlain
"application/openapi+json" -> CTOpenAPI
"application/vnd.pgrst.object+json" -> CTSingularJSON
"application/vnd.pgrst.object" -> CTSingularJSON
"application/x-www-form-urlencoded" -> CTUrlEncoded
"application/octet-stream" -> CTOctetStream
"*/*" -> CTAny
ct' -> CTOther ct'
-- | A SQL query that can be executed independently
type SqlQuery = ByteString
-- | A part of a SQL query that cannot be executed independently
type SqlFragment = ByteString
data PreferResolution = MergeDuplicates | IgnoreDuplicates
instance Show PreferResolution where
show MergeDuplicates = "resolution=merge-duplicates"
show IgnoreDuplicates = "resolution=ignore-duplicates"
-- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2
data PreferRepresentation = Full -- ^ Return the body plus the Location header(in case of POST).
| HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
| None -- ^ Return nothing from the mutated data.
deriving Eq
instance Show PreferRepresentation where
show Full = "return=representation"
show None = "return=minimal"
show HeadersOnly = mempty
data PreferParameters
= SingleObject -- ^ Pass all parameters as a single json object to a stored procedure
| MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure
deriving Eq
instance Show PreferParameters where
show SingleObject = "params=single-object"
show MultipleObjects = "params=multiple-objects"
data PreferCount
= ExactCount -- ^ exact count(slower)
| PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.
| EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
deriving Eq
instance Show PreferCount where
show ExactCount = "count=exact"
show PlannedCount = "count=planned"
show EstimatedCount = "count=estimated"
data PreferTransaction
= Commit -- Commit transaction - the default.
| Rollback -- Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
deriving Eq
instance Show PreferTransaction where
show Commit = "tx=commit"
show Rollback = "tx=rollback"
data DbStructure = DbStructure {
dbTables :: [Table]
, dbColumns :: [Column]
, dbRelations :: [Relation]
, dbPrimaryKeys :: [PrimaryKey]
, dbProcs :: ProcsMap
, pgVersion :: PgVersion
} deriving (Generic, JSON.ToJSON)
-- TODO Table could hold references to all its Columns
tableCols :: DbStructure -> Schema -> TableName -> [Column]
tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs
-- TODO Table could hold references to all its PrimaryKeys
tablePKCols :: DbStructure -> Schema -> TableName -> [Text]
tablePKCols dbs tSchema tName = pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs)
data PgArg = PgArg {
pgaName :: Text
, pgaType :: Text
, pgaReq :: Bool
, pgaVar :: Bool
} deriving (Eq, Ord, Generic, JSON.ToJSON)
data PgType = Scalar | Composite QualifiedIdentifier deriving (Eq, Ord, Generic, JSON.ToJSON)
data RetType = Single PgType | SetOf PgType deriving (Eq, Ord, Generic, JSON.ToJSON)
data ProcVolatility = Volatile | Stable | Immutable
deriving (Eq, Ord, Generic, JSON.ToJSON)
data ProcDescription = ProcDescription {
pdSchema :: Schema
, pdName :: Text
, pdDescription :: Maybe Text
, pdArgs :: [PgArg]
, pdReturnType :: RetType
, pdVolatility :: ProcVolatility
, pdHasVariadic :: Bool
} deriving (Eq, Generic, JSON.ToJSON)
-- Order by least number of args in the case of overloaded functions
instance Ord ProcDescription where
ProcDescription schema1 name1 des1 args1 rt1 vol1 hasVar1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2 hasVar2
| schema1 == schema2 && name1 == name2 && length args1 < length args2 = LT
| schema2 == schema2 && name1 == name2 && length args1 > length args2 = GT
| otherwise = (schema1, name1, des1, args1, rt1, vol1, hasVar1) `compare` (schema2, name2, des2, args2, rt2, vol2, hasVar2)
-- | A map of all procs, all of which can be overloaded(one entry will have more than one ProcDescription).
-- | It uses a HashMap for a faster lookup.
type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]
{-|
Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it.
An overloaded function can have a different volatility or even a different return type.
Ideally, handling overloaded functions should be left to pg itself. But we need to know certain proc attributes in advance.
-}
findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> ProcDescription
findProc qi payloadKeys paramsAsSingleObject allProcs = fromMaybe fallback bestMatch
where
-- instead of passing Maybe ProcDescription around, we create a fallback description here when we can't find a matching function
-- args is empty, but because "specifiedProcArgs" will fill the missing arguments with default type text, this is not a problem
fallback = ProcDescription (qiSchema qi) (qiName qi) Nothing mempty (SetOf $ Composite $ QualifiedIdentifier mempty "record") Volatile False
bestMatch =
case M.lookup qi allProcs of
Nothing -> Nothing
Just [proc] -> Just proc -- if it's not an overloaded function then immediately get the ProcDescription
Just procs -> find matches procs -- Handle overloaded functions case
matches proc =
if paramsAsSingleObject
-- if the arg is not of json type let the db give the err
then length (pdArgs proc) == 1
else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc)
{-|
Search the procedure parameters by matching them with the specified keys.
If the key doesn't match a parameter, a parameter with a default type "text" is assumed.
-}
specifiedProcArgs :: S.Set FieldName -> ProcDescription -> [PgArg]
specifiedProcArgs keys proc =
(\k -> fromMaybe (PgArg k "text" True False) (find ((==) k . pgaName) (pdArgs proc))) <$> S.toList keys
procReturnsScalar :: ProcDescription -> Bool
procReturnsScalar proc = case proc of
ProcDescription{pdReturnType = (Single Scalar)} -> True
ProcDescription{pdReturnType = (SetOf Scalar)} -> True
_ -> False
procReturnsSingle :: ProcDescription -> Bool
procReturnsSingle proc = case proc of
ProcDescription{pdReturnType = (Single _)} -> True
_ -> False
procTableName :: ProcDescription -> Maybe TableName
procTableName proc = case pdReturnType proc of
SetOf (Composite qi) -> Just $ qiName qi
Single (Composite qi) -> Just $ qiName qi
_ -> Nothing
type Schema = Text
type TableName = Text
data Table = Table {
tableSchema :: Schema
, tableName :: TableName
, tableDescription :: Maybe Text
, tableInsertable :: Bool
} deriving (Show, Ord, Generic, JSON.ToJSON)
instance Eq Table where
Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
tableQi :: Table -> QualifiedIdentifier
tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n
newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Eq, Ord, Generic, JSON.ToJSON)
data Column =
Column {
colTable :: Table
, colName :: FieldName
, colDescription :: Maybe Text
, colNullable :: Bool
, colType :: Text
, colMaxLen :: Maybe Int32
, colDefault :: Maybe Text
, colEnum :: [Text]
, colFK :: Maybe ForeignKey
} deriving (Ord, Generic, JSON.ToJSON)
instance Eq Column where
Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
-- | The source table column a view column refers to
type SourceColumn = (Column, ViewColumn)
type ViewColumn = Column
data PrimaryKey = PrimaryKey {
pkTable :: Table
, pkName :: Text
} deriving (Generic, JSON.ToJSON)
data OrderDirection = OrderAsc | OrderDesc deriving (Eq)
instance Show OrderDirection where
show OrderAsc = "ASC"
show OrderDesc = "DESC"
data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq)
instance Show OrderNulls where
show OrderNullsFirst = "NULLS FIRST"
show OrderNullsLast = "NULLS LAST"
data OrderTerm = OrderTerm {
otTerm :: Field
, otDirection :: Maybe OrderDirection
, otNullOrder :: Maybe OrderNulls
} deriving (Eq)
{-|
Represents a pg identifier with a prepended schema name "schema.table"
When qiSchema is "", the schema is defined by the pg search_path
-}
data QualifiedIdentifier = QualifiedIdentifier {
qiSchema :: Schema
, qiName :: TableName
} deriving (Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)
instance Hashable QualifiedIdentifier
-- | The relationship [cardinality](https://en.wikipedia.org/wiki/Cardinality_(data_modeling)).
-- | TODO: missing one-to-one
data Cardinality = O2M -- ^ one-to-many, previously known as Parent
| M2O -- ^ many-to-one, previously known as Child
| M2M -- ^ many-to-many, previously known as Many
deriving (Eq, Generic, JSON.ToJSON)
instance Show Cardinality where
show O2M = "o2m"
show M2O = "m2o"
show M2M = "m2m"
{-|
"Relation"ship between two tables.
The order of the relColumns and relFColumns should be maintained to get the join conditions right.
TODO merge relColumns and relFColumns to a tuple or Data.Bimap
-}
data Relation = Relation {
relTable :: Table
, relColumns :: [Column]
, relFTable :: Table
, relFColumns :: [Column]
, relType :: Cardinality
, relLink :: Link -- ^ Constraint on O2M/M2O, Junction for M2M Cardinality
} deriving (Eq, Generic, JSON.ToJSON)
type ConstraintName = Text
-- | Junction table on an M2M relationship
data Link
= Constraint { constName :: ConstraintName }
| Junction {
junTable :: Table
, junLink1 :: Link
, junCols1 :: [Column]
, junLink2 :: Link
, junCols2 :: [Column]
}
deriving (Eq, Generic, JSON.ToJSON)
isSelfReference :: Relation -> Bool
isSelfReference r = relTable r == relFTable r
data PayloadJSON =
-- | Cached attributes of a JSON payload
ProcessedJSON {
-- | This is the raw ByteString that comes from the request body.
-- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding
-- had high memory usage, see https://github.com/PostgREST/postgrest/pull/1005 for more details
pjRaw :: BL.ByteString
-- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects
, pjKeys :: S.Set Text
}|
RawJSON {
pjRaw :: BL.ByteString
}
data PJType = PJArray { pjaLength :: Int } | PJObject
data Proxy = Proxy {
proxyScheme :: Text
, proxyHost :: Text
, proxyPort :: Integer
, proxyPath :: Text
}
type Operator = Text
operators :: M.HashMap Operator SqlFragment
operators = M.union (M.fromList [
("eq", "="),
("gte", ">="),
("gt", ">"),
("lte", "<="),
("lt", "<"),
("neq", "<>"),
("like", "LIKE"),
("ilike", "ILIKE"),
("in", "IN"),
("is", "IS"),
("cs", "@>"),
("cd", "<@"),
("ov", "&&"),
("sl", "<<"),
("sr", ">>"),
("nxr", "&<"),
("nxl", "&>"),
("adj", "-|-")]) ftsOperators
ftsOperators :: M.HashMap Operator SqlFragment
ftsOperators = M.fromList [
("fts", "@@ to_tsquery"),
("plfts", "@@ plainto_tsquery"),
("phfts", "@@ phraseto_tsquery"),
("wfts", "@@ websearch_to_tsquery")
]
data OpExpr = OpExpr Bool Operation deriving (Eq)
data Operation = Op Operator SingleVal |
In ListVal |
Fts Operator (Maybe Language) SingleVal deriving (Eq)
type Language = Text
-- | Represents a single value in a filter, e.g. id=eq.singleval
type SingleVal = Text
-- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3)
type ListVal = [Text]
data LogicOperator = And | Or deriving Eq
instance Show LogicOperator where
show And = "AND"
show Or = "OR"
{-|
Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
And
/ \
name.eq.N Or
/ \
id.eq.1 id.eq.2
-}
data LogicTree = Expr Bool LogicOperator [LogicTree] | Stmnt Filter deriving (Eq)
type FieldName = Text
{-|
Json path operations as specified in https://www.postgresql.org/docs/current/static/functions-json.html
-}
type JsonPath = [JsonOperation]
-- | Represents the single arrow `->` or double arrow `->>` operators
data JsonOperation = JArrow{jOp :: JsonOperand} | J2Arrow{jOp :: JsonOperand} deriving (Eq)
-- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text because we reuse our escaping functons and let pg do the casting with '1'::int
data JsonOperand = JKey{jVal :: Text} | JIdx{jVal :: Text} deriving (Eq)
type Field = (FieldName, JsonPath)
type Alias = Text
type Cast = Text
type NodeName = Text
{-|
Custom guc header, it's obtained by parsing the json in a:
`SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'
-}
newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
instance JSON.FromJSON GucHeader where
parseJSON (JSON.Object o) = case headMay (M.toList o) of
Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (CI.mk $ toS k, toS s)
| otherwise -> mzero
_ -> mzero
parseJSON _ = mzero
unwrapGucHeader :: GucHeader -> Header
unwrapGucHeader (GucHeader (k, v)) = (k, v)
-- | Add headers not already included to allow the user to override them instead of duplicating them
addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header]
addHeadersIfNotIncluded newHeaders initialHeaders =
filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
initialHeaders
{-|
This type will hold information about which particular 'Relation' between two tables to choose when there are multiple ones.
Specifically, it will contain the name of the foreign key or the join table in many to many relations.
-}
type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint)
-- | Disambiguates an embedding operation when there's multiple relationships between two tables.
-- | Can be the name of a foreign key constraint, column name or the junction in an m2m relationship.
type EmbedHint = Text
-- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"]
type EmbedPath = [Text]
data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Eq)
data JoinCondition = JoinCondition (QualifiedIdentifier, FieldName)
(QualifiedIdentifier, FieldName) deriving (Eq)
data ReadQuery = Select {
select :: [SelectItem]
, from :: QualifiedIdentifier
-- | A table alias is used in case of self joins
, fromAlias :: Maybe Alias
-- | Only used for Many to Many joins. Parent and Child joins use explicit joins.
, implicitJoins :: [QualifiedIdentifier]
, where_ :: [LogicTree]
, joinConditions :: [JoinCondition]
, order :: [OrderTerm]
, range_ :: NonnegRange
} deriving (Eq)
data MutateQuery =
Insert {
in_ :: QualifiedIdentifier
, insCols :: S.Set FieldName
, insBody :: Maybe BL.ByteString
, onConflict :: Maybe (PreferResolution, [FieldName])
, where_ :: [LogicTree]
, returning :: [FieldName]
}|
Update {
in_ :: QualifiedIdentifier
, updCols :: S.Set FieldName
, updBody :: Maybe BL.ByteString
, where_ :: [LogicTree]
, returning :: [FieldName]
}|
Delete {
in_ :: QualifiedIdentifier
, where_ :: [LogicTree]
, returning :: [FieldName]
}
type ReadRequest = Tree ReadNode
type MutateRequest = MutateQuery
type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe EmbedHint, Depth))
type Depth = Integer
-- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d))
fstFieldNames :: ReadRequest -> [FieldName]
fstFieldNames (Node (sel, _) _) =
fst . view _1 <$> select sel
data PgVersion = PgVersion {
pgvNum :: Int32
, pgvName :: Text
} deriving (Eq, Generic, JSON.ToJSON)
instance Ord PgVersion where
(PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2
-- | Tells the minimum PostgreSQL version required by this version of PostgREST
minimumPgVersion :: PgVersion
minimumPgVersion = pgVersion95
pgVersion95 :: PgVersion
pgVersion95 = PgVersion 90500 "9.5"
pgVersion96 :: PgVersion
pgVersion96 = PgVersion 90600 "9.6"
pgVersion100 :: PgVersion
pgVersion100 = PgVersion 100000 "10"
pgVersion109 :: PgVersion
pgVersion109 = PgVersion 100009 "10.9"
pgVersion110 :: PgVersion
pgVersion110 = PgVersion 110000 "11.0"
pgVersion112 :: PgVersion
pgVersion112 = PgVersion 110002 "11.2"
pgVersion114 :: PgVersion
pgVersion114 = PgVersion 110004 "11.4"
pgVersion121 :: PgVersion
pgVersion121 = PgVersion 120001 "12.1"
pgVersion130 :: PgVersion
pgVersion130 = PgVersion 130000 "13.0"
sourceCTEName :: SqlFragment
sourceCTEName = "pgrst_source"
-- | full jspath, e.g. .property[0].attr.detail
type JSPath = [JSPathExp]
-- | jspath expression, e.g. .property, .property[0] or ."property-dash"
data JSPathExp = JSPKey Text | JSPIdx Int
instance Show JSPathExp where
-- TODO: this needs to be quoted properly for special chars
show (JSPKey k) = "." <> show k
show (JSPIdx i) = "[" <> show i <> "]"
-- | Current database connection status data ConnectionStatus
data ConnectionStatus
= NotConnected
| Connected PgVersion
| FatalConnectionError Text
deriving (Eq)
-- | Schema cache status
data SCacheStatus
= SCLoaded
| SCOnRetry
| SCFatalFail
data LogLevel = LogCrit | LogError | LogWarn | LogInfo
instance Show LogLevel where
show LogCrit = "crit"
show LogError = "error"
show LogWarn = "warn"
show LogInfo = "info"
+3 -2
View File
@@ -7,8 +7,9 @@ import Test.Hspec
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import PostgREST.Types (PgVersion, pgVersion112)
import Protolude hiding (get)
import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112)
import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
+3 -2
View File
@@ -7,8 +7,9 @@ import Test.Hspec
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import PostgREST.Types (PgVersion, pgVersion112)
import Protolude hiding (get)
import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112)
import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
+4 -2
View File
@@ -11,8 +11,10 @@ import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import Text.Heredoc
import PostgREST.Types (PgVersion, pgVersion112, pgVersion130)
import Protolude hiding (get)
import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112,
pgVersion130)
import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
+4 -3
View File
@@ -7,9 +7,10 @@ import Test.Hspec
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import PostgREST.Types (PgVersion, pgVersion112, pgVersion121,
pgVersion95)
import Protolude hiding (get)
import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112,
pgVersion121, pgVersion95)
import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
+1 -1
View File
@@ -15,7 +15,7 @@ import Test.Hspec.Wai.JSON
import Protolude
import SpecHelper
import PostgREST.Types (PgVersion, pgVersion96)
import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion96)
spec :: PgVersion -> SpecWith ((), Application)
spec actualPgVersion =
+3 -3
View File
@@ -8,9 +8,9 @@ import Test.Hspec hiding (pendingWith)
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import PostgREST.Types (PgVersion, pgVersion112, pgVersion121,
pgVersion96)
import Protolude hiding (get)
import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion112,
pgVersion121, pgVersion96)
import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
+6 -4
View File
@@ -11,10 +11,12 @@ import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import Text.Heredoc
import PostgREST.Types (PgVersion, pgVersion100, pgVersion109,
pgVersion110, pgVersion112, pgVersion114,
pgVersion96)
import Protolude hiding (get)
import PostgREST.DbStructure.PgVersion (PgVersion, pgVersion100,
pgVersion109, pgVersion110,
pgVersion112, pgVersion114,
pgVersion96)
import Protolude hiding (get)
import SpecHelper
spec :: PgVersion -> SpecWith ((), Application)
+6 -6
View File
@@ -12,12 +12,12 @@ import Data.Time.Clock (getCurrentTime)
import Data.IORef
import Test.Hspec
import PostgREST.App (postgrest)
import PostgREST.Config (AppConfig (..))
import PostgREST.DbStructure (getDbStructure, getPgVersion)
import PostgREST.Types (LogLevel (..), pgVersion96)
import Protolude hiding (toList, toS)
import Protolude.Conv (toS)
import PostgREST.App (postgrest)
import PostgREST.Config (AppConfig (..), LogLevel (..))
import PostgREST.DbStructure (getDbStructure, getPgVersion)
import PostgREST.DbStructure.PgVersion (pgVersion96)
import Protolude hiding (toList, toS)
import Protolude.Conv (toS)
import SpecHelper
import qualified Feature.AndOrParamsSpec
+6 -2
View File
@@ -14,8 +14,12 @@ import Text.Heredoc
import Protolude hiding (get, toS)
import Protolude.Conv (toS)
import PostgREST.QueryBuilder (requestToCallProcQuery)
import PostgREST.Types
import PostgREST.Query.QueryBuilder (requestToCallProcQuery)
import PostgREST.Request.ApiRequest (PayloadJSON (..))
import PostgREST.DbStructure.Identifiers
import PostgREST.DbStructure.Proc
import PostgREST.Request.Preferences
import SpecHelper (getEnvVarWithDefault)
+2 -2
View File
@@ -22,8 +22,8 @@ import Test.Hspec
import Test.Hspec.Wai
import Text.Heredoc
import PostgREST.Config (AppConfig (..), parseSecret)
import PostgREST.Types (JSPathExp (..), LogLevel (..))
import PostgREST.Config (AppConfig (..), JSPathExp (..),
LogLevel (..), parseSecret)
import Protolude hiding (toS)
import Protolude.Conv (toS)