jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Upgrade hasql to 1.4 (#1325)

Browse Source
This commit is contained in:
Robert
2019-06-17 16:54:45 -05:00
committed by Steve Chávez
parent 51d3a7864a
commit 9bcf39f41f
4 changed files with 85 additions and 55 deletions
Download Patch File Download Diff File Expand all files Collapse all files
postgrest.cabal
+6 -6
View File
@@ -56,9 +56,9 @@ library
, cookie >= 0.4.2 && < 0.5 , cookie >= 0.4.2 && < 0.5
, either >= 4.4.1 && < 5.1 , either >= 4.4.1 && < 5.1
, gitrev >= 1.2 && < 1.4 , gitrev >= 1.2 && < 1.4
, hasql >= 1.3 && < 1.4 , hasql >= 1.4 && < 1.5
, hasql-pool >= 0.5 && < 0.6 , hasql-pool >= 0.5 && < 0.6
, hasql-transaction >= 0.7 && < 0.8 , hasql-transaction >= 0.7.2 && < 0.8
, heredoc >= 0.2 && < 0.3 , heredoc >= 0.2 && < 0.3
, http-types >= 0.12.2 && < 0.13 , http-types >= 0.12.2 && < 0.13
, insert-ordered-containers >= 0.1 && < 0.3 , insert-ordered-containers >= 0.1 && < 0.3
@@ -94,9 +94,9 @@ executable postgrest
, base64-bytestring >= 1 && < 1.1 , base64-bytestring >= 1 && < 1.1
, bytestring >= 0.10.8 && < 0.11 , bytestring >= 0.10.8 && < 0.11
, directory >= 1.2.6 && < 1.4 , directory >= 1.2.6 && < 1.4
, hasql >= 1.3 && < 1.4 , hasql >= 1.4 && < 1.5
, hasql-pool >= 0.5 && < 0.6 , hasql-pool >= 0.5 && < 0.6
, hasql-transaction >= 0.7 && < 0.8 , hasql-transaction >= 0.7.2 && < 0.8
, network < 2.9 , network < 2.9
, postgrest , postgrest
, protolude >= 0.2.2 && < 0.3 , protolude >= 0.2.2 && < 0.3
@@ -155,9 +155,9 @@ test-suite spec
, cassava >= 0.4.5 && < 0.6 , cassava >= 0.4.5 && < 0.6
, containers >= 0.5.7 && < 0.7 , containers >= 0.5.7 && < 0.7
, contravariant >= 1.4 && < 1.6 , contravariant >= 1.4 && < 1.6
, hasql >= 1.3 && < 1.4 , hasql >= 1.4 && < 1.5
, hasql-pool >= 0.5 && < 0.6 , hasql-pool >= 0.5 && < 0.6
, hasql-transaction >= 0.7 && < 0.8 , hasql-transaction >= 0.7.2 && < 0.8
, heredoc >= 0.2 && < 0.3 , heredoc >= 0.2 && < 0.3
, hspec >= 2.3 && < 2.8 , hspec >= 2.3 && < 2.8
, hspec-wai >= 0.7 && < 0.10 , hspec-wai >= 0.7 && < 0.10
src/PostgREST/DbStructure.hs
+53 -41
View File
@@ -43,6 +43,18 @@ import Control.Applicative
import PostgREST.Types import PostgREST.Types
import Protolude import Protolude
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
element :: HD.Value a -> HD.Array a
element = HD.element . HD.nonNullable
param :: HE.Value a -> HE.Params a
param = HE.param . HE.nonNullable
getDbStructure :: Schema -> PgVersion -> HT.Transaction DbStructure getDbStructure :: Schema -> PgVersion -> HT.Transaction DbStructure
getDbStructure schema pgVer = do getDbStructure schema pgVer = do
HT.sql "set local schema ''" -- for getting the fully qualified name(schema.name) of every db object HT.sql "set local schema ''" -- for getting the fully qualified name(schema.name) of every db object
@@ -70,10 +82,10 @@ decodeTables :: HD.Result [Table]
decodeTables = decodeTables =
HD.rowList tblRow HD.rowList tblRow
where where
tblRow = Table <$> HD.column HD.text tblRow = Table <$> column HD.text
<*> HD.column HD.text <*> column HD.text
<*> HD.nullableColumn HD.text <*> nullableColumn HD.text
<*> HD.column HD.bool <*> column HD.bool
decodeColumns :: [Table] -> HD.Result [Column] decodeColumns :: [Table] -> HD.Result [Column]
decodeColumns tables = decodeColumns tables =
@@ -81,41 +93,41 @@ decodeColumns tables =
where where
colRow = colRow =
(,,,,,,,,,,,) (,,,,,,,,,,,)
<$> HD.column HD.text <*> HD.column HD.text <$> column HD.text <*> column HD.text
<*> HD.column HD.text <*> HD.nullableColumn HD.text <*> column HD.text <*> nullableColumn HD.text
<*> HD.column HD.int4 <*> HD.column HD.bool <*> column HD.int4 <*> column HD.bool
<*> HD.column HD.text <*> HD.column HD.bool <*> column HD.text <*> column HD.bool
<*> HD.nullableColumn HD.int4 <*> nullableColumn HD.int4
<*> HD.nullableColumn HD.int4 <*> nullableColumn HD.int4
<*> HD.nullableColumn HD.text <*> nullableColumn HD.text
<*> HD.nullableColumn HD.text <*> nullableColumn HD.text
decodeRelations :: [Table] -> [Column] -> HD.Result [Relation] decodeRelations :: [Table] -> [Column] -> HD.Result [Relation]
decodeRelations tables cols = decodeRelations tables cols =
mapMaybe (relationFromRow tables cols) <$> HD.rowList relRow mapMaybe (relationFromRow tables cols) <$> HD.rowList relRow
where where
relRow = (,,,,,) relRow = (,,,,,)
<$> HD.column HD.text <$> column HD.text
<*> HD.column HD.text <*> column HD.text
<*> HD.column (HD.array (HD.dimension replicateM (HD.element HD.text))) <*> column (HD.array (HD.dimension replicateM (element HD.text)))
<*> HD.column HD.text <*> column HD.text
<*> HD.column HD.text <*> column HD.text
<*> HD.column (HD.array (HD.dimension replicateM (HD.element HD.text))) <*> column (HD.array (HD.dimension replicateM (element HD.text)))
decodePks :: [Table] -> HD.Result [PrimaryKey] decodePks :: [Table] -> HD.Result [PrimaryKey]
decodePks tables = decodePks tables =
mapMaybe (pkFromRow tables) <$> HD.rowList pkRow mapMaybe (pkFromRow tables) <$> HD.rowList pkRow
where where
pkRow = (,,) <$> HD.column HD.text <*> HD.column HD.text <*> HD.column HD.text pkRow = (,,) <$> column HD.text <*> column HD.text <*> column HD.text
decodeSynonyms :: [Column] -> HD.Result [Synonym] decodeSynonyms :: [Column] -> HD.Result [Synonym]
decodeSynonyms cols = decodeSynonyms cols =
mapMaybe (synonymFromRow cols) <$> HD.rowList synRow mapMaybe (synonymFromRow cols) <$> HD.rowList synRow
where where
synRow = (,,,,,) synRow = (,,,,,)
<$> HD.column HD.text <*> HD.column HD.text <$> column HD.text <*> column HD.text
<*> HD.column HD.text <*> HD.column HD.text <*> column HD.text <*> column HD.text
<*> HD.column HD.text <*> HD.column HD.text <*> column HD.text <*> column HD.text
decodeProcs :: HD.Result (M.HashMap Text [ProcDescription]) decodeProcs :: HD.Result (M.HashMap Text [ProcDescription])
decodeProcs = decodeProcs =
@@ -123,15 +135,15 @@ decodeProcs =
map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addName) <$> HD.rowList tblRow map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addName) <$> HD.rowList tblRow
where where
tblRow = ProcDescription tblRow = ProcDescription
<$> HD.column HD.text <$> column HD.text
<*> HD.nullableColumn HD.text <*> nullableColumn HD.text
<*> (parseArgs <$> HD.column HD.text) <*> (parseArgs <$> column HD.text)
<*> (parseRetType <*> (parseRetType
<$> HD.column HD.text <$> column HD.text
<*> HD.column HD.text <*> column HD.text
<*> HD.column HD.bool <*> column HD.bool
<*> HD.column HD.char) <*> column HD.char)
<*> (parseVolatility <$> HD.column HD.char) <*> (parseVolatility <$> column HD.char)
addName :: ProcDescription -> (Text, ProcDescription) addName :: ProcDescription -> (Text, ProcDescription)
addName pd = (pdName pd, pd) addName pd = (pdName pd, pd)
@@ -168,10 +180,10 @@ decodeProcs =
| otherwise = Volatile -- only 'v' can happen here | otherwise = Volatile -- only 'v' can happen here
allProcs :: H.Statement Schema (M.HashMap Text [ProcDescription]) allProcs :: H.Statement Schema (M.HashMap Text [ProcDescription])
allProcs = H.Statement (toS procsSqlQuery) (HE.param HE.text) decodeProcs True allProcs = H.Statement (toS procsSqlQuery) (param HE.text) decodeProcs True
accessibleProcs :: H.Statement Schema (M.HashMap Text [ProcDescription]) accessibleProcs :: H.Statement Schema (M.HashMap Text [ProcDescription])
accessibleProcs = H.Statement (toS sql) (HE.param HE.text) decodeProcs True accessibleProcs = H.Statement (toS sql) (param HE.text) decodeProcs True
where where
sql = procsSqlQuery <> " AND has_function_privilege(p.oid, 'execute')" sql = procsSqlQuery <> " AND has_function_privilege(p.oid, 'execute')"
@@ -196,7 +208,7 @@ procsSqlQuery = [q|
schemaDescription :: H.Statement Schema (Maybe Text) schemaDescription :: H.Statement Schema (Maybe Text)
schemaDescription = schemaDescription =
H.Statement sql (HE.param HE.text) (join <$> HD.rowMaybe (HD.nullableColumn HD.text)) True H.Statement sql (param HE.text) (join <$> HD.rowMaybe (nullableColumn HD.text)) True
where where
sql = [q| sql = [q|
select select
@@ -209,7 +221,7 @@ schemaDescription =
accessibleTables :: H.Statement Schema [Table] accessibleTables :: H.Statement Schema [Table]
accessibleTables = accessibleTables =
H.Statement sql (HE.param HE.text) decodeTables True H.Statement sql (param HE.text) decodeTables True
where where
sql = [q| sql = [q|
select select
@@ -351,7 +363,7 @@ addViewPrimaryKeys syns = concatMap (\pk ->
allTables :: H.Statement () [Table] allTables :: H.Statement () [Table]
allTables = allTables =
H.Statement sql HE.unit decodeTables True H.Statement sql HE.noParams decodeTables True
where where
sql = [q| sql = [q|
SELECT SELECT
@@ -374,7 +386,7 @@ allTables =
allColumns :: [Table] -> H.Statement Schema [Column] allColumns :: [Table] -> H.Statement Schema [Column]
allColumns tabs = allColumns tabs =
H.Statement sql (HE.param HE.text) (decodeColumns tabs) True H.Statement sql (param HE.text) (decodeColumns tabs) True
where where
sql = [q| sql = [q|
SELECT DISTINCT SELECT DISTINCT
@@ -561,7 +573,7 @@ columnFromRow tabs (s, t, n, desc, pos, nul, typ, u, l, p, d, e) = buildColumn <
allChildRelations :: [Table] -> [Column] -> H.Statement () [Relation] allChildRelations :: [Table] -> [Column] -> H.Statement () [Relation]
allChildRelations tabs cols = allChildRelations tabs cols =
H.Statement sql HE.unit (decodeRelations tabs cols) True H.Statement sql HE.noParams (decodeRelations tabs cols) True
where where
sql = [q| sql = [q|
SELECT ns1.nspname AS table_schema, SELECT ns1.nspname AS table_schema,
@@ -602,7 +614,7 @@ relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) =
allPrimaryKeys :: [Table] -> H.Statement () [PrimaryKey] allPrimaryKeys :: [Table] -> H.Statement () [PrimaryKey]
allPrimaryKeys tabs = allPrimaryKeys tabs =
H.Statement sql HE.unit (decodePks tabs) True H.Statement sql HE.noParams (decodePks tabs) True
where where
sql = [q| sql = [q|
/* /*
@@ -712,7 +724,7 @@ pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n
allSynonyms :: [Column] -> PgVersion -> H.Statement Schema [Synonym] allSynonyms :: [Column] -> PgVersion -> H.Statement Schema [Synonym]
allSynonyms cols pgVer = allSynonyms cols pgVer =
H.Statement sql (HE.param HE.text) (decodeSynonyms cols) True H.Statement sql (param HE.text) (decodeSynonyms cols) True
-- query explanation at https://gist.github.com/steve-chavez/7ee0e6590cddafb532e5f00c46275569 -- query explanation at https://gist.github.com/steve-chavez/7ee0e6590cddafb532e5f00c46275569
where where
subselectRegex :: Text subselectRegex :: Text
@@ -787,7 +799,7 @@ synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2
findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols
getPgVersion :: H.Session PgVersion getPgVersion :: H.Session PgVersion
getPgVersion = H.statement () $ H.Statement sql HE.unit versionRow False getPgVersion = H.statement () $ H.Statement sql HE.noParams versionRow False
where where
sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')" sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')"
versionRow = HD.singleRow $ PgVersion <$> HD.column HD.int4 <*> HD.column HD.text versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text
src/PostgREST/QueryBuilder.hs
+20 -8
View File
@@ -51,6 +51,18 @@ import PostgREST.RangeQuery (allRange, rangeLimit, rangeOffset)
import PostgREST.Types import PostgREST.Types
import Protolude hiding (cast, intercalate, replace) import Protolude hiding (cast, intercalate, replace)
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
element :: HD.Value a -> HD.Array a
element = HD.element . HD.nonNullable
param :: HE.Value a -> HE.Params a
param = HE.param . HE.nonNullable
{-| The generic query result format used by API responses. The location header {-| The generic query result format used by API responses. The location header
is represented as a list of strings containing variable bindings like is represented as a list of strings containing variable bindings like
@"k1=eq.42"@, or the empty list if there is no location header. @"k1=eq.42"@, or the empty list if there is no location header.
@@ -58,10 +70,10 @@ import Protolude hiding (cast, intercalate, replace)
type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString) type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString)
standardRow :: HD.Row ResultsWithCount standardRow :: HD.Row ResultsWithCount
standardRow = (,,,) <$> HD.nullableColumn HD.int8 <*> HD.column HD.int8 standardRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8
<*> HD.column header <*> HD.column HD.bytea <*> column header <*> column HD.bytea
where where
header = HD.array $ HD.dimension replicateM $ HD.element HD.bytea header = HD.array $ HD.dimension replicateM $ element HD.bytea
noLocationF :: Text noLocationF :: Text
noLocationF = "array[]::text[]" noLocationF = "array[]::text[]"
@@ -81,7 +93,7 @@ decodeStandardMay =
createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName -> createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName ->
H.Statement () ResultsWithCount H.Statement () ResultsWithCount
createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField = createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =
unicodeStatement sql HE.unit decodeStandard False unicodeStatement sql HE.noParams decodeStandard False
where where
sql = [qc| sql = [qc|
WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols} WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}
@@ -104,7 +116,7 @@ createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
PreferRepresentation -> [Text] -> PreferRepresentation -> [Text] ->
H.Statement ByteString (Maybe ResultsWithCount) H.Statement ByteString (Maybe ResultsWithCount)
createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys = createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys =
unicodeStatement sql (HE.param HE.unknown) decodeStandardMay True unicodeStatement sql (param HE.unknown) decodeStandardMay True
where where
sql = case rep of sql = case rep of
@@ -146,7 +158,7 @@ callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bo
Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion ->
H.Statement ByteString (Maybe ProcResults) H.Statement ByteString (Maybe ProcResults)
callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField pgVer = callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField pgVer =
unicodeStatement sql (HE.param HE.unknown) decodeProc True unicodeStatement sql (param HE.unknown) decodeProc True
where where
sql =[qc| sql =[qc|
WITH WITH
@@ -210,8 +222,8 @@ callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle para
else "'[]'" :: Text else "'[]'" :: Text
decodeProc = HD.rowMaybe procRow decodeProc = HD.rowMaybe procRow
procRow = (,,,) <$> HD.nullableColumn HD.int8 <*> HD.column HD.int8 procRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8
<*> HD.column HD.bytea <*> HD.column HD.bytea <*> column HD.bytea <*> column HD.bytea
pgFmtIdent :: SqlFragment -> SqlFragment pgFmtIdent :: SqlFragment -> SqlFragment
pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\"" pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""
stack.yaml
+6
View File
@@ -6,6 +6,12 @@ extra-deps:
- Ranged-sets-0.4.0 - Ranged-sets-0.4.0
- configurator-pg-0.1.0.3 - configurator-pg-0.1.0.3
- http-types-0.12.3 - http-types-0.12.3
- hasql-1.4
- hasql-pool-0.5.1
- hasql-transaction-0.7.2
- text-builder-0.6.5.1
- deferred-folds-0.9.10.1
- primitive-0.6.4.0
ghc-options: ghc-options:
postgrest: -O2 -Werror -Wall -fwarn-identities -fno-warn-redundant-constraints postgrest: -O2 -Werror -Wall -fwarn-identities -fno-warn-redundant-constraints
nix: nix: