{-# LANGUAGE DuplicateRecordFields #-}
module PostgREST.Types where
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
data ContentType = CTApplicationJSON | CTSingularJSON
| CTTextCSV | CTTextPlain | CTTextHtml
| 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 CTTextHtml = "text/html"
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
"text/html" -> CTTextHtml
"application/openapi+json" -> CTOpenAPI
"application/vnd.pgrst.object+json" -> CTSingularJSON
"application/vnd.pgrst.object" -> CTSingularJSON
"application/octet-stream" -> CTOctetStream
"*/*" -> CTAny
ct' -> CTOther ct'
rawContentTypes :: [ContentType]
rawContentTypes = [CTOctetStream, CTTextPlain, CTTextHtml]
data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq
instance Show PreferResolution where
show MergeDuplicates = "resolution=merge-duplicates"
show IgnoreDuplicates = "resolution=ignore-duplicates"
data DbStructure = DbStructure {
dbTables :: [Table]
, dbColumns :: [Column]
, dbRelations :: [Relation]
, dbPrimaryKeys :: [PrimaryKey]
, dbProcs :: M.HashMap Text [ProcDescription]
, 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 {
pdName :: Text
, pdDescription :: Maybe Text
, pdArgs :: [PgArg]
, pdReturnType :: RetType
, pdVolatility :: ProcVolatility
} deriving (Show, Eq)
instance Ord ProcDescription where
ProcDescription name1 des1 args1 rt1 vol1 `compare` ProcDescription name2 des2 args2 rt2 vol2
| name1 == name2 && length args1 < length args2 = LT
| name1 == name2 && length args1 > length args2 = GT
| otherwise = (name1, des1, args1, rt1, vol1) `compare` (name2, des2, args2, rt2, vol2)
findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription
findProc qi payloadKeys paramsAsSingleObject allProcs =
case M.lookup (qiName 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
type Schema = Text
type TableName = Text
type SqlQuery = Text
type SqlFragment = 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
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 Synonym = (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)
data RelationType = Child | Parent | Many | Root deriving (Show, Eq)
data Relation = Relation {
relTable :: Table
, relColumns :: [Column]
, relFTable :: Table
, relFColumns :: [Column]
, relType :: RelationType
, relLinkTable :: Maybe Table
, relLinkCols1 :: Maybe [Column]
, relLinkCols2 :: Maybe [Column]
} deriving (Show, Eq)
isSelfJoin :: Relation -> Bool
isSelfJoin r = relType r /= Root && relTable r == relFTable r
data PayloadJSON =
ProcessedJSON {
pjRaw :: BL.ByteString
, pjType :: PJType
, 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")
]
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 (Text, Text)
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 (k, s)
| otherwise -> mzero
_ -> mzero
parseJSON _ = mzero
toHeaders :: [GucHeader] -> [Header]
toHeaders = map $ \(GucHeader (k, v)) -> (CI.mk $ toS k, toS v)
type RelationDetail = Text
type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe RelationDetail)
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 :: TableName
, fromAlias :: Maybe Alias
, implicitJoins :: [TableName]
, where_ :: [LogicTree]
, joinConditions :: [JoinCondition]
, order :: [OrderTerm]
, range_ :: NonnegRange
} deriving (Show, Eq)
data MutateQuery =
Insert {
in_ :: TableName
, insCols :: S.Set FieldName
, onConflict :: Maybe (PreferResolution, [FieldName])
, where_ :: [LogicTree]
, returning :: [FieldName]
}|
Update {
in_ :: TableName
, updCols :: S.Set FieldName
, where_ :: [LogicTree]
, returning :: [FieldName]
}|
Delete {
in_ :: TableName
, where_ :: [LogicTree]
, returning :: [FieldName]
} deriving (Show, Eq)
data DbRequest = DbRead ReadRequest | DbMutate MutateRequest
type ReadRequest = Tree ReadNode
type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail, Depth))
type Depth = Integer
type MutateRequest = MutateQuery
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"
pgVersion112 :: PgVersion
pgVersion112 = PgVersion 110002 "11.2"
sourceCTEName :: SqlFragment
sourceCTEName = "pg_source"
type JSPath = [JSPathExp]
data JSPathExp = JSPKey Text | JSPIdx Int deriving (Eq, Show)
data ConnectionStatus
= NotConnected
| Connected PgVersion
| FatalConnectionError Text
deriving (Eq, Show)