From a0af096ff4f2cda0023ef5cea4ebcf69ecc7978d Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 18 Nov 2015 19:17:55 -0800 Subject: [PATCH 01/30] WIP: translate HTTP request into user intent The app code will base its logic off the intent data --- postgrest.cabal | 3 + src/PostgREST/RequestIntent.hs | 104 +++++++++++++++++++++++++++++++++ 2 files changed, 107 insertions(+) create mode 100644 src/PostgREST/RequestIntent.hs diff --git a/postgrest.cabal b/postgrest.cabal index c0b2b81ac..e76a2e824 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -72,6 +72,7 @@ executable postgrest , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery + , PostgREST.RequestIntent , PostgREST.Types library @@ -135,6 +136,7 @@ library , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery + , PostgREST.RequestIntent , PostgREST.Types hs-source-dirs: src @@ -165,6 +167,7 @@ Test-Suite spec , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery + , PostgREST.RequestIntent , PostgREST.Types , Spec , SpecHelper diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs new file mode 100644 index 000000000..58036c144 --- /dev/null +++ b/src/PostgREST/RequestIntent.hs @@ -0,0 +1,104 @@ +module PostgREST.RequestIntent where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.List (find) +import Data.Maybe (fromMaybe, isJust, isNothing, + listToMaybe) +import Network.Wai (Request (..)) +import Network.Wai.Parse (parseHttpAccept) +import PostgREST.RangeQuery (NonnegRange, rangeRequested) +import PostgREST.Types (QualifiedIdentifier (..), Schema) + +type RequestBody = BL.ByteString + +-- | Types of things a user wants to do to tables/views/procs +data Action = ActionCreate | ActionRead + | ActionUpdate | ActionDelete + | ActionInfo | ActionInvoke +-- | The target db object of a user action +data Target = TargetIdent QualifiedIdentifier + | TargetRoot +-- | Enumeration of currently supported content types for +-- route responses and upload payloads +data ContentType = ApplicationJSON | TextCSV +-- | When Hasql supports the COPY command then we can +-- have a special payload just for CSV, but until +-- then CSV is converted to a JSON array +data Payload = PayloadJSON JSON.Array + +-- | Describes what the user wants to do. This data type is a +-- translation of the raw elements of an HTTP request into domain +-- specific language. There is no guarantee that the intent is +-- sensible, it is up to a later stage of processing to determine +-- if it is an action we are able to perform. +data Intent = Intent { + -- | Set to Nothing for unknown HTTP verbs + iAction :: Maybe Action + -- | Set to Nothing for malformed range + , iRange :: Maybe NonnegRange + -- | Set to Nothing for strangely nested urls + , iTarget :: Maybe Target + -- | The content type the client most desires (or JSON if undecided) + , iAccepts :: Either BS.ByteString ContentType + -- | {foo} becomes [{foo}] and CSV is converted to JSON + , iPayload :: Maybe Payload + -- | Taken from JSON Web Token + , iTrustedClaims :: Maybe JSON.Object + -- | If client wants created items echoed back + , iPreferRepresentation :: Bool + -- | If client wants first row as raw object + , iPreferSingular :: Bool + } + +-- | Examines HTTP request and translates it into user intent. +userIntent :: Schema -> Request -> RequestBody -> Intent +userIntent schema req _ = + let action = case requestMethod req of + "GET" -> Just ActionRead + "POST" -> Just $ if isTargetingProc + then ActionInvoke + else ActionCreate + "PATCH" -> Just ActionUpdate + "DELETE" -> Just ActionDelete + "OPTIONS" -> Just ActionInfo + _ -> Nothing + target = case path of + [] -> Just TargetRoot + [table] -> Just $ TargetIdent + $ QualifiedIdentifier schema table + ["rpc", proc] -> Just $ TargetIdent + $ QualifiedIdentifier schema proc + _ -> Nothing in + + Intent action + (rangeRequested hdrs) + target + (pickContentType $ lookupHeader "accept") + Nothing -- TODO: calculate payload + Nothing -- TODO: decode jwt + (hasPrefer "return=representation") + (hasPrefer "plurality=singular") + + where + path = pathInfo req + isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path + hdrs = requestHeaders req + lookupHeader = flip lookup hdrs + hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs + +-- | Chooses a payload from the items in an accept header. +-- When possible it picks JSON. +pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType +pickContentType accept + | isNothing accept || has ctAll || has ctJson = Right ApplicationJSON + | has ctCsv = Right TextCSV + | otherwise = Left acceptH + where + ctAll = "*/*" + ctCsv = "text/csv" + ctJson = "application/json" + Just acceptH = accept + findInAccept = flip find $ parseHttpAccept acceptH + has = isJust . findInAccept . BS.isPrefixOf From ed18f2b1e8c8182e9ac1b0be0180c1ae0c3ae3ab Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 18 Nov 2015 20:17:49 -0800 Subject: [PATCH 02/30] Function to convert parsed CSV to array of JSON objects --- src/PostgREST/RequestIntent.hs | 51 ++++++++++++++++++++++++++-------- 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index 58036c144..ef19b286d 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -1,15 +1,20 @@ module PostgREST.RequestIntent where -import qualified Data.Aeson as JSON -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import Data.List (find) -import Data.Maybe (fromMaybe, isJust, isNothing, - listToMaybe) -import Network.Wai (Request (..)) -import Network.Wai.Parse (parseHttpAccept) -import PostgREST.RangeQuery (NonnegRange, rangeRequested) -import PostgREST.Types (QualifiedIdentifier (..), Schema) +import qualified Data.Aeson as JSON +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Csv as CSV +import Data.List (find) +import qualified Data.HashMap.Strict as M +import Data.Maybe (fromMaybe, isJust, isNothing, + listToMaybe) +import Data.String.Conversions (cs) +import qualified Data.Text as T +import qualified Data.Vector as V +import Network.Wai (Request (..)) +import Network.Wai.Parse (parseHttpAccept) +import PostgREST.RangeQuery (NonnegRange, rangeRequested) +import PostgREST.Types (QualifiedIdentifier (..), Schema) type RequestBody = BL.ByteString @@ -25,8 +30,9 @@ data Target = TargetIdent QualifiedIdentifier data ContentType = ApplicationJSON | TextCSV -- | When Hasql supports the COPY command then we can -- have a special payload just for CSV, but until --- then CSV is converted to a JSON array +-- then CSV is converted to a JSON array. data Payload = PayloadJSON JSON.Array + | PayloadParseError BS.ByteString -- | Describes what the user wants to do. This data type is a -- translation of the raw elements of an HTTP request into domain @@ -42,7 +48,7 @@ data Intent = Intent { , iTarget :: Maybe Target -- | The content type the client most desires (or JSON if undecided) , iAccepts :: Either BS.ByteString ContentType - -- | {foo} becomes [{foo}] and CSV is converted to JSON + -- | Set to Nothing when client sends no data , iPayload :: Maybe Payload -- | Taken from JSON Web Token , iTrustedClaims :: Maybe JSON.Object @@ -88,6 +94,8 @@ userIntent schema req _ = lookupHeader = flip lookup hdrs hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs +-- PRIVATE --------------------------------------------------------------- + -- | Chooses a payload from the items in an accept header. -- When possible it picks JSON. pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType @@ -102,3 +110,22 @@ pickContentType accept Just acceptH = accept findInAccept = flip find $ parseHttpAccept acceptH has = isJust . findInAccept . BS.isPrefixOf + +type CsvData = V.Vector (V.Vector BL.ByteString) + +-- | Convert +-- a,b +-- 1,2 +-- 3,4 +-- +-- into +-- [ {"a": 1, "b": 2}, {"a": 3, "b": 4} ] +csvToJson :: (CSV.Header, CsvData) -> JSON.Array +csvToJson (cols, vals) = + V.map rowToJson vals + where + cols' = V.map cs cols :: V.Vector T.Text + rowToJson :: V.Vector BL.ByteString -> JSON.Value + rowToJson val = JSON.Object $ + let val' = V.map (JSON.String . cs) val in + M.fromList . V.toList $ V.zip cols' val' From ffeb02e72e887720b9df9201ad67732a62837e8b Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 18 Nov 2015 23:43:47 -0800 Subject: [PATCH 03/30] Include request payload in userIntent --- src/PostgREST/RequestIntent.hs | 67 +++++++++++++++++++++++----------- 1 file changed, 46 insertions(+), 21 deletions(-) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index ef19b286d..9fa56584a 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -8,6 +8,7 @@ import Data.List (find) import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe) +import Data.Monoid ((<>)) import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.Vector as V @@ -48,8 +49,8 @@ data Intent = Intent { , iTarget :: Maybe Target -- | The content type the client most desires (or JSON if undecided) , iAccepts :: Either BS.ByteString ContentType - -- | Set to Nothing when client sends no data - , iPayload :: Maybe Payload + -- | Data sent by client and used for mutation actions + , iPayload :: Payload -- | Taken from JSON Web Token , iTrustedClaims :: Maybe JSON.Object -- | If client wants created items echoed back @@ -60,7 +61,7 @@ data Intent = Intent { -- | Examines HTTP request and translates it into user intent. userIntent :: Schema -> Request -> RequestBody -> Intent -userIntent schema req _ = +userIntent schema req reqBody = let action = case requestMethod req of "GET" -> Just ActionRead "POST" -> Just $ if isTargetingProc @@ -76,13 +77,25 @@ userIntent schema req _ = $ QualifiedIdentifier schema table ["rpc", proc] -> Just $ TargetIdent $ QualifiedIdentifier schema proc - _ -> Nothing in + _ -> Nothing + reqPayload = case pickContentType (lookupHeader "content-type") of + Right ApplicationJSON -> + either (PayloadParseError . cs) + (PayloadJSON . pluralize) + (JSON.eitherDecode reqBody) + Right TextCSV -> + either (PayloadParseError . cs) + (PayloadJSON . csvToJson) + (CSV.decodeByName reqBody) + Left accept -> + PayloadParseError $ + "Content-type not acceptable: " <> accept in Intent action (rangeRequested hdrs) target (pickContentType $ lookupHeader "accept") - Nothing -- TODO: calculate payload + reqPayload Nothing -- TODO: decode jwt (hasPrefer "return=representation") (hasPrefer "plurality=singular") @@ -94,6 +107,7 @@ userIntent schema req _ = lookupHeader = flip lookup hdrs hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs + -- PRIVATE --------------------------------------------------------------- -- | Chooses a payload from the items in an accept header. @@ -102,30 +116,41 @@ pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType pickContentType accept | isNothing accept || has ctAll || has ctJson = Right ApplicationJSON | has ctCsv = Right TextCSV - | otherwise = Left acceptH + | otherwise = Left accept' where ctAll = "*/*" ctCsv = "text/csv" ctJson = "application/json" - Just acceptH = accept - findInAccept = flip find $ parseHttpAccept acceptH + Just accept' = accept + findInAccept = flip find $ parseHttpAccept accept' has = isJust . findInAccept . BS.isPrefixOf -type CsvData = V.Vector (V.Vector BL.ByteString) +type CsvData = V.Vector (M.HashMap T.Text BL.ByteString) --- | Convert +-- | Converts CSV like -- a,b --- 1,2 --- 3,4 +-- 1,hi +-- 2,bye -- --- into --- [ {"a": 1, "b": 2}, {"a": 3, "b": 4} ] +-- into a JSON array like +-- [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ] +-- +-- The reason for its odd signature is so that it can compose +-- directly with CSV.decodeByName csvToJson :: (CSV.Header, CsvData) -> JSON.Array -csvToJson (cols, vals) = - V.map rowToJson vals +csvToJson (_, vals) = + V.map rowToJsonObj vals where - cols' = V.map cs cols :: V.Vector T.Text - rowToJson :: V.Vector BL.ByteString -> JSON.Value - rowToJson val = JSON.Object $ - let val' = V.map (JSON.String . cs) val in - M.fromList . V.toList $ V.zip cols' val' + rowToJsonObj = JSON.Object . + M.map (\str -> + if str == "NULL" + then JSON.Null + else JSON.String $ cs str + ) + +-- | Convert {foo} to [{foo}], leave arrays unchanged +-- and truncate everything else to an empty array. +pluralize :: JSON.Value -> JSON.Array +pluralize obj@(JSON.Object _) = V.singleton obj +pluralize (JSON.Array arr) = arr +pluralize _ = V.empty From b260cff6fd470c5b85ee4c7be4aee45f6a5713d7 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 18 Nov 2015 23:48:32 -0800 Subject: [PATCH 04/30] Provide more context for unknown actions --- src/PostgREST/RequestIntent.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index 9fa56584a..d90f21d28 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -23,6 +23,7 @@ type RequestBody = BL.ByteString data Action = ActionCreate | ActionRead | ActionUpdate | ActionDelete | ActionInfo | ActionInvoke + | ActionUnknown BS.ByteString -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier | TargetRoot @@ -42,7 +43,7 @@ data Payload = PayloadJSON JSON.Array -- if it is an action we are able to perform. data Intent = Intent { -- | Set to Nothing for unknown HTTP verbs - iAction :: Maybe Action + iAction :: Action -- | Set to Nothing for malformed range , iRange :: Maybe NonnegRange -- | Set to Nothing for strangely nested urls @@ -63,14 +64,14 @@ data Intent = Intent { userIntent :: Schema -> Request -> RequestBody -> Intent userIntent schema req reqBody = let action = case requestMethod req of - "GET" -> Just ActionRead - "POST" -> Just $ if isTargetingProc + "GET" -> ActionRead + "POST" -> if isTargetingProc then ActionInvoke else ActionCreate - "PATCH" -> Just ActionUpdate - "DELETE" -> Just ActionDelete - "OPTIONS" -> Just ActionInfo - _ -> Nothing + "PATCH" -> ActionUpdate + "DELETE" -> ActionDelete + "OPTIONS" -> ActionInfo + other -> ActionUnknown other target = case path of [] -> Just TargetRoot [table] -> Just $ TargetIdent From 8f04967103ed6d9d402bbc1084cb2cabddccd772 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 18 Nov 2015 23:51:59 -0800 Subject: [PATCH 05/30] Provide more context about unknown routes --- src/PostgREST/RequestIntent.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index d90f21d28..50c07428d 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -27,6 +27,7 @@ data Action = ActionCreate | ActionRead -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier | TargetRoot + | TargetUnknown [T.Text] -- | Enumeration of currently supported content types for -- route responses and upload payloads data ContentType = ApplicationJSON | TextCSV @@ -47,7 +48,7 @@ data Intent = Intent { -- | Set to Nothing for malformed range , iRange :: Maybe NonnegRange -- | Set to Nothing for strangely nested urls - , iTarget :: Maybe Target + , iTarget :: Target -- | The content type the client most desires (or JSON if undecided) , iAccepts :: Either BS.ByteString ContentType -- | Data sent by client and used for mutation actions @@ -73,12 +74,12 @@ userIntent schema req reqBody = "OPTIONS" -> ActionInfo other -> ActionUnknown other target = case path of - [] -> Just TargetRoot - [table] -> Just $ TargetIdent - $ QualifiedIdentifier schema table - ["rpc", proc] -> Just $ TargetIdent - $ QualifiedIdentifier schema proc - _ -> Nothing + [] -> TargetRoot + [table] -> TargetIdent + $ QualifiedIdentifier schema table + ["rpc", proc] -> TargetIdent + $ QualifiedIdentifier schema proc + other -> TargetUnknown other reqPayload = case pickContentType (lookupHeader "content-type") of Right ApplicationJSON -> either (PayloadParseError . cs) From 496cd775107bffdefdd1e74fd0be6be2b877f15e Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 18 Nov 2015 23:56:59 -0800 Subject: [PATCH 06/30] More docs for pickContentType --- src/PostgREST/RequestIntent.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index 50c07428d..a8e56eb94 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -112,8 +112,14 @@ userIntent schema req reqBody = -- PRIVATE --------------------------------------------------------------- --- | Chooses a payload from the items in an accept header. --- When possible it picks JSON. +-- | Picks a preferred content type from an Accept header (or from +-- Content-Type as a degenerate case). +-- +-- For example +-- text/csv -> TextCSV +-- */* -> ApplicationJSON +-- text/csv, application/json -> TextCSV +-- application/json, text/csv -> ApplicationJSON pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType pickContentType accept | isNothing accept || has ctAll || has ctJson = Right ApplicationJSON From 2c3a52fc35159166c8064ae42a3067094849b240 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 19 Nov 2015 00:03:48 -0800 Subject: [PATCH 07/30] Cool person style for long comments --- src/PostgREST/RequestIntent.hs | 52 +++++++++++++++++++--------------- 1 file changed, 29 insertions(+), 23 deletions(-) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index a8e56eb94..29b01ad03 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -37,11 +37,13 @@ data ContentType = ApplicationJSON | TextCSV data Payload = PayloadJSON JSON.Array | PayloadParseError BS.ByteString --- | Describes what the user wants to do. This data type is a --- translation of the raw elements of an HTTP request into domain --- specific language. There is no guarantee that the intent is --- sensible, it is up to a later stage of processing to determine --- if it is an action we are able to perform. +{-| + Describes what the user wants to do. This data type is a + translation of the raw elements of an HTTP request into domain + specific language. There is no guarantee that the intent is + sensible, it is up to a later stage of processing to determine + if it is an action we are able to perform. +-} data Intent = Intent { -- | Set to Nothing for unknown HTTP verbs iAction :: Action @@ -112,14 +114,16 @@ userIntent schema req reqBody = -- PRIVATE --------------------------------------------------------------- --- | Picks a preferred content type from an Accept header (or from --- Content-Type as a degenerate case). --- --- For example --- text/csv -> TextCSV --- */* -> ApplicationJSON --- text/csv, application/json -> TextCSV --- application/json, text/csv -> ApplicationJSON +{-| + Picks a preferred content type from an Accept header (or from + Content-Type as a degenerate case). + + For example + text/csv -> TextCSV + */* -> ApplicationJSON + text/csv, application/json -> TextCSV + application/json, text/csv -> ApplicationJSON +-} pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType pickContentType accept | isNothing accept || has ctAll || has ctJson = Right ApplicationJSON @@ -135,16 +139,18 @@ pickContentType accept type CsvData = V.Vector (M.HashMap T.Text BL.ByteString) --- | Converts CSV like --- a,b --- 1,hi --- 2,bye --- --- into a JSON array like --- [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ] --- --- The reason for its odd signature is so that it can compose --- directly with CSV.decodeByName +{-| + Converts CSV like + a,b + 1,hi + 2,bye + + into a JSON array like + [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ] + + The reason for its odd signature is so that it can compose + directly with CSV.decodeByName +-} csvToJson :: (CSV.Header, CsvData) -> JSON.Array csvToJson (_, vals) = V.map rowToJsonObj vals From 87c946ef5217f332b55c1a13f2af3de97045e6d1 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 19 Nov 2015 09:58:41 -0800 Subject: [PATCH 08/30] Treat JWT as a Secret, not String --- src/PostgREST/App.hs | 2 +- src/PostgREST/Auth.hs | 8 ++++---- src/PostgREST/Config.hs | 6 ++++-- src/PostgREST/Main.hs | 3 ++- src/PostgREST/Middleware.hs | 2 +- 5 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index bac5a4960..cd72a0d66 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -184,7 +184,7 @@ app dbStructure conf reqBody req = hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs accept = lookupHeader hAccept schema = cs $ configSchema conf - jwtSecret = (cs $ configJwtSecret conf) :: Text + jwtSecret = configJwtSecret conf range = rangeRequested hdrs allOrigins = ("Access-Control-Allow-Origin", "*") :: Header contentType = fromMaybe "application/json" $ contentTypeForAccept accept diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 22d7de82a..f46da3c71 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -51,7 +51,7 @@ claimsToSQL = map setVar . toList returns a map of JWT claims In case there is any problem decoding the JWT it returns Nothing. -} -jwtClaims :: Text -> Text -> NominalDiffTime -> Maybe JWT.ClaimsMap +jwtClaims :: JWT.Secret -> Text -> NominalDiffTime -> Maybe JWT.ClaimsMap jwtClaims secret input time = case join $ claim JWT.exp of Just expires -> @@ -60,7 +60,7 @@ jwtClaims secret input time = else Nothing _ -> customClaims where - decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input + decoded = JWT.decodeAndVerifySignature secret input claim :: (JWT.JWTClaimsSet -> a) -> Maybe a claim prop = prop . JWT.claims <$> decoded customClaims = claim JWT.unregisteredClaims @@ -74,8 +74,8 @@ setRole role = "set local role " <> cs (pgFmtLit role) <> ";" Receives the JWT secret (from config) and a JWT and a JSON value and returns a signed JWT. -} -tokenJWT :: Text -> Value -> Text -tokenJWT secret (Array a) = JWT.encodeSigned JWT.HS256 (JWT.secret secret) +tokenJWT :: JWT.Secret -> Value -> Text +tokenJWT secret (Array a) = JWT.encodeSigned JWT.HS256 secret JWT.def { JWT.unregisteredClaims = fromHashMap o } where Object o = if V.null a then emptyObject else V.head a diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 17a94ff07..e7a9cc110 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -30,6 +30,7 @@ import Network.Wai import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) import Options.Applicative import Paths_postgrest (version) +import Web.JWT (Secret, secret) import Prelude -- | Data type to store all command line options @@ -38,7 +39,7 @@ data AppConfig = AppConfig { , configPort :: Int , configAnonRole :: String , configSchema :: String - , configJwtSecret :: String + , configJwtSecret :: Secret , configPool :: Int } @@ -49,7 +50,8 @@ argParser = AppConfig <*> option auto (long "port" <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault) <*> strOption (long "anonymous" <> short 'a' <> help "postgres role to use for non-authenticated requests" <> metavar "ROLE") <*> strOption (long "schema" <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "1" <> showDefault) - <*> strOption (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault) + <*> (secret . cs <$> + strOption (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault)) <*> option auto (long "pool" <> short 'o' <> help "max connections in database pool" <> metavar "COUNT" <> value 10 <> showDefault) defaultCorsPolicy :: CorsResourcePolicy diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 02640cdd5..fed0c41df 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -25,6 +25,7 @@ import Network.Wai.Middleware.RequestLogger (logStdout) import System.IO (BufferMode (..), hSetBuffering, stderr, stdin, stdout) +import Web.JWT (secret) isServerVersionSupported :: H.Session P.Postgres IO Bool isServerVersionSupported = do @@ -43,7 +44,7 @@ main = do conf <- readOptions let port = configPort conf - unless ("secret" /= configJwtSecret conf) $ + unless (secret "secret" /= configJwtSecret conf) $ putStrLn "WARNING, running in insecure mode, JWT secret is the default value" Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 6a60f20d0..a8e800768 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -51,7 +51,7 @@ runWithClaims conf app req = do where stmt c = B.Stmt c V.empty True hdrs = requestHeaders req - jwtSecret = (cs $ configJwtSecret conf) :: Text + jwtSecret = configJwtSecret conf auth = fromMaybe "" $ lookup hAuthorization hdrs anon = cs $ configAnonRole conf setAnon = setRole anon From f3d5759c1a93387357450032f89ecba403c00fe8 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 19 Nov 2015 10:21:27 -0800 Subject: [PATCH 09/30] JWT is handled by middleware, do not need it in Intent --- src/PostgREST/RequestIntent.hs | 3 --- test/SpecHelper.hs | 3 ++- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index 29b01ad03..326fe05be 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -55,8 +55,6 @@ data Intent = Intent { , iAccepts :: Either BS.ByteString ContentType -- | Data sent by client and used for mutation actions , iPayload :: Payload - -- | Taken from JSON Web Token - , iTrustedClaims :: Maybe JSON.Object -- | If client wants created items echoed back , iPreferRepresentation :: Bool -- | If client wants first row as raw object @@ -100,7 +98,6 @@ userIntent schema req reqBody = target (pickContentType $ lookupHeader "accept") reqPayload - Nothing -- TODO: decode jwt (hasPrefer "return=representation") (hasPrefer "plurality=singular") diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 2a7cb123a..f7c429cca 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -23,6 +23,7 @@ import Data.Maybe (fromMaybe) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import System.Process (readProcess) +import Web.JWT (secret) import qualified Data.Aeson.Types as J @@ -40,7 +41,7 @@ isLeft (Left _ ) = True isLeft _ = False cfg :: AppConfig -cfg = AppConfig dbString 3000 "postgrest_anonymous" "test" "safe" 10 +cfg = AppConfig dbString 3000 "postgrest_anonymous" "test" (secret "safe") 10 testPoolOpts :: PoolSettings testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30 From b6a58935f3b8ebb25d11958dd49e9f2cd047e5b4 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 19 Nov 2015 11:21:27 -0800 Subject: [PATCH 10/30] Greater type safety for OrderTerm --- src/PostgREST/Parsers.hs | 12 ++++++++---- src/PostgREST/QueryBuilder.hs | 16 ++++++++++++++-- src/PostgREST/Types.hs | 10 ++++++---- 3 files changed, 28 insertions(+), 10 deletions(-) diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 933b6d970..d58a46d0b 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -101,8 +101,12 @@ pOrderTerm = try ( do c <- pFieldName _ <- pDelimiter - d <- string "asc" <|> string "desc" - nls <- optionMaybe (pDelimiter *> ( try(string "nullslast" *> pure ("nulls last"::String)) <|> try(string "nullsfirst" *> pure ("nulls first"::String)))) - return $ OrderTerm (cs c) (cs d) (cs <$> nls) + d <- (string "asc" *> pure OrderAsc) + <|> (string "desc" *> pure OrderDesc) + nls <- optionMaybe (pDelimiter *> ( + try(string "nullslast" *> pure OrderNullsLast) + <|> try(string "nullsfirst" *> pure OrderNullsFirst) + )) + return $ OrderTerm c d nls ) - <|> OrderTerm <$> (cs <$> pFieldName) <*> pure "asc" <*> pure Nothing + <|> OrderTerm <$> (cs <$> pFieldName) <*> pure OrderAsc <*> pure Nothing diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 2e2a4e0db..f2a56d135 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -321,8 +321,20 @@ orderF ts = queryTerm :: OrderTerm -> Text queryTerm t = " " <> cs (pgFmtIdent $ otTerm t) <> " " - <> cs (otDirection t) <> " " - <> maybe "" cs (otNullOrder t) <> " " + <> sqlOrderDirection (otDirection t) <> " " + <> maybe "" sqlOrderNulls (otNullOrder t) <> " " + +sqlOrderDirection :: OrderDirection -> SqlFragment +sqlOrderDirection d = + case d of + OrderDesc -> "desc" + OrderAsc -> "asc" + +sqlOrderNulls :: OrderNulls -> SqlFragment +sqlOrderNulls d = + case d of + OrderNullsFirst -> "nulls first" + OrderNullsLast -> "nulls last" insertableValue :: JSON.Value -> SqlFragment insertableValue JSON.Null = "null" diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 795c87e32..02243c20a 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -1,8 +1,7 @@ module PostgREST.Types where import Data.Text import Data.Tree -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy as BL import Data.Aeson import Data.Map @@ -51,10 +50,13 @@ data PrimaryKey = PrimaryKey { , pkName :: Text } deriving (Show, Eq) +data OrderDirection = OrderAsc | OrderDesc deriving (Show, Eq) +data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Show, Eq) + data OrderTerm = OrderTerm { otTerm :: Text -, otDirection :: BS.ByteString -, otNullOrder :: Maybe BS.ByteString +, otDirection :: OrderDirection +, otNullOrder :: Maybe OrderNulls } deriving (Show, Eq) data QualifiedIdentifier = QualifiedIdentifier { From c80ab6be0f20ed6b9403660ca3a1bcd67e20cccf Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 19 Nov 2015 20:45:24 -0800 Subject: [PATCH 11/30] WIP: converting App --- src/PostgREST/App.hs | 237 ++++++++++++++++++--------------- src/PostgREST/DbStructure.hs | 12 +- src/PostgREST/RequestIntent.hs | 8 +- 3 files changed, 143 insertions(+), 114 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index cd72a0d66..a9ae15570 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -47,6 +47,9 @@ import PostgREST.Config (AppConfig (..)) import PostgREST.Parsers import PostgREST.DbStructure import PostgREST.RangeQuery +import PostgREST.RequestIntent (Intent(..), ContentType(..) + , Action(..), Target(..) + , Payload(..), userIntent) import PostgREST.Types import PostgREST.Auth (tokenJWT) import PostgREST.Error (errResponse) @@ -72,89 +75,42 @@ import Prelude app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response app dbStructure conf reqBody req = - case (path, verb) of - ([table], "OPTIONS") -> do - let cols = filter (filterCol schema table) $ dbColumns dbStructure - pkeys = map pkName $ filter (filterPk schema table) allPrKeys + let schema = configSchema conf + intent = userIntent schema req reqBody + -- TODO: blow up for Left values + contentType = either (const ApplicationJSON) id (iAccepts intent) + contentTypeH = (hContentType, contentType) in + + case (iAction intent, iTarget intent, iPayload intent) of + (ActionUnknown _, _, _) -> return notFound + (_, TargetUnknown _, _) -> return notFound + (_, _, PayloadParseError e) -> + return $ responseLBS status400 [jsonH] + (formatGeneralError "Cannot parse request payload" e) + + (ActionInfo, TargetIdent tSchema tTable, _) -> do + let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure + pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys body = encode (TableOptions cols pkeys) filterCol :: Schema -> TableName -> Column -> Bool filterCol sc tb (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && t==tb filterCol _ _ _ = False - return $ responseLBS status200 [jsonH, allOrigins] $ cs body - ([table], _) -> - case request of - Left e -> return $ responseLBS status400 [jsonH] $ cs e - Right (selectQuery, Nothing) -> -- should we do sanity check to make sure its a GET request? - if range == Just emptyRange - then return $ errResponse status416 "HTTP Range error" - else do - let q = createReadStatement selectQuery (if singular then Nothing else range) singular (not $ hasPrefer "count=none") isCsv - row <- H.maybeEx q - let (tableTotal, queryTotal, _ , body) = extractQueryResult row - if singular - then return $ if queryTotal <= 0 - then responseLBS status404 [] "" - else responseLBS status200 [contentTypeH] (fromMaybe "{}" body) - else do - let frm = fromMaybe 0 $ rangeOffset <$> range - to = frm+queryTotal-1 - contentRange = contentRangeH frm to tableTotal - status = rangeStatus frm to tableTotal - canonical = urlEncodeVars -- should this be moved to the dbStructure (location)? - . sortBy (comparing fst) - . map (join (***) cs) - . parseSimpleQuery - $ rawQueryString req - return $ responseLBS status - [contentTypeH, contentRange, - ("Content-Location", - "/" <> cs table <> - if Prelude.null canonical then "" else "?" <> cs canonical - ) - ] (fromMaybe "[]" body) - Right (selectQuery, Just (mutateQuery, isSingle)) -> - case verb of - "POST" -> do - let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? - q = createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys isCsv - row <- H.maybeEx q - let (_, _, location, body) = extractQueryResult row - return $ responseLBS status201 - [ - contentTypeH, - (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) - ] - $ if echoRequested then fromMaybe "[]" body else "" - "PATCH" -> do - let q = createWriteStatement selectQuery mutateQuery False echoRequested [] isCsv - row <- H.maybeEx q - let (_, queryTotal, _, body) = extractQueryResult row - r = contentRangeH 0 (queryTotal-1) (Just queryTotal) - s = case () of _ | queryTotal == 0 -> status404 - | echoRequested -> status200 - | otherwise -> status204 - return $ responseLBS s [contentTypeH, r] - $ if echoRequested then fromMaybe "[]" body else "" - "DELETE" -> do - let q = createWriteStatement selectQuery mutateQuery False False [] isCsv - row <- H.maybeEx q - let (_, queryTotal, _, _) = extractQueryResult row - return $ if queryTotal == 0 - then notFound - else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] "" - _ -> return notFound + (ActionRead, TargetRoot, _) -> do + body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure)) + return $ responseLBS status200 [jsonH] $ cs body - (["rpc", proc], "POST") -> do - let qi = QualifiedIdentifier schema (cs proc) - exists <- doesProcExist schema proc + (ActionInvoke, TargetIdent qi, PayloadJSON payload) -> do + exists <- doesProcExist (qiSchema qi) (qiName qi) if exists then do let call = B.Stmt "select " V.empty True <> - asJson (callProc qi $ fromMaybe HM.empty (decode reqBody)) + asJson (callProc qi payload) + jwtSecret = configJwtSecret conf + bodyJson :: Maybe (Identity Value) <- H.maybeEx call - returnJWT <- doesProcReturnJWT schema proc + returnJWT <- doesProcReturnJWT qi return $ responseLBS status200 [jsonH] (let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in if returnJWT @@ -162,37 +118,99 @@ app dbStructure conf reqBody req = else cs $ encode body) else return notFound - -- check that proc exists - -- check that arg names are all specified - -- select * from public.proc(a := "foo"::undefined) where whereT limit limitT + (ActionRead, TargetIdent qi, _) -> do + let range = iRange intent + singular = iPreferSingular intent + selectQuery = requestToQuery schema <$> selectApiRequest + q = createReadStatement selectQuery range singular + (not $ iPreferCount intent) contentType + if range == Just emptyRange + then return $ errResponse status416 "HTTP Range error" + else do + row <- H.maybeEx q + let (tableTotal, queryTotal, _ , body) = extractQueryResult row + if singular + then return $ if queryTotal <= 0 + then responseLBS status404 [] "" + else responseLBS status200 [contentTypeH] (fromMaybe "{}" body) + else do + let frm = fromMaybe 0 $ rangeOffset <$> range + to = frm+queryTotal-1 + contentRange = contentRangeH frm to tableTotal + status = rangeStatus frm to tableTotal + canonical = urlEncodeVars -- should this be moved to the dbStructure (location)? + . sortBy (comparing fst) + . map (join (***) cs) + . parseSimpleQuery + $ rawQueryString req + return $ responseLBS status + [contentTypeH, contentRange, + ("Content-Location", + "/" <> cs (qiName qi) <> + if Prelude.null canonical then "" else "?" <> cs canonical + ) + ] (fromMaybe "[]" body) + (ActionCreate, TargetIdent qi, PayloadJSON payload) -> undefined + (ActionUpdate, TargetIdent qi, PayloadJSON payload) -> undefined + (ActionDelete, TargetIdent qi, _) -> undefined + (ActionRead, TargetIdent qi, _) -> undefined - ([], "GET") -> do -- this should be a GET request only - body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure)) - return $ responseLBS status200 [jsonH] $ cs body + (_, _, _) -> return notFound - (_, _) -> - return notFound + where + notFound = responseLBS status404 [] "" + filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk + allPrKeys = dbPrimaryKeys dbStructure + allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + -- path = pathInfo req + -- verb = requestMethod req + -- hdrs = requestHeaders req + -- lookupHeader = flip lookup hdrs + -- hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs + -- schema = cs $ configSchema conf + -- range = rangeRequested hdrs + -- request = parseRequest schema (dbRelations dbStructure) (head path) req reqBody --TODO! is head safe? - where - notFound = responseLBS status404 [] "" - allPrKeys = dbPrimaryKeys dbStructure - filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk - path = pathInfo req - verb = requestMethod req - hdrs = requestHeaders req - lookupHeader = flip lookup hdrs - hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs - accept = lookupHeader hAccept - schema = cs $ configSchema conf - jwtSecret = configJwtSecret conf - range = rangeRequested hdrs - allOrigins = ("Access-Control-Allow-Origin", "*") :: Header - contentType = fromMaybe "application/json" $ contentTypeForAccept accept - isCsv = contentType == csvMT - contentTypeH = (hContentType, contentType) - echoRequested = hasPrefer "return=representation" - singular = hasPrefer "plurality=singular" - request = parseRequest schema (dbRelations dbStructure) (head path) req reqBody --TODO! is head safe? + + + -- case (path, verb) of + -- ([table], _) -> + -- case request of + -- Left e -> return $ responseLBS status400 [jsonH] $ cs e + -- Right (selectQuery, Nothing) -> -- should we do sanity check to make sure its a GET request? + -- Right (selectQuery, Just (mutateQuery, isSingle)) -> + -- case verb of + -- "POST" -> do + -- let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? + -- q = createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys isCsv + -- row <- H.maybeEx q + -- let (_, _, location, body) = extractQueryResult row + -- return $ responseLBS status201 + -- [ + -- contentTypeH, + -- (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) + -- ] + -- $ if echoRequested then fromMaybe "[]" body else "" + -- "PATCH" -> do + -- let q = createWriteStatement selectQuery mutateQuery False echoRequested [] isCsv + -- row <- H.maybeEx q + -- let (_, queryTotal, _, body) = extractQueryResult row + -- r = contentRangeH 0 (queryTotal-1) (Just queryTotal) + -- s = case () of _ | queryTotal == 0 -> status404 + -- | echoRequested -> status200 + -- | otherwise -> status204 + -- return $ responseLBS s [contentTypeH, r] + -- $ if echoRequested then fromMaybe "[]" body else "" + -- "DELETE" -> do + -- let q = createWriteStatement selectQuery mutateQuery False False [] isCsv + -- row <- H.maybeEx q + -- let (_, queryTotal, _, _) = extractQueryResult row + -- return $ if queryTotal == 0 + -- then notFound + -- else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] "" + -- _ -> return notFound + + -- where rangeStatus :: Int -> Int -> Maybe Int -> Status rangeStatus _ _ Nothing = status200 @@ -239,19 +257,21 @@ parseCsvCell :: BL.ByteString -> Value parseCsvCell s = if s == "NULL" then Null else String $ cs s formatRelationError :: Text -> Text -formatRelationError e = cs $ encode $ object [ - "mesage" .= ("could not find foreign keys between these entities"::String), - "details" .= e] +formatRelationError e = formatGeneralError + "could not find foreign keys between these entities" e formatParserError :: ParseError -> Text -formatParserError e = cs $ encode $ object [ - "message" .= message, - "details" .= details] +formatParserError e = formatGeneralError message details where message = show (errorPos e) details = strip $ replace "\n" " " $ cs $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) +formatGeneralError :: Text -> Text -> Text +formatGeneralError message details = cs $ encode $ object [ + "message" .= message, + "details" .= details] + parseRequestBody :: Bool -> RequestBody -> Either Text ([Text],[[Value]]) parseRequestBody isCsv reqBody = first cs $ checkStructure =<< @@ -401,6 +421,11 @@ instance ToJSON TableOptions where "columns" .= tblOptcolumns t , "pkey" .= tblOptpkey t ] +createSelectQuery :: [Relation] -> QualifiedIdentifier -> SqlQuery +createSelectQuery rels qi = + requestToQuery schema <$> selectApiRequest + undefined + parseRequest :: Schema -> [Relation] -> TableName -> Request -> RequestBody -> Either Text (SqlQuery, Maybe (SqlQuery, Bool)) parseRequest schema allRels rootTableName httpRequest reqBody = if method == "GET" diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 81c96b059..bfe871ae9 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -45,13 +45,13 @@ getDbStructure schema = do } doesProc :: forall c s. B.CxValue c Int => - (Text -> Text -> B.Stmt c) -> Text -> Text -> H.Tx c s Bool -doesProc stmt schema proc = do - row :: Maybe (Identity Int) <- H.maybeEx $ stmt schema proc + (Text -> Text -> B.Stmt c) -> QualifiedIdentifier -> H.Tx c s Bool +doesProc stmt qi = do + row :: Maybe (Identity Int) <- H.maybeEx $ stmt (qiSchema qi) (qiName qi) return $ isJust row -doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool -doesProcExist = doesProc [H.stmt| +doesProcExist :: QualifiedIdentifier -> H.Tx P.Postgres s Bool +doesProcExist = doesProc $ [H.stmt| SELECT 1 FROM pg_catalog.pg_namespace n JOIN pg_catalog.pg_proc p @@ -60,7 +60,7 @@ doesProcExist = doesProc [H.stmt| AND proname = ? |] -doesProcReturnJWT :: Text -> Text -> H.Tx P.Postgres s Bool +doesProcReturnJWT :: QualifiedIdentifier -> H.Tx P.Postgres s Bool doesProcReturnJWT = doesProc [H.stmt| SELECT 1 FROM pg_catalog.pg_namespace n diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index 326fe05be..702c0bb9c 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -59,6 +59,8 @@ data Intent = Intent { , iPreferRepresentation :: Bool -- | If client wants first row as raw object , iPreferSingular :: Bool + -- | Whether the client wants a result count (slower) + , iPreferCount :: Bool } -- | Examines HTTP request and translates it into user intent. @@ -94,12 +96,13 @@ userIntent schema req reqBody = "Content-type not acceptable: " <> accept in Intent action - (rangeRequested hdrs) + (if singular then Nothing else rangeRequested hdrs) target (pickContentType $ lookupHeader "accept") reqPayload (hasPrefer "return=representation") - (hasPrefer "plurality=singular") + singular + (not $ hasPrefer "count=none") where path = pathInfo req @@ -107,6 +110,7 @@ userIntent schema req reqBody = hdrs = requestHeaders req lookupHeader = flip lookup hdrs hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs + singular = (hasPrefer "plurality=singular") -- PRIVATE --------------------------------------------------------------- From 7f52430e0e81e625ab958d4ea0bd82c91f331c30 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 20 Nov 2015 14:04:00 +0200 Subject: [PATCH 12/30] Get the refactored code to compile (5 test failing) --- src/PostgREST/App.hs | 369 ++++++++++++++++++++------------- src/PostgREST/DbStructure.hs | 2 +- src/PostgREST/RequestIntent.hs | 51 +++-- 3 files changed, 267 insertions(+), 155 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index a9ae15570..7dee11013 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -13,7 +13,7 @@ import Control.Monad (join) import Data.Bifunctor (first) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BL -import qualified Data.Csv as CSV +--import qualified Data.Csv as CSV import Data.Functor.Identity import qualified Data.HashMap.Strict as HM import Data.List (find, sortBy, delete, transpose) @@ -23,7 +23,8 @@ import Data.Ranged.Ranges (emptyRange, singletonRange) import Data.String.Conversions (cs) import Data.Text (Text, replace, strip) import Data.Tree -import qualified Data.Map as M +import qualified Data.Map as M +import qualified Data.Aeson as JSON import Text.Parsec.Error import Text.ParserCombinators.Parsec (parse) @@ -75,20 +76,22 @@ import Prelude app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response app dbStructure conf reqBody req = - let schema = configSchema conf - intent = userIntent schema req reqBody + let -- TODO: blow up for Left values contentType = either (const ApplicationJSON) id (iAccepts intent) - contentTypeH = (hContentType, contentType) in + contentTypeS ct = case ct of + ApplicationJSON -> "application/json" + TextCSV -> "text/csv" + contentTypeH = (hContentType, contentTypeS contentType) in case (iAction intent, iTarget intent, iPayload intent) of (ActionUnknown _, _, _) -> return notFound (_, TargetUnknown _, _) -> return notFound - (_, _, PayloadParseError e) -> - return $ responseLBS status400 [jsonH] - (formatGeneralError "Cannot parse request payload" e) + (_, _, Just (PayloadParseError e)) -> + return $ responseLBS status400 [jsonH] $ + cs (formatGeneralError "Cannot parse request payload" (cs e)) - (ActionInfo, TargetIdent tSchema tTable, _) -> do + (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), _) -> do let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys body = encode (TableOptions cols pkeys) @@ -101,12 +104,16 @@ app dbStructure conf reqBody req = body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure)) return $ responseLBS status200 [jsonH] $ cs body - (ActionInvoke, TargetIdent qi, PayloadJSON payload) -> do - exists <- doesProcExist (qiSchema qi) (qiName qi) + (ActionInvoke, TargetIdent qi, Just (PayloadJSON payload)) -> do + exists <- doesProcExist qi if exists then do - let call = B.Stmt "select " V.empty True <> - asJson (callProc qi payload) + let p = case pp of + JSON.Object o -> o + _ -> undefined + where pp = V.head payload + call = B.Stmt "select " V.empty True <> + asJson (callProc qi p) jwtSecret = configJwtSecret conf bodyJson :: Maybe (Identity Value) <- H.maybeEx call @@ -118,42 +125,77 @@ app dbStructure conf reqBody req = else cs $ encode body) else return notFound - (ActionRead, TargetIdent qi, _) -> do - let range = iRange intent - singular = iPreferSingular intent - selectQuery = requestToQuery schema <$> selectApiRequest - q = createReadStatement selectQuery range singular - (not $ iPreferCount intent) contentType - if range == Just emptyRange - then return $ errResponse status416 "HTTP Range error" - else do - row <- H.maybeEx q - let (tableTotal, queryTotal, _ , body) = extractQueryResult row - if singular - then return $ if queryTotal <= 0 - then responseLBS status404 [] "" - else responseLBS status200 [contentTypeH] (fromMaybe "{}" body) - else do - let frm = fromMaybe 0 $ rangeOffset <$> range - to = frm+queryTotal-1 - contentRange = contentRangeH frm to tableTotal - status = rangeStatus frm to tableTotal - canonical = urlEncodeVars -- should this be moved to the dbStructure (location)? - . sortBy (comparing fst) - . map (join (***) cs) - . parseSimpleQuery - $ rawQueryString req - return $ responseLBS status - [contentTypeH, contentRange, - ("Content-Location", - "/" <> cs (qiName qi) <> - if Prelude.null canonical then "" else "?" <> cs canonical - ) - ] (fromMaybe "[]" body) - (ActionCreate, TargetIdent qi, PayloadJSON payload) -> undefined - (ActionUpdate, TargetIdent qi, PayloadJSON payload) -> undefined - (ActionDelete, TargetIdent qi, _) -> undefined - (ActionRead, TargetIdent qi, _) -> undefined + (ActionRead, TargetIdent qi, _) -> + case selectQuery of + Left e -> return $ responseLBS status400 [jsonH] $ cs e + Right q -> do + let range = iRange intent + singular = iPreferSingular intent + stm = createReadStatement q range singular + (iPreferCount intent) (contentType == TextCSV) + if range == Just emptyRange + then return $ errResponse status416 "HTTP Range error" + else do + row <- H.maybeEx stm + let (tableTotal, queryTotal, _ , body) = extractQueryResult row + if singular + then return $ if queryTotal <= 0 + then responseLBS status404 [] "" + else responseLBS status200 [contentTypeH] (fromMaybe "{}" body) + else do + let frm = fromMaybe 0 $ rangeOffset <$> range + to = frm+queryTotal-1 + contentRange = contentRangeH frm to tableTotal + status = rangeStatus frm to tableTotal + canonical = urlEncodeVars -- should this be moved to the dbStructure (location)? + . sortBy (comparing fst) + . map (join (***) cs) + . parseSimpleQuery + $ rawQueryString req + return $ responseLBS status + [contentTypeH, contentRange, + ("Content-Location", + "/" <> cs (qiName qi) <> + if Prelude.null canonical then "" else "?" <> cs canonical + ) + ] (fromMaybe "[]" body) + (ActionCreate, TargetIdent (QualifiedIdentifier _ table), _) -> + case queries of + Left e -> return $ responseLBS status400 [jsonH] $ cs e + Right (sq,mq,isSingle) -> do + 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 sq mq isSingle (iPreferRepresentation intent) pKeys (contentType == TextCSV) + row <- H.maybeEx stm + let (_, _, location, body) = extractQueryResult row + return $ responseLBS status201 + [ + contentTypeH, + (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) + ] + $ if iPreferRepresentation intent then fromMaybe "[]" body else "" + (ActionUpdate, TargetIdent _, _) -> + case queries of + Left e -> return $ responseLBS status400 [jsonH] $ cs e + Right (sq,mq,_) -> do + let stm = createWriteStatement sq mq False (iPreferRepresentation intent) [] (contentType == TextCSV) + row <- H.maybeEx stm + let (_, queryTotal, _, body) = extractQueryResult row + r = contentRangeH 0 (queryTotal-1) (Just queryTotal) + s = case () of _ | queryTotal == 0 -> status404 + | iPreferRepresentation intent -> status200 + | otherwise -> status204 + return $ responseLBS s [contentTypeH, r] + $ if iPreferRepresentation intent then fromMaybe "[]" body else "" + (ActionDelete, TargetIdent _, _) -> + case queries of + Left e -> return $ responseLBS status400 [jsonH] $ cs e + Right (sq,mq,_) -> do + let stm = createWriteStatement sq mq False False [] (contentType == TextCSV) + row <- H.maybeEx stm + let (_, queryTotal, _, _) = extractQueryResult row + return $ if queryTotal == 0 + then notFound + else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] "" (_, _, _) -> return notFound @@ -162,12 +204,20 @@ app dbStructure conf reqBody req = filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk allPrKeys = dbPrimaryKeys dbStructure allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + schema = cs $ configSchema conf + intent = userIntent schema req reqBody + selectApiRequest = buildSelectApiRequest intent (dbRelations dbStructure) + selectQuery = requestToQuery schema <$> selectApiRequest + mutateTuple = buildMutateApiRequest intent + mutateApiRequest = fst <$> mutateTuple + isSingleRecord = snd <$> mutateTuple + mutateQuery = requestToQuery schema <$> mutateApiRequest + queries = (,,) <$> selectQuery <*> mutateQuery <*> isSingleRecord -- path = pathInfo req -- verb = requestMethod req -- hdrs = requestHeaders req -- lookupHeader = flip lookup hdrs -- hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs - -- schema = cs $ configSchema conf -- range = rangeRequested hdrs -- request = parseRequest schema (dbRelations dbStructure) (head path) req reqBody --TODO! is head safe? @@ -253,17 +303,17 @@ contentTypeForAccept accept findInAccept = flip find $ parseHttpAccept acceptH has = isJust . findInAccept . BS.isPrefixOf -parseCsvCell :: BL.ByteString -> Value -parseCsvCell s = if s == "NULL" then Null else String $ cs s +-- parseCsvCell :: BL.ByteString -> Value +-- parseCsvCell s = if s == "NULL" then Null else String $ cs s formatRelationError :: Text -> Text -formatRelationError e = formatGeneralError - "could not find foreign keys between these entities" e +formatRelationError = formatGeneralError + "could not find foreign keys between these entities" formatParserError :: ParseError -> Text formatParserError e = formatGeneralError message details where - message = show (errorPos e) + message = cs $ show (errorPos e) details = strip $ replace "\n" " " $ cs $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) @@ -272,31 +322,31 @@ formatGeneralError message details = cs $ encode $ object [ "message" .= message, "details" .= details] -parseRequestBody :: Bool -> RequestBody -> Either Text ([Text],[[Value]]) -parseRequestBody isCsv reqBody = first cs $ - checkStructure =<< - if isCsv - then do - rows <- (map V.toList . V.toList) <$> CSV.decode CSV.NoHeader reqBody - if null rows then Left "CSV requires header" -- TODO! should check if length rows > 1 (header and 1 row) - else Right (head rows, (map $ map $ parseCsvCell . cs) (tail rows)) - else eitherDecode reqBody >>= convertJson - where - checkStructure :: ([Text], [[Value]]) -> Either String ([Text], [[Value]]) - checkStructure v - | headerMatchesContent v = Right v - | isCsv = Left "CSV header does not match rows length" - | otherwise = Left "The number of keys in objects do not match" +-- parseRequestBody :: Bool -> RequestBody -> Either Text ([Text],[[Value]]) +-- parseRequestBody isCsv reqBody = first cs $ +-- checkStructure =<< +-- if isCsv +-- then do +-- rows <- (map V.toList . V.toList) <$> CSV.decode CSV.NoHeader reqBody +-- if null rows then Left "CSV requires header" -- TODO! should check if length rows > 1 (header and 1 row) +-- else Right (head rows, (map $ map $ parseCsvCell . cs) (tail rows)) +-- else eitherDecode reqBody >>= convertJson +-- where +-- checkStructure :: ([Text], [[Value]]) -> Either String ([Text], [[Value]]) +-- checkStructure v +-- | headerMatchesContent v = Right v +-- | isCsv = Left "CSV header does not match rows length" +-- | otherwise = Left "The number of keys in objects do not match" +-- +-- headerMatchesContent :: ([Text], [[Value]]) -> Bool +-- headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals +-- where headerLength = length header - headerMatchesContent :: ([Text], [[Value]]) -> Bool - headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals - where headerLength = length header - -convertJson :: Value -> Either String ([Text],[[Value]]) +convertJson :: Value -> Either Text ([Text],[[Value]]) convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized) where - invalidMsg = "Expecting single JSON object or JSON array of objects" - normalized :: Either String [(Text, [Value])] + invalidMsg = "Expecting single JSON object or JSON array of objects"::Text + normalized :: Either Text [(Text, [Value])] normalized = groupByKey =<< normalizeValue v vals :: [(Text, [Value])] -> [[Value]] @@ -305,16 +355,16 @@ convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized) header :: [(Text, [Value])] -> [Text] header = map fst - groupByKey :: Value -> Either String [(Text,[Value])] + groupByKey :: Value -> Either Text [(Text,[Value])] groupByKey (Array a) = HM.toList . foldr (HM.unionWith (++)) (HM.fromList []) <$> maps where - maps :: Either String [HM.HashMap Text [Value]] + maps :: Either Text [HM.HashMap Text [Value]] maps = mapM getElems $ V.toList a getElems (Object o) = Right $ HM.map (:[]) o getElems _ = Left invalidMsg groupByKey _ = Left invalidMsg - normalizeValue :: Value -> Either String Value + normalizeValue :: Value -> Either Text Value normalizeValue val = case val of Object obj -> Right $ Array (V.fromList[Object obj]) @@ -327,63 +377,104 @@ augumentRequestWithJoin schema allRels request = >>= addJoinConditions schema -- we use strings here because most of this data will be sent to parsers (which need strings for now) -queryParams :: Request -> [(String, Maybe String)] -queryParams httpRequest = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] +-- queryParams :: Request -> [(String, Maybe String)] +-- queryParams httpRequest = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] +-- +-- selectStr :: [(String, Maybe String)] -> String +-- selectStr qParams = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams +-- +-- whereFilters :: [(String, Maybe String)] -> [(String, String)] +-- whereFilters qParams = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ] +-- +-- orderStr :: [(String, Maybe String)] -> Maybe String +-- orderStr qParams = join $ lookup "order" qParams -selectStr :: [(String, Maybe String)] -> String -selectStr qParams = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams - -whereFilters :: [(String, Maybe String)] -> [(String, String)] -whereFilters qParams = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ] - -orderStr :: [(String, Maybe String)] -> Maybe String -orderStr qParams = join $ lookup "order" qParams - -buildSelectApiRequest :: Text -> Schema -> TableName -> [(String, String)] -> [Relation] -> [(String, Maybe String)] -> Either Text ApiRequest -buildSelectApiRequest method schema rootTableName allFilters allRels qParams = +buildSelectApiRequest :: Intent -> [Relation] -> Either Text ApiRequest +buildSelectApiRequest intent allRels = augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts) where - selStr = selectStr qParams - orderS = orderStr qParams - rels = case method of - "POST" -> fakeSourceRelations ++ allRels - "PATCH" -> fakeSourceRelations ++ allRels - _ -> allRels - where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation - sel = if method == "DELETE" - then "*" -- we are not returning the records so no need to consider nested items - else selStr - rootName = if method == "GET" + selStr = iSelect intent + orderS = iOrder intent + action = iAction intent + target = iTarget intent + (schema, rootTableName) = fromJust $ -- Make it safe + case target of + (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t) + _ -> Nothing + + rootName = if action == ActionRead then rootTableName else sourceSubqueryName - filters = if method == "GET" - then allFilters - else filter (( '.' `elem` ) . fst) allFilters -- there can be no filters on the root table whre we are doing insert/update - apiRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++sel++">>") sel + filters = if action == ActionRead + then iFilters intent + else filter (( '.' `elem` ) . fst) $ iFilters intent -- there can be no filters on the root table whre we are doing insert/update + rels = case action of + ActionCreate -> fakeSourceRelations ++ allRels + ActionUpdate -> fakeSourceRelations ++ allRels + _ -> allRels + where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation + apiRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr addOrder (Node (q,i) f) o = Node (q{order=o}, i) f flts = mapM pRequestFilter filters ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS -buildMutateApiRequest :: Text -> Bool -> TableName -> RequestBody -> [(String, String)] -> Either Text (ApiRequest, Bool) -buildMutateApiRequest method isCsv rootTableName reqBody allFilters = +--buildMutateApiRequest :: Text -> Bool -> TableName -> RequestBody -> [(String, String)] -> Either Text (ApiRequest, Bool) +--buildMutateApiRequest method isCsv rootTableName reqBody allFilters = +buildMutateApiRequest :: Intent -> Either Text (ApiRequest, Bool) +buildMutateApiRequest intent = (,) <$> mutateApiRequest <*> pure isSingleRecord where - mutateApiRequest = case method of - "POST" -> Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)) <*> pure [] - "PATCH" -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure [] - "DELETE" -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure [] + action = iAction intent + target = iTarget intent + rootTableName = fromJust $ -- Make it safe + case target of + (TargetIdent (QualifiedIdentifier _ t) ) -> Just t + _ -> Nothing + mutateApiRequest = case action of + ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)) <*> pure [] + ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure [] + ActionDelete -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure [] _ -> Left "Unsupported HTTP verb" parseField f = parse pField ("failed to parse field <<"++f++">>") f - parsedBody = parseRequestBody isCsv reqBody + payload = case iPayload intent of + Just (PayloadJSON v) -> JSON.Array v + _ -> undefined --TODO! fix + parsedBody = convertJson payload -- TODO! either check structure or refactor to send json directly to postgres isSingleRecord = either (const False) ((==1) . length . snd ) parsedBody flds = join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsedBody) vals = snd <$> parsedBody - mutateFilters = filter (not . ( '.' `elem` ) . fst) allFilters -- update/delete filters can be only on the root table + mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters intent -- update/delete filters can be only on the root table cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters setWith = if isSingleRecord then M.fromList <$> (zip <$> flds <*> (head <$> vals)) else Left "Expecting a sigle CSV line with header or a JSON object" +-- buildSelectApiRequest :: Text -> Schema -> TableName -> [(String, String)] -> [Relation] -> [(String, Maybe String)] -> Either Text ApiRequest +-- buildSelectApiRequest method schema rootTableName allFilters allRels qParams = +-- augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts) +-- where +-- selStr = selectStr qParams +-- orderS = orderStr qParams +-- rels = case method of +-- "POST" -> fakeSourceRelations ++ allRels +-- "PATCH" -> fakeSourceRelations ++ allRels +-- _ -> allRels +-- where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation +-- sel = if method == "DELETE" +-- then "*" -- we are not returning the records so no need to consider nested items +-- else selStr +-- rootName = if method == "GET" +-- then rootTableName +-- else sourceSubqueryName +-- filters = if method == "GET" +-- then allFilters +-- else filter (( '.' `elem` ) . fst) allFilters -- there can be no filters on the root table whre we are doing insert/update +-- apiRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++sel++">>") sel +-- addOrder (Node (q,i) f) o = Node (q{order=o}, i) f +-- flts = mapM pRequestFilter filters +-- ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS + + addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest addFilter (path, flt) (Node rn forest) = @@ -421,30 +512,30 @@ instance ToJSON TableOptions where "columns" .= tblOptcolumns t , "pkey" .= tblOptpkey t ] -createSelectQuery :: [Relation] -> QualifiedIdentifier -> SqlQuery -createSelectQuery rels qi = - requestToQuery schema <$> selectApiRequest - undefined +-- createSelectQuery :: [Relation] -> QualifiedIdentifier -> SqlQuery +-- createSelectQuery rels qi = +-- requestToQuery schema <$> selectApiRequest +-- undefined -parseRequest :: Schema -> [Relation] -> TableName -> Request -> RequestBody -> Either Text (SqlQuery, Maybe (SqlQuery, Bool)) -parseRequest schema allRels rootTableName httpRequest reqBody = - if method == "GET" - then (,Nothing) <$> selectQuery - else (,) <$> selectQuery <*> ( Just <$> mutatePart ) - where - mutatePart = (,) <$> mutateQuery <*> isSingleRecord - hdrs = requestHeaders httpRequest - lookupHeader = flip lookup hdrs - isCsv = lookupHeader "Content-Type" == Just csvMT - method = requestMethod httpRequest - qParams = queryParams httpRequest - allFilters = whereFilters qParams - selectApiRequest = buildSelectApiRequest (cs method) schema rootTableName allFilters allRels qParams - mutateTuple = buildMutateApiRequest (cs method) isCsv rootTableName reqBody allFilters - mutateApiRequest = fst <$> mutateTuple - isSingleRecord = snd <$> mutateTuple - selectQuery = requestToQuery schema <$> selectApiRequest - mutateQuery = requestToQuery schema <$> mutateApiRequest +-- parseRequest :: Schema -> [Relation] -> TableName -> Request -> RequestBody -> Either Text (SqlQuery, Maybe (SqlQuery, Bool)) +-- parseRequest schema allRels rootTableName httpRequest reqBody = +-- if method == "GET" +-- then (,Nothing) <$> selectQuery +-- else (,) <$> selectQuery <*> ( Just <$> mutatePart ) +-- where +-- mutatePart = (,) <$> mutateQuery <*> isSingleRecord +-- hdrs = requestHeaders httpRequest +-- lookupHeader = flip lookup hdrs +-- isCsv = lookupHeader "Content-Type" == Just csvMT +-- method = requestMethod httpRequest +-- qParams = queryParams httpRequest +-- allFilters = whereFilters qParams +-- selectApiRequest = buildSelectApiRequest (cs method) schema rootTableName allFilters allRels qParams +-- mutateTuple = buildMutateApiRequest (cs method) isCsv rootTableName reqBody allFilters +-- mutateApiRequest = fst <$> mutateTuple +-- isSingleRecord = snd <$> mutateTuple +-- selectQuery = requestToQuery schema <$> selectApiRequest +-- mutateQuery = requestToQuery schema <$> mutateApiRequest createReadStatement :: SqlQuery -> Maybe NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres createReadStatement selectQuery range isSingle countTable asCsv = diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index bfe871ae9..d47a3d236 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -51,7 +51,7 @@ doesProc stmt qi = do return $ isJust row doesProcExist :: QualifiedIdentifier -> H.Tx P.Postgres s Bool -doesProcExist = doesProc $ [H.stmt| +doesProcExist = doesProc [H.stmt| SELECT 1 FROM pg_catalog.pg_namespace n JOIN pg_catalog.pg_proc p diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index 702c0bb9c..03f06b47a 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -7,7 +7,8 @@ import qualified Data.Csv as CSV import Data.List (find) import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe, isJust, isNothing, - listToMaybe) + listToMaybe, fromJust) +import Control.Monad (join) import Data.Monoid ((<>)) import Data.String.Conversions (cs) import qualified Data.Text as T @@ -23,14 +24,14 @@ type RequestBody = BL.ByteString data Action = ActionCreate | ActionRead | ActionUpdate | ActionDelete | ActionInfo | ActionInvoke - | ActionUnknown BS.ByteString + | ActionUnknown BS.ByteString deriving Eq -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier | TargetRoot | TargetUnknown [T.Text] -- | Enumeration of currently supported content types for -- route responses and upload payloads -data ContentType = ApplicationJSON | TextCSV +data ContentType = ApplicationJSON | TextCSV deriving Eq -- | When Hasql supports the COPY command then we can -- have a special payload just for CSV, but until -- then CSV is converted to a JSON array. @@ -54,19 +55,25 @@ data Intent = Intent { -- | The content type the client most desires (or JSON if undecided) , iAccepts :: Either BS.ByteString ContentType -- | Data sent by client and used for mutation actions - , iPayload :: Payload + , iPayload :: Maybe Payload -- | If client wants created items echoed back , iPreferRepresentation :: Bool -- | If client wants first row as raw object , iPreferSingular :: Bool -- | Whether the client wants a result count (slower) , iPreferCount :: Bool + -- | Filters on the result ("id", "eq.10") + , iFilters :: [(String, String)] + -- | &select parameter used to shape the response + , iSelect :: String + -- | &order parameter + , iOrder :: Maybe String } -- | Examines HTTP request and translates it into user intent. userIntent :: Schema -> Request -> RequestBody -> Intent userIntent schema req reqBody = - let action = case requestMethod req of + let action = case method of "GET" -> ActionRead "POST" -> if isTargetingProc then ActionInvoke @@ -82,7 +89,11 @@ userIntent schema req reqBody = ["rpc", proc] -> TargetIdent $ QualifiedIdentifier schema proc other -> TargetUnknown other - reqPayload = case pickContentType (lookupHeader "content-type") of + reqPayload = case action of + ActionCreate -> Just payload + ActionUpdate -> Just payload + _ -> Nothing + where payload = case pickContentType (lookupHeader "content-type") of Right ApplicationJSON -> either (PayloadParseError . cs) (PayloadJSON . pluralize) @@ -95,22 +106,32 @@ userIntent schema req reqBody = PayloadParseError $ "Content-type not acceptable: " <> accept in - Intent action - (if singular then Nothing else rangeRequested hdrs) - target - (pickContentType $ lookupHeader "accept") - reqPayload - (hasPrefer "return=representation") - singular - (not $ hasPrefer "count=none") + Intent { + iAction = action + , iRange = if singular then Nothing else rangeRequested hdrs + , iTarget = target + , iAccepts = pickContentType $ lookupHeader "accept" + , iPayload = reqPayload + , iPreferRepresentation = hasPrefer "return=representation" + , iPreferSingular = singular + , iPreferCount = not $ hasPrefer "count=none" + , iFilters = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ] + , iSelect = if method == "DELETE" + then "*" + else fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams + , iOrder = join $ lookup "order" qParams + } where path = pathInfo req + method = requestMethod req isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path hdrs = requestHeaders req + qParams = [(cs k, cs <$> v)|(k,v) <- queryString req] lookupHeader = flip lookup hdrs hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs - singular = (hasPrefer "plurality=singular") + singular = hasPrefer "plurality=singular" + -- PRIVATE --------------------------------------------------------------- From f5bb898992e69d53a5a01e60fa9aac52f595f2cf Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 20 Nov 2015 14:10:28 +0200 Subject: [PATCH 13/30] delete commented code --- src/PostgREST/App.hs | 117 ------------------------------------------- 1 file changed, 117 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 7dee11013..621a2c447 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -213,54 +213,6 @@ app dbStructure conf reqBody req = isSingleRecord = snd <$> mutateTuple mutateQuery = requestToQuery schema <$> mutateApiRequest queries = (,,) <$> selectQuery <*> mutateQuery <*> isSingleRecord - -- path = pathInfo req - -- verb = requestMethod req - -- hdrs = requestHeaders req - -- lookupHeader = flip lookup hdrs - -- hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs - -- range = rangeRequested hdrs - -- request = parseRequest schema (dbRelations dbStructure) (head path) req reqBody --TODO! is head safe? - - - - -- case (path, verb) of - -- ([table], _) -> - -- case request of - -- Left e -> return $ responseLBS status400 [jsonH] $ cs e - -- Right (selectQuery, Nothing) -> -- should we do sanity check to make sure its a GET request? - -- Right (selectQuery, Just (mutateQuery, isSingle)) -> - -- case verb of - -- "POST" -> do - -- let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? - -- q = createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys isCsv - -- row <- H.maybeEx q - -- let (_, _, location, body) = extractQueryResult row - -- return $ responseLBS status201 - -- [ - -- contentTypeH, - -- (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) - -- ] - -- $ if echoRequested then fromMaybe "[]" body else "" - -- "PATCH" -> do - -- let q = createWriteStatement selectQuery mutateQuery False echoRequested [] isCsv - -- row <- H.maybeEx q - -- let (_, queryTotal, _, body) = extractQueryResult row - -- r = contentRangeH 0 (queryTotal-1) (Just queryTotal) - -- s = case () of _ | queryTotal == 0 -> status404 - -- | echoRequested -> status200 - -- | otherwise -> status204 - -- return $ responseLBS s [contentTypeH, r] - -- $ if echoRequested then fromMaybe "[]" body else "" - -- "DELETE" -> do - -- let q = createWriteStatement selectQuery mutateQuery False False [] isCsv - -- row <- H.maybeEx q - -- let (_, queryTotal, _, _) = extractQueryResult row - -- return $ if queryTotal == 0 - -- then notFound - -- else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] "" - -- _ -> return notFound - - -- where rangeStatus :: Int -> Int -> Maybe Int -> Status rangeStatus _ _ Nothing = status200 @@ -303,9 +255,6 @@ contentTypeForAccept accept findInAccept = flip find $ parseHttpAccept acceptH has = isJust . findInAccept . BS.isPrefixOf --- parseCsvCell :: BL.ByteString -> Value --- parseCsvCell s = if s == "NULL" then Null else String $ cs s - formatRelationError :: Text -> Text formatRelationError = formatGeneralError "could not find foreign keys between these entities" @@ -376,19 +325,6 @@ augumentRequestWithJoin schema allRels request = (first formatRelationError . addRelations schema allRels Nothing) request >>= addJoinConditions schema --- we use strings here because most of this data will be sent to parsers (which need strings for now) --- queryParams :: Request -> [(String, Maybe String)] --- queryParams httpRequest = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] --- --- selectStr :: [(String, Maybe String)] -> String --- selectStr qParams = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams --- --- whereFilters :: [(String, Maybe String)] -> [(String, String)] --- whereFilters qParams = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ] --- --- orderStr :: [(String, Maybe String)] -> Maybe String --- orderStr qParams = join $ lookup "order" qParams - buildSelectApiRequest :: Intent -> [Relation] -> Either Text ApiRequest buildSelectApiRequest intent allRels = augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts) @@ -418,8 +354,6 @@ buildSelectApiRequest intent allRels = flts = mapM pRequestFilter filters ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS ---buildMutateApiRequest :: Text -> Bool -> TableName -> RequestBody -> [(String, String)] -> Either Text (ApiRequest, Bool) ---buildMutateApiRequest method isCsv rootTableName reqBody allFilters = buildMutateApiRequest :: Intent -> Either Text (ApiRequest, Bool) buildMutateApiRequest intent = (,) <$> mutateApiRequest <*> pure isSingleRecord @@ -449,32 +383,6 @@ buildMutateApiRequest intent = then M.fromList <$> (zip <$> flds <*> (head <$> vals)) else Left "Expecting a sigle CSV line with header or a JSON object" --- buildSelectApiRequest :: Text -> Schema -> TableName -> [(String, String)] -> [Relation] -> [(String, Maybe String)] -> Either Text ApiRequest --- buildSelectApiRequest method schema rootTableName allFilters allRels qParams = --- augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts) --- where --- selStr = selectStr qParams --- orderS = orderStr qParams --- rels = case method of --- "POST" -> fakeSourceRelations ++ allRels --- "PATCH" -> fakeSourceRelations ++ allRels --- _ -> allRels --- where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation --- sel = if method == "DELETE" --- then "*" -- we are not returning the records so no need to consider nested items --- else selStr --- rootName = if method == "GET" --- then rootTableName --- else sourceSubqueryName --- filters = if method == "GET" --- then allFilters --- else filter (( '.' `elem` ) . fst) allFilters -- there can be no filters on the root table whre we are doing insert/update --- apiRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++sel++">>") sel --- addOrder (Node (q,i) f) o = Node (q{order=o}, i) f --- flts = mapM pRequestFilter filters --- ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS - - addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest addFilter (path, flt) (Node rn forest) = @@ -512,31 +420,6 @@ instance ToJSON TableOptions where "columns" .= tblOptcolumns t , "pkey" .= tblOptpkey t ] --- createSelectQuery :: [Relation] -> QualifiedIdentifier -> SqlQuery --- createSelectQuery rels qi = --- requestToQuery schema <$> selectApiRequest --- undefined - --- parseRequest :: Schema -> [Relation] -> TableName -> Request -> RequestBody -> Either Text (SqlQuery, Maybe (SqlQuery, Bool)) --- parseRequest schema allRels rootTableName httpRequest reqBody = --- if method == "GET" --- then (,Nothing) <$> selectQuery --- else (,) <$> selectQuery <*> ( Just <$> mutatePart ) --- where --- mutatePart = (,) <$> mutateQuery <*> isSingleRecord --- hdrs = requestHeaders httpRequest --- lookupHeader = flip lookup hdrs --- isCsv = lookupHeader "Content-Type" == Just csvMT --- method = requestMethod httpRequest --- qParams = queryParams httpRequest --- allFilters = whereFilters qParams --- selectApiRequest = buildSelectApiRequest (cs method) schema rootTableName allFilters allRels qParams --- mutateTuple = buildMutateApiRequest (cs method) isCsv rootTableName reqBody allFilters --- mutateApiRequest = fst <$> mutateTuple --- isSingleRecord = snd <$> mutateTuple --- selectQuery = requestToQuery schema <$> selectApiRequest --- mutateQuery = requestToQuery schema <$> mutateApiRequest - createReadStatement :: SqlQuery -> Maybe NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres createReadStatement selectQuery range isSingle countTable asCsv = B.Stmt ( From f18cfbd7f4a7aa9e714fdc0c85741f68b092421f Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 20 Nov 2015 15:36:04 +0200 Subject: [PATCH 14/30] Stricter pattern matching & case branches rearangement + remove a few small functions --- src/PostgREST/App.hs | 121 ++++++++++++++++-------------------- src/PostgREST/Middleware.hs | 15 +++-- 2 files changed, 59 insertions(+), 77 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 621a2c447..0836f3211 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -4,20 +4,17 @@ --module PostgREST.App where module PostgREST.App ( app -, contentTypeForAccept ) where import Control.Applicative import Control.Arrow ((***)) import Control.Monad (join) import Data.Bifunctor (first) -import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BL ---import qualified Data.Csv as CSV import Data.Functor.Identity import qualified Data.HashMap.Strict as HM import Data.List (find, sortBy, delete, transpose) -import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, mapMaybe) +import Data.Maybe (fromMaybe, fromJust, isNothing, mapMaybe) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange, singletonRange) import Data.String.Conversions (cs) @@ -34,7 +31,6 @@ import Network.HTTP.Types.Header import Network.HTTP.Types.Status import Network.HTTP.Types.URI (parseSimpleQuery) import Network.Wai -import Network.Wai.Parse (parseHttpAccept) import Data.Aeson import Data.Aeson.Types (emptyArray) @@ -77,7 +73,7 @@ import Prelude app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response app dbStructure conf reqBody req = let - -- TODO: blow up for Left values + -- TODO: blow up for Left values (there is a middleware that checks the headers) contentType = either (const ApplicationJSON) id (iAccepts intent) contentTypeS ct = case ct of ApplicationJSON -> "application/json" @@ -85,47 +81,8 @@ app dbStructure conf reqBody req = contentTypeH = (hContentType, contentTypeS contentType) in case (iAction intent, iTarget intent, iPayload intent) of - (ActionUnknown _, _, _) -> return notFound - (_, TargetUnknown _, _) -> return notFound - (_, _, Just (PayloadParseError e)) -> - return $ responseLBS status400 [jsonH] $ - cs (formatGeneralError "Cannot parse request payload" (cs e)) - (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), _) -> do - let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure - pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys - body = encode (TableOptions cols pkeys) - filterCol :: Schema -> TableName -> Column -> Bool - filterCol sc tb (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && t==tb - filterCol _ _ _ = False - return $ responseLBS status200 [jsonH, allOrigins] $ cs body - - (ActionRead, TargetRoot, _) -> do - body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure)) - return $ responseLBS status200 [jsonH] $ cs body - - (ActionInvoke, TargetIdent qi, Just (PayloadJSON payload)) -> do - exists <- doesProcExist qi - if exists - then do - let p = case pp of - JSON.Object o -> o - _ -> undefined - where pp = 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 - return $ responseLBS status200 [jsonH] - (let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in - if returnJWT - then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}" - else cs $ encode body) - else return notFound - - (ActionRead, TargetIdent qi, _) -> + (ActionRead, TargetIdent qi, Nothing) -> case selectQuery of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right q -> do @@ -159,7 +116,8 @@ app dbStructure conf reqBody req = if Prelude.null canonical then "" else "?" <> cs canonical ) ] (fromMaybe "[]" body) - (ActionCreate, TargetIdent (QualifiedIdentifier _ table), _) -> + + (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just (PayloadJSON _)) -> case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq,isSingle) -> do @@ -173,7 +131,8 @@ app dbStructure conf reqBody req = (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) ] $ if iPreferRepresentation intent then fromMaybe "[]" body else "" - (ActionUpdate, TargetIdent _, _) -> + + (ActionUpdate, TargetIdent _, Just (PayloadJSON _)) -> case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq,_) -> do @@ -186,7 +145,8 @@ app dbStructure conf reqBody req = | otherwise -> status204 return $ responseLBS s [contentTypeH, r] $ if iPreferRepresentation intent then fromMaybe "[]" body else "" - (ActionDelete, TargetIdent _, _) -> + + (ActionDelete, TargetIdent _, Nothing) -> case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq,_) -> do @@ -197,6 +157,48 @@ app dbStructure conf reqBody req = then notFound else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] "" + (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> do + let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure + pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys + body = encode (TableOptions cols pkeys) + filterCol :: Schema -> TableName -> Column -> Bool + filterCol sc tb (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && t==tb + filterCol _ _ _ = False + return $ responseLBS status200 [jsonH, allOrigins] $ cs body + + (ActionInvoke, TargetIdent qi, Just (PayloadJSON payload)) -> do + exists <- doesProcExist qi + if exists + then do + let p = case pp of + JSON.Object o -> o + _ -> undefined + where pp = 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 + return $ responseLBS status200 [jsonH] + (let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in + if returnJWT + then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}" + else cs $ encode body) + else return notFound + + (ActionRead, TargetRoot, Nothing) -> do + body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure)) + return $ responseLBS status200 [jsonH] $ cs body + + (ActionUnknown _, _, _) -> return notFound + + (_, TargetUnknown _, _) -> return notFound + + (_, _, Just (PayloadParseError e)) -> + return $ responseLBS status400 [jsonH] $ + cs (formatGeneralError "Cannot parse request payload" (cs e)) + (_, _, _) -> return notFound where @@ -233,27 +235,8 @@ contentRangeH frm to total = totalNotZero = fromMaybe True ((/=) 0 <$> total) fromInRange = frm <= to -jsonMT :: BS.ByteString -jsonMT = "application/json" - -csvMT :: BS.ByteString -csvMT = "text/csv" - -allMT :: BS.ByteString -allMT = "*/*" - jsonH :: Header -jsonH = (hContentType, jsonMT) - -contentTypeForAccept :: Maybe BS.ByteString -> Maybe BS.ByteString -contentTypeForAccept accept - | isNothing accept || has allMT || has jsonMT = Just jsonMT - | has csvMT = Just csvMT - | otherwise = Nothing - where - Just acceptH = accept - findInAccept = flip find $ parseHttpAccept acceptH - has = isJust . findInAccept . BS.isPrefixOf +jsonH = (hContentType, "application/json") formatRelationError :: Text -> Text formatRelationError = formatGeneralError diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index a8e800768..495cfd5ab 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -3,7 +3,7 @@ module PostgREST.Middleware where -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe) import Data.Text import Data.String.Conversions (cs) import Data.Time.Clock.POSIX (getPOSIXTime) @@ -18,7 +18,7 @@ import Network.Wai.Middleware.Cors (cors) import Network.Wai.Middleware.Gzip (def, gzip) import Network.Wai.Middleware.Static (only, staticPolicy) -import PostgREST.App (contentTypeForAccept) +import PostgREST.RequestIntent (pickContentType) import PostgREST.Auth (setRole, jwtClaims, claimsToSQL) import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (errResponse) @@ -58,12 +58,11 @@ runWithClaims conf app req = do invalidJWT = return $ errResponse status400 "Invalid JWT" unsupportedAccept :: Application -> Application -unsupportedAccept app req respond = do - let - accept = lookup hAccept $ requestHeaders req - if isNothing $ contentTypeForAccept accept - then respond $ errResponse status415 "Unsupported Accept header, try: application/json" - else app req respond +unsupportedAccept app req respond = + case accept of + Left _ -> respond $ errResponse status415 "Unsupported Accept header, try: application/json" + Right _ -> app req respond + where accept = pickContentType $ lookup hAccept $ requestHeaders req defaultMiddle :: Application -> Application defaultMiddle = From aa2f0287b1c29b473d63d3895d827a1e8ce86393 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 20 Nov 2015 15:50:53 +0200 Subject: [PATCH 15/30] Fix RPC failing tests --- src/PostgREST/RequestIntent.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index 03f06b47a..f1b369702 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -92,6 +92,7 @@ userIntent schema req reqBody = reqPayload = case action of ActionCreate -> Just payload ActionUpdate -> Just payload + ActionInvoke -> Just payload _ -> Nothing where payload = case pickContentType (lookupHeader "content-type") of Right ApplicationJSON -> From 0cce22f8c16d68dd9ac5b2fce9bcc5e279131071 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 20 Nov 2015 16:07:20 +0200 Subject: [PATCH 16/30] check request payload for structure & remove bad test for csv --- src/PostgREST/App.hs | 29 +++++++++-------------------- test/Feature/InsertSpec.hs | 7 ++++--- 2 files changed, 13 insertions(+), 23 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 0836f3211..77ae8bb50 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -254,25 +254,14 @@ formatGeneralError message details = cs $ encode $ object [ "message" .= message, "details" .= details] --- parseRequestBody :: Bool -> RequestBody -> Either Text ([Text],[[Value]]) --- parseRequestBody isCsv reqBody = first cs $ --- checkStructure =<< --- if isCsv --- then do --- rows <- (map V.toList . V.toList) <$> CSV.decode CSV.NoHeader reqBody --- if null rows then Left "CSV requires header" -- TODO! should check if length rows > 1 (header and 1 row) --- else Right (head rows, (map $ map $ parseCsvCell . cs) (tail rows)) --- else eitherDecode reqBody >>= convertJson --- where --- checkStructure :: ([Text], [[Value]]) -> Either String ([Text], [[Value]]) --- checkStructure v --- | headerMatchesContent v = Right v --- | isCsv = Left "CSV header does not match rows length" --- | otherwise = Left "The number of keys in objects do not match" --- --- headerMatchesContent :: ([Text], [[Value]]) -> Bool --- headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals --- where headerLength = length header +checkStructure :: ([Text], [[Value]]) -> Either Text ([Text], [[Value]]) +checkStructure v + | headerMatchesContent v = Right v + | otherwise = Left "The number of keys in objects do not match" + +headerMatchesContent :: ([Text], [[Value]]) -> Bool +headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals + where headerLength = length header convertJson :: Value -> Either Text ([Text],[[Value]]) convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized) @@ -356,7 +345,7 @@ buildMutateApiRequest intent = payload = case iPayload intent of Just (PayloadJSON v) -> JSON.Array v _ -> undefined --TODO! fix - parsedBody = convertJson payload -- TODO! either check structure or refactor to send json directly to postgres + parsedBody = checkStructure =<< convertJson payload isSingleRecord = either (const False) ((==1) . length . snd ) parsedBody flds = join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsedBody) vals = snd <$> parsedBody diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 861a286ed..160bf5c1d 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -211,9 +211,10 @@ spec = afterAll_ resetDb $ around withApp $ do it "fails for too few" $ do p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz" liftIO $ simpleStatus p `shouldBe` badRequest400 - it "fails for too many" $ do - p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz,bat,bad" - liftIO $ simpleStatus p `shouldBe` badRequest400 + -- it does not fail because the extra columns are ignored + -- it "fails for too many" $ do + -- p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz,bat,bad" + -- liftIO $ simpleStatus p `shouldBe` badRequest400 describe "Putting record" $ do From cf2e45d47fdb8b3db1e33efed0037a7c83a87a7f Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 20 Nov 2015 16:11:21 +0200 Subject: [PATCH 17/30] Fix lint issue --- test/Feature/InsertSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 160bf5c1d..edd1280d5 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -207,7 +207,7 @@ spec = afterAll_ resetDb $ around withApp $ do } - after_ (clearTable "no_pk") . context "with wrong number of columns" $ do + after_ (clearTable "no_pk") . context "with wrong number of columns" $ it "fails for too few" $ do p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz" liftIO $ simpleStatus p `shouldBe` badRequest400 From 78fd766de3d5d499e0ff77e0336161b85ab07a4d Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Fri, 20 Nov 2015 18:19:13 +0200 Subject: [PATCH 18/30] small refactor --- src/PostgREST/App.hs | 27 ++++++++++++--------------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 77ae8bb50..e08885acb 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -117,10 +117,11 @@ app dbStructure conf reqBody req = ) ] (fromMaybe "[]" body) - (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just (PayloadJSON _)) -> + (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just (PayloadJSON payload)) -> case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e - Right (sq,mq,isSingle) -> do + Right (sq,mq) -> do + let isSingle = (==1) $ V.length payload 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 sq mq isSingle (iPreferRepresentation intent) pKeys (contentType == TextCSV) row <- H.maybeEx stm @@ -135,7 +136,7 @@ app dbStructure conf reqBody req = (ActionUpdate, TargetIdent _, Just (PayloadJSON _)) -> case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e - Right (sq,mq,_) -> do + Right (sq,mq) -> do let stm = createWriteStatement sq mq False (iPreferRepresentation intent) [] (contentType == TextCSV) row <- H.maybeEx stm let (_, queryTotal, _, body) = extractQueryResult row @@ -149,7 +150,7 @@ app dbStructure conf reqBody req = (ActionDelete, TargetIdent _, Nothing) -> case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e - Right (sq,mq,_) -> do + Right (sq,mq) -> do let stm = createWriteStatement sq mq False False [] (contentType == TextCSV) row <- H.maybeEx stm let (_, queryTotal, _, _) = extractQueryResult row @@ -208,13 +209,9 @@ app dbStructure conf reqBody req = allOrigins = ("Access-Control-Allow-Origin", "*") :: Header schema = cs $ configSchema conf intent = userIntent schema req reqBody - selectApiRequest = buildSelectApiRequest intent (dbRelations dbStructure) - selectQuery = requestToQuery schema <$> selectApiRequest - mutateTuple = buildMutateApiRequest intent - mutateApiRequest = fst <$> mutateTuple - isSingleRecord = snd <$> mutateTuple - mutateQuery = requestToQuery schema <$> mutateApiRequest - queries = (,,) <$> selectQuery <*> mutateQuery <*> isSingleRecord + selectQuery = requestToQuery schema <$> buildSelectApiRequest (dbRelations dbStructure) intent + mutateQuery = requestToQuery schema <$> buildMutateApiRequest intent + queries = (,) <$> selectQuery <*> mutateQuery rangeStatus :: Int -> Int -> Maybe Int -> Status rangeStatus _ _ Nothing = status200 @@ -297,8 +294,8 @@ augumentRequestWithJoin schema allRels request = (first formatRelationError . addRelations schema allRels Nothing) request >>= addJoinConditions schema -buildSelectApiRequest :: Intent -> [Relation] -> Either Text ApiRequest -buildSelectApiRequest intent allRels = +buildSelectApiRequest :: [Relation] -> Intent -> Either Text ApiRequest +buildSelectApiRequest allRels intent = augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts) where selStr = iSelect intent @@ -326,9 +323,9 @@ buildSelectApiRequest intent allRels = flts = mapM pRequestFilter filters ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS -buildMutateApiRequest :: Intent -> Either Text (ApiRequest, Bool) +buildMutateApiRequest :: Intent -> Either Text ApiRequest buildMutateApiRequest intent = - (,) <$> mutateApiRequest <*> pure isSingleRecord + mutateApiRequest where action = iAction intent target = iTarget intent From f54742186b0738804d85fafe0659f431f6f6f13b Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 20 Nov 2015 10:29:08 -0800 Subject: [PATCH 19/30] Use show instances for a shortcut --- src/PostgREST/App.hs | 5 +---- src/PostgREST/QueryBuilder.hs | 16 ++-------------- src/PostgREST/RequestIntent.hs | 6 +++++- src/PostgREST/Types.hs | 11 +++++++++-- 4 files changed, 17 insertions(+), 21 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index e08885acb..3009a4d8b 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -75,10 +75,7 @@ app dbStructure conf reqBody req = let -- TODO: blow up for Left values (there is a middleware that checks the headers) contentType = either (const ApplicationJSON) id (iAccepts intent) - contentTypeS ct = case ct of - ApplicationJSON -> "application/json" - TextCSV -> "text/csv" - contentTypeH = (hContentType, contentTypeS contentType) in + contentTypeH = (hContentType, cs $ show contentType) in case (iAction intent, iTarget intent, iPayload intent) of diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index f2a56d135..72ba5b8b1 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -321,20 +321,8 @@ orderF ts = queryTerm :: OrderTerm -> Text queryTerm t = " " <> cs (pgFmtIdent $ otTerm t) <> " " - <> sqlOrderDirection (otDirection t) <> " " - <> maybe "" sqlOrderNulls (otNullOrder t) <> " " - -sqlOrderDirection :: OrderDirection -> SqlFragment -sqlOrderDirection d = - case d of - OrderDesc -> "desc" - OrderAsc -> "asc" - -sqlOrderNulls :: OrderNulls -> SqlFragment -sqlOrderNulls d = - case d of - OrderNullsFirst -> "nulls first" - OrderNullsLast -> "nulls last" + <> (cs.show) (otDirection t) <> " " + <> maybe "" (cs.show) (otNullOrder t) <> " " insertableValue :: JSON.Value -> SqlFragment insertableValue JSON.Null = "null" diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index f1b369702..d00404b8e 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -32,6 +32,10 @@ data Target = TargetIdent QualifiedIdentifier -- | Enumeration of currently supported content types for -- route responses and upload payloads data ContentType = ApplicationJSON | TextCSV deriving Eq +instance Show ContentType where + show ApplicationJSON = "application/json" + show TextCSV = "text/csv" + -- | When Hasql supports the COPY command then we can -- have a special payload just for CSV, but until -- then CSV is converted to a JSON array. @@ -128,7 +132,7 @@ userIntent schema req reqBody = method = requestMethod req isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path hdrs = requestHeaders req - qParams = [(cs k, cs <$> v)|(k,v) <- queryString req] + qParams = [(cs k, cs <$> v)|(k,v) <- queryString req] lookupHeader = flip lookup hdrs hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs singular = hasPrefer "plurality=singular" diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 02243c20a..0bea9245a 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -50,8 +50,15 @@ data PrimaryKey = PrimaryKey { , pkName :: Text } deriving (Show, Eq) -data OrderDirection = OrderAsc | OrderDesc deriving (Show, Eq) -data OrderNulls = OrderNullsFirst | OrderNullsLast 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 :: Text From 60007b5f10083196e8be404b25d08f113283c220 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 20 Nov 2015 13:08:23 -0800 Subject: [PATCH 20/30] WIP: Insertion memory leak fixed But a whole lot of other things broken, including updates --- src/PostgREST/App.hs | 45 ++++++++++++++-------------------- src/PostgREST/QueryBuilder.hs | 45 ++++++++++++++-------------------- src/PostgREST/RequestIntent.hs | 9 ++----- src/PostgREST/Types.hs | 12 ++++++--- 4 files changed, 47 insertions(+), 64 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 3009a4d8b..24963e4e2 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -20,7 +20,6 @@ import Data.Ranged.Ranges (emptyRange, singletonRange) import Data.String.Conversions (cs) import Data.Text (Text, replace, strip) import Data.Tree -import qualified Data.Map as M import qualified Data.Aeson as JSON import Text.Parsec.Error @@ -46,7 +45,7 @@ import PostgREST.DbStructure import PostgREST.RangeQuery import PostgREST.RequestIntent (Intent(..), ContentType(..) , Action(..), Target(..) - , Payload(..), userIntent) + , userIntent) import PostgREST.Types import PostgREST.Auth (tokenJWT) import PostgREST.Error (errResponse) @@ -114,13 +113,13 @@ app dbStructure conf reqBody req = ) ] (fromMaybe "[]" body) - (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just (PayloadJSON payload)) -> + (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) -> case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do - let isSingle = (==1) $ V.length payload + 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 sq mq isSingle (iPreferRepresentation intent) pKeys (contentType == TextCSV) + let stm = createWriteStatement sq mq isSingle (iPreferRepresentation intent) pKeys (contentType == TextCSV) payload row <- H.maybeEx stm let (_, _, location, body) = extractQueryResult row return $ responseLBS status201 @@ -130,11 +129,11 @@ app dbStructure conf reqBody req = ] $ if iPreferRepresentation intent then fromMaybe "[]" body else "" - (ActionUpdate, TargetIdent _, Just (PayloadJSON _)) -> + (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON _)) -> case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do - let stm = createWriteStatement sq mq False (iPreferRepresentation intent) [] (contentType == TextCSV) + let stm = createWriteStatement sq mq False (iPreferRepresentation intent) [] (contentType == TextCSV) payload row <- H.maybeEx stm let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 0 (queryTotal-1) (Just queryTotal) @@ -148,7 +147,8 @@ app dbStructure conf reqBody req = case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do - let stm = createWriteStatement sq mq False False [] (contentType == TextCSV) + let fakeload = PayloadJSON V.empty + let stm = createWriteStatement sq mq False False [] (contentType == TextCSV) fakeload row <- H.maybeEx stm let (_, queryTotal, _, _) = extractQueryResult row return $ if queryTotal == 0 @@ -326,28 +326,18 @@ buildMutateApiRequest intent = where action = iAction intent target = iTarget intent - rootTableName = fromJust $ -- Make it safe + payload = fromJust $ iPayload intent + rootTableName = -- TODO: Make it safe case target of - (TargetIdent (QualifiedIdentifier _ t) ) -> Just t - _ -> Nothing + (TargetIdent (QualifiedIdentifier _ t) ) -> t + _ -> undefined mutateApiRequest = case action of - ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)) <*> pure [] - ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure [] + ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> pure payload) <*> pure (rootTableName, Nothing)) <*> pure [] + --ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure [] ActionDelete -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure [] _ -> Left "Unsupported HTTP verb" - parseField f = parse pField ("failed to parse field <<"++f++">>") f - payload = case iPayload intent of - Just (PayloadJSON v) -> JSON.Array v - _ -> undefined --TODO! fix - parsedBody = checkStructure =<< convertJson payload - isSingleRecord = either (const False) ((==1) . length . snd ) parsedBody - flds = join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsedBody) - vals = snd <$> parsedBody mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters intent -- update/delete filters can be only on the root table cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters - setWith = if isSingleRecord - then M.fromList <$> (zip <$> flds <*> (head <$> vals)) - else Left "Expecting a sigle CSV line with header or a JSON object" addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest @@ -399,8 +389,9 @@ createReadStatement selectQuery range isSingle countTable asCsv = ] selectStarF (if isNothing range && isSingle then Just $ singletonRange 0 else range) ) V.empty True -createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> [Text] -> Bool -> B.Stmt P.Postgres -createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv = +createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> + [Text] -> Bool -> Payload -> B.Stmt P.Postgres +createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv (PayloadJSON rows) = B.Stmt ( wrapQuery mutateQuery [ countNoneF, -- when updateing it does not make sense @@ -414,7 +405,7 @@ createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv else "null" ] selectQuery Nothing - ) V.empty True + ) (V.singleton . B.encodeValue . JSON.Array $ rows) True extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) -> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 72ba5b8b1..0f3d3b93d 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -229,33 +229,24 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _) --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many getQueryParts (Node (_,(_,Nothing)) _) _ = undefined -requestToQuery schema (Node (Insert _ flds vals, (mainTbl, _)) _) = - query - where - qi = QualifiedIdentifier schema mainTbl - query = unwords [ - "INSERT INTO ", fromQi qi, - " (" <> intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ", - "VALUES " <> intercalate ", " - ( map (\v -> - "(" <> - intercalate ", " ( map insertableValue v ) <> - ")" - ) vals - ), - "RETURNING " <> fromQi qi <> ".*" - ] -requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) = - query - where - qi = QualifiedIdentifier schema mainTbl - query = unwords [ - "UPDATE ", fromQi qi, - " SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ", - ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, - "RETURNING " <> fromQi qi <> ".*" - ] - formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v +requestToQuery schema (Node (Insert _ payload, (mainTbl, _)) _) = + let qi = QualifiedIdentifier schema mainTbl in + unwords [ + "INSERT INTO ", fromQi qi, + "select * from json_populate_recordset(null::" , fromQi qi, ", ?)", + "RETURNING " <> fromQi qi <> ".*" + ] +-- requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) = +-- query +-- where +-- qi = QualifiedIdentifier schema mainTbl +-- query = unwords [ +-- "UPDATE ", fromQi qi, +-- " SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ", +-- ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, +-- "RETURNING " <> fromQi qi <> ".*" +-- ] +-- formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) = query where diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index d00404b8e..b3199caee 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -16,7 +16,8 @@ import qualified Data.Vector as V import Network.Wai (Request (..)) import Network.Wai.Parse (parseHttpAccept) import PostgREST.RangeQuery (NonnegRange, rangeRequested) -import PostgREST.Types (QualifiedIdentifier (..), Schema) +import PostgREST.Types (QualifiedIdentifier (..), + Schema, Payload(..)) type RequestBody = BL.ByteString @@ -36,12 +37,6 @@ instance Show ContentType where show ApplicationJSON = "application/json" show TextCSV = "text/csv" --- | When Hasql supports the COPY command then we can --- have a special payload just for CSV, but until --- then CSV is converted to a JSON array. -data Payload = PayloadJSON JSON.Array - | PayloadParseError BS.ByteString - {-| Describes what the user wants to do. This data type is a translation of the raw elements of an HTTP request into domain diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 0bea9245a..9e1346f94 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -2,8 +2,8 @@ module PostgREST.Types where import Data.Text import Data.Tree import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BS import Data.Aeson -import Data.Map data DbStructure = DbStructure { dbTables :: [Table] @@ -84,6 +84,12 @@ data Relation = Relation { , relLCols2 :: Maybe [Column] } deriving (Show, Eq) +-- | When Hasql supports the COPY command then we can +-- have a special payload just for CSV, but until +-- then CSV is converted to a JSON array. +data Payload = PayloadJSON Array + | PayloadParseError BS.ByteString + deriving (Show, Eq) type Operator = Text data FValue = VText Text | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq) @@ -95,9 +101,9 @@ type NodeName = Text type SelectItem = (Field, Maybe Cast) type Path = [Text] data Query = Select { select::[SelectItem], from::[Text], where_::[Filter], order::Maybe [OrderTerm] } - | Insert { into::Text, fields::[Field], values::[[Value]] } + | Insert { into::Text, qPayload::Payload } | Delete { from::[Text], where_::[Filter] } - | Update { into::Text, set::Map Field Value, where_::[Filter] } deriving (Show, Eq) + | Update { into::Text, qPayload::Payload, where_::[Filter] } deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) type ApiNode = (Query, (NodeName, Maybe Relation)) type ApiRequest = Tree ApiNode From 1f6fc5cbd84e11c72f47f9d488a17c9ae20e2368 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 22 Nov 2015 13:51:46 -0800 Subject: [PATCH 21/30] Ensure JSON payload objects all have same keys --- src/PostgREST/App.hs | 19 +++++----- src/PostgREST/RequestIntent.hs | 65 ++++++++++++++++++++++++---------- src/PostgREST/Types.hs | 8 ++++- 3 files changed, 63 insertions(+), 29 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 24963e4e2..d5961ded2 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -13,6 +13,7 @@ import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as BL import Data.Functor.Identity import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as S import Data.List (find, sortBy, delete, transpose) import Data.Maybe (fromMaybe, fromJust, isNothing, mapMaybe) import Data.Ord (comparing) @@ -113,7 +114,8 @@ app dbStructure conf reqBody req = ) ] (fromMaybe "[]" body) - (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) -> + (ActionCreate, TargetIdent (QualifiedIdentifier _ table), + Just payload@(PayloadJSON (UniformObjects rows))) -> case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do @@ -147,7 +149,7 @@ app dbStructure conf reqBody req = case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do - let fakeload = PayloadJSON V.empty + let fakeload = PayloadJSON $ UniformObjects V.empty let stm = createWriteStatement sq mq False False [] (contentType == TextCSV) fakeload row <- H.maybeEx stm let (_, queryTotal, _, _) = extractQueryResult row @@ -164,14 +166,12 @@ app dbStructure conf reqBody req = filterCol _ _ _ = False return $ responseLBS status200 [jsonH, allOrigins] $ cs body - (ActionInvoke, TargetIdent qi, Just (PayloadJSON payload)) -> do + (ActionInvoke, TargetIdent qi, + Just (PayloadJSON (UniformObjects payload))) -> do exists <- doesProcExist qi if exists then do - let p = case pp of - JSON.Object o -> o - _ -> undefined - where pp = V.head payload + let p = V.head payload call = B.Stmt "select " V.empty True <> asJson (callProc qi p) jwtSecret = configJwtSecret conf @@ -391,7 +391,8 @@ createReadStatement selectQuery range isSingle countTable asCsv = createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> [Text] -> Bool -> Payload -> B.Stmt P.Postgres -createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv (PayloadJSON rows) = +createWriteStatement selectQuery mutateQuery isSingle echoRequested + pKeys asCsv (PayloadJSON (UniformObjects rows)) = B.Stmt ( wrapQuery mutateQuery [ countNoneF, -- when updateing it does not make sense @@ -405,7 +406,7 @@ createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv else "null" ] selectQuery Nothing - ) (V.singleton . B.encodeValue . JSON.Array $ rows) True + ) (V.singleton . B.encodeValue . JSON.Array . V.map Object $ rows) True extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) -> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index b3199caee..f802eac26 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -6,6 +6,7 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Csv as CSV import Data.List (find) import qualified Data.HashMap.Strict as M +import qualified Data.Set as S import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, fromJust) import Control.Monad (join) @@ -17,7 +18,8 @@ import Network.Wai (Request (..)) import Network.Wai.Parse (parseHttpAccept) import PostgREST.RangeQuery (NonnegRange, rangeRequested) import PostgREST.Types (QualifiedIdentifier (..), - Schema, Payload(..)) + Schema, Payload(..), + UniformObjects(..)) type RequestBody = BL.ByteString @@ -88,30 +90,32 @@ userIntent schema req reqBody = ["rpc", proc] -> TargetIdent $ QualifiedIdentifier schema proc other -> TargetUnknown other - reqPayload = case action of + payload = case pickContentType (lookupHeader "content-type") of + Right ApplicationJSON -> + either (PayloadParseError . cs) + (\val -> case ensureUniform (pluralize val) of + Nothing -> PayloadParseError "All object keys must match" + Just json -> PayloadJSON json) + (JSON.eitherDecode reqBody) + Right TextCSV -> + either (PayloadParseError . cs) + (PayloadJSON . csvToJson) + (CSV.decodeByName reqBody) + Left accept -> + PayloadParseError $ + "Content-type not acceptable: " <> accept + relevantPayload = case action of ActionCreate -> Just payload ActionUpdate -> Just payload ActionInvoke -> Just payload - _ -> Nothing - where payload = case pickContentType (lookupHeader "content-type") of - Right ApplicationJSON -> - either (PayloadParseError . cs) - (PayloadJSON . pluralize) - (JSON.eitherDecode reqBody) - Right TextCSV -> - either (PayloadParseError . cs) - (PayloadJSON . csvToJson) - (CSV.decodeByName reqBody) - Left accept -> - PayloadParseError $ - "Content-type not acceptable: " <> accept in + _ -> Nothing in Intent { iAction = action , iRange = if singular then Nothing else rangeRequested hdrs , iTarget = target , iAccepts = pickContentType $ lookupHeader "accept" - , iPayload = reqPayload + , iPayload = relevantPayload , iPreferRepresentation = hasPrefer "return=representation" , iPreferSingular = singular , iPreferCount = not $ hasPrefer "count=none" @@ -173,11 +177,11 @@ type CsvData = V.Vector (M.HashMap T.Text BL.ByteString) The reason for its odd signature is so that it can compose directly with CSV.decodeByName -} -csvToJson :: (CSV.Header, CsvData) -> JSON.Array +csvToJson :: (CSV.Header, CsvData) -> UniformObjects csvToJson (_, vals) = - V.map rowToJsonObj vals + UniformObjects $ V.map rowToJsonObj vals where - rowToJsonObj = JSON.Object . + rowToJsonObj = M.map (\str -> if str == "NULL" then JSON.Null @@ -190,3 +194,26 @@ pluralize :: JSON.Value -> JSON.Array pluralize obj@(JSON.Object _) = V.singleton obj pluralize (JSON.Array arr) = arr pluralize _ = V.empty + +-- | Test that Array contains only Objects having the same keys +-- and if so mark it as UniformObjects +ensureUniform :: JSON.Array -> Maybe UniformObjects +ensureUniform arr = + let objs :: V.Vector JSON.Object + objs = foldr -- filter non-objects, map to raw objects + (\result val -> case val of + JSON.Object o -> V.cons o result + _ -> result) + V.empty arr + keysPerObj :: [S.Set T.Text] + keysPerObj = V.toList $ V.map (S.fromList . M.keys) objs + allKeys :: S.Set T.Text + allKeys = S.unions keysPerObj + commonKeys :: S.Set T.Text + commonKeys = case keysPerObj of + h : _ -> foldr S.intersection h keysPerObj + [] -> S.empty in + + if (length objs == length arr) && (allKeys == commonKeys) + then Just (UniformObjects objs) + else Nothing diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 9e1346f94..e9a6ad586 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -3,6 +3,7 @@ import Data.Text import Data.Tree import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS +import qualified Data.Vector as V import Data.Aeson data DbStructure = DbStructure { @@ -84,10 +85,15 @@ data Relation = Relation { , relLCols2 :: Maybe [Column] } deriving (Show, Eq) +-- | An array of JSON objects that has been verified to have +-- the same keys in every object +newtype UniformObjects = UniformObjects (V.Vector Object) + deriving (Show, Eq) + -- | When Hasql supports the COPY command then we can -- have a special payload just for CSV, but until -- then CSV is converted to a JSON array. -data Payload = PayloadJSON Array +data Payload = PayloadJSON UniformObjects | PayloadParseError BS.ByteString deriving (Show, Eq) From d03d68c25f5f917b1736b5702a3abea288d54196 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 22 Nov 2015 15:00:28 -0800 Subject: [PATCH 22/30] Simplify checking object keys for equality --- src/PostgREST/RequestIntent.hs | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index f802eac26..b21f45870 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -201,19 +201,14 @@ ensureUniform :: JSON.Array -> Maybe UniformObjects ensureUniform arr = let objs :: V.Vector JSON.Object objs = foldr -- filter non-objects, map to raw objects - (\result val -> case val of + (\val result -> case val of JSON.Object o -> V.cons o result _ -> result) V.empty arr - keysPerObj :: [S.Set T.Text] - keysPerObj = V.toList $ V.map (S.fromList . M.keys) objs - allKeys :: S.Set T.Text - allKeys = S.unions keysPerObj - commonKeys :: S.Set T.Text - commonKeys = case keysPerObj of - h : _ -> foldr S.intersection h keysPerObj - [] -> S.empty in + keysPerObj = V.map (S.fromList . M.keys) objs + canonicalKeys = fromMaybe S.empty $ keysPerObj V.!? 0 + areKeysUniform = all (==canonicalKeys) keysPerObj in - if (length objs == length arr) && (allKeys == commonKeys) + if (V.length objs == V.length arr) && areKeysUniform then Just (UniformObjects objs) else Nothing From 936a368be724851ae706444dd7a520311b34b413 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 22 Nov 2015 17:46:00 -0800 Subject: [PATCH 23/30] Update only the columns specified in the json payload --- src/PostgREST/QueryBuilder.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 0f3d3b93d..4b191dfca 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -32,14 +32,15 @@ import qualified Data.Aeson as JSON import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset) import Control.Error (note, fromMaybe, mapMaybe) import Control.Monad (join) +import qualified Data.HashMap.Strict as HM import Data.List (find) import Data.Monoid ((<>)) import Data.Text (Text, intercalate, unwords, replace, isInfixOf, toLower, split) import qualified Data.Text as T (map, takeWhile) import Data.String.Conversions (cs) -import qualified Data.HashMap.Strict as H import Control.Applicative (empty, (<|>)) import Data.Tree (Tree(..)) +import qualified Data.Vector as V import PostgREST.Types import qualified Data.Map as M import Text.Regex.TDFA ((=~)) @@ -125,7 +126,7 @@ asJsonSingleF = "string_agg(row_to_json(t)::text, ',')::character varying " callProc :: QualifiedIdentifier -> JSON.Object -> PStmt callProc qi params = do - let args = intercalate "," $ map assignment (H.toList params) + let args = intercalate "," $ map assignment (HM.toList params) B.Stmt ("select * from " <> fromQi qi <> "(" <> args <> ")") empty True where assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v @@ -229,12 +230,16 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _) --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many getQueryParts (Node (_,(_,Nothing)) _) _ = undefined -requestToQuery schema (Node (Insert _ payload, (mainTbl, _)) _) = - let qi = QualifiedIdentifier schema mainTbl in +requestToQuery schema (Node (Insert _ (PayloadJSON (UniformObjects rows)), (mainTbl, _)) _) = + let qi = QualifiedIdentifier schema mainTbl + cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0)) + colsString = intercalate ", " cols in unwords [ "INSERT INTO ", fromQi qi, - "select * from json_populate_recordset(null::" , fromQi qi, ", ?)", - "RETURNING " <> fromQi qi <> ".*" + " (" <> colsString <> ")" <> + " SELECT " <> colsString <> + " FROM json_populate_recordset(null::" , fromQi qi, ", ?)", + " RETURNING " <> fromQi qi <> ".*" ] -- requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) = -- query From bc552848baa9c98f665c694a0488d0061a8e6dc2 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 22 Nov 2015 21:51:42 -0800 Subject: [PATCH 24/30] Prevent inserting CSV with varying row length --- src/PostgREST/RequestIntent.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index b21f45870..69d62b696 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/RequestIntent.hs @@ -99,7 +99,9 @@ userIntent schema req reqBody = (JSON.eitherDecode reqBody) Right TextCSV -> either (PayloadParseError . cs) - (PayloadJSON . csvToJson) + (\val -> case ensureUniform (csvToJson val) of + Nothing -> PayloadParseError "All lines must have same number of fields" + Just json -> PayloadJSON json) (CSV.decodeByName reqBody) Left accept -> PayloadParseError $ @@ -177,11 +179,11 @@ type CsvData = V.Vector (M.HashMap T.Text BL.ByteString) The reason for its odd signature is so that it can compose directly with CSV.decodeByName -} -csvToJson :: (CSV.Header, CsvData) -> UniformObjects +csvToJson :: (CSV.Header, CsvData) -> JSON.Array csvToJson (_, vals) = - UniformObjects $ V.map rowToJsonObj vals + V.map rowToJsonObj vals where - rowToJsonObj = + rowToJsonObj = JSON.Object . M.map (\str -> if str == "NULL" then JSON.Null From 7f58600dbb92c9b4ba7b96898a1378e8d708e452 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 22 Nov 2015 22:38:54 -0800 Subject: [PATCH 25/30] All green But still unsightly --- src/PostgREST/App.hs | 41 +---------------------------------- src/PostgREST/QueryBuilder.hs | 26 ++++++++++++---------- 2 files changed, 16 insertions(+), 51 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index d5961ded2..3d7525028 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -13,7 +13,6 @@ import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as BL import Data.Functor.Identity import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as S import Data.List (find, sortBy, delete, transpose) import Data.Maybe (fromMaybe, fromJust, isNothing, mapMaybe) import Data.Ord (comparing) @@ -248,44 +247,6 @@ formatGeneralError message details = cs $ encode $ object [ "message" .= message, "details" .= details] -checkStructure :: ([Text], [[Value]]) -> Either Text ([Text], [[Value]]) -checkStructure v - | headerMatchesContent v = Right v - | otherwise = Left "The number of keys in objects do not match" - -headerMatchesContent :: ([Text], [[Value]]) -> Bool -headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals - where headerLength = length header - -convertJson :: Value -> Either Text ([Text],[[Value]]) -convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized) - where - invalidMsg = "Expecting single JSON object or JSON array of objects"::Text - normalized :: Either Text [(Text, [Value])] - normalized = groupByKey =<< normalizeValue v - - vals :: [(Text, [Value])] -> [[Value]] - vals = transpose . map snd - - header :: [(Text, [Value])] -> [Text] - header = map fst - - groupByKey :: Value -> Either Text [(Text,[Value])] - groupByKey (Array a) = HM.toList . foldr (HM.unionWith (++)) (HM.fromList []) <$> maps - where - maps :: Either Text [HM.HashMap Text [Value]] - maps = mapM getElems $ V.toList a - getElems (Object o) = Right $ HM.map (:[]) o - getElems _ = Left invalidMsg - groupByKey _ = Left invalidMsg - - normalizeValue :: Value -> Either Text Value - normalizeValue val = - case val of - Object obj -> Right $ Array (V.fromList[Object obj]) - a@(Array _) -> Right a - _ -> Left invalidMsg - augumentRequestWithJoin :: Schema -> [Relation] -> ApiRequest -> Either Text ApiRequest augumentRequestWithJoin schema allRels request = (first formatRelationError . addRelations schema allRels Nothing) request @@ -333,7 +294,7 @@ buildMutateApiRequest intent = _ -> undefined mutateApiRequest = case action of ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> pure payload) <*> pure (rootTableName, Nothing)) <*> pure [] - --ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure [] + ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> pure payload <*> cond) <*> pure (rootTableName, Nothing)) <*> pure [] ActionDelete -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure [] _ -> Left "Unsupported HTTP verb" mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters intent -- update/delete filters can be only on the root table diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 4b191dfca..812c00cf4 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -241,17 +241,21 @@ requestToQuery schema (Node (Insert _ (PayloadJSON (UniformObjects rows)), (main " FROM json_populate_recordset(null::" , fromQi qi, ", ?)", " RETURNING " <> fromQi qi <> ".*" ] --- requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) = --- query --- where --- qi = QualifiedIdentifier schema mainTbl --- query = unwords [ --- "UPDATE ", fromQi qi, --- " SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ", --- ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, --- "RETURNING " <> fromQi qi <> ".*" --- ] --- formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v +requestToQuery schema (Node (Update _ (PayloadJSON (UniformObjects rows)) conditions, (mainTbl, _)) _) = + case rows V.!? 0 of + Just obj -> + let assignments = map + (\(k,v) -> pgFmtIdent k <> "=" <> insertableValue v) $ HM.toList obj in + unwords [ + "UPDATE ", fromQi qi, + " SET " <> (intercalate "," assignments) <> " ", + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, + "RETURNING " <> fromQi qi <> ".*" + ] + Nothing -> "" + where + qi = QualifiedIdentifier schema mainTbl + requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) = query where From 50745ad48be94f6cc2480b8d9730241f74129198 Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Mon, 23 Nov 2015 10:12:29 +0200 Subject: [PATCH 26/30] Type refactoring (ApiRequest/DbRequest) --- postgrest.cabal | 6 +- .../{RequestIntent.hs => ApiRequest.hs} | 10 +-- src/PostgREST/App.hs | 78 +++++++++---------- src/PostgREST/Middleware.hs | 2 +- src/PostgREST/Parsers.hs | 4 +- src/PostgREST/QueryBuilder.hs | 32 ++++---- src/PostgREST/Types.hs | 14 ++-- 7 files changed, 75 insertions(+), 71 deletions(-) rename src/PostgREST/{RequestIntent.hs => ApiRequest.hs} (97%) diff --git a/postgrest.cabal b/postgrest.cabal index e76a2e824..e458c732a 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -72,7 +72,7 @@ executable postgrest , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery - , PostgREST.RequestIntent + , PostgREST.ApiRequest , PostgREST.Types library @@ -136,7 +136,7 @@ library , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery - , PostgREST.RequestIntent + , PostgREST.ApiRequest , PostgREST.Types hs-source-dirs: src @@ -167,7 +167,7 @@ Test-Suite spec , PostgREST.DbStructure , PostgREST.QueryBuilder , PostgREST.RangeQuery - , PostgREST.RequestIntent + , PostgREST.ApiRequest , PostgREST.Types , Spec , SpecHelper diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/ApiRequest.hs similarity index 97% rename from src/PostgREST/RequestIntent.hs rename to src/PostgREST/ApiRequest.hs index 69d62b696..ce228b948 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/ApiRequest.hs @@ -1,4 +1,4 @@ -module PostgREST.RequestIntent where +module PostgREST.ApiRequest where import qualified Data.Aeson as JSON import qualified Data.ByteString as BS @@ -46,7 +46,7 @@ instance Show ContentType where sensible, it is up to a later stage of processing to determine if it is an action we are able to perform. -} -data Intent = Intent { +data ApiRequest = ApiRequest { -- | Set to Nothing for unknown HTTP verbs iAction :: Action -- | Set to Nothing for malformed range @@ -72,8 +72,8 @@ data Intent = Intent { } -- | Examines HTTP request and translates it into user intent. -userIntent :: Schema -> Request -> RequestBody -> Intent -userIntent schema req reqBody = +userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest +userApiRequest schema req reqBody = let action = case method of "GET" -> ActionRead "POST" -> if isTargetingProc @@ -112,7 +112,7 @@ userIntent schema req reqBody = ActionInvoke -> Just payload _ -> Nothing in - Intent { + ApiRequest { iAction = action , iRange = if singular then Nothing else rangeRequested hdrs , iTarget = target diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 3d7525028..e16ba5056 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -12,8 +12,7 @@ import Control.Monad (join) import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as BL import Data.Functor.Identity -import qualified Data.HashMap.Strict as HM -import Data.List (find, sortBy, delete, transpose) +import Data.List (find, sortBy, delete) import Data.Maybe (fromMaybe, fromJust, isNothing, mapMaybe) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange, singletonRange) @@ -43,9 +42,9 @@ import PostgREST.Config (AppConfig (..)) import PostgREST.Parsers import PostgREST.DbStructure import PostgREST.RangeQuery -import PostgREST.RequestIntent (Intent(..), ContentType(..) +import PostgREST.ApiRequest (ApiRequest(..), ContentType(..) , Action(..), Target(..) - , userIntent) + , userApiRequest) import PostgREST.Types import PostgREST.Auth (tokenJWT) import PostgREST.Error (errResponse) @@ -73,19 +72,19 @@ app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s R app dbStructure conf reqBody req = let -- TODO: blow up for Left values (there is a middleware that checks the headers) - contentType = either (const ApplicationJSON) id (iAccepts intent) + contentType = either (const ApplicationJSON) id (iAccepts apiRequest) contentTypeH = (hContentType, cs $ show contentType) in - case (iAction intent, iTarget intent, iPayload intent) of + case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of (ActionRead, TargetIdent qi, Nothing) -> case selectQuery of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right q -> do - let range = iRange intent - singular = iPreferSingular intent + let range = iRange apiRequest + singular = iPreferSingular apiRequest stm = createReadStatement q range singular - (iPreferCount intent) (contentType == TextCSV) + (iPreferCount apiRequest) (contentType == TextCSV) if range == Just emptyRange then return $ errResponse status416 "HTTP Range error" else do @@ -120,7 +119,7 @@ app dbStructure conf reqBody req = 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 sq mq isSingle (iPreferRepresentation intent) pKeys (contentType == TextCSV) payload + let stm = createWriteStatement sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload row <- H.maybeEx stm let (_, _, location, body) = extractQueryResult row return $ responseLBS status201 @@ -128,21 +127,21 @@ app dbStructure conf reqBody req = contentTypeH, (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) ] - $ if iPreferRepresentation intent then fromMaybe "[]" body else "" + $ if iPreferRepresentation apiRequest then fromMaybe "[]" body else "" (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON _)) -> case queries of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do - let stm = createWriteStatement sq mq False (iPreferRepresentation intent) [] (contentType == TextCSV) payload + let stm = createWriteStatement sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload row <- H.maybeEx stm let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 0 (queryTotal-1) (Just queryTotal) s = case () of _ | queryTotal == 0 -> status404 - | iPreferRepresentation intent -> status200 + | iPreferRepresentation apiRequest -> status200 | otherwise -> status204 return $ responseLBS s [contentTypeH, r] - $ if iPreferRepresentation intent then fromMaybe "[]" body else "" + $ if iPreferRepresentation apiRequest then fromMaybe "[]" body else "" (ActionDelete, TargetIdent _, Nothing) -> case queries of @@ -204,9 +203,9 @@ app dbStructure conf reqBody req = allPrKeys = dbPrimaryKeys dbStructure allOrigins = ("Access-Control-Allow-Origin", "*") :: Header schema = cs $ configSchema conf - intent = userIntent schema req reqBody - selectQuery = requestToQuery schema <$> buildSelectApiRequest (dbRelations dbStructure) intent - mutateQuery = requestToQuery schema <$> buildMutateApiRequest intent + apiRequest = userApiRequest schema req reqBody + selectQuery = requestToQuery schema <$> (DbRead <$> buildReadRequest (dbRelations dbStructure) apiRequest) + mutateQuery = requestToQuery schema <$> (DbMutate <$> buildMutateRequest apiRequest) queries = (,) <$> selectQuery <*> mutateQuery rangeStatus :: Int -> Int -> Maybe Int -> Status @@ -247,19 +246,19 @@ formatGeneralError message details = cs $ encode $ object [ "message" .= message, "details" .= details] -augumentRequestWithJoin :: Schema -> [Relation] -> ApiRequest -> Either Text ApiRequest +augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either Text ReadRequest augumentRequestWithJoin schema allRels request = (first formatRelationError . addRelations schema allRels Nothing) request >>= addJoinConditions schema -buildSelectApiRequest :: [Relation] -> Intent -> Either Text ApiRequest -buildSelectApiRequest allRels intent = - augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts) +buildReadRequest :: [Relation] -> ApiRequest -> Either Text ReadRequest +buildReadRequest allRels apiRequest = + augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> readRequest <*> ord) <*> flts) where - selStr = iSelect intent - orderS = iOrder intent - action = iAction intent - target = iTarget intent + selStr = iSelect apiRequest + orderS = iOrder apiRequest + action = iAction apiRequest + target = iTarget apiRequest (schema, rootTableName) = fromJust $ -- Make it safe case target of (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t) @@ -269,39 +268,39 @@ buildSelectApiRequest allRels intent = then rootTableName else sourceSubqueryName filters = if action == ActionRead - then iFilters intent - else filter (( '.' `elem` ) . fst) $ iFilters intent -- there can be no filters on the root table whre we are doing insert/update + then iFilters apiRequest + else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update rels = case action of ActionCreate -> fakeSourceRelations ++ allRels ActionUpdate -> fakeSourceRelations ++ allRels _ -> allRels where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation - apiRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr + readRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr addOrder (Node (q,i) f) o = Node (q{order=o}, i) f flts = mapM pRequestFilter filters ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS -buildMutateApiRequest :: Intent -> Either Text ApiRequest -buildMutateApiRequest intent = +buildMutateRequest :: ApiRequest -> Either Text MutateRequest +buildMutateRequest apiRequest = mutateApiRequest where - action = iAction intent - target = iTarget intent - payload = fromJust $ iPayload intent + action = iAction apiRequest + target = iTarget apiRequest + payload = fromJust $ iPayload apiRequest rootTableName = -- TODO: Make it safe case target of (TargetIdent (QualifiedIdentifier _ t) ) -> t _ -> undefined mutateApiRequest = case action of - ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> pure payload) <*> pure (rootTableName, Nothing)) <*> pure [] - ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> pure payload <*> cond) <*> pure (rootTableName, Nothing)) <*> pure [] - ActionDelete -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure [] + ActionCreate -> Insert rootTableName <$> pure payload + ActionUpdate -> Update rootTableName <$> pure payload <*> cond + ActionDelete -> Delete rootTableName <$> cond _ -> Left "Unsupported HTTP verb" - mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters intent -- update/delete filters can be only on the root table + mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters -addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest -addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest +addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest +addFilter ([], flt) (Node (q@(Select {flt_=flts}), i) forest) = Node (q {flt_=flt:flts}, i) forest addFilter (path, flt) (Node rn forest) = case targetNode of Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path @@ -352,6 +351,7 @@ createReadStatement selectQuery range isSingle countTable asCsv = createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> [Text] -> Bool -> Payload -> B.Stmt P.Postgres +createWriteStatement _ _ _ _ _ _ (PayloadParseError _) = undefined createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv (PayloadJSON (UniformObjects rows)) = B.Stmt ( diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 495cfd5ab..0a3885e19 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -18,7 +18,7 @@ import Network.Wai.Middleware.Cors (cors) import Network.Wai.Middleware.Gzip (def, gzip) import Network.Wai.Middleware.Static (only, staticPolicy) -import PostgREST.RequestIntent (pickContentType) +import PostgREST.ApiRequest (pickContentType) import PostgREST.Auth (setRole, jwtClaims, claimsToSQL) import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (errResponse) diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index d58a46d0b..e6fbe30a9 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -12,12 +12,12 @@ import PostgREST.Types import Text.ParserCombinators.Parsec hiding (many, (<|>)) import PostgREST.QueryBuilder (operators) -pRequestSelect :: Text -> Parser ApiRequest +pRequestSelect :: Text -> Parser ReadRequest pRequestSelect rootNodeName = do fieldTree <- pFieldForest return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree where - treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest + treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) = case fldForest of [] -> Node (q {select=fld:select q}, i) rForest diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 812c00cf4..b4a25bc81 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -58,7 +58,7 @@ instance Monoid PStmt where mempty = B.Stmt "" empty True type StatementT = PStmt -> PStmt -addRelations :: Schema -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest +addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) = case parentNode of Nothing -> Node (query, (table, Nothing)) <$> updatedForest @@ -67,14 +67,14 @@ addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) for rel = note ("no relation between " <> table <> " and " <> parentTable) $ findRelation schema table parentTable <|> findRelation schema parentTable table - addRel :: (Query, (NodeName, Maybe Relation)) -> Relation -> (Query, (NodeName, Maybe Relation)) + addRel :: (ReadQuery, (NodeName, Maybe Relation)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation)) addRel (q, (t, _)) r = (q, (t, Just r)) where updatedForest = mapM (addRelations schema allRelations (Just node)) forest findRelation s t1 t2 = find (\r -> s == (tableSchema . relTable) r && t1 == (tableName . relTable) r && t2 == (tableName . relFTable) r) allRelations -addJoinConditions :: Schema -> ApiRequest -> Either Text ApiRequest +addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest addJoinConditions schema (Node (query, (n, r)) forest) = case r of Nothing -> Node (updatedQuery, (n,r)) <$> updatedForest -- this is the root node @@ -96,7 +96,7 @@ addJoinConditions schema (Node (query, (n, r)) forest) = getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel) getParents _ = Nothing updatedForest = mapM (addJoinConditions schema) forest - addCond q con = q{where_=con ++ where_ q} + addCond q con = q{flt_=con ++ flt_ q} asCsvF :: SqlFragment asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF @@ -189,8 +189,10 @@ pgFmtLit x = then "E" <> slashed else slashed -requestToQuery :: Schema -> ApiRequest -> SqlQuery -requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest) = +requestToQuery :: Schema -> DbRequest -> SqlQuery +requestToQuery _ (DbMutate (Insert _ (PayloadParseError _))) = undefined +requestToQuery _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined +requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest)) = query where -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name @@ -206,31 +208,31 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _) orderF (fromMaybe [] ord) ] (withs, selects) = foldr getQueryParts ([],[]) forest - getQueryParts :: Tree ApiNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment]) + getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment]) getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s) where sel = "(" <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " <> "FROM (" <> subquery <> ") " <> table <> ") AS " <> table - where subquery = requestToQuery schema (Node n forst) + where subquery = requestToQuery schema (DbRead (Node n forst)) getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s) where sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular wit = table <> " AS ( " <> subquery <> " )" - where subquery = requestToQuery schema (Node n forst) + where subquery = requestToQuery schema (DbRead (Node n forst)) getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s) where sel = "(" <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " <> "FROM (" <> subquery <> ") " <> table <> ") AS " <> table - where subquery = requestToQuery schema (Node n forst) + where subquery = requestToQuery schema (DbRead (Node n forst)) --the following is just to remove the warning --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many getQueryParts (Node (_,(_,Nothing)) _) _ = undefined -requestToQuery schema (Node (Insert _ (PayloadJSON (UniformObjects rows)), (mainTbl, _)) _) = +requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects rows)))) = let qi = QualifiedIdentifier schema mainTbl cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0)) colsString = intercalate ", " cols in @@ -241,22 +243,22 @@ requestToQuery schema (Node (Insert _ (PayloadJSON (UniformObjects rows)), (main " FROM json_populate_recordset(null::" , fromQi qi, ", ?)", " RETURNING " <> fromQi qi <> ".*" ] -requestToQuery schema (Node (Update _ (PayloadJSON (UniformObjects rows)) conditions, (mainTbl, _)) _) = +requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) = case rows V.!? 0 of Just obj -> let assignments = map (\(k,v) -> pgFmtIdent k <> "=" <> insertableValue v) $ HM.toList obj in unwords [ "UPDATE ", fromQi qi, - " SET " <> (intercalate "," assignments) <> " ", + " SET " <> intercalate "," assignments <> " ", ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, "RETURNING " <> fromQi qi <> ".*" ] - Nothing -> "" + Nothing -> undefined where qi = QualifiedIdentifier schema mainTbl -requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) = +requestToQuery schema (DbMutate (Delete mainTbl conditions)) = query where qi = QualifiedIdentifier schema mainTbl diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index e9a6ad586..2737ca386 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -106,13 +106,15 @@ type Cast = Text type NodeName = Text type SelectItem = (Field, Maybe Cast) type Path = [Text] -data Query = Select { select::[SelectItem], from::[Text], where_::[Filter], order::Maybe [OrderTerm] } - | Insert { into::Text, qPayload::Payload } - | Delete { from::[Text], where_::[Filter] } - | Update { into::Text, qPayload::Payload, where_::[Filter] } deriving (Show, Eq) +data ReadQuery = Select { select::[SelectItem], from::[Text], flt_::[Filter], order::Maybe [OrderTerm] } deriving (Show, Eq) +data MutateQuery = Insert { in_::Text, qPayload::Payload } + | Delete { in_::Text, where_::[Filter] } + | Update { in_::Text, qPayload::Payload, where_::[Filter] } deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) -type ApiNode = (Query, (NodeName, Maybe Relation)) -type ApiRequest = Tree ApiNode +type ReadNode = (ReadQuery, (NodeName, Maybe Relation)) +type ReadRequest = Tree ReadNode +type MutateRequest = MutateQuery +data DbRequest = DbRead ReadRequest | DbMutate MutateRequest instance ToJSON Column where From be9cce0043a18df812e43668b159731bee7fa82d Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Mon, 23 Nov 2015 13:45:10 -0500 Subject: [PATCH 27/30] Moves createReadStatement and createWriteStatement to QueryBuilder since they build queries. Also reduces QueryBuilder module interface. --- src/PostgREST/App.hs | 48 +---------- src/PostgREST/QueryBuilder.hs | 153 ++++++++++++++++++++-------------- 2 files changed, 95 insertions(+), 106 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index e16ba5056..ca5b66539 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -13,13 +13,12 @@ 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, isNothing, mapMaybe) +import Data.Maybe (fromMaybe, fromJust, mapMaybe) import Data.Ord (comparing) -import Data.Ranged.Ranges (emptyRange, singletonRange) +import Data.Ranged.Ranges (emptyRange) import Data.String.Conversions (cs) import Data.Text (Text, replace, strip) import Data.Tree -import qualified Data.Aeson as JSON import Text.Parsec.Error import Text.ParserCombinators.Parsec (parse) @@ -51,19 +50,12 @@ import PostgREST.Error (errResponse) import PostgREST.QueryBuilder ( asJson , callProc - , asCsvF - , asJsonF - , selectStarF - , countF - , locationF - , asJsonSingleF , addJoinConditions , sourceSubqueryName , requestToQuery - , wrapQuery - , countAllF - , countNoneF , addRelations + , createReadStatement + , createWriteStatement ) import Prelude @@ -336,38 +328,6 @@ instance ToJSON TableOptions where "columns" .= tblOptcolumns t , "pkey" .= tblOptpkey t ] -createReadStatement :: SqlQuery -> Maybe NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres -createReadStatement selectQuery range isSingle countTable asCsv = - B.Stmt ( - wrapQuery selectQuery [ - if countTable then countAllF else countNoneF, - countF, - "null", -- location header can not be calucalted - if asCsv - then asCsvF - else if isSingle then asJsonSingleF else asJsonF - ] selectStarF (if isNothing range && isSingle then Just $ singletonRange 0 else range) - ) V.empty True - -createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> - [Text] -> Bool -> Payload -> B.Stmt P.Postgres -createWriteStatement _ _ _ _ _ _ (PayloadParseError _) = undefined -createWriteStatement selectQuery mutateQuery isSingle echoRequested - pKeys asCsv (PayloadJSON (UniformObjects rows)) = - B.Stmt ( - wrapQuery mutateQuery [ - countNoneF, -- when updateing it does not make sense - countF, - if isSingle then locationF pKeys else "null", - if echoRequested - then - if asCsv - then asCsvF - else if isSingle then asJsonSingleF else asJsonF - else "null" - - ] selectQuery Nothing - ) (V.singleton . B.encodeValue . JSON.Array . V.map Object $ rows) True extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) -> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index b4a25bc81..98e572bb2 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -4,23 +4,16 @@ module PostgREST.QueryBuilder ( addRelations , addJoinConditions - , asCsvF , asJson - , asJsonF - , asJsonSingleF , callProc - , countAllF - , countF - , countNoneF - , locationF + , createReadStatement + , createWriteStatement , operators , pgFmtIdent , pgFmtLit , requestToQuery - , selectStarF , sourceSubqueryName , unquoted - , wrapQuery ) where import qualified Hasql as H @@ -31,6 +24,7 @@ import qualified Data.Aeson as JSON import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset) import Control.Error (note, fromMaybe, mapMaybe) +import Data.Maybe (isNothing) import Control.Monad (join) import qualified Data.HashMap.Strict as HM import Data.List (find) @@ -51,6 +45,8 @@ import Data.Scientific ( FPFormat (..) ) import Prelude hiding (unwords) +import Data.Ranged.Ranges (singletonRange) + type PStmt = H.Stmt P.Postgres instance Monoid PStmt where mappend (B.Stmt query params prep) (B.Stmt query' params' prep') = @@ -58,6 +54,39 @@ instance Monoid PStmt where mempty = B.Stmt "" empty True type StatementT = PStmt -> PStmt +createReadStatement :: SqlQuery -> Maybe NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres +createReadStatement selectQuery range isSingle countTable asCsv = + B.Stmt ( + wrapQuery selectQuery [ + if countTable then countAllF else countNoneF, + countF, + "null", -- location header can not be calucalted + if asCsv + then asCsvF + else if isSingle then asJsonSingleF else asJsonF + ] selectStarF (if isNothing range && isSingle then Just $ singletonRange 0 else range) + ) V.empty True + +createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> + [Text] -> Bool -> Payload -> B.Stmt P.Postgres +createWriteStatement _ _ _ _ _ _ (PayloadParseError _) = undefined +createWriteStatement selectQuery mutateQuery isSingle echoRequested + pKeys asCsv (PayloadJSON (UniformObjects rows)) = + B.Stmt ( + wrapQuery mutateQuery [ + countNoneF, -- when updateing it does not make sense + countF, + if isSingle then locationF pKeys else "null", + if echoRequested + then + if asCsv + then asCsvF + else if isSingle then asJsonSingleF else asJsonF + else "null" + + ] selectQuery Nothing + ) (V.singleton . B.encodeValue . JSON.Array . V.map JSON.Object $ rows) True + addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) = case parentNode of @@ -98,32 +127,12 @@ addJoinConditions schema (Node (query, (n, r)) forest) = updatedForest = mapM (addJoinConditions schema) forest addCond q con = q{flt_=con ++ flt_ q} -asCsvF :: SqlFragment -asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF - where - asCsvHeaderF = - "(SELECT string_agg(a.k, ',')" <> - " FROM (" <> - " SELECT json_object_keys(r)::TEXT as k" <> - " FROM ( " <> - " SELECT row_to_json(hh) as r from " <> sourceSubqueryName <> " as hh limit 1" <> - " ) s" <> - " ) a" <> - ")" - asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')" - asJson :: StatementT asJson s = s { B.stmtTemplate = "array_to_json(coalesce(array_agg(row_to_json(t)), '{}'))::character varying from (" <> B.stmtTemplate s <> ") t" } -asJsonF :: SqlFragment -asJsonF = "array_to_json(array_agg(row_to_json(t)))::character varying" - -asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element -asJsonSingleF = "string_agg(row_to_json(t)::text, ',')::character varying " - callProc :: QualifiedIdentifier -> JSON.Object -> PStmt callProc qi params = do let args = intercalate "," $ map assignment (HM.toList params) @@ -131,28 +140,6 @@ callProc qi params = do where assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v -countAllF :: SqlFragment -countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM " <> sourceSubqueryName <> ") a )" - -countF :: SqlFragment -countF = "pg_catalog.count(t)" - -countNoneF :: SqlFragment -countNoneF = "null" - -locationF :: [Text] -> SqlFragment -locationF pKeys = - "(" <> - " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceSubqueryName <> " as ss limit 1)" <> - " SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <> - " FROM s, json_each_text(s.r) AS json_data" <> - ( - if null pKeys - then "" - else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')" - ) <> - ")" - operators :: [(Text, SqlFragment)] operators = [ ("eq", "="), @@ -268,9 +255,6 @@ requestToQuery schema (DbMutate (Delete mainTbl conditions)) = "RETURNING " <> fromQi qi <> ".*" ] -selectStarF :: SqlFragment -selectStarF = "SELECT * FROM " <> sourceSubqueryName - sourceSubqueryName :: SqlFragment sourceSubqueryName = "pg_source" @@ -281,15 +265,49 @@ unquoted (JSON.Number n) = unquoted (JSON.Bool b) = cs . show $ b unquoted v = cs $ JSON.encode v -wrapQuery :: SqlQuery -> [Text] -> Text -> Maybe NonnegRange -> SqlQuery -wrapQuery source selectColumns returnSelect range = - withSourceF source <> - " SELECT " <> - intercalate ", " selectColumns <> - " " <> - fromF returnSelect ( limitF range ) - -- private functions +asCsvF :: SqlFragment +asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF + where + asCsvHeaderF = + "(SELECT string_agg(a.k, ',')" <> + " FROM (" <> + " SELECT json_object_keys(r)::TEXT as k" <> + " FROM ( " <> + " SELECT row_to_json(hh) as r from " <> sourceSubqueryName <> " as hh limit 1" <> + " ) s" <> + " ) a" <> + ")" + asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')" + +asJsonF :: SqlFragment +asJsonF = "array_to_json(array_agg(row_to_json(t)))::character varying" + +asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element +asJsonSingleF = "string_agg(row_to_json(t)::text, ',')::character varying " + +countAllF :: SqlFragment +countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM " <> sourceSubqueryName <> ") a )" + +countF :: SqlFragment +countF = "pg_catalog.count(t)" + +countNoneF :: SqlFragment +countNoneF = "null" + +locationF :: [Text] -> SqlFragment +locationF pKeys = + "(" <> + " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceSubqueryName <> " as ss limit 1)" <> + " SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <> + " FROM s, json_each_text(s.r) AS json_data" <> + ( + if null pKeys + then "" + else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')" + ) <> + ")" + fromQi :: QualifiedIdentifier -> SqlFragment fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n where @@ -409,3 +427,14 @@ limitF r = "LIMIT " <> limit <> " OFFSET " <> offset where limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r + +selectStarF :: SqlFragment +selectStarF = "SELECT * FROM " <> sourceSubqueryName + +wrapQuery :: SqlQuery -> [Text] -> Text -> Maybe NonnegRange -> SqlQuery +wrapQuery source selectColumns returnSelect range = + withSourceF source <> + " SELECT " <> + intercalate ", " selectColumns <> + " " <> + fromF returnSelect ( limitF range ) From addd47c09fbbc88762ccb55f719b41aa4ced33ec Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Mon, 23 Nov 2015 13:56:47 -0500 Subject: [PATCH 28/30] Adds haddock string to QueryBuilder module --- src/PostgREST/QueryBuilder.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 98e572bb2..e73ab758f 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -1,6 +1,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module : PostgREST.QueryBuilder +Description : PostgREST SQL generating functions. + +This module provides functions to consume data types that +represent database objects (e.g. Relation, Schema, SqlQuery) +and produces SQL Statements. + +Any function that outputs a SQL fragment should be in this module. +-} module PostgREST.QueryBuilder ( addRelations , addJoinConditions From 029276bd62dc92f2b33f1dcefd6a251c3b614455 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 23 Nov 2015 10:58:04 -0800 Subject: [PATCH 29/30] Use brackets to specify subqueries --- src/PostgREST/Parsers.hs | 2 +- test/Feature/InsertSpec.hs | 2 +- test/Feature/QuerySpec.hs | 14 +++++++------- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index e6fbe30a9..437369031 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -51,7 +51,7 @@ pFieldForest :: Parser [Tree SelectItem] pFieldForest = pFieldTree `sepBy1` lexeme (char ',') pFieldTree :: Parser (Tree SelectItem) -pFieldTree = try (Node <$> pSelect <*> between (char '(') (char ')') pFieldForest) +pFieldTree = try (Node <$> pSelect <*> between (char '{') (char '}') pFieldForest) <|> Node <$> pSelect <*> pure [] pStar :: Parser Text diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index edd1280d5..3639c72d1 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -44,7 +44,7 @@ spec = afterAll_ resetDb $ around withApp $ do } it "includes related data after insert" $ - request methodPost "/projects?select=id,name,clients(id,name)" [("Prefer", "return=representation")] + request methodPost "/projects?select=id,name,clients{id,name}" [("Prefer", "return=representation")] [str|{"id":5,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher { matchBody = Just [str|{"id":5,"name":"New Project","clients":{"id":2,"name":"Apple"}}|] , matchStatus = 201 diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index fd8dc5808..47ecd936f 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -134,7 +134,7 @@ spec = [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] it "matches filtering nested items" $ - get "/clients?select=id,projects(id,tasks(id,name))&projects.tasks.name=like.Design*" `shouldRespondWith` + get "/clients?select=id,projects{id,tasks{id,name}}&projects.tasks.name=like.Design*" `shouldRespondWith` "[{\"id\":1,\"projects\":[{\"id\":1,\"tasks\":[{\"id\":1,\"name\":\"Design w7\"}]},{\"id\":2,\"tasks\":[{\"id\":3,\"name\":\"Design w10\"}]}]},{\"id\":2,\"projects\":[{\"id\":3,\"tasks\":[{\"id\":5,\"name\":\"Design IOS\"}]},{\"id\":4,\"tasks\":[{\"id\":7,\"name\":\"Design OSX\"}]}]}]" it "matches with @> operator" $ @@ -195,23 +195,23 @@ spec = [json| [{"int":1}] |] -- the value in the db is an int, but here we expect a string for now it "requesting parents and children" $ - get "/projects?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith` + get "/projects?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith` "[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}]" it "requesting children 2 levels" $ - get "/clients?id=eq.1&select=id,projects(id,tasks(id))" `shouldRespondWith` + get "/clients?id=eq.1&select=id,projects{id,tasks{id}}" `shouldRespondWith` "[{\"id\":1,\"projects\":[{\"id\":1,\"tasks\":[{\"id\":1},{\"id\":2}]},{\"id\":2,\"tasks\":[{\"id\":3},{\"id\":4}]}]}]" it "requesting many<->many relation" $ - get "/tasks?select=id,users(id)" `shouldRespondWith` + get "/tasks?select=id,users{id}" `shouldRespondWith` "[{\"id\":1,\"users\":[{\"id\":1},{\"id\":3}]},{\"id\":2,\"users\":[{\"id\":1}]},{\"id\":3,\"users\":[{\"id\":1}]},{\"id\":4,\"users\":[{\"id\":1}]},{\"id\":5,\"users\":[{\"id\":2},{\"id\":3}]},{\"id\":6,\"users\":[{\"id\":2}]},{\"id\":7,\"users\":[{\"id\":2}]},{\"id\":8,\"users\":null}]" it "requesting parents and children on views" $ - get "/projects_view?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith` + get "/projects_view?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith` "[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}]" it "requesting children with composite key" $ - get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments(content)" `shouldRespondWith` + get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments{content}" `shouldRespondWith` "[{\"user_id\":2,\"task_id\":6,\"comments\":[{\"content\":\"Needs to be delivered ASAP\"}]}]" describe "Plurality singular" $ do @@ -228,7 +228,7 @@ spec = `shouldRespondWith` 404 it "can shape plurality singular object routes" $ - request methodGet "/projects_view?id=eq.1&select=id,name,clients(*),tasks(id,name)" [("Prefer","plurality=singular")] "" + request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [("Prefer","plurality=singular")] "" `shouldRespondWith` "{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}" From a5e7d9aff06e5b1f920a4259f27c4cf6594d5e69 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Mon, 23 Nov 2015 11:15:24 -0800 Subject: [PATCH 30/30] Update changelog --- CHANGELOG.md | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a3564e099..d5266ee30 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,10 +5,13 @@ This project adheres to [Semantic Versioning](http://semver.org/). ## Unreleased +### Fixed +- Use reasonable amount of memory during bulk inserts - @begriffs + ### Added - Ensure JWT expires - @calebmer - Postgres connection string argument - @calebmer -- Encode JWT for procs that return type `jwt_claims` - @ +- Encode JWT for procs that return type `jwt_claims` - @diogob - Full text operators `@>`,`<@` - @ruslantalpa - Shaping of the response body (filter columns, embed relations) with &select parameter for POST/PATCH - @ruslantalpa - Detect relationships between public views and private tables - @calebmer @@ -20,6 +23,9 @@ This project adheres to [Semantic Versioning](http://semver.org/). - Secure flag - @calebmer - PUT request handling - @ruslantalpa +### Changed +- Embed foreign keys with {} rather than () - @begriffs + ## [0.2.12.1] - 2015-11-12 ### Fixed