From cb3977679d918e6a364cf82ae6c83528f2b5f28f Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 18 Jan 2016 15:00:17 -0800 Subject: [PATCH] App.hs compiles (dubiously) Removed query body is no longer a maybe value --- src/PostgREST/App.hs | 68 +++++++++++++++++------------------ src/PostgREST/Config.hs | 2 +- src/PostgREST/DbStructure.hs | 2 +- src/PostgREST/QueryBuilder.hs | 49 +++++++++++++------------ src/PostgREST/RangeQuery.hs | 12 +++---- src/PostgREST/Types.hs | 2 +- 6 files changed, 68 insertions(+), 67 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 90853917b..2012ea65f 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -10,8 +10,6 @@ import Control.Applicative import Control.Arrow ((***)) import Control.Monad (join) import Data.Bifunctor (first) -import qualified Data.ByteString.Lazy as BL -import Data.Functor.Identity import Data.List (find, sortBy, delete) import Data.Maybe (fromMaybe, fromJust, mapMaybe) import Data.Ord (comparing) @@ -33,7 +31,7 @@ import Data.Aeson import Data.Aeson.Types (emptyArray) import Data.Monoid import qualified Data.Vector as V -import qualified Hasql.Connection as H +import qualified Hasql.Session as H import PostgREST.Config (AppConfig (..)) import PostgREST.Parsers @@ -47,8 +45,7 @@ import PostgREST.Types import PostgREST.Auth (tokenJWT) import PostgREST.Error (errResponse) -import PostgREST.QueryBuilder ( asJson - , callProc +import PostgREST.QueryBuilder ( callProc , addJoinConditions , sourceCTEName , requestToQuery @@ -56,11 +53,12 @@ import PostgREST.QueryBuilder ( asJson , addRelations , createReadStatement , createWriteStatement + , ResultsWithCount ) import Prelude -app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response +app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Session Response app dbStructure conf reqBody req = let -- TODO: blow up for Left values (there is a middleware that checks the headers) @@ -80,17 +78,17 @@ app dbStructure conf reqBody req = if range == emptyRange then return $ errResponse status416 "HTTP Range error" else do - row <- H.maybeEx stm - let (tableTotal, queryTotal, _ , body) = extractQueryResult row + row <- H.query () stm + let (tableTotal, queryTotal, _ , body) = row if singular then return $ if queryTotal <= 0 then responseLBS status404 [] "" - else responseLBS status200 [contentTypeH] (fromMaybe "{}" body) + else responseLBS status200 [contentTypeH] (cs body) else do - let frm = rangeOffset range - to = frm+queryTotal-1 - contentRange = contentRangeH frm to tableTotal - status = rangeStatus frm to tableTotal + let frm = toInteger $ rangeOffset range + to = frm+(toInteger queryTotal)-1 + contentRange = contentRangeH frm to (toInteger <$> tableTotal) + status = rangeStatus frm to (toInteger <$> tableTotal) canonical = urlEncodeVars -- should this be moved to the dbStructure (location)? . sortBy (comparing fst) . map (join (***) cs) @@ -102,46 +100,47 @@ app dbStructure conf reqBody req = "/" <> cs (qiName qi) <> if Prelude.null canonical then "" else "?" <> cs canonical ) - ] (fromMaybe "[]" body) + ] (cs body) (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), - Just payload@(PayloadJSON (UniformObjects rows))) -> + Just payload@(PayloadJSON uniform@(UniformObjects rows))) -> case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do let isSingle = (==1) $ V.length rows let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload - row <- H.maybeEx stm + row <- H.query uniform stm let (_, _, location, body) = extractQueryResult row return $ responseLBS status201 [ contentTypeH, - (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) + (hLocation, "/" <> cs table <> "?" <> cs location) ] - $ if iPreferRepresentation apiRequest == Full then fromMaybe "[]" body else "" + $ if iPreferRepresentation apiRequest == Full then cs body else "" - (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON _)) -> + (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload - row <- H.maybeEx stm + row <- H.query uniform stm let (_, queryTotal, _, body) = extractQueryResult row - r = contentRangeH 0 (queryTotal-1) (Just queryTotal) + r = contentRangeH 0 (toInteger $ queryTotal-1) (toInteger <$> Just queryTotal) s = case () of _ | queryTotal == 0 -> status404 | iPreferRepresentation apiRequest == Full -> status200 | otherwise -> status204 return $ responseLBS s [contentTypeH, r] - $ if iPreferRepresentation apiRequest == Full then fromMaybe "[]" body else "" + $ if iPreferRepresentation apiRequest == Full then cs body else "" (ActionDelete, TargetIdent qi, Nothing) -> case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do - let fakeload = PayloadJSON $ UniformObjects V.empty + let emptyUniform = UniformObjects V.empty + let fakeload = PayloadJSON $ emptyUniform let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload - row <- H.maybeEx stm + row <- H.query emptyUniform stm let (_, queryTotal, _, _) = extractQueryResult row return $ if queryTotal == 0 then notFound @@ -158,25 +157,23 @@ app dbStructure conf reqBody req = (ActionInvoke, TargetIdent qi, Just (PayloadJSON (UniformObjects payload))) -> do - exists <- doesProcExist qi + exists <- H.query qi doesProcExist if exists then do let p = V.head payload - call = B.Stmt "select " V.empty True <> - asJson (callProc qi p) jwtSecret = configJwtSecret conf - bodyJson :: Maybe (Identity Value) <- H.maybeEx call - returnJWT <- doesProcReturnJWT qi + bodyJson <- H.query () (callProc qi p) + returnJWT <- H.query qi doesProcReturnJWT return $ responseLBS status200 [jsonH] - (let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in + (let body = fromMaybe emptyArray $ bodyJson in if returnJWT then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}" else cs $ encode body) else return notFound (ActionRead, TargetRoot, Nothing) -> do - body <- encode <$> accessibleTables (cs schema) + body <- encode <$> H.query schema accessibleTables return $ responseLBS status200 [jsonH] $ cs body (ActionUnknown _, _, _) -> return notFound @@ -204,14 +201,14 @@ app dbStructure conf reqBody req = readSqlParts = (,) <$> selectQuery <*> countQuery mutateSqlParts = (,) <$> selectQuery <*> mutateQuery -rangeStatus :: Int -> Int -> Maybe Int -> Status +rangeStatus :: Integer -> Integer -> Maybe Integer -> Status rangeStatus _ _ Nothing = status200 rangeStatus frm to (Just total) | frm > total = status416 | (1 + to - frm) < total = status206 | otherwise = status200 -contentRangeH :: Int -> Int -> Maybe Int -> Header +contentRangeH :: Integer -> Integer -> Maybe Integer -> Header contentRangeH frm to total = ("Content-Range", cs headerValue) where @@ -333,6 +330,5 @@ instance ToJSON TableOptions where , "pkey" .= tblOptpkey t ] -extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) - -> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) -extractQueryResult = fromMaybe (Just 0, 0, Just "", Just "") +extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount +extractQueryResult = fromMaybe (Nothing, 0, "", "") diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 91dd51fb5..f7392335e 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -42,7 +42,7 @@ data AppConfig = AppConfig { , configSchema :: String , configJwtSecret :: Secret , configPool :: Int - , configMaxRows :: Maybe Int + , configMaxRows :: Maybe Integer } argParser :: Parser AppConfig diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 162d245a9..dc620ed1d 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -26,7 +26,7 @@ import qualified Hasql.Session as H import PostgREST.Types import GHC.Exts (groupWith) -import GHC.Int (Int32) +import Data.Int (Int32) import Prelude getDbStructure :: Schema -> H.Session DbStructure diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 2b40f236e..54316f09e 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -15,7 +15,6 @@ Any function that outputs a SQL fragment should be in this module. module PostgREST.QueryBuilder ( addRelations , addJoinConditions - , asJson , callProc , createReadStatement , createWriteStatement @@ -26,6 +25,7 @@ module PostgREST.QueryBuilder ( , requestToCountQuery , sourceCTEName , unquoted + , ResultsWithCount ) where import qualified Hasql.Query as H @@ -62,7 +62,7 @@ import PostgREST.ApiRequest (PreferRepresentation (..)) {-| The generic query result format used by API responses -} -type ResultsWithCount = (Int64, Int64, BS.ByteString, BS.ByteString) +type ResultsWithCount = (Maybe Int64, Int64, BS.ByteString, BS.ByteString) {-| Read and Write api requests use a similar response format which includes various record counts and possible location header. This is the decoder @@ -72,7 +72,14 @@ decodeStandard :: HD.Result ResultsWithCount decodeStandard = HD.singleRow standardRow where - standardRow = (,,,) <$> HD.value HD.int8 <*> HD.value HD.int8 + standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8 + <*> HD.value HD.bytea <*> HD.value HD.bytea + +decodeStandardMay :: HD.Result (Maybe ResultsWithCount) +decodeStandardMay = + HD.maybeRow standardRow + where + standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8 <*> HD.value HD.bytea <*> HD.value HD.bytea {-| JSON and CSV payloads from the client are given to us as @@ -105,11 +112,11 @@ createReadStatement selectQuery countQuery range isSingle countTotal asCsv = createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> PreferRepresentation -> [Text] -> Bool -> Payload -> - H.Query UniformObjects ResultsWithCount + H.Query UniformObjects (Maybe ResultsWithCount) createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined createWriteStatement _ _ mutateQuery _ None _ _ (PayloadJSON (UniformObjects _)) = - H.statement sql encodeUniformObjs decodeStandard True + H.statement sql encodeUniformObjs decodeStandardMay True where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery}) @@ -117,7 +124,7 @@ createWriteStatement _ _ mutateQuery _ None createWriteStatement qi _ mutateQuery isSingle HeadersOnly pKeys _ (PayloadJSON (UniformObjects _)) = - H.statement sql encodeUniformObjs decodeStandard True + H.statement sql encodeUniformObjs decodeStandardMay True where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*) @@ -132,7 +139,7 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly createWriteStatement qi selectQuery mutateQuery isSingle Full pKeys asCsv (PayloadJSON (UniformObjects _)) = - H.statement sql encodeUniformObjs decodeStandard True + H.statement sql encodeUniformObjs decodeStandardMay True where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*) @@ -196,19 +203,18 @@ addJoinConditions schema (Node (query, (n, r)) forest) = updatedForest = mapM (addJoinConditions schema) forest addCond query' con = query'{flt_=con ++ flt_ query'} -asJson :: BS.ByteString -> BS.ByteString -asJson _sql = - [q| SELECT array_to_json( - coalesce(array_agg(row_to_json(t)), '{}') - )::character varying - from ({_sql}) t |] - -callProc :: QualifiedIdentifier -> JSON.Object -> BS.ByteString -callProc qi params = do - [qc| select * from {fromQi qi}({args}) |] +callProc :: QualifiedIdentifier -> JSON.Object -> H.Query () (Maybe JSON.Value) +callProc qi params = + H.statement sql HE.unit decodeObj True where - args = intercalate "," $ map assignment (HM.toList params) - assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v + sql = [q| SELECT array_to_json( + coalesce(array_agg(row_to_json(t)), '{}') + )::character varying + from ({_callSql}) t |] + _args = intercalate "," $ map _assignment (HM.toList params) + _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v + _callSql = [qc| select * from {fromQi qi}({_args}) |] :: BS.ByteString + decodeObj = HD.maybeRow (HD.value HD.json) operators :: [(Text, SqlFragment)] operators = [ @@ -327,7 +333,7 @@ requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects row "INSERT INTO ", fromQi qi, " (" <> colsString <> ")" <> " SELECT " <> colsString <> - " FROM json_populate_recordset(null::" , fromQi qi, ", ?)" + " FROM json_populate_recordset(null::" , fromQi qi, ", $1)" ] requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) = case rows V.!? 0 of @@ -393,8 +399,7 @@ locationF pKeys = if null pKeys then "" else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')" - ) <> - ")" + ) <> ")" limitF :: NonnegRange -> SqlFragment limitF r = "LIMIT " <> limit <> " OFFSET " <> offset diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index c82a88b3d..e65ce4b3f 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -24,7 +24,7 @@ import Data.Maybe (fromMaybe, listToMaybe) import Prelude -type NonnegRange = Range Int +type NonnegRange = Range Integer rangeParse :: BS.ByteString -> NonnegRange rangeParse range = do @@ -41,28 +41,28 @@ rangeParse range = do rangeRequested :: RequestHeaders -> NonnegRange rangeRequested = rangeParse . fromMaybe "" . lookup hRange -restrictRange :: Maybe Int -> NonnegRange -> NonnegRange +restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange restrictRange Nothing r = r restrictRange (Just limit) r = rangeIntersection r $ Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1) -rangeLimit :: NonnegRange -> Maybe Int +rangeLimit :: NonnegRange -> Maybe Integer rangeLimit range = case [rangeLower range, rangeUpper range] of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from) _ -> Nothing -rangeOffset :: NonnegRange -> Int +rangeOffset :: NonnegRange -> Integer rangeOffset range = case rangeLower range of BoundaryBelow from -> from _ -> error "range without lower bound" -- should never happen -rangeGeq :: Int -> NonnegRange +rangeGeq :: Integer -> NonnegRange rangeGeq n = Range (BoundaryBelow n) BoundaryAboveAll -rangeLeq :: Int -> NonnegRange +rangeLeq :: Integer -> NonnegRange rangeLeq n = Range BoundaryBelowAll (BoundaryAbove n) diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 4eb8c3487..4b5473f8e 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -5,7 +5,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS import qualified Data.Vector as V import Data.Aeson -import GHC.Int (Int32) +import Data.Int (Int32) data DbStructure = DbStructure { dbTables :: [Table]