From e0cc4d157106fb8978b00456181347cdb96ae1c7 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Thu, 28 Jun 2018 01:02:09 -0400 Subject: [PATCH] Update hasql Move to hasql 1.3. --- postgrest.cabal | 6 +- src/PostgREST/App.hs | 16 ++--- src/PostgREST/DbStructure.hs | 126 +++++++++++++++++----------------- src/PostgREST/Error.hs | 11 +-- src/PostgREST/QueryBuilder.hs | 30 ++++---- 5 files changed, 96 insertions(+), 93 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 252314749..acfe7af90 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -64,9 +64,9 @@ library , contravariant-extras , either , gitrev - , hasql == 1.1 - , hasql-pool == 0.4.3 - , hasql-transaction == 0.5.2 + , hasql >= 1.3 + , hasql-pool >= 0.5 + , hasql-transaction >= 0.7 , heredoc , HTTP , http-types diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 022d95acc..ff12b6ddf 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -102,7 +102,7 @@ findProc qi payloadKeys paramsAsSingleObject allProcs = else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs x)) ) <$> procs -transactionMode :: Maybe ProcDescription -> Action -> H.Mode +transactionMode :: Maybe ProcDescription -> Action -> HT.Mode transactionMode proc action = case action of ActionRead -> HT.Read @@ -131,7 +131,7 @@ app dbStructure proc conf apiRequest = Right ((q, cq), bField) -> do let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount (contentType == CTTextCSV) bField - row <- H.query () stm + row <- H.statement () stm let (tableTotal, queryTotal, _ , body) = row (status, contentRange) = rangeHeader queryTotal tableTotal canonical = iCanonicalQS apiRequest @@ -162,7 +162,7 @@ app dbStructure proc conf apiRequest = stm = createWriteStatement sq mq (contentType == CTSingularJSON) isSingle (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols - row <- H.query (toS pjRaw) stm + row <- H.statement (toS pjRaw) stm let (_, _, fs, body) = extractQueryResult row headers = catMaybes [ if null fs @@ -191,7 +191,7 @@ app dbStructure proc conf apiRequest = let stm = createWriteStatement sq mq (contentType == CTSingularJSON) False (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] - row <- H.query (toS pjRaw) stm + row <- H.statement (toS pjRaw) stm let (_, queryTotal, _, body) = extractQueryResult row if contentType == CTSingularJSON && queryTotal /= 1 @@ -224,7 +224,7 @@ app dbStructure proc conf apiRequest = else if S.fromList colNames /= pjKeys then return $ simpleError status400 [] "You must specify all columns in the payload when using PUT" else do - row <- H.query (toS pjRaw) $ + row <- H.statement (toS pjRaw) $ createWriteStatement sq mq (contentType == CTSingularJSON) False (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] let (_, queryTotal, _, body) = extractQueryResult row @@ -248,7 +248,7 @@ app dbStructure proc conf apiRequest = (contentType == CTSingularJSON) False (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] - row <- H.query mempty stm + row <- H.statement mempty stm let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 1 0 $ toInteger <$> if shouldCount then Just queryTotal else Nothing @@ -287,7 +287,7 @@ app dbStructure proc conf apiRequest = PJArray _ -> False singular = contentType == CTSingularJSON specifiedPgArgs = filter ((`S.member` pjKeys) . pgaName) $ fromMaybe [] (pdArgs <$> proc) - row <- H.query (toS pjRaw) $ + row <- H.statement (toS pjRaw) $ callProc qi specifiedPgArgs returnsScalar q cq shouldCount singular (iPreferSingleObjectParameter apiRequest) (contentType == CTTextCSV) @@ -316,7 +316,7 @@ app dbStructure proc conf apiRequest = toTableInfo :: [Table] -> [(Table, [Column], [Text])] toTableInfo = map (\t -> let (s, tn) = (tableSchema t, tableName t) in (t, tableCols dbStructure s tn, tablePKCols dbStructure s tn)) encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd $ dbPrimaryKeys dbStructure - body <- encodeApi <$> H.query schema accessibleTables <*> H.query schema schemaDescription <*> H.query schema accessibleProcs + body <- encodeApi <$> H.statement schema accessibleTables <*> H.statement schema schemaDescription <*> H.statement schema accessibleProcs return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body _ -> return notFound diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 99e792ec6..82a482100 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -14,7 +14,7 @@ module PostgREST.DbStructure ( import qualified Hasql.Decoders as HD import qualified Hasql.Encoders as HE -import qualified Hasql.Query as H +import qualified Hasql.Statement as H import Control.Applicative import qualified Data.HashMap.Strict as M @@ -34,12 +34,12 @@ import Unsafe (unsafeHead) getDbStructure :: Schema -> PgVersion -> H.Session DbStructure getDbStructure schema pgVer = do - tabs <- H.query () allTables - cols <- H.query schema $ allColumns tabs - syns <- H.query schema $ allSynonyms cols - childRels <- H.query () $ allChildRelations tabs cols - keys <- H.query () $ allPrimaryKeys tabs - procs <- H.query schema allProcs + tabs <- H.statement () allTables + cols <- H.statement schema $ allColumns tabs + syns <- H.statement schema $ allSynonyms cols + childRels <- H.statement () $ allChildRelations tabs cols + keys <- H.statement () $ allPrimaryKeys tabs + procs <- H.statement schema allProcs let rels = addManyToManyRelations . addParentRelations $ addViewRelations syns childRels cols' = addForeignKeys rels cols @@ -56,70 +56,70 @@ getDbStructure schema pgVer = do decodeTables :: HD.Result [Table] decodeTables = - HD.rowsList tblRow + HD.rowList tblRow where - tblRow = Table <$> HD.value HD.text - <*> HD.value HD.text - <*> HD.nullableValue HD.text - <*> HD.value HD.bool + tblRow = Table <$> HD.column HD.text + <*> HD.column HD.text + <*> HD.nullableColumn HD.text + <*> HD.column HD.bool decodeColumns :: [Table] -> HD.Result [Column] decodeColumns tables = - mapMaybe (columnFromRow tables) <$> HD.rowsList colRow + mapMaybe (columnFromRow tables) <$> HD.rowList colRow where colRow = (,,,,,,,,,,,) - <$> HD.value HD.text <*> HD.value HD.text - <*> HD.value HD.text <*> HD.nullableValue HD.text - <*> HD.value HD.int4 <*> HD.value HD.bool - <*> HD.value HD.text <*> HD.value HD.bool - <*> HD.nullableValue HD.int4 - <*> HD.nullableValue HD.int4 - <*> HD.nullableValue HD.text - <*> HD.nullableValue HD.text + <$> HD.column HD.text <*> HD.column HD.text + <*> HD.column HD.text <*> HD.nullableColumn HD.text + <*> HD.column HD.int4 <*> HD.column HD.bool + <*> HD.column HD.text <*> HD.column HD.bool + <*> HD.nullableColumn HD.int4 + <*> HD.nullableColumn HD.int4 + <*> HD.nullableColumn HD.text + <*> HD.nullableColumn HD.text decodeRelations :: [Table] -> [Column] -> HD.Result [Relation] decodeRelations tables cols = - mapMaybe (relationFromRow tables cols) <$> HD.rowsList relRow + mapMaybe (relationFromRow tables cols) <$> HD.rowList relRow where relRow = (,,,,,) - <$> HD.value HD.text - <*> HD.value HD.text - <*> HD.value (HD.array (HD.arrayDimension replicateM (HD.arrayValue HD.text))) - <*> HD.value HD.text - <*> HD.value HD.text - <*> HD.value (HD.array (HD.arrayDimension replicateM (HD.arrayValue HD.text))) + <$> HD.column HD.text + <*> HD.column HD.text + <*> HD.column (HD.array (HD.dimension replicateM (HD.element HD.text))) + <*> HD.column HD.text + <*> HD.column HD.text + <*> HD.column (HD.array (HD.dimension replicateM (HD.element HD.text))) decodePks :: [Table] -> HD.Result [PrimaryKey] decodePks tables = - mapMaybe (pkFromRow tables) <$> HD.rowsList pkRow + mapMaybe (pkFromRow tables) <$> HD.rowList pkRow where - pkRow = (,,) <$> HD.value HD.text <*> HD.value HD.text <*> HD.value HD.text + pkRow = (,,) <$> HD.column HD.text <*> HD.column HD.text <*> HD.column HD.text decodeSynonyms :: [Column] -> HD.Result [Synonym] decodeSynonyms cols = - mapMaybe (synonymFromRow cols) <$> HD.rowsList synRow + mapMaybe (synonymFromRow cols) <$> HD.rowList synRow where synRow = (,,,,,) - <$> HD.value HD.text <*> HD.value HD.text - <*> HD.value HD.text <*> HD.value HD.text - <*> HD.value HD.text <*> HD.value HD.text + <$> HD.column HD.text <*> HD.column HD.text + <*> HD.column HD.text <*> HD.column HD.text + <*> HD.column HD.text <*> HD.column HD.text decodeProcs :: HD.Result (M.HashMap Text [ProcDescription]) decodeProcs = -- Duplicate rows for a function means they're overloaded, order these by least args according to ProcDescription Ord instance - map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addName) <$> HD.rowsList tblRow + map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addName) <$> HD.rowList tblRow where tblRow = ProcDescription - <$> HD.value HD.text - <*> HD.nullableValue HD.text - <*> (parseArgs <$> HD.value HD.text) + <$> HD.column HD.text + <*> HD.nullableColumn HD.text + <*> (parseArgs <$> HD.column HD.text) <*> (parseRetType - <$> HD.value HD.text - <*> HD.value HD.text - <*> HD.value HD.bool - <*> HD.value HD.char) - <*> (parseVolatility <$> HD.value HD.char) + <$> HD.column HD.text + <*> HD.column HD.text + <*> HD.column HD.bool + <*> HD.column HD.char) + <*> (parseVolatility <$> HD.column HD.char) addName :: ProcDescription -> (Text, ProcDescription) addName pd = (pdName pd, pd) @@ -155,11 +155,11 @@ decodeProcs = | v == 's' = Stable | otherwise = Volatile -- only 'v' can happen here -allProcs :: H.Query Schema (M.HashMap Text [ProcDescription]) -allProcs = H.statement (toS procsSqlQuery) (HE.value HE.text) decodeProcs True +allProcs :: H.Statement Schema (M.HashMap Text [ProcDescription]) +allProcs = H.Statement (toS procsSqlQuery) (HE.param HE.text) decodeProcs True -accessibleProcs :: H.Query Schema (M.HashMap Text [ProcDescription]) -accessibleProcs = H.statement (toS sql) (HE.value HE.text) decodeProcs True +accessibleProcs :: H.Statement Schema (M.HashMap Text [ProcDescription]) +accessibleProcs = H.Statement (toS sql) (HE.param HE.text) decodeProcs True where sql = procsSqlQuery <> " AND has_function_privilege(p.oid, 'execute')" @@ -182,9 +182,9 @@ procsSqlQuery = [q| WHERE pn.nspname = $1 |] -schemaDescription :: H.Query Schema (Maybe Text) +schemaDescription :: H.Statement Schema (Maybe Text) schemaDescription = - H.statement sql (HE.value HE.text) (join <$> HD.maybeRow (HD.nullableValue HD.text)) True + H.Statement sql (HE.param HE.text) (join <$> HD.rowMaybe (HD.nullableColumn HD.text)) True where sql = [q| select @@ -195,9 +195,9 @@ schemaDescription = where n.nspname = $1 |] -accessibleTables :: H.Query Schema [Table] +accessibleTables :: H.Statement Schema [Table] accessibleTables = - H.statement sql (HE.value HE.text) decodeTables True + H.Statement sql (HE.param HE.text) decodeTables True where sql = [q| select @@ -324,9 +324,9 @@ addViewPrimaryKeys syns = concatMap (\pk -> filter (\(col, _) -> colTable col == pkTable pk && colName col == pkName pk) syns in pk : viewPks) -allTables :: H.Query () [Table] +allTables :: H.Statement () [Table] allTables = - H.statement sql HE.unit decodeTables True + H.Statement sql HE.unit decodeTables True where sql = [q| SELECT @@ -347,9 +347,9 @@ allTables = GROUP BY table_schema, table_name, insertable ORDER BY table_schema, table_name |] -allColumns :: [Table] -> H.Query Schema [Column] +allColumns :: [Table] -> H.Statement Schema [Column] allColumns tabs = - H.statement sql (HE.value HE.text) (decodeColumns tabs) True + H.Statement sql (HE.param HE.text) (decodeColumns tabs) True where sql = [q| SELECT DISTINCT @@ -534,9 +534,9 @@ columnFromRow tabs (s, t, n, desc, pos, nul, typ, u, l, p, d, e) = buildColumn < parseEnum :: Maybe Text -> [Text] parseEnum str = fromMaybe [] $ split (==',') <$> str -allChildRelations :: [Table] -> [Column] -> H.Query () [Relation] +allChildRelations :: [Table] -> [Column] -> H.Statement () [Relation] allChildRelations tabs cols = - H.statement sql HE.unit (decodeRelations tabs cols) True + H.Statement sql HE.unit (decodeRelations tabs cols) True where sql = [q| SELECT ns1.nspname AS table_schema, @@ -575,9 +575,9 @@ relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) = cols = mapM (findCol rs rt) rcs colsF = mapM (findCol frs frt) frcs -allPrimaryKeys :: [Table] -> H.Query () [PrimaryKey] +allPrimaryKeys :: [Table] -> H.Statement () [PrimaryKey] allPrimaryKeys tabs = - H.statement sql HE.unit (decodePks tabs) True + H.Statement sql HE.unit (decodePks tabs) True where sql = [q| /* @@ -685,9 +685,9 @@ pkFromRow :: [Table] -> (Schema, Text, Text) -> Maybe PrimaryKey pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs -allSynonyms :: [Column] -> H.Query Schema [Synonym] +allSynonyms :: [Column] -> H.Statement Schema [Synonym] allSynonyms cols = - H.statement sql (HE.value HE.text) (decodeSynonyms cols) True + H.Statement sql (HE.param HE.text) (decodeSynonyms cols) True -- query explanation at https://gist.github.com/steve-chavez/7ee0e6590cddafb532e5f00c46275569 where sql = [q| with @@ -756,7 +756,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 getPgVersion :: H.Session PgVersion -getPgVersion = H.query () $ H.statement sql HE.unit versionRow False +getPgVersion = H.statement () $ H.Statement sql HE.unit versionRow False where sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')" - versionRow = HD.singleRow $ PgVersion <$> HD.value HD.int4 <*> HD.value HD.text + versionRow = HD.singleRow $ PgVersion <$> HD.column HD.int4 <*> HD.column HD.text diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 0972b2819..f54a8e638 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -118,7 +118,10 @@ instance JSON.ToJSON P.UsageError where "details" .= (toS $ fromMaybe "" e :: Text)] toJSON (P.SessionError e) = JSON.toJSON e -- H.Error -instance JSON.ToJSON H.Error where +instance JSON.ToJSON H.QueryError where + toJSON (H.QueryError _ _ e) = JSON.toJSON e + +instance JSON.ToJSON H.CommandError where toJSON (H.ResultError (H.ServerError c m d h)) = case toS c of 'P':'T':_ -> JSON.object [ @@ -154,7 +157,7 @@ instance JSON.ToJSON H.Error where httpStatus :: Bool -> P.UsageError -> HT.Status httpStatus _ (P.ConnectionError _) = HT.status503 -httpStatus authed (P.SessionError (H.ResultError (H.ServerError c m _ _))) = +httpStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError (H.ServerError c m _ _)))) = case toS c of '0':'8':_ -> HT.status503 -- pg connection err '0':'9':_ -> HT.status500 -- triggered action exception @@ -184,5 +187,5 @@ httpStatus authed (P.SessionError (H.ResultError (H.ServerError c m _ _))) = "42501" -> if authed then HT.status403 else HT.status401 -- insufficient privilege 'P':'T':n -> fromMaybe HT.status500 (HT.mkStatus <$> readMaybe n <*> pure m) _ -> HT.status400 -httpStatus _ (P.SessionError (H.ResultError _)) = HT.status500 -httpStatus _ (P.SessionError (H.ClientError _)) = HT.status503 +httpStatus _ (P.SessionError (H.QueryError _ _ (H.ResultError _))) = HT.status500 +httpStatus _ (P.SessionError (H.QueryError _ _ (H.ClientError _))) = HT.status503 diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index e29ce6308..95bc25162 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -26,7 +26,7 @@ module PostgREST.QueryBuilder ( , pgFmtSetLocal ) where -import qualified Hasql.Query as H +import qualified Hasql.Statement as H import qualified Hasql.Encoders as HE import qualified Hasql.Decoders as HD @@ -58,10 +58,10 @@ import PostgREST.ApiRequest (PreferRepresentation (..)) type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString) standardRow :: HD.Row ResultsWithCount -standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8 - <*> HD.value header <*> HD.value HD.bytea +standardRow = (,,,) <$> HD.nullableColumn HD.int8 <*> HD.column HD.int8 + <*> HD.column header <*> HD.column HD.bytea where - header = HD.array $ HD.arrayDimension replicateM $ HD.arrayValue HD.bytea + header = HD.array $ HD.dimension replicateM $ HD.element HD.bytea noLocationF :: Text noLocationF = "array[]::text[]" @@ -76,10 +76,10 @@ decodeStandard = decodeStandardMay :: HD.Result (Maybe ResultsWithCount) decodeStandardMay = - HD.maybeRow standardRow + HD.rowMaybe standardRow createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName -> - H.Query () ResultsWithCount + H.Statement () ResultsWithCount createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField = unicodeStatement sql HE.unit decodeStandard False where @@ -102,9 +102,9 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> PreferRepresentation -> [Text] -> - H.Query ByteString (Maybe ResultsWithCount) + H.Statement ByteString (Maybe ResultsWithCount) createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys = - unicodeStatement sql (HE.value HE.unknown) decodeStandardMay True + unicodeStatement sql (HE.param HE.unknown) decodeStandardMay True where sql = case rep of @@ -139,9 +139,9 @@ createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys type ProcResults = (Maybe Int64, Int64, ByteString, ByteString) callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> Bool -> PgVersion -> - H.Query ByteString (Maybe ProcResults) + H.Statement ByteString (Maybe ProcResults) callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField isObject pgVer = - unicodeStatement sql (HE.value HE.unknown) decodeProc True + unicodeStatement sql (HE.param HE.unknown) decodeProc True where sql = if returnsScalar then [qc| @@ -182,9 +182,9 @@ callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle para if pgVer >= pgVersion96 then "coalesce(nullif(current_setting('response.headers', true), ''), '[]')" :: Text -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15 else "'[]'" :: Text - decodeProc = HD.maybeRow procRow - procRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8 - <*> HD.value HD.bytea <*> HD.value HD.bytea + decodeProc = HD.rowMaybe procRow + procRow = (,,,) <$> HD.nullableColumn HD.int8 <*> HD.column HD.int8 + <*> HD.column HD.bytea <*> HD.column HD.bytea scalarBodyF | asBinary = asBinaryF _procName | otherwise = "(row_to_json(_postgrest_t)->" <> pgFmtLit _procName <> ")::character varying" @@ -381,8 +381,8 @@ fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n n = qiName t s = qiSchema t -unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Query a b -unicodeStatement = H.statement . T.encodeUtf8 +unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Statement a b +unicodeStatement = H.Statement . T.encodeUtf8 emptyOnFalse :: Text -> Bool -> Text emptyOnFalse val cond = if cond then "" else val