{-# 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)
data ContentType = CTApplicationJSON | CTSingularJSON
| CTTextCSV | CTTextPlain
| CTOpenAPI | CTOctetStream
| CTAny | CTOther ByteString deriving (Show, Eq)
toHeader :: ContentType -> Header
toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
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 CTOctetStream = "application/octet-stream"
toMime CTAny = "*/*"
toMime (CTOther ct) = ct
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/octet-stream" -> CTOctetStream
"*/*" -> CTAny
ct' -> CTOther ct'
type SqlQuery = Text
type SqlFragment = Text
data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq
instance Show PreferResolution where
show MergeDuplicates = "resolution=merge-duplicates"
show IgnoreDuplicates = "resolution=ignore-duplicates"
data PreferRepresentation = Full
| HeadersOnly
| None
deriving Eq
instance Show PreferRepresentation where
show Full = "return=representation"
show None = "return=minimal"
show HeadersOnly = mempty
data PreferParameters
= SingleObject
| MultipleObjects
deriving Eq
instance Show PreferParameters where
show SingleObject = "params=single-object"
show MultipleObjects = "params=multiple-objects"
data PreferCount
= ExactCount
| PlannedCount
| EstimatedCount
deriving Eq
instance Show PreferCount where
show ExactCount = "count=exact"
show PlannedCount = "count=planned"
show EstimatedCount = "count=estimated"
data DbStructure = DbStructure {
dbTables :: [Table]
, dbColumns :: [Column]
, dbRelations :: [Relation]
, dbPrimaryKeys :: [PrimaryKey]
, dbProcs :: ProcsMap
, pgVersion :: PgVersion
} deriving (Show, Eq)
tableCols :: DbStructure -> Schema -> TableName -> [Column]
tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs
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
} deriving (Show, Eq, Ord)
data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show, Ord)
data RetType = Single PgType | SetOf PgType deriving (Eq, Show, Ord)
data ProcVolatility = Volatile | Stable | Immutable
deriving (Eq, Show, Ord)
data ProcDescription = ProcDescription {
pdSchema :: Schema
, pdName :: Text
, pdDescription :: Maybe Text
, pdArgs :: [PgArg]
, pdReturnType :: RetType
, pdVolatility :: ProcVolatility
} deriving (Show, Eq)
instance Ord ProcDescription where
ProcDescription schema1 name1 des1 args1 rt1 vol1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2
| 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) `compare` (schema2, name2, des2, args2, rt2, vol2)
type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]
findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> Maybe ProcDescription
findProc qi payloadKeys paramsAsSingleObject allProcs =
case M.lookup qi allProcs of
Nothing -> Nothing
Just [proc] -> Just proc
Just procs -> find matches procs
where
matches proc =
if paramsAsSingleObject
then length (pdArgs proc) == 1
else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc)
specifiedProcArgs :: S.Set FieldName -> Maybe ProcDescription -> [PgArg]
specifiedProcArgs keys proc =
let
args = maybe [] pdArgs proc
in
(\k -> fromMaybe (PgArg k "text" True) (find ((==) k . pgaName) args)) <$> S.toList keys
procReturnsScalar :: ProcDescription -> Bool
procReturnsScalar proc = case proc of
ProcDescription{pdReturnType = (Single (Scalar _))} -> 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)
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 (Show, Eq, Ord)
data Column =
Column {
colTable :: Table
, colName :: FieldName
, colDescription :: Maybe Text
, colPosition :: Int32
, colNullable :: Bool
, colType :: Text
, colUpdatable :: Bool
, colMaxLen :: Maybe Int32
, colPrecision :: Maybe Int32
, colDefault :: Maybe Text
, colEnum :: [Text]
, colFK :: Maybe ForeignKey
} deriving (Show, Ord)
instance Eq Column where
Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
type SourceColumn = (Column, ViewColumn)
type ViewColumn = Column
data PrimaryKey = PrimaryKey {
pkTable :: Table
, pkName :: Text
} deriving (Show, 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 OrderTerm = OrderTerm {
otTerm :: Field
, otDirection :: Maybe OrderDirection
, otNullOrder :: Maybe OrderNulls
} deriving (Show, Eq)
data QualifiedIdentifier = QualifiedIdentifier {
qiSchema :: Schema
, qiName :: TableName
} deriving (Show, Eq, Ord, Generic)
instance Hashable QualifiedIdentifier
data Cardinality = O2M
| M2O
| M2M
deriving Eq
instance Show Cardinality where
show O2M = "o2m"
show M2O = "m2o"
show M2M = "m2m"
type ConstraintName = Text
data Relation = Relation {
relTable :: Table
, relColumns :: [Column]
, relConstraint :: Maybe ConstraintName
, relFTable :: Table
, relFColumns :: [Column]
, relType :: Cardinality
, relJunction :: Maybe Junction
} deriving (Show, Eq)
data Junction = Junction {
junTable :: Table
, junConstraint1 :: Maybe ConstraintName
, junCols1 :: [Column]
, junConstraint2 :: Maybe ConstraintName
, junCols2 :: [Column]
} deriving (Show, Eq)
isSelfReference :: Relation -> Bool
isSelfReference r = relTable r == relFTable r
data PayloadJSON =
ProcessedJSON {
pjRaw :: BL.ByteString
, pjKeys :: S.Set Text
}|
RawJSON {
pjRaw :: BL.ByteString
} deriving (Show, Eq)
data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq)
data Proxy = Proxy {
proxyScheme :: Text
, proxyHost :: Text
, proxyPort :: Integer
, proxyPath :: Text
} deriving (Show, Eq)
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, Show)
data Operation = Op Operator SingleVal |
In ListVal |
Fts Operator (Maybe Language) SingleVal deriving (Eq, Show)
type Language = Text
type SingleVal = Text
type ListVal = [Text]
data LogicOperator = And | Or deriving Eq
instance Show LogicOperator where
show And = "AND"
show Or = "OR"
data LogicTree = Expr Bool LogicOperator [LogicTree] | Stmnt Filter deriving (Show, Eq)
type FieldName = Text
type JsonPath = [JsonOperation]
data JsonOperation = JArrow{jOp :: JsonOperand} | J2Arrow{jOp :: JsonOperand} deriving (Show, Eq)
data JsonOperand = JKey{jVal :: Text} | JIdx{jVal :: Text} deriving (Show, Eq)
type Field = (FieldName, JsonPath)
type Alias = Text
type Cast = Text
type NodeName = Text
type RpcQParam = (Text, Text)
newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
deriving (Show, Eq)
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)
addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header]
addHeadersIfNotIncluded newHeaders initialHeaders =
filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
initialHeaders
type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint)
type EmbedHint = Text
type EmbedPath = [Text]
data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq)
data JoinCondition = JoinCondition (QualifiedIdentifier, FieldName)
(QualifiedIdentifier, FieldName) deriving (Show, Eq)
data ReadQuery = Select {
select :: [SelectItem]
, from :: QualifiedIdentifier
, fromAlias :: Maybe Alias
, implicitJoins :: [QualifiedIdentifier]
, where_ :: [LogicTree]
, joinConditions :: [JoinCondition]
, order :: [OrderTerm]
, range_ :: NonnegRange
} deriving (Show, Eq)
data MutateQuery =
Insert {
in_ :: QualifiedIdentifier
, insCols :: S.Set FieldName
, onConflict :: Maybe (PreferResolution, [FieldName])
, where_ :: [LogicTree]
, returning :: [FieldName]
}|
Update {
in_ :: QualifiedIdentifier
, updCols :: S.Set FieldName
, where_ :: [LogicTree]
, returning :: [FieldName]
}|
Delete {
in_ :: QualifiedIdentifier
, where_ :: [LogicTree]
, returning :: [FieldName]
} deriving (Show, Eq)
type ReadRequest = Tree ReadNode
type MutateRequest = MutateQuery
type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe EmbedHint, Depth))
type Depth = Integer
fstFieldNames :: ReadRequest -> [FieldName]
fstFieldNames (Node (sel, _) _) =
fst . view _1 <$> select sel
data PgVersion = PgVersion {
pgvNum :: Int32
, pgvName :: Text
} deriving (Eq, Show)
instance Ord PgVersion where
(PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2
minimumPgVersion :: PgVersion
minimumPgVersion = pgVersion94
pgVersion94 :: PgVersion
pgVersion94 = PgVersion 90400 "9.4"
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"
sourceCTEName :: SqlFragment
sourceCTEName = "pgrst_source"
type JSPath = [JSPathExp]
data JSPathExp = JSPKey Text | JSPIdx Int deriving (Eq, Show)
data ConnectionStatus
= NotConnected
| Connected PgVersion
| FatalConnectionError Text
deriving (Eq, Show)