diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits. -version: 0.2.12.1 +version: 0.3.0.0 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE @@ -22,10 +22,15 @@ Default: False executable postgrest + if flag(ci) + ghc-options: -Wall -W -Werror + else + ghc-options: -Wall -W -O2 + main-is: PostgREST/Main.hs default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes default-language: Haskell2010 - build-depends: base >=4.6 && <5 + build-depends: base >= 4.8 && < 5 , postgrest , hasql >= 0.7.3 && < 0.8 , hasql-backend >= 0.4.1 && < 0.5 @@ -37,6 +42,7 @@ , case-insensitive , scientific, time , aeson >= 0.8, network >= 2.6 + , aeson-pretty >= 0.7 && < 0.8 , bytestring, text, split, string-conversions , stringsearch , containers, unordered-containers @@ -56,6 +62,18 @@ , errors , bifunctors hs-source-dirs: src + other-modules: Paths_postgrest + , PostgREST.App + , PostgREST.Auth + , PostgREST.Config + , PostgREST.Error + , PostgREST.Middleware + , PostgREST.Parsers + , PostgREST.DbStructure + , PostgREST.QueryBuilder + , PostgREST.RangeQuery + , PostgREST.ApiRequest + , PostgREST.Types library if flag(ci) @@ -65,47 +83,61 @@ default-language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes - build-depends: base >=4.6 && <5 - , hasql, hasql-backend - , hasql-postgres - , warp, wai - , wai-extra, wai-cors - , wai-middleware-static - , HTTP, convertible, http-types - , case-insensitive - , scientific, time - , aeson, network - , bytestring, text, split, string-conversions - , stringsearch - , containers, unordered-containers - , optparse-applicative - , regex-base, regex-tdfa + build-depends: HTTP + , MissingH , Ranged-sets - , transformers, MissingH - , bcrypt, base64-string - , network-uri - , resource-pool + , aeson + , base >=4.6 && <5 + , base64-string + , bcrypt + , bifunctors , blaze-builder - , vector - , mtl + , bytestring + , case-insensitive , cassava + , containers + , convertible + , errors + , hasql + , hasql-backend + , hasql-postgres + , http-types , jwt + , mtl + , network + , network-uri + , optparse-applicative , parsec - , errors - , bifunctors + , regex-base + , regex-tdfa + , resource-pool + , scientific + , split + , string-conversions + , stringsearch + , text + , time + , transformers + , unordered-containers + , vector + , wai + , wai-cors + , wai-extra + , wai-middleware-static + , warp Other-Modules: Paths_postgrest Exposed-Modules: PostgREST.App - , PostgREST.Types - , PostgREST.Parsers - , PostgREST.QueryBuilder , PostgREST.Auth , PostgREST.Config , PostgREST.Error , PostgREST.Middleware - , PostgREST.PgQuery - , PostgREST.PgStructure + , PostgREST.Parsers + , PostgREST.DbStructure + , PostgREST.QueryBuilder , PostgREST.RangeQuery + , PostgREST.ApiRequest + , PostgREST.Types hs-source-dirs: src Test-Suite spec @@ -118,21 +150,29 @@ else ghc-options: -Wall -W -O2 Main-Is: Main.hs - Other-Modules: PostgREST.App - , PostgREST.Types - , PostgREST.Parsers - , PostgREST.QueryBuilder + Other-Modules: Feature.AuthSpec + , Feature.CorsSpec + , Feature.DeleteSpec + , Feature.InsertSpec + , Feature.QuerySpec + , Feature.RangeSpec + , Feature.StructureSpec + , Paths_postgrest + , PostgREST.App , PostgREST.Auth , PostgREST.Config , PostgREST.Error , PostgREST.Middleware - , PostgREST.PgQuery - , PostgREST.PgStructure + , PostgREST.Parsers + , PostgREST.DbStructure + , PostgREST.QueryBuilder , PostgREST.RangeQuery + , PostgREST.ApiRequest + , PostgREST.Types , Spec , SpecHelper - , Paths_postgrest - Build-Depends: base, hspec == 2.1.*, QuickCheck + , TestTypes + Build-Depends: base, hspec == 2.2.*, QuickCheck , hspec-wai, hspec-wai-json , hasql, hasql-backend , hasql-postgres diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/ApiRequest.hs @@ -0,0 +1,216 @@ +module PostgREST.ApiRequest where + +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 qualified Data.Set as S +import Data.Maybe (fromMaybe, isJust, isNothing, + listToMaybe, fromJust) +import Control.Monad (join) +import Data.Monoid ((<>)) +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, Payload(..), + UniformObjects(..)) + +type RequestBody = BL.ByteString + +-- | Types of things a user wants to do to tables/views/procs +data Action = ActionCreate | ActionRead + | ActionUpdate | ActionDelete + | ActionInfo | ActionInvoke + | 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 deriving Eq +instance Show ContentType where + show ApplicationJSON = "application/json" + show TextCSV = "text/csv" + +{-| + 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 ApiRequest = ApiRequest { + -- | Set to Nothing for unknown HTTP verbs + iAction :: Action + -- | Set to Nothing for malformed range + , iRange :: Maybe NonnegRange + -- | Set to Nothing for strangely nested urls + , 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 + , 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. +userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest +userApiRequest schema req reqBody = + let action = case method of + "GET" -> ActionRead + "POST" -> if isTargetingProc + then ActionInvoke + else ActionCreate + "PATCH" -> ActionUpdate + "DELETE" -> ActionDelete + "OPTIONS" -> ActionInfo + other -> ActionUnknown other + target = case path of + [] -> TargetRoot + [table] -> TargetIdent + $ QualifiedIdentifier schema table + ["rpc", proc] -> TargetIdent + $ QualifiedIdentifier schema proc + other -> TargetUnknown other + 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) + (\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 $ + "Content-type not acceptable: " <> accept + relevantPayload = case action of + ActionCreate -> Just payload + ActionUpdate -> Just payload + ActionInvoke -> Just payload + _ -> Nothing in + + ApiRequest { + iAction = action + , iRange = if singular then Nothing else rangeRequested hdrs + , iTarget = target + , iAccepts = pickContentType $ lookupHeader "accept" + , iPayload = relevantPayload + , 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" + + + +-- 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 +-} +pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType +pickContentType accept + | isNothing accept || has ctAll || has ctJson = Right ApplicationJSON + | has ctCsv = Right TextCSV + | otherwise = Left accept' + where + ctAll = "*/*" + ctCsv = "text/csv" + ctJson = "application/json" + Just accept' = accept + findInAccept = flip find $ parseHttpAccept accept' + has = isJust . findInAccept . BS.isPrefixOf + +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 +-} +csvToJson :: (CSV.Header, CsvData) -> JSON.Array +csvToJson (_, vals) = + V.map rowToJsonObj vals + where + 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 + +-- | 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 + (\val result -> case val of + JSON.Object o -> V.cons o result + _ -> result) + V.empty arr + keysPerObj = V.map (S.fromList . M.keys) objs + canonicalKeys = fromMaybe S.empty $ keysPerObj V.!? 0 + areKeysUniform = all (==canonicalKeys) keysPerObj in + + if (V.length objs == V.length arr) && areKeysUniform + then Just (UniformObjects objs) + else Nothing diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,409 +1,322 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +--module PostgREST.App where module PostgREST.App ( app -, sqlError -, isSqlError -, contentTypeForAccept -, jsonH -, requestedSchema -, TableOptions(..) ) where -import qualified Blaze.ByteString.Builder as BB import Control.Applicative -import Control.Arrow (second, (***)) +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 Data.CaseInsensitive (original) -import qualified Data.Csv as CSV import Data.Functor.Identity -import qualified Data.HashMap.Strict as M -import Data.List (find, sortBy) -import Data.Maybe (fromMaybe, isJust, isNothing, - mapMaybe) +import Data.List (find, sortBy, delete) +import Data.Maybe (fromMaybe, fromJust, mapMaybe) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) -import qualified Data.Set as S import Data.String.Conversions (cs) import Data.Text (Text, replace, strip) -import Text.Regex.TDFA ((=~)) +import Data.Tree import Text.Parsec.Error +import Text.ParserCombinators.Parsec (parse) import Network.HTTP.Base (urlEncodeVars) import Network.HTTP.Types.Header import Network.HTTP.Types.Status import Network.HTTP.Types.URI (parseSimpleQuery) import Network.Wai -import Network.Wai.Internal (Response (..)) -import Network.Wai.Parse (parseHttpAccept) import Data.Aeson +import Data.Aeson.Types (emptyArray) import Data.Monoid import qualified Data.Vector as V import qualified Hasql as H import qualified Hasql.Backend as B import qualified Hasql.Postgres as P -import PostgREST.Auth import PostgREST.Config (AppConfig (..)) import PostgREST.Parsers -import PostgREST.PgQuery -import PostgREST.PgStructure -import PostgREST.QueryBuilder +import PostgREST.DbStructure import PostgREST.RangeQuery +import PostgREST.ApiRequest (ApiRequest(..), ContentType(..) + , Action(..), Target(..) + , userApiRequest) import PostgREST.Types +import PostgREST.Auth (tokenJWT) +import PostgREST.Error (errResponse) -import Prelude +import PostgREST.QueryBuilder ( asJson + , callProc + , addJoinConditions + , sourceSubqueryName + , requestToQuery + , addRelations + , createReadStatement + , createWriteStatement + ) -app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response -app dbstructure conf reqBody dbrole req = - case (path, verb) of +import Prelude - ([], _) -> do - let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs - return $ responseLBS status200 [jsonH] $ cs body +app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response +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 apiRequest) + contentTypeH = (hContentType, cs $ show contentType) in - ([table], "OPTIONS") -> do - let cols = filter (filterCol schema table) allCols - pkeys = map pkName $ filter (filterPk schema table) allPrKeys - body = encode (TableOptions cols pkeys) - return $ responseLBS status200 [jsonH, allOrigins] $ cs body + case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of - ([table], "GET") -> - if range == Just emptyRange - then return $ responseLBS status416 [] "HTTP Range error" - else - case queries of - Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e - Right (qs, cqs) -> do - let qt = qualify table - count = if hasPrefer "count=none" - then countNone - else cqs - q = B.Stmt "select " V.empty True <> - parentheticT count - <> commaq <> ( - bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables - . limitT range - $ qs + (ActionRead, TargetIdent qi, Nothing) -> + case selectQuery of + Left e -> return $ responseLBS status400 [jsonH] $ cs e + Right q -> do + let range = iRange apiRequest + singular = iPreferSingular apiRequest + stm = createReadStatement q range singular + (iPreferCount apiRequest) (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 ) - row <- H.maybeEx q - let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString) row - to = from+queryTotal-1 - contentRange = contentRangeH from to tableTotal - status = rangeStatus from to tableTotal - canonical = urlEncodeVars - . 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) - - where - from = fromMaybe 0 $ rangeOffset <$> range - apiRequest = first formatParserError (parseGetRequest req) - >>= first formatRelationError . addRelations schema allRels Nothing - >>= addJoinConditions schema allCols - where - formatRelationError :: Text -> Text - formatRelationError e = cs $ encode $ object [ - "mesage" .= ("could not find foreign keys between these entities"::String), - "details" .= e] - formatParserError :: ParseError -> Text - formatParserError e = cs $ encode $ object [ - "message" .= message, - "details" .= details] - where - message = show (errorPos e) - details = strip $ replace "\n" " " $ cs - $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) - - query = requestToQuery schema <$> apiRequest - countQuery = requestToCountQuery schema <$> apiRequest - queries = (,) <$> query <*> countQuery - - - (["postgrest", "users"], "POST") -> do - let user = decode reqBody :: Maybe AuthUser + ] (fromMaybe "[]" body) - case user of - Nothing -> return $ responseLBS status400 [jsonH] $ - encode . object $ [("message", String "Failed to parse user.")] - Just u -> do - _ <- addUser (cs $ userId u) - (cs $ userPass u) (cs <$> userRole u) + (ActionCreate, TargetIdent (QualifiedIdentifier _ table), + Just payload@(PayloadJSON (UniformObjects rows))) -> + case queries of + Left e -> return $ responseLBS status400 [jsonH] $ cs e + Right (sq,mq) -> do + let isSingle = (==1) $ V.length rows + let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? + let stm = createWriteStatement sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload + row <- H.maybeEx stm + let (_, _, location, body) = extractQueryResult row return $ responseLBS status201 - [ jsonH - , (hLocation, "/postgrest/users?id=eq." <> cs (userId u)) - ] "" + [ + contentTypeH, + (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) + ] + $ if iPreferRepresentation apiRequest then fromMaybe "[]" body else "" - (["postgrest", "tokens"], "POST") -> - case jwtSecret of - "secret" -> return $ responseLBS status500 [jsonH] $ - encode . object $ [("message", String "JWT Secret is set as \"secret\" which is an unsafe default.")] - _ -> do - let user = decode reqBody :: Maybe AuthUser + (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 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 apiRequest -> status200 + | otherwise -> status204 + return $ responseLBS s [contentTypeH, r] + $ if iPreferRepresentation apiRequest then fromMaybe "[]" body else "" - case user of - Nothing -> return $ responseLBS status400 [jsonH] $ - encode . object $ [("message", String "Failed to parse user.")] - Just u -> do - setRole authenticator - login <- signInRole (cs $ userId u) (cs $ userPass u) - case login of - LoginSuccess role uid -> - return $ responseLBS status201 [ jsonH ] $ - encode . object $ [("token", String $ tokenJWT jwtSecret uid role)] - _ -> return $ responseLBS status401 [jsonH] $ - encode . object $ [("message", String "Failed authentication.")] + (ActionDelete, TargetIdent _, Nothing) -> + case queries of + Left e -> return $ responseLBS status400 [jsonH] $ cs e + Right (sq,mq) -> do + let fakeload = PayloadJSON $ UniformObjects V.empty + let stm = createWriteStatement sq mq False False [] (contentType == TextCSV) fakeload + row <- H.maybeEx stm + let (_, queryTotal, _, _) = extractQueryResult row + return $ if queryTotal == 0 + then notFound + else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] "" - ([table], "POST") -> do - let qt = qualify table - echoRequested = hasPrefer "return=representation" - parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value)) - parsed = if lookupHeader "Content-Type" == Just csvMT - then do - rows <- CSV.decode CSV.NoHeader reqBody - if V.null rows then Left "CSV requires header" - else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows)) - else eitherDecode reqBody >>= \val -> - case val of - Object obj -> Right . second V.singleton . V.unzip . V.fromList $ - M.toList obj - _ -> Left "Expecting single JSON object or CSV rows" - case parsed of - Left err -> return $ responseLBS status400 [] $ - encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)] - Right toBeInserted -> do - rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted - let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows - pKeys = map pkName $ filter (filterPk schema table) allPrKeys - responses = flip map inserted $ \obj -> do - let primaries = - if Prelude.null pKeys - then obj - else M.filterWithKey (const . (`elem` pKeys)) obj - let params = urlEncodeVars - $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t))) - $ sortBy (comparing fst) $ M.toList primaries - responseLBS status201 - [ jsonH - , (hLocation, "/" <> cs table <> "?" <> cs params) - ] $ if echoRequested then encode obj else "" - return $ multipart status201 responses + (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 - (["rpc", proc], "POST") -> do - let qi = QualifiedIdentifier schema (cs proc) - exists <- doesProcExist schema proc + (ActionInvoke, TargetIdent qi, + Just (PayloadJSON (UniformObjects payload))) -> do + exists <- doesProcExist qi if exists then do - let call = B.Stmt "select " V.empty True <> - asJson (callProc qi $ fromMaybe M.empty (decode reqBody)) - body :: Maybe (Identity Text) <- H.maybeEx call - return $ responseLBS status200 [jsonH] - (cs $ fromMaybe "[]" $ runIdentity <$> body) - else return $ responseLBS status404 [] "" - - -- check that proc exists - -- check that arg names are all specified - -- select * from "1".proc(a := "foo"::undefined) where whereT limit limitT - - ([table], "PUT") -> - handleJsonObj reqBody $ \obj -> do - let qt = qualify table - pKeys = map pkName $ filter (filterPk schema table) allPrKeys - specifiedKeys = map (cs . fst) qq - if S.fromList pKeys /= S.fromList specifiedKeys - then return $ responseLBS status405 [] - "You must speficy all and only primary keys as params" - else do - let tableCols = map (cs . colName) $ filter (filterCol schema table) allCols - cols = map cs $ M.keys obj - if S.fromList tableCols == S.fromList cols - then do - let vals = M.elems obj - H.unitEx $ iffNotT - (whereT qt qq $ update qt cols vals) - (insertSelect qt cols vals) - return $ responseLBS status204 [ jsonH ] "" - - else return $ if Prelude.null tableCols - then responseLBS status404 [] "" - else responseLBS status400 [] - "You must specify all columns in PUT request" - - ([table], "PATCH") -> - handleJsonObj reqBody $ \obj -> do - let qt = qualify table - up = returningStarT - . whereT qt qq - $ update qt (map cs $ M.keys obj) (M.elems obj) - patch = withT up "t" $ B.Stmt - "select count(t), array_to_json(array_agg(row_to_json(t)))::character varying" - V.empty True + let p = V.head payload + call = B.Stmt "select " V.empty True <> + asJson (callProc qi p) + jwtSecret = configJwtSecret conf - row <- H.maybeEx patch - let (queryTotal, body) = - fromMaybe (0 :: Int, Just "" :: Maybe Text) row - r = contentRangeH 0 (queryTotal-1) (Just queryTotal) - echoRequested = hasPrefer "return=representation" - s = case () of _ | queryTotal == 0 -> status404 - | echoRequested -> status200 - | otherwise -> status204 - return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else "" + 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 - ([table], "DELETE") -> do - let qt = qualify table - del = countT - . returningStarT - . whereT qt qq - $ deleteFrom qt - row <- H.maybeEx del - let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row - return $ if deletedCount == 0 - then responseLBS status404 [] "" - else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] "" + (ActionRead, TargetRoot, Nothing) -> do + body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure)) + return $ responseLBS status200 [jsonH] $ cs body - (_, _) -> - return $ responseLBS status404 [] "" + (ActionUnknown _, _, _) -> return notFound - where - allTabs = tables dbstructure - allRels = relations dbstructure - allCols = columns dbstructure - allPrKeys = primaryKeys dbstructure - filterCol sc table (Column{colSchema=s, colTable=t}) = s==sc && table==t - filterCol _ _ _ = False - filterPk sc table pk = sc == pkSchema pk && table == pkTable pk + (_, TargetUnknown _, _) -> return notFound - filterTableAcl :: Text -> Table -> Bool - filterTableAcl r (Table{tableAcl=a}) = r `elem` a - path = pathInfo req - verb = requestMethod req - qq = queryString req - qualify = QualifiedIdentifier schema - hdrs = requestHeaders req - lookupHeader = flip lookup hdrs - hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs - accept = lookupHeader hAccept - schema = requestedSchema (cs $ configV1Schema conf) accept - authenticator = cs $ configDbUser conf - jwtSecret = cs $ configJwtSecret conf - range = rangeRequested hdrs - allOrigins = ("Access-Control-Allow-Origin", "*") :: Header - contentType = fromMaybe "application/json" $ contentTypeForAccept accept - contentTypeH = (hContentType, contentType) + (_, _, Just (PayloadParseError e)) -> + return $ responseLBS status400 [jsonH] $ + cs (formatGeneralError "Cannot parse request payload" (cs e)) -sqlError :: t -sqlError = undefined + (_, _, _) -> return notFound -isSqlError :: t -isSqlError = undefined + 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 + schema = cs $ configSchema conf + 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 rangeStatus _ _ Nothing = status200 -rangeStatus from to (Just total) - | from > total = status416 - | (1 + to - from) < total = status206 +rangeStatus frm to (Just total) + | frm > total = status416 + | (1 + to - frm) < total = status206 | otherwise = status200 contentRangeH :: Int -> Int -> Maybe Int -> Header -contentRangeH from to total = +contentRangeH frm to total = ("Content-Range", cs headerValue) where headerValue = rangeString <> "/" <> totalString rangeString - | totalNotZero && fromInRange = show from <> "-" <> cs (show to) + | totalNotZero && fromInRange = show frm <> "-" <> cs (show to) | otherwise = "*" totalString = fromMaybe "*" (show <$> total) totalNotZero = fromMaybe True ((/=) 0 <$> total) - fromInRange = from <= to - -requestedSchema :: Text -> Maybe BS.ByteString -> Text -requestedSchema v1schema accept = - case verStr of - Just [[_, ver]] -> if ver == "1" then v1schema else cs ver - _ -> v1schema - - where - verRegex = "version[ ]*=[ ]*([0-9]+)" :: BS.ByteString - verStr = (=~ verRegex) <$> accept :: Maybe [[BS.ByteString]] + fromInRange = frm <= to +jsonH :: Header +jsonH = (hContentType, "application/json") -jsonMT :: BS.ByteString -jsonMT = "application/json" +formatRelationError :: Text -> Text +formatRelationError = formatGeneralError + "could not find foreign keys between these entities" -csvMT :: BS.ByteString -csvMT = "text/csv" +formatParserError :: ParseError -> Text +formatParserError e = formatGeneralError message details + where + message = cs $ show (errorPos e) + details = strip $ replace "\n" " " $ cs + $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) -allMT :: BS.ByteString -allMT = "*/*" +formatGeneralError :: Text -> Text -> Text +formatGeneralError message details = cs $ encode $ object [ + "message" .= message, + "details" .= details] -jsonH :: Header -jsonH = (hContentType, jsonMT) +augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either Text ReadRequest +augumentRequestWithJoin schema allRels request = + (first formatRelationError . addRelations schema allRels Nothing) request + >>= addJoinConditions schema -contentTypeForAccept :: Maybe BS.ByteString -> Maybe BS.ByteString -contentTypeForAccept accept - | isNothing accept || has allMT || has jsonMT = Just jsonMT - | has csvMT = Just csvMT - | otherwise = Nothing +buildReadRequest :: [Relation] -> ApiRequest -> Either Text ReadRequest +buildReadRequest allRels apiRequest = + augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> readRequest <*> ord) <*> flts) where - Just acceptH = accept - findInAccept = flip find $ parseHttpAccept acceptH - has = isJust . findInAccept . BS.isPrefixOf - -bodyForAccept :: BS.ByteString -> QualifiedIdentifier -> StatementT -bodyForAccept contentType table - | contentType == csvMT = asCsvWithCount table - | otherwise = asJsonWithCount -- defaults to JSON - -handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response) - -> H.Tx P.Postgres s Response -handleJsonObj reqBody handler = do - let p = eitherDecode reqBody - case p of - Left err -> - return $ responseLBS status400 [jsonH] jErr - where - jErr = encode . object $ - [("message", String $ "Failed to parse JSON payload. " <> cs err)] - Right (Object o) -> handler o - Right _ -> - return $ responseLBS status400 [jsonH] jErr - where - jErr = encode . object $ - [("message", String "Expecting a JSON object")] + 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) + _ -> Nothing -parseCsvCell :: BL.ByteString -> Value -parseCsvCell s = if s == "NULL" then Null else String $ cs s + rootName = if action == ActionRead + then rootTableName + else sourceSubqueryName + filters = if action == ActionRead + 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 + 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 -multipart :: Status -> [Response] -> Response -multipart _ [] = responseLBS status204 [] "" -multipart _ [r] = r -multipart s rs = - responseLBS s [(hContentType, "multipart/mixed; boundary=\"postgrest_boundary\"")] $ - BL.intercalate "\n--postgrest_boundary\n" (map renderResponseBody rs) +buildMutateRequest :: ApiRequest -> Either Text MutateRequest +buildMutateRequest apiRequest = + mutateApiRequest + where + 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 -> Insert rootTableName <$> pure payload + ActionUpdate -> Update rootTableName <$> pure payload <*> cond + ActionDelete -> Delete rootTableName <$> cond + _ -> Left "Unsupported HTTP verb" + 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) -> 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 + Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest) where - renderHeader :: Header -> BL.ByteString - renderHeader (k, v) = cs (original k) <> ": " <> cs v + targetNodeName:remainingPath = path + (targetNode,restForest) = splitForest targetNodeName forest + splitForest name forst = + case maybeNode of + Nothing -> (Nothing,forest) + Just node -> (Just node, delete node forest) + where maybeNode = find ((name==).fst.snd.rootLabel) forst - renderResponseBody :: Response -> BL.ByteString - renderResponseBody (ResponseBuilder _ headers b) = - BL.intercalate "\n" (map renderHeader headers) - <> "\n\n" <> BB.toLazyByteString b - renderResponseBody _ = error - "Unable to create multipart response from non-ResponseBuilder" +-- in a relation where one of the tables mathces "TableName" +-- replace the name to that table with pg_source +-- this "fake" relations is needed so that in a mutate query +-- we can look a the "returning *" part which is wrapped with a "with" +-- as just another table that has relations with other tables +toSourceRelation :: TableName -> Relation -> Maybe Relation +toSourceRelation mt r@(Relation t _ ft _ _ rt _ _) + | mt == tableName t = Just $ r {relTable=t {tableName=sourceSubqueryName}} + | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceSubqueryName}} + | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceSubqueryName}) <$> rt} + | otherwise = Nothing data TableOptions = TableOptions { tblOptcolumns :: [Column] @@ -414,3 +327,8 @@ toJSON t = object [ "columns" .= tblOptcolumns t , "pkey" .= tblOptpkey t ] + + +extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) + -> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString) +extractQueryResult = fromMaybe (Just 0, 0, Just "", Just "") diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -1,104 +1,84 @@ -module PostgREST.Auth where +{-# LANGUAGE FlexibleContexts #-} +{-| +Module : PostgREST.Auth +Description : PostgREST authorization functions. -import Control.Applicative -import Control.Monad (mzero) -import Crypto.BCrypt -import Data.Aeson -import Data.Map -import Data.Monoid +This module provides functions to deal with the JWT authorization (http://jwt.io). +It also can be used to define other authorization functions, +in the future Oauth, LDAP and similar integrations can be coded here. + +Authentication should always be implemented in an external service. +In the test suite there is an example of simple login function that can be used for a +very simple authentication system inside the PostgreSQL database. +-} +module PostgREST.Auth ( + setRole + , claimsToSQL + , jwtClaims + , tokenJWT + ) where + +import Control.Monad (join) +import Data.Aeson (Value (..), Object) +import Data.Aeson.Types (emptyObject, emptyArray) +import Data.Vector as V (null, head) +import Data.Map as M (fromList, toList) +import Data.Monoid ((<>)) import Data.String.Conversions (cs) -import Data.Text -import Data.Maybe (isNothing) -import qualified Data.Vector as V -import qualified Hasql as H -import qualified Hasql.Backend as B -import qualified Hasql.Postgres as P -import PostgREST.PgQuery (pgFmtLit) -import Prelude +import Data.Text (Text) +import Data.Time.Clock (NominalDiffTime) +import PostgREST.QueryBuilder (pgFmtLit, pgFmtIdent, unquoted) import qualified Web.JWT as JWT +import qualified Data.HashMap.Lazy as H -import System.IO.Unsafe +{-| + Receives a map of JWT claims and returns a list + of PostgreSQL statements to set the claims as user defined GUCs. + Except if we have a claim called role, + this one is mapped to a SET ROLE statement. + In case there is any problem decoding the JWT it returns Nothing. +-} +claimsToSQL :: JWT.ClaimsMap -> [Text] +claimsToSQL = map setVar . toList + where + setVar ("role", String val) = setRole val + setVar (k, val) = "set local postgrest.claims." <> pgFmtIdent k <> + " = " <> valueToVariable val <> ";" + valueToVariable = pgFmtLit . unquoted -data AuthUser = AuthUser { - userId :: String - , userPass :: String - , userRole :: Maybe String - } deriving (Show) +{-| + Receives the JWT secret (from config) and a JWT and + returns a map of JWT claims + In case there is any problem decoding the JWT it returns Nothing. +-} +jwtClaims :: JWT.Secret -> Text -> NominalDiffTime -> Maybe JWT.ClaimsMap +jwtClaims secret input time = + case join $ claim JWT.exp of + Just expires -> + if JWT.secondsSinceEpoch expires > time + then customClaims + else Nothing + _ -> customClaims + where + decoded = JWT.decodeAndVerifySignature secret input + claim :: (JWT.JWTClaimsSet -> a) -> Maybe a + claim prop = prop . JWT.claims <$> decoded + customClaims = claim JWT.unregisteredClaims -instance FromJSON AuthUser where - parseJSON (Object v) = AuthUser <$> - v .: "id" <*> - v .: "pass" <*> - v .:? "role" - parseJSON _ = mzero +-- | Receives the name of a role and returns a SET ROLE statement +setRole :: Text -> Text +setRole role = "set local role " <> cs (pgFmtLit role) <> ";" -instance ToJSON AuthUser where - toJSON u = object [ - "id" .= userId u - , "pass" .= userPass u - , "role" .= userRole u ] -type DbRole = Text -type UserId = Text - -data LoginAttempt = - NoCredentials - | MalformedAuth - | LoginFailed - | LoginSuccess DbRole UserId - deriving (Eq, Show) - -checkPass :: Text -> Text -> Bool -checkPass = (. cs) . validatePassword . cs - -setRole :: Text -> H.Tx P.Postgres s () -setRole role = H.unitEx $ B.Stmt ("set local role " <> cs (pgFmtLit role)) V.empty True - -setUserId :: Text -> H.Tx P.Postgres s () -setUserId uid = - if uid /= "" - then H.unitEx $ B.Stmt ("set local user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True - else resetUserId - -resetUserId :: H.Tx P.Postgres s () -resetUserId = H.unitEx [H.stmt|reset user_vars.user_id|] - -addUser :: Text -> Text -> Maybe Text -> H.Tx P.Postgres s () -addUser identity pass role = - H.unitEx $ - if isNothing role - then [H.stmt|insert into postgrest.auth (id, pass) values (?, ?)|] - identity hashedText - else [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|] - identity hashedText role - where Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass) - hashedText = cs hashed :: Text - -signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt -signInRole user pass = do - u <- H.maybeEx $ [H.stmt|select id, pass, rolname from postgrest.auth where id = ?|] user - return $ maybe LoginFailed (\r -> - let (uid, hashed, role) = r in - if checkPass hashed pass - then LoginSuccess role uid - else LoginFailed - ) u - -signInWithJWT :: Text -> Text -> LoginAttempt -signInWithJWT secret input = case maybeRole of - Just (Just (String role)) -> case maybeUserId of - Just (Just (String uid)) -> LoginSuccess (cs role) (cs uid) - _ -> LoginFailed - _ -> LoginFailed - where - maybeRole = (Data.Map.lookup "role" <$> claims) ::Maybe (Maybe Value) - maybeUserId = (Data.Map.lookup "id" <$> claims) ::Maybe (Maybe Value) - claims = JWT.unregisteredClaims <$> JWT.claims <$> decoded - decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input - -tokenJWT :: Text -> Text -> Text -> Text -tokenJWT secret uid role = JWT.encodeSigned JWT.HS256 (JWT.secret secret) claimsSet - where - claimsSet = JWT.def { - JWT.unregisteredClaims = Data.Map.fromList [("id", String uid), ("role", String role)] - } +{-| + Receives the JWT secret (from config) and a JWT and a JSON value + and returns a signed JWT. +-} +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 + fromHashMap :: Object -> JWT.ClaimsMap + fromHashMap = M.fromList . H.toList +tokenJWT secret _ = tokenJWT secret emptyArray diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -28,44 +28,35 @@ import Data.Version (versionBranch) import Network.Wai import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) -import Options.Applicative hiding (columns) +import Options.Applicative import Paths_postgrest (version) +import Web.JWT (Secret, secret) import Prelude -- | Data type to store all command line options data AppConfig = AppConfig { - configDbName :: String - , configDbPort :: Int - , configDbUser :: String - , configDbPass :: String - , configDbHost :: String - + configDatabase :: String , configPort :: Int , configAnonRole :: String - , configSecure :: Bool + , configSchema :: String + , configJwtSecret :: Secret , configPool :: Int - , configV1Schema :: String - , configJwtSecret :: String } argParser :: Parser AppConfig argParser = AppConfig - <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database") - <*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault) - <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role") - <*> strOption (long "db-pass" <> metavar "PASS" <> value "" <> help "password for authenticator role") - <*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault) + <$> argument str (help "database connection string" <> metavar "STRING") - <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault) - <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE" <> help "postgres role to use for non-authenticated requests") - <*> switch (long "secure" <> short 's' <> help "Redirect all requests to HTTPS") - <*> option auto (long "db-pool" <> metavar "COUNT" <> value 10 <> help "Max connections in database pool" <> showDefault) - <*> strOption (long "v1schema" <> metavar "NAME" <> value "1" <> help "Schema to use for nonspecified version (or explicit v1)" <> showDefault) - <*> strOption (long "jwt-secret" <> metavar "SECRET" <> value "secret" <> help "Secret used to encrypt and decrypt JWT tokens)" <> showDefault) + <*> 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) + <*> (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 defaultCorsPolicy = CorsResourcePolicy Nothing - ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing + ["GET", "POST", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing (Just $ 60*60*24) False False True -- | CORS policy to be used in by Wai Cors middleware diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/DbStructure.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +module PostgREST.DbStructure ( + getDbStructure +, accessibleTables +, doesProcExist +, doesProcReturnJWT +) where + +import Control.Applicative +import Control.Monad (join) +import Data.Functor.Identity +import Data.List (elemIndex, find, subsequences, sort, transpose) +import Data.Maybe (fromMaybe, fromJust, isJust, mapMaybe, listToMaybe) +import Data.Monoid +import Data.Text (Text, split) +import qualified Hasql as H +import qualified Hasql.Postgres as P +import qualified Hasql.Backend as B +import PostgREST.Types + +import GHC.Exts (groupWith) +import Prelude + +getDbStructure :: Schema -> H.Tx P.Postgres s DbStructure +getDbStructure schema = do + tabs <- allTables + cols <- allColumns tabs + syns <- allSynonyms cols + rels <- allRelations tabs cols + keys <- allPrimaryKeys tabs + + let rels' = (addManyToManyRelations . raiseRelations schema syns . addParentRelations . addSynonymousRelations syns) rels + cols' = addForeignKeys rels' cols + keys' = synonymousPrimaryKeys syns keys + + return DbStructure { + dbTables = tabs + , dbColumns = cols' + , dbRelations = rels' + , dbPrimaryKeys = keys' + } + +doesProc :: forall c s. B.CxValue c Int => + (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 :: 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 + ON pronamespace = n.oid + WHERE nspname = ? + AND proname = ? + |] + +doesProcReturnJWT :: QualifiedIdentifier -> H.Tx P.Postgres s Bool +doesProcReturnJWT = doesProc [H.stmt| + SELECT 1 + FROM pg_catalog.pg_namespace n + JOIN pg_catalog.pg_proc p + ON pronamespace = n.oid + WHERE nspname = ? + AND proname = ? + AND pg_catalog.pg_get_function_result(p.oid) like '%jwt_claims' + |] + +accessibleTables :: [Table] -> H.Tx P.Postgres s [Table] +accessibleTables allTabs = do + accessible <- H.listEx $ [H.stmt| + SELECT + n.nspname AS table_schema, + c.relname AS table_name + FROM pg_class c + JOIN pg_namespace n ON n.oid = c.relnamespace + WHERE + c.relkind IN ('v','r','m') AND + n.nspname NOT IN ('pg_catalog', 'information_schema') AND ( + pg_has_role(c.relowner, 'USAGE'::text) OR + has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR + has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) + ) + ORDER BY table_schema, table_name + |] + let isAccessible table = isJust $ find (\(s,n) -> tableSchema table == s && tableName table == n) accessible + return $ filter isAccessible allTabs + +synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]] +synonymousColumns allSyns cols = synCols' + where + syns = sort $ filter ((== colTable (head cols)) . colTable . fst) allSyns + synCols  = transpose $ map (\c -> map snd $ filter ((== c) . fst) syns) cols + synCols' = (filter sameTable . filter matchLength) synCols + matchLength cs = length cols == length cs + sameTable (c:cs) = all (\cc -> colTable c == colTable cc) (c:cs) + sameTable [] = False + +addForeignKeys :: [Relation] -> [Column] -> [Column] +addForeignKeys rels = map addFk + where + addFk col = col { colFK = fk col } + fk col = join $ relToFk col <$> find (lookupFn col) rels + lookupFn :: Column -> Relation -> Bool + lookupFn c (Relation{relColumns=cs, relType=rty}) = c `elem` cs && rty==Child + -- lookupFn _ _ = False + relToFk col (Relation{relColumns=cols, relFColumns=colsF}) = ForeignKey <$> colF + where + pos = elemIndex col cols + colF = (colsF !!) <$> pos + +addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation] +addSynonymousRelations _ [] = [] +addSynonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ addSynonymousRelations syns rels + where + synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs}) + synRelsF = synRels (relFColumns rel) (\t cs -> rel{relFTable=t,relFColumns=cs}) + synRels cols mapFn = map (\cs -> mapFn (colTable $ head cs) cs) $ synonymousColumns syns cols + +addParentRelations :: [Relation] -> [Relation] +addParentRelations [] = [] +addParentRelations (rel@(Relation t c ft fc _ _ _ _):rels) = Relation ft fc t c Parent Nothing Nothing Nothing : rel : addParentRelations rels + +addManyToManyRelations :: [Relation] -> [Relation] +addManyToManyRelations rels = rels ++ mapMaybe link2Relation links + where + links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels + groupFn :: Relation -> Text + groupFn (Relation{relTable=Table{tableSchema=s, tableName=t}}) = s<>"_"<>t + combinations k ns = filter ((k==).length) (subsequences ns) + link2Relation [ + Relation{relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c}, + Relation{ relColumns=lc2, relFTable=ft, relFColumns=fc} + ] + | lc1 /= lc2 && length lc1 == 1 && length lc2 == 1 = Just $ Relation t c ft fc Many (Just lt) (Just lc1) (Just lc2) + | otherwise = Nothing + link2Relation _ = Nothing + +raiseRelations :: Schema -> [(Column,Column)] -> [Relation] -> [Relation] +raiseRelations schema syns = map raiseRel + where + raiseRel rel + | tableSchema table == schema = rel + | isJust newCols = rel{relFTable=fromJust newTable,relFColumns=fromJust newCols} + | otherwise = rel + where + cols = relFColumns rel + table = relFTable rel + newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . head) (synonymousColumns syns cols) + newTable = (colTable . head) <$> newCols + +synonymousPrimaryKeys :: [(Column,Column)] -> [PrimaryKey] -> [PrimaryKey] +synonymousPrimaryKeys _ [] = [] +synonymousPrimaryKeys syns (key:keys) = key : newKeys ++ synonymousPrimaryKeys syns keys + where + keySyns = filter ((\c -> colTable c == pkTable key && colName c == pkName key) . fst) syns + newKeys = map ((\c -> PrimaryKey{pkTable=colTable c,pkName=colName c}) . snd) keySyns + +allTables :: H.Tx P.Postgres s [Table] +allTables = do + rows <- H.listEx $ [H.stmt| + SELECT + n.nspname AS table_schema, + c.relname AS table_name, + c.relkind = 'r' OR (c.relkind IN ('v','f')) + AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8 + OR (EXISTS + ( SELECT 1 + FROM pg_trigger + WHERE pg_trigger.tgrelid = c.oid + AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable + FROM pg_class c + JOIN pg_namespace n ON n.oid = c.relnamespace + WHERE c.relkind IN ('v','r','m') + AND n.nspname NOT IN ('pg_catalog', 'information_schema') + GROUP BY table_schema, table_name, insertable + ORDER BY table_schema, table_name + |] + return $ map tableFromRow rows + +tableFromRow :: (Text, Text, Bool) -> Table +tableFromRow (s, n, i) = Table s n i + +allColumns :: [Table] -> H.Tx P.Postgres s [Column] +allColumns tabs = do + cols <- H.listEx $ [H.stmt| + SELECT DISTINCT + info.table_schema AS schema, + info.table_name AS table_name, + info.column_name AS name, + info.ordinal_position AS position, + info.is_nullable::boolean AS nullable, + info.data_type AS col_type, + info.is_updatable::boolean AS updatable, + info.character_maximum_length AS max_len, + info.numeric_precision AS precision, + info.column_default AS default_value, + array_to_string(enum_info.vals, ',') AS enum + FROM ( + SELECT + table_schema, + table_name, + column_name, + ordinal_position, + is_nullable, + data_type, + is_updatable, + character_maximum_length, + numeric_precision, + column_default, + udt_name + FROM information_schema.columns + WHERE table_schema NOT IN ('pg_catalog', 'information_schema') + ) AS info + LEFT OUTER JOIN ( + SELECT + n.nspname AS s, + t.typname AS n, + array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals + FROM pg_type t + JOIN pg_enum e ON t.oid = e.enumtypid + JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace + GROUP BY s,n + ) AS enum_info ON (info.udt_name = enum_info.n) + ORDER BY schema, position + |] + return $ mapMaybe (columnFromRow tabs) cols + +columnFromRow :: [Table] -> + (Text, Text, Text, + Int, Bool, Text, + Bool, Maybe Int, Maybe Int, + Maybe Text, Maybe Text) + -> Maybe Column +columnFromRow tabs (s, t, n, pos, nul, typ, u, l, p, d, e) = buildColumn <$> table + where + buildColumn tbl = Column tbl n pos nul typ u l p d (parseEnum e) Nothing + table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs + parseEnum :: Maybe Text -> [Text] + parseEnum str = fromMaybe [] $ split (==',') <$> str + +allRelations :: [Table] -> [Column] -> H.Tx P.Postgres s [Relation] +allRelations tabs cols = do + rels <- H.listEx $ [H.stmt| + SELECT ns1.nspname AS table_schema, + tab.relname AS table_name, + column_info.cols AS columns, + ns2.nspname AS foreign_table_schema, + other.relname AS foreign_table_name, + column_info.refs AS foreign_columns + FROM pg_constraint, + LATERAL (SELECT array_agg(cols.attname) AS cols, + array_agg(cols.attnum) AS nums, + array_agg(refs.attname) AS refs + FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k, + LATERAL (SELECT * FROM pg_attribute + WHERE attrelid = conrelid AND attnum = col) + AS cols, + LATERAL (SELECT * FROM pg_attribute + WHERE attrelid = confrelid AND attnum = ref) + AS refs) + AS column_info, + LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = connamespace) AS ns1, + LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab, + LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other, + LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = other.relnamespace) AS ns2 + WHERE confrelid != 0 + ORDER BY (conrelid, column_info.nums) + |] + return $ mapMaybe (relationFromRow tabs cols) rels + +relationFromRow :: [Table] -> [Column] -> (Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation +relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) = + if isJust table && isJust tableF && length cols == length rcs && length colsF == length frcs + then Just $ Relation (fromJust table) cols (fromJust tableF) colsF Child Nothing Nothing Nothing + else Nothing + where + findTable s t = find (\tbl -> tableSchema tbl == s && tableName tbl == t) allTabs + findCols s t cs = filter (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col `elem` cs) allCols + table = findTable rs rt + tableF = findTable frs frt + cols = findCols rs rt rcs + colsF = findCols frs frt frcs + +allPrimaryKeys :: [Table] -> H.Tx P.Postgres s [PrimaryKey] +allPrimaryKeys tabs = do + pks <- H.listEx $ [H.stmt| + SELECT + kc.table_schema, + kc.table_name, + kc.column_name + FROM + information_schema.table_constraints tc, + information_schema.key_column_usage kc + WHERE + tc.constraint_type = 'PRIMARY KEY' AND + kc.table_name = tc.table_name AND + kc.table_schema = tc.table_schema AND + kc.constraint_name = tc.constraint_name AND + kc.table_schema NOT IN ('pg_catalog', 'information_schema') + |] + return $ mapMaybe (pkFromRow tabs) pks + +pkFromRow :: [Table] -> (Schema, Text, Text) -> Maybe PrimaryKey +pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n + where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs + +allSynonyms :: [Column] -> H.Tx P.Postgres s [(Column,Column)] +allSynonyms allCols = do + syns <- H.listEx $ [H.stmt| + WITH synonyms AS ( + SELECT + vcu.table_schema AS src_table_schema, + vcu.table_name AS src_table_name, + vcu.column_name AS src_column_name, + view.table_schema AS syn_table_schema, + view.table_name AS syn_table_name, + view.view_definition AS view_definition + FROM + information_schema.views AS view, + information_schema.view_column_usage AS vcu + WHERE + view.table_schema = vcu.view_schema AND + view.table_name = vcu.view_name AND + view.table_schema NOT IN ('pg_catalog', 'information_schema') AND + (SELECT COUNT(*) FROM information_schema.view_table_usage WHERE view_schema = view.table_schema AND view_name = view.table_name) = 1 + ) + SELECT + src_table_schema, src_table_name, src_column_name, + syn_table_schema, syn_table_name, + (regexp_matches(view_definition, CONCAT('\.(', src_column_name, ')(?=,|$)'), 'gn'))[1] + FROM synonyms + UNION ( + SELECT + src_table_schema, src_table_name, src_column_name, + syn_table_schema, syn_table_name, + (regexp_matches(view_definition, CONCAT('\.', src_column_name, '\sAS\s("?)(.+?)\1(,|$)'), 'gn'))[2] /* " <- for syntax highlighting */ + FROM synonyms + ) + |] + return $ mapMaybe (synonymFromRow allCols) syns + +synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column) +synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2 + where + col1 = findCol s1 t1 c1 + col2 = findCol s2 t2 c2 + findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -2,13 +2,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -module PostgREST.Error (PgError, errResponse) where +module PostgREST.Error (PgError, pgErrResponse, errResponse) where import Data.Aeson ((.=)) import qualified Data.Aeson as JSON import Data.String.Conversions (cs) import Data.String.Utils (replace) +import Data.Text (Text) import qualified Data.Text as T import qualified Hasql as H import qualified Hasql.Postgres as P @@ -18,8 +19,11 @@ type PgError = H.SessionError P.Postgres -errResponse :: PgError -> Response -errResponse e = responseLBS (httpStatus e) +errResponse :: HT.Status -> Text -> Response +errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"]) + +pgErrResponse :: PgError -> Response +pgErrResponse e = responseLBS (httpStatus e) [(hContentType, "application/json")] (JSON.encode e) instance JSON.ToJSON PgError where diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -1,39 +1,40 @@ module Main where -import PostgREST.PgStructure -import PostgREST.Types -import Network.Wai - import PostgREST.App -import PostgREST.Error (errResponse) +import PostgREST.Config (AppConfig (..), + minimumPgVersion, + prettyVersion, + readOptions) +import PostgREST.Error (pgErrResponse, PgError) import PostgREST.Middleware +import PostgREST.DbStructure import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) +import Data.Aeson (encode) import Data.Functor.Identity import Data.Monoid ((<>)) import Data.String.Conversions (cs) import Data.Text (Text) import qualified Hasql as H import qualified Hasql.Postgres as P +import Network.Wai import Network.Wai.Handler.Warp hiding (Connection) import Network.Wai.Middleware.RequestLogger (logStdout) - import System.IO (BufferMode (..), hSetBuffering, stderr, stdin, stdout) - -import PostgREST.Config (AppConfig (..), - prettyVersion, - readOptions, - minimumPgVersion) +import Web.JWT (secret) isServerVersionSupported :: H.Session P.Postgres IO Bool isServerVersionSupported = do - Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|] + Identity (row :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SHOW server_version_num|] return $ read (cs row) >= minimumPgVersion +hasqlError :: PgError -> IO a +hasqlError = error . cs . encode + main :: IO () main = do hSetBuffering stdout LineBuffering @@ -43,55 +44,36 @@ conf <- readOptions let port = configPort conf - unless (configSecure conf) $ - putStrLn "WARNING, running in insecure mode, auth will be in plaintext" - 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) - let pgSettings = P.ParamSettings (cs $ configDbHost conf) - (fromIntegral $ configDbPort conf) - (cs $ configDbUser conf) - (cs $ configDbPass conf) - (cs $ configDbName conf) + let pgSettings = P.StringSettings $ cs (configDatabase conf) appSettings = setPort port . setServerName (cs $ "postgrest/" <> prettyVersion) $ defaultSettings - middle = logStdout . defaultMiddle (configSecure conf) + middle = logStdout . defaultMiddle poolSettings <- maybe (fail "Improper session settings") return $ H.poolSettings (fromIntegral $ configPool conf) 30 pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings supportedOrError <- H.session pool isServerVersionSupported - either (fail . show) + either hasqlError (\supported -> unless supported $ - fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0" + error ( + "Cannot run in this PostgreSQL version, PostgREST needs at least " + <> show minimumPgVersion) ) supportedOrError let txSettings = Just (H.ReadCommitted, Just True) - metadata <- H.session pool $ H.tx txSettings $ do - tabs <- allTables - rels <- allRelations - cols <- allColumns rels - keys <- allPrimaryKeys - return (tabs, rels, cols, keys) - - dbstructure <- case metadata of - Left e -> fail $ show e - Right (tabs, rels, cols, keys) -> - return DbStructure { - tables=tabs - , columns=cols - , relations=rels - , primaryKeys=keys - } - + dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema conf) + dbStructure <- either hasqlError return dbOrError runSettings appSettings $ middle $ \ req respond -> do body <- strictRequestBody req resOrError <- liftIO $ H.session pool $ H.tx txSettings $ - authenticated conf (app dbstructure conf body) req - either (respond . errResponse) respond resOrError + runWithClaims conf (app dbStructure conf body) req + either (respond . pgErrResponse) respond resOrError diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -3,103 +3,70 @@ module PostgREST.Middleware where -import Data.Maybe (fromMaybe, isNothing) -import Data.Monoid +import Data.Maybe (fromMaybe) import Data.Text import Data.String.Conversions (cs) +import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Hasql as H import qualified Hasql.Postgres as P -import Network.HTTP.Types (RequestHeaders) -import Network.HTTP.Types.Header (hAccept, hAuthorization, - hLocation) -import Network.HTTP.Types.Status (status301, status400, status401, - status415) -import Network.URI (URI (..), parseURI) -import Network.Wai (Application, Request (..), - Response, isSecure, rawPathInfo, - rawQueryString, requestHeaders, - responseLBS) +import Network.HTTP.Types.Header (hAccept, hAuthorization) +import Network.HTTP.Types.Status (status415, status400) +import Network.Wai (Application, Request (..), Response, + requestHeaders) import Network.Wai.Middleware.Cors (cors) import Network.Wai.Middleware.Gzip (def, gzip) import Network.Wai.Middleware.Static (only, staticPolicy) -import Codec.Binary.Base64.String (decode) -import PostgREST.App (contentTypeForAccept) -import PostgREST.Auth (DbRole, LoginAttempt (..), - setRole, setUserId, signInRole, - signInWithJWT) +import PostgREST.ApiRequest (pickContentType) +import PostgREST.Auth (setRole, jwtClaims, claimsToSQL) import PostgREST.Config (AppConfig (..), corsPolicy) - -import Prelude - -authenticated :: forall s. AppConfig -> - (DbRole -> Request -> H.Tx P.Postgres s Response) -> - Request -> H.Tx P.Postgres s Response -authenticated conf app req = do - attempt <- httpRequesterRole (requestHeaders req) - case attempt of - MalformedAuth -> - return $ responseLBS status400 [] "Malformed basic auth header" - LoginFailed -> - return $ responseLBS status401 [] "Invalid username or password" - LoginSuccess role uid -> if role /= currentRole then runInRole role uid else app currentRole req - NoCredentials -> if anon /= currentRole then runInRole anon "" else app currentRole req - - where - jwtSecret = cs $ configJwtSecret conf - currentRole = cs $ configDbUser conf - anon = cs $ configAnonRole conf - httpRequesterRole :: RequestHeaders -> H.Tx P.Postgres s LoginAttempt - httpRequesterRole hdrs = do - let auth = fromMaybe "" $ lookup hAuthorization hdrs - case split (==' ') (cs auth) of - ("Basic" : b64 : _) -> - case split (==':') (cs . decode . cs $ b64) of - (u:p:_) -> signInRole u p - _ -> return MalformedAuth - ("Bearer" : jwt : _) -> - return $ signInWithJWT jwtSecret jwt - _ -> return NoCredentials +import PostgREST.Error (errResponse) - runInRole :: Text -> Text -> H.Tx P.Postgres s Response - runInRole r uid = do - setUserId uid - setRole r - app r req +import System.IO.Unsafe (unsafePerformIO) +import Prelude hiding(concat) -redirectInsecure :: Application -> Application -redirectInsecure app req respond = do - let hdrs = requestHeaders req - host = lookup "host" hdrs - uriM = parseURI . cs =<< mconcat [ - Just "https://", - host, - Just $ rawPathInfo req, - Just $ rawQueryString req] - isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https" +import qualified Data.Vector as V +import qualified Hasql.Backend as B +import qualified Data.Map.Lazy as M - if not (isSecure req || isHerokuSecure) - then case uriM of - Just uri -> - respond $ responseLBS status301 [ - (hLocation, cs . show $ uri { uriScheme = "https:" }) - ] "" - Nothing -> - respond $ responseLBS status400 [] "SSL is required" - else app req respond +runWithClaims :: forall s. AppConfig -> + (Request -> H.Tx P.Postgres s Response) -> + Request -> H.Tx P.Postgres s Response +runWithClaims conf app req = do + _ <- H.unitEx $ stmt setAnon + let time = unsafePerformIO getPOSIXTime + case split (== ' ') (cs auth) of + ("Bearer" : tokenStr : _) -> + case jwtClaims jwtSecret tokenStr time of + Just claims -> + if M.member "role" claims + then do + mapM_ H.unitEx $ stmt <$> claimsToSQL claims + app req + else invalidJWT + _ -> invalidJWT + _ -> app req + where + stmt c = B.Stmt c V.empty True + hdrs = requestHeaders req + jwtSecret = configJwtSecret conf + auth = fromMaybe "" $ lookup hAuthorization hdrs + anon = cs $ configAnonRole conf + setAnon = setRole anon + 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 $ responseLBS 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 :: Bool -> Application -> Application -defaultMiddle secure = (if secure then redirectInsecure else id) - . gzip def . cors corsPolicy +defaultMiddle :: Application -> Application +defaultMiddle = + gzip def + . cors corsPolicy . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) . unsupportedAccept diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -1,48 +1,27 @@ module PostgREST.Parsers -( parseGetRequest -) +-- ( parseGetRequest +-- ) where import Control.Applicative hiding ((<$>)) ---lines needed for ghc 7.8 -import Data.Functor ((<$>)) -import Data.Traversable (traverse) - -import Control.Monad (join) -import Data.List (delete, find) -import Data.Maybe import Data.Monoid import Data.String.Conversions (cs) import Data.Text (Text) import Data.Tree -import Network.Wai (Request, pathInfo, queryString) import PostgREST.Types import Text.ParserCombinators.Parsec hiding (many, (<|>)) - -parseGetRequest :: Request -> Either ParseError ApiRequest -parseGetRequest httpRequest = - foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts - where - apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr - addOrder (Node r f) o = Node r{order=o} f - flts = mapM pRequestFilter whereFilters - rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head - qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] - orderStr = join $ lookup "order" qString - ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr - selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * - whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] +import PostgREST.QueryBuilder (operators) -pRequestSelect :: Text -> Parser ApiRequest +pRequestSelect :: Text -> Parser ReadRequest pRequestSelect rootNodeName = do fieldTree <- pFieldForest - return $ foldr treeEntry (Node (Select rootNodeName [] [] [] Nothing Nothing) []) fieldTree + return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree where - treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest - treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) = + treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest + treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) = case fldForest of - [] -> Node (rNode {fields=fld:fields rNode}) rForest - _ -> Node rNode (foldr treeEntry (Node (Select fn [] [] [] Nothing Nothing) []) fldForest:rForest) + [] -> Node (q {select=fld:select q}, i) rForest + _ -> Node (q, i) (foldr treeEntry (Node (Select [] [fn] [] Nothing, (fn, Nothing)) []) fldForest:rForest) pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) @@ -54,21 +33,6 @@ op = fst <$> opVal val = snd <$> opVal -addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest -addFilter ([], flt) (Node rn@(Select {filters=flts}) forest) = Node (rn {filters=flt:flts}) 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 - Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest) - where - targetNodeName:remainingPath = path - (targetNode,restForest) = splitForest targetNodeName forest - splitForest name forst = - case maybeNode of - Nothing -> (Nothing,forest) - Just node -> (Just node, delete node forest) - where maybeNode = find ((name==).mainTable.rootLabel) forst - ws :: Parser Text ws = cs <$> many (oneOf " \t") @@ -82,22 +46,20 @@ let pp = map cs p jpp = map cs <$> jp return (init pp, (last pp, jpp)) - where - pFieldForest :: Parser [Tree SelectItem] pFieldForest = pFieldTree `sepBy1` lexeme (char ',') pFieldTree :: Parser (Tree SelectItem) -pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')')) - <|> Node <$> pSelect <*> pure [] +pFieldTree = try (Node <$> pSelect <*> between (char '{') (char '}') pFieldForest) + <|> Node <$> pSelect <*> pure [] pStar :: Parser Text pStar = cs <$> (string "*" *> pure ("*"::String)) pFieldName :: Parser Text pFieldName = cs <$> (many1 (letter <|> digit <|> oneOf "_") - "field name (* or [a..z0..9_])") + "field name (* or [a..z0..9_])") pJsonPathStep :: Parser Text pJsonPathStep = cs <$> try (string "->" *> pFieldName) @@ -116,22 +78,8 @@ return ((s, Nothing), Nothing) pOperator :: Parser Operator -pOperator = cs <$> ( try (string "lte") -- has to be before lt - <|> try (string "lt") - <|> try (string "eq") - <|> try (string "gte") -- has to be before gh - <|> try (string "gt") - <|> try (string "lt") - <|> try (string "neq") - <|> try (string "like") - <|> try (string "ilike") - <|> try (string "in") - <|> try (string "notin") - <|> try (string "is" ) - <|> try (string "isnot") - <|> try (string "@@") - "operator (eq, gt, ...)" - ) +pOperator = cs <$> (pOp "operator (eq, gt, ...)") + where pOp = foldl (<|>) empty $ map (try . string . cs . fst) operators pValue :: Parser FValue pValue = VText <$> (cs <$> many anyChar) @@ -153,8 +101,12 @@ 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/PgQuery.hs b/src/PostgREST/PgQuery.hs deleted file mode 100644 --- a/src/PostgREST/PgQuery.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module PostgREST.PgQuery where - - -import qualified Hasql as H -import qualified Hasql.Backend as B -import qualified Hasql.Postgres as P -import PostgREST.RangeQuery -import PostgREST.Types (OrderTerm (..), QualifiedIdentifier(..)) - -import Control.Monad (join) -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Char8 as BS -import Data.Functor -import qualified Data.HashMap.Strict as H -import qualified Data.List as L -import Data.Maybe (fromMaybe) -import Data.Monoid -import Data.Scientific (FPFormat (..), formatScientific, - isInteger) -import Data.String.Conversions (cs) -import qualified Data.Text as T -import Data.Vector (empty) -import qualified Data.Vector as V -import qualified Network.HTTP.Types.URI as Net -import Text.Regex.TDFA ((=~)) - -import Prelude - -type PStmt = H.Stmt P.Postgres -instance Monoid PStmt where - mappend (B.Stmt query params prep) (B.Stmt query' params' prep') = - B.Stmt (query <> query') (params <> params') (prep && prep') - mempty = B.Stmt "" empty True -type StatementT = PStmt -> PStmt - - -limitT :: Maybe NonnegRange -> StatementT -limitT r q = - q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True - where - limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r - offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r - -whereT :: QualifiedIdentifier -> Net.Query -> StatementT -whereT table params q = - if L.null cols - then q - else q <> B.Stmt " where " empty True <> conjunction - where - cols = [ col | col <- params, fst col `notElem` ["order","select"] ] - wherePredTable = wherePred table - conjunction = mconcat $ L.intersperse andq (map wherePredTable cols) - -withT :: PStmt -> T.Text -> StatementT -withT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) = - B.Stmt ("WITH " <> v <> " AS (" <> eq <> ") " <> wq <> " from " <> v) - (ep <> wp) - (epre && wpre) - -orderT :: [OrderTerm] -> StatementT -orderT ts q = - if L.null ts - then q - else q <> B.Stmt " order by " empty True <> clause - where - clause = mconcat $ L.intersperse commaq (map queryTerm ts) - queryTerm :: OrderTerm -> PStmt - queryTerm t = B.Stmt - (" " <> cs (pgFmtIdent $ otTerm t) <> " " - <> cs (otDirection t) <> " " - <> maybe "" cs (otNullOrder t) <> " ") - empty True - -parentheticT :: StatementT -parentheticT s = - s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " } - -iffNotT :: PStmt -> StatementT -iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) = - B.Stmt - ("WITH aaa AS (" <> aq <> " returning *) " <> - bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)") - (ap <> bp) - (apre && bpre) - -countT :: StatementT -countT s = - s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT pg_catalog.count(1) FROM qqq" } - -countRows :: QualifiedIdentifier -> PStmt -countRows t = B.Stmt ("select pg_catalog.count(1) from " <> fromQi t) empty True - -countNone :: PStmt -countNone = B.Stmt "select null" empty True - -asCsvWithCount :: QualifiedIdentifier -> StatementT -asCsvWithCount table = withCount . asCsv table - -asCsv :: QualifiedIdentifier -> StatementT -asCsv table s = s { - B.stmtTemplate = - "(select string_agg(quote_ident(column_name::text), ',') from " - <> "(select column_name from information_schema.columns where quote_ident(table_schema) || '.' || table_name = '" - <> fromQi table <> "' order by ordinal_position) h) || '\r' || " - <> "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\r'), '') from (" - <> B.stmtTemplate s <> ") t" } - -asJsonWithCount :: StatementT -asJsonWithCount = withCount . asJson - -asJson :: StatementT -asJson s = s { - B.stmtTemplate = - "array_to_json(coalesce(array_agg(row_to_json(t)), '{}'))::character varying from (" - <> B.stmtTemplate s <> ") t" } - -withCount :: StatementT -withCount s = s { B.stmtTemplate = "pg_catalog.count(t), " <> B.stmtTemplate s } - -asJsonRow :: StatementT -asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" } - -returningStarT :: StatementT -returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" } - -deleteFrom :: QualifiedIdentifier -> PStmt -deleteFrom t = B.Stmt ("delete from " <> fromQi t) empty True - -insertInto :: QualifiedIdentifier - -> V.Vector T.Text - -> V.Vector (V.Vector JSON.Value) - -> PStmt -insertInto t cols vals - | V.null cols = B.Stmt ("insert into " <> fromQi t <> " default values returning *") empty True - | otherwise = B.Stmt - ("insert into " <> fromQi t <> " (" <> - T.intercalate ", " (V.toList $ V.map pgFmtIdent cols) <> - ") values " - <> T.intercalate ", " - (V.toList $ V.map (\v -> "(" - <> T.intercalate ", " (V.toList $ V.map insertableValue v) - <> ")" - ) vals - ) - <> " returning row_to_json(" <> fromQi t <> ".*)") - empty True - -insertSelect :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt -insertSelect t [] _ = B.Stmt - ("insert into " <> fromQi t <> " default values returning *") empty True -insertSelect t cols vals = B.Stmt - ("insert into " <> fromQi t <> " (" - <> T.intercalate ", " (map pgFmtIdent cols) - <> ") select " - <> T.intercalate ", " (map insertableValue vals)) - empty True - -update :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt -update t cols vals = B.Stmt - ("update " <> fromQi t <> " set (" - <> T.intercalate ", " (map pgFmtIdent cols) - <> ") = (" - <> T.intercalate ", " (map insertableValue vals) - <> ")") - empty True - -callProc :: QualifiedIdentifier -> JSON.Object -> PStmt -callProc qi params = do - let args = T.intercalate "," $ map assignment (H.toList params) - B.Stmt ("select * from " <> fromQi qi <> "(" <> args <> ")") empty True - where - assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v - -wherePred :: QualifiedIdentifier -> Net.QueryItem -> PStmt -wherePred table (col, predicate) = - B.Stmt (notOp <> " " <> pgFmtJsonbPath table (cs col) <> " " <> op <> " " <> - if opCode `elem` ["is","isnot"] then whiteList value - else cs sqlValue) - empty True - - where - headPredicate:rest = T.split (=='.') $ cs $ fromMaybe "." predicate - hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse - opCode = hasNot (head rest) headPredicate - notOp = hasNot headPredicate "" - value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest) - sqlValue = pgFmtValue opCode value - op = pgFmtOperator opCode - - -whiteList :: T.Text -> T.Text -whiteList val = fromMaybe - (cs (pgFmtLit val) <> "::unknown ") - (L.find ((==) . T.toLower $ val) ["null","true","false"]) - -pgFmtValue :: T.Text -> T.Text -> T.Text -pgFmtValue opCode value = - case opCode of - "like" -> unknownLiteral $ T.map star value - "ilike" -> unknownLiteral $ T.map star value - "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " - "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") " - "@@" -> "to_tsquery(" <> unknownLiteral value <> ") " - _ -> unknownLiteral value - where - star c = if c == '*' then '%' else c - unknownLiteral = (<> "::unknown ") . pgFmtLit - -pgFmtOperator :: T.Text -> T.Text -pgFmtOperator opCode = - case opCode of - "eq" -> "=" - "gt" -> ">" - "lt" -> "<" - "gte" -> ">=" - "lte" -> "<=" - "neq" -> "<>" - "like"-> "like" - "ilike"-> "ilike" - "in" -> "in" - "notin" -> "not in" - "is" -> "is" - "isnot" -> "is not" - "@@" -> "@@" - _ -> "=" - -commaq :: PStmt -commaq = B.Stmt ", " empty True - -andq :: PStmt -andq = B.Stmt " and " empty True - -data JsonbPath = - ColIdentifier T.Text - | KeyIdentifier T.Text - | SingleArrow JsonbPath JsonbPath - | DoubleArrow JsonbPath JsonbPath - deriving (Show) - -parseJsonbPath :: T.Text -> Maybe JsonbPath -parseJsonbPath p = - case T.splitOn "->>" p of - [a,b] -> - let i:is = T.splitOn "->" a in - Just $ DoubleArrow - (foldl SingleArrow (ColIdentifier i) (map KeyIdentifier is)) - (KeyIdentifier b) - _ -> Nothing - -pgFmtJsonbPath :: QualifiedIdentifier -> T.Text -> T.Text -pgFmtJsonbPath table p = - pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p) - where - pgFmtJsonbPath' (ColIdentifier i) = fromQi table <> "." <> pgFmtIdent i - pgFmtJsonbPath' (KeyIdentifier i) = pgFmtLit i - pgFmtJsonbPath' (SingleArrow a b) = - pgFmtJsonbPath' a <> "->" <> pgFmtJsonbPath' b - pgFmtJsonbPath' (DoubleArrow a b) = - pgFmtJsonbPath' a <> "->>" <> pgFmtJsonbPath' b - -pgFmtIdent :: T.Text -> T.Text -pgFmtIdent x = - let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in - if (cs escaped :: BS.ByteString) =~ danger - then "\"" <> escaped <> "\"" - else escaped - - where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString - -pgFmtLit :: T.Text -> T.Text -pgFmtLit x = - let trimmed = trimNullChars x - escaped = "'" <> T.replace "'" "''" trimmed <> "'" - slashed = T.replace "\\" "\\\\" escaped in - if T.isInfixOf "\\\\" escaped - then "E" <> slashed - else slashed - -trimNullChars :: T.Text -> T.Text -trimNullChars = T.takeWhile (/= '\x0') - -fromQi :: QualifiedIdentifier -> T.Text -fromQi t = pgFmtIdent (qiSchema t) <> "." <> pgFmtIdent (qiName t) - -unquoted :: JSON.Value -> T.Text -unquoted (JSON.String t) = t -unquoted (JSON.Number n) = - cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n -unquoted (JSON.Bool b) = cs . show $ b -unquoted v = cs $ JSON.encode v - -insertableText :: T.Text -> T.Text -insertableText = (<> "::unknown") . pgFmtLit - -insertableValue :: JSON.Value -> T.Text -insertableValue JSON.Null = "null" -insertableValue v = insertableText $ unquoted v - -paramFilter :: JSON.Value -> T.Text -paramFilter JSON.Null = "is.null" -paramFilter v = "eq." <> unquoted v diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs deleted file mode 100644 --- a/src/PostgREST/PgStructure.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -module PostgREST.PgStructure where - -import Control.Applicative -import Control.Monad (join) -import Data.Functor.Identity -import Data.List (elemIndex, find) -import Data.Maybe (fromMaybe, isJust, mapMaybe) -import Data.Monoid -import Data.Text (Text, split) -import qualified Hasql as H -import qualified Hasql.Postgres as P -import PostgREST.PgQuery () -import PostgREST.Types - -import GHC.Exts (groupWith) -import Prelude - - -doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool -doesProcExist schema proc = do - row :: Maybe (Identity Int) <- H.maybeEx $ [H.stmt| - SELECT 1 - FROM pg_catalog.pg_namespace n - JOIN pg_catalog.pg_proc p - ON pronamespace = n.oid - WHERE nspname = ? - AND proname = ? - |] schema proc - return $ isJust row - - -tableFromRow :: (Text, Text, Bool, Maybe Text) -> Table -tableFromRow (s, n, i, a) = Table s n i (parseAcl a) - where - parseAcl :: Maybe Text -> [Text] - parseAcl str = fromMaybe [] $ split (==',') <$> str - -columnFromRow :: (Text, Text, Text, - Int, Bool, Text, - Bool, Maybe Int, Maybe Int, - Maybe Text, Maybe Text) - -> Column -columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) = - Column s t n pos nul typ u l p d (parseEnum e) Nothing - - where - parseEnum :: Maybe Text -> [Text] - parseEnum str = fromMaybe [] $ split (==',') <$> str - - -relationFromRow :: (Text, Text, [Text], Text, [Text]) -> Relation -relationFromRow (s, t, cs, ft, fcs) = Relation s t cs ft fcs Child Nothing Nothing Nothing - -pkFromRow :: (Text, Text, Text) -> PrimaryKey -pkFromRow (s, t, n) = PrimaryKey s t n - - -addParentRelation :: Relation -> [Relation] -> [Relation] -addParentRelation rel@(Relation s t c ft fc _ _ _ _) rels = Relation s ft fc t c Parent Nothing Nothing Nothing:rel:rels - -allTables :: H.Tx P.Postgres s [Table] -allTables = do - rows <- H.listEx $ [H.stmt| - SELECT - n.nspname AS table_schema, - c.relname AS table_name, - c.relkind = 'r' OR (c.relkind IN ('v','f')) - AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8 - OR (EXISTS - ( SELECT 1 - FROM pg_trigger - WHERE pg_trigger.tgrelid = c.oid - AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable, - array_to_string(array_agg(r.rolname), ',') AS acl - FROM pg_class c - CROSS JOIN pg_roles r - JOIN pg_namespace n ON n.oid = c.relnamespace - WHERE c.relkind IN ('v','r','m') - AND n.nspname NOT IN ('pg_catalog', 'information_schema') - AND ( - pg_has_role(r.rolname, c.relowner, 'USAGE'::text) OR - has_table_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR - has_any_column_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) ) - - GROUP BY table_schema, table_name, insertable - ORDER BY table_schema, table_name - |] - return $ map tableFromRow rows - -allRelations :: H.Tx P.Postgres s [Relation] -allRelations = do - rels <- H.listEx $ [H.stmt| - WITH table_fk AS ( - SELECT ns.nspname AS table_schema, - tab.relname AS table_name, - column_info.cols AS columns, - other.relname AS foreign_table_name, - column_info.refs AS foreign_columns - FROM pg_constraint, - LATERAL (SELECT array_agg(cols.attname) AS cols, - array_agg(cols.attnum) AS nums, - array_agg(refs.attname) AS refs - FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k, - LATERAL (SELECT * FROM pg_attribute - WHERE attrelid = conrelid AND attnum = col) - AS cols, - LATERAL (SELECT * FROM pg_attribute - WHERE attrelid = confrelid AND attnum = ref) - AS refs) - AS column_info, - LATERAL (SELECT * FROM pg_namespace - WHERE pg_namespace.oid = connamespace) AS ns, - LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab, - LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other - WHERE confrelid != 0 - ORDER BY (conrelid, column_info.nums) - ) - - SELECT * FROM table_fk - UNION - ( - SELECT - vcu.table_schema, - vcu.view_name AS table_name, - array_agg(vcu.column_name::text) AS columns, - table_fk.foreign_table_name, - table_fk.foreign_columns - FROM information_schema.view_column_usage as vcu - JOIN table_fk ON - table_fk.table_schema = vcu.view_schema AND - table_fk.table_name = vcu.table_name AND - vcu.column_name = ANY (table_fk.columns) - WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') - AND columns = table_fk.columns - GROUP BY vcu.table_schema, vcu.view_name, table_fk.foreign_table_name, table_fk.foreign_columns - ) - UNION - ( - SELECT - vcu.view_schema as table_schema, - table_fk.table_name, - table_fk.columns, - vcu.view_name as foreign_table_name, - array_agg(vcu.column_name::text) as foreign_columns - FROM information_schema.view_column_usage as vcu - JOIN table_fk ON - table_fk.table_schema = vcu.view_schema AND - table_fk.foreign_table_name = vcu.table_name AND - vcu.column_name = ANY (table_fk.foreign_columns) - WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema') - AND foreign_columns = table_fk.foreign_columns - GROUP BY vcu.view_schema, table_fk.table_name, vcu.view_name, table_fk.columns - ) - |] - let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels - let links = filter ((==2).length) $ groupWith groupFn $ filter ( (==Child). relType) simpleRelations - return $ simpleRelations ++ mapMaybe link2Relation links - where - groupFn :: Relation -> Text - groupFn (Relation{relSchema=s, relTable=t}) = s<>"_"<>t - link2Relation [ - Relation{relSchema=sc, relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c}, - Relation{ relColumns=lc2, relFTable=ft, relFColumns=fc} - ] = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2) - link2Relation _ = Nothing - -allColumns :: [Relation] -> H.Tx P.Postgres s [Column] -allColumns rels = do - cols <- H.listEx $ [H.stmt| - SELECT - info.table_schema AS schema, - info.table_name AS table_name, - info.column_name AS name, - info.ordinal_position AS position, - info.is_nullable::boolean AS nullable, - info.data_type AS col_type, - info.is_updatable::boolean AS updatable, - info.character_maximum_length AS max_len, - info.numeric_precision AS precision, - info.column_default AS default_value, - array_to_string(enum_info.vals, ',') AS enum - FROM ( - SELECT - table_schema, - table_name, - column_name, - ordinal_position, - is_nullable, - data_type, - is_updatable, - character_maximum_length, - numeric_precision, - column_default, - udt_name - FROM information_schema.columns - WHERE table_schema NOT IN ('pg_catalog', 'information_schema') - ) AS info - LEFT OUTER JOIN ( - SELECT - n.nspname AS s, - t.typname AS n, - array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals - FROM pg_type t - JOIN pg_enum e ON t.oid = e.enumtypid - JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace - GROUP BY s,n - ) AS enum_info ON (info.udt_name = enum_info.n) - ORDER BY schema, position - |] - return $ map (addFK . columnFromRow) cols - - where - addFK col = col { colFK = fk col } - fk col = join $ relToFk (colName col) <$> find (lookupFn col) rels - lookupFn :: Column -> Relation -> Bool - lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumns=rc, relType=rty}) = - cs==rs && ct==rt && cn `elem` rc && rty==Child - lookupFn _ _ = False - relToFk cName (Relation{relFTable=t, relColumns=cs, relFColumns=fcs}) = ForeignKey t <$> c - where - pos = elemIndex cName cs - c = (fcs !!) <$> pos - -allPrimaryKeys :: H.Tx P.Postgres s [PrimaryKey] -allPrimaryKeys = do - pks <- H.listEx $ [H.stmt| - WITH table_pk AS ( - SELECT - kc.table_schema, - kc.table_name, - kc.column_name - FROM - information_schema.table_constraints tc, - information_schema.key_column_usage kc - WHERE - tc.constraint_type = 'PRIMARY KEY' AND - kc.table_name = tc.table_name AND - kc.table_schema = tc.table_schema AND - kc.constraint_name = tc.constraint_name AND - kc.table_schema NOT IN ('pg_catalog', 'information_schema') - ) - SELECT table_schema, - table_name, - column_name - FROM table_pk - UNION ( - SELECT - vcu.view_schema, - vcu.view_name, - vcu.column_name - FROM information_schema.view_column_usage AS vcu - JOIN - table_pk ON table_pk.table_schema = vcu.view_schema AND - table_pk.table_name = vcu.table_name AND - table_pk.column_name = vcu.column_name - WHERE vcu.view_schema NOT IN ('pg_catalog','information_schema') - ) - |] - return $ map pkFromRow pks diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -1,130 +1,380 @@ -module PostgREST.QueryBuilder -where +{-# 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. -import Control.Error -import Data.List (find) -import Data.Monoid -import Data.Text hiding (filter, find, foldr, head, last, map, - null, zipWith) -import Control.Applicative -import Data.Tree -import PostgREST.PgQuery (PStmt, fromQi, - orderT, pgFmtIdent, pgFmtLit, pgFmtOperator, - pgFmtValue, whiteList) +Any function that outputs a SQL fragment should be in this module. +-} +module PostgREST.QueryBuilder ( + addRelations + , addJoinConditions + , asJson + , callProc + , createReadStatement + , createWriteStatement + , operators + , pgFmtIdent + , pgFmtLit + , requestToQuery + , sourceSubqueryName + , unquoted + ) where + +import qualified Hasql as H +import qualified Hasql.Backend as B +import qualified Hasql.Postgres as P + +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) +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 Control.Applicative (empty, (<|>)) +import Data.Tree (Tree(..)) +import qualified Data.Vector as V import PostgREST.Types -import qualified Data.Vector as V (empty) -import qualified Hasql.Backend as B +import qualified Data.Map as M +import Text.Regex.TDFA ((=~)) +import qualified Data.ByteString.Char8 as BS +import Data.Scientific ( FPFormat (..) + , formatScientific + , isInteger + ) +import Prelude hiding (unwords) -findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation -findRelation allRelations s t1 t2 = - find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations +import Data.Ranged.Ranges (singletonRange) -addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest -addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) = +type PStmt = H.Stmt P.Postgres +instance Monoid PStmt where + mappend (B.Stmt query params prep) (B.Stmt query' params' prep') = + B.Stmt (query <> query') (params <> params') (prep && prep') + 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 - Nothing -> Node query{relation=Nothing} <$> updatedForest - (Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest + Nothing -> Node (query, (table, Nothing)) <$> updatedForest + (Just (Node (_, (parentTable, _)) _)) -> Node <$> (addRel n <$> rel) <*> updatedForest where rel = note ("no relation between " <> table <> " and " <> parentTable) - $ findRelation allRelations schema table parentTable - <|> findRelation allRelations schema parentTable table - addRel :: Query -> Relation -> Query - addRel q r = q{relation = Just r} + $ findRelation schema table parentTable + <|> findRelation schema parentTable table + 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 - -getJoinConditions :: Relation -> [Filter] -getJoinConditions (Relation s t cs ft fcs typ lt lc1 lc2) = - case typ of - Child -> zipWith (toFilter t ft) cs fcs - Parent -> zipWith (toFilter t ft) cs fcs - Many -> zipWith (toFilter t (fromMaybe "" lt)) cs (fromMaybe [] lc1) ++ zipWith (toFilter ft (fromMaybe "" lt)) fcs (fromMaybe [] lc2) - where - toFilter :: Text -> Text -> FieldName -> FieldName -> Filter - toFilter tb ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey ftb fc)) + findRelation s t1 t2 = + find (\r -> s == (tableSchema . relTable) r && t1 == (tableName . relTable) r && t2 == (tableName . relFTable) r) allRelations -addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest -addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) = +addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest +addJoinConditions schema (Node (query, (n, r)) forest) = case r of - Nothing -> Node updatedQuery <$> updatedForest -- this is the root node - Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest - Just (Relation{relType=Parent}) -> Node updatedQuery <$> updatedForest + Nothing -> Node (updatedQuery, (n,r)) <$> updatedForest -- this is the root node + Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel),(n,r)) <$> updatedForest + Just (Relation{relType=Parent}) -> Node (updatedQuery, (n,r)) <$> updatedForest Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) -> - Node <$> pure qq <*> updatedForest + Node (qq, (n, r)) <$> updatedForest where q = addCond updatedQuery (getJoinConditions rel) - qq = q{joinTables=linkTable:joinTables q} - _ -> Left "unknow relation" + qq = q{from=tableName linkTable : from q} + _ -> Left "unknown relation" where -- add parentTable and parentJoinConditions to the query - updatedQuery = foldr (flip addCond) (query{joinTables = parentTables ++ joinTables query}) parentJoinConditions + updatedQuery = foldr (flip addCond) (query{from = parentTables ++ from query}) parentJoinConditions where - parentJoinConditions = map (getJoinConditions.snd) parents + parentJoinConditions = map (getJoinConditions . snd) parents parentTables = map fst parents - parents = mapMaybe (getParents.rootLabel) forest - getParents qq@(Select{relation=(Just rel@(Relation{relType=Parent}))}) = Just (mainTable qq, rel) + parents = mapMaybe (getParents . rootLabel) forest + getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel) getParents _ = Nothing - updatedForest = mapM (addJoinConditions schema allColumns) forest - addCond q con = q{filters=con ++ filters q} + updatedForest = mapM (addJoinConditions schema) forest + addCond q con = q{flt_=con ++ flt_ q} -requestToCountQuery :: Text -> ApiRequest -> PStmt -requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) = - B.Stmt query V.empty True +asJson :: StatementT +asJson s = s { + B.stmtTemplate = + "array_to_json(coalesce(array_agg(row_to_json(t)), '{}'))::character varying from (" + <> B.stmtTemplate s <> ") t" } + +callProc :: QualifiedIdentifier -> JSON.Object -> PStmt +callProc qi params = do + let args = intercalate "," $ map assignment (HM.toList params) + B.Stmt ("select * from " <> fromQi qi <> "(" <> args <> ")") empty True where - query = Data.Text.unwords [ - "SELECT pg_catalog.count(1)", - "FROM ", fromQi $ QualifiedIdentifier schema mainTbl, - ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions - ] - emptyOnNull val x = if null x then "" else val - localConditions = filter fn conditions - where - fn (Filter{value=VText _}) = True - fn (Filter{value=VForeignKey _ _}) = False + assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v -requestToQuery :: Text -> ApiRequest -> PStmt -requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) = - orderT (fromMaybe [] ord) query +operators :: [(Text, SqlFragment)] +operators = [ + ("eq", "="), + ("gte", ">="), -- has to be before gt (parsers) + ("gt", ">"), + ("lte", "<="), -- has to be before lt (parsers) + ("lt", "<"), + ("neq", "<>"), + ("like", "like"), + ("ilike", "ilike"), + ("in", "in"), + ("notin", "not in"), + ("isnot", "is not"), -- has to be before is (parsers) + ("is", "is"), + ("@@", "@@"), + ("@>", "@>"), + ("<@", "<@") + ] + +pgFmtIdent :: SqlFragment -> SqlFragment +pgFmtIdent x = + let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in + if (cs escaped :: BS.ByteString) =~ danger + then "\"" <> escaped <> "\"" + else escaped + where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString + +pgFmtLit :: SqlFragment -> SqlFragment +pgFmtLit x = + let trimmed = trimNullChars x + escaped = "'" <> replace "'" "''" trimmed <> "'" + slashed = replace "\\" "\\\\" escaped in + if "\\\\" `isInfixOf` escaped + then "E" <> slashed + else slashed + +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 - query = B.Stmt qStr V.empty True - qStr = Data.Text.unwords [ + -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name + -- of our WITH query part + tblSchema tbl = if tbl == sourceSubqueryName then "" else schema + qi = QualifiedIdentifier (tblSchema mainTbl) mainTbl + toQi t = QualifiedIdentifier (tblSchema t) t + query = unwords [ ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, - "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects), - "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) (mainTbl:tbls)), - ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions + "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects), + "FROM ", intercalate ", " (map (fromQi . toQi) tbls), + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, + orderF (fromMaybe [] ord) ] - emptyOnNull val x = if null x then "" else val (withs, selects) = foldr getQueryParts ([],[]) forest - getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text]) - getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Child}))}) forst) (w,s) = (w,sel:s) + 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 (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) - - getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType=Parent}))}) forst) (w,s) = (wit:w,sel:s) + 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 (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) - - getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Many}))}) forst) (w,s) = (w,sel:s) + 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 (B.Stmt subquery _ _) = requestToQuery schema (Node q forst) - - -- the following is just to remove the warning + 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 (Select{relation=Nothing}) _) _ = undefined + getQueryParts (Node (_,(_,Nothing)) _) _ = undefined +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 + unwords [ + "INSERT INTO ", fromQi qi, + " (" <> colsString <> ")" <> + " SELECT " <> colsString <> + " FROM json_populate_recordset(null::" , fromQi qi, ", ?)", + " RETURNING " <> fromQi qi <> ".*" + ] +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 <> " ", + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, + "RETURNING " <> fromQi qi <> ".*" + ] + Nothing -> undefined + where + qi = QualifiedIdentifier schema mainTbl -pgFmtCondition :: QualifiedIdentifier -> Filter -> Text +requestToQuery schema (DbMutate (Delete mainTbl conditions)) = + query + where + qi = QualifiedIdentifier schema mainTbl + query = unwords [ + "DELETE FROM ", fromQi qi, + ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, + "RETURNING " <> fromQi qi <> ".*" + ] + +sourceSubqueryName :: SqlFragment +sourceSubqueryName = "pg_source" + +unquoted :: JSON.Value -> Text +unquoted (JSON.String t) = t +unquoted (JSON.Number n) = + cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n +unquoted (JSON.Bool b) = cs . show $ b +unquoted v = cs $ JSON.encode v + +-- 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 + n = qiName t + s = qiSchema t + +getJoinConditions :: Relation -> [Filter] +getJoinConditions (Relation t cols ft fcs typ lt lc1 lc2) = + case typ of + Child -> zipWith (toFilter tN ftN) cols fcs + Parent -> zipWith (toFilter tN ftN) cols fcs + Many -> zipWith (toFilter tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2) + where + s = tableSchema t + tN = tableName t + ftN = tableName ft + ltN = fromMaybe "" (tableName <$> lt) + toFilter :: Text -> Text -> Column -> Column -> Filter + toFilter tb ftb c fc = Filter (colName c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})) + +emptyOnNull :: Text -> [a] -> Text +emptyOnNull val x = if null x then "" else val + +orderF :: [OrderTerm] -> SqlFragment +orderF ts = + if null ts + then "" + else "ORDER BY " <> clause + where + clause = intercalate "," (map queryTerm ts) + queryTerm :: OrderTerm -> Text + queryTerm t = " " + <> cs (pgFmtIdent $ otTerm t) <> " " + <> (cs.show) (otDirection t) <> " " + <> maybe "" (cs.show) (otNullOrder t) <> " " + +insertableValue :: JSON.Value -> SqlFragment +insertableValue JSON.Null = "null" +insertableValue v = (<> "::unknown") . pgFmtLit $ unquoted v + +whiteList :: Text -> SqlFragment +whiteList val = fromMaybe + (cs (pgFmtLit val) <> "::unknown ") + (find ((==) . toLower $ val) ["null","true","false"]) + +pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment +pgFmtColumn table "*" = fromQi table <> ".*" +pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c + +pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment +pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp + +pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment +pgFmtSelectItem table (f@(_, jp), Nothing) = pgFmtField table f <> pgFmtAsJsonPath jp +pgFmtSelectItem table (f@(_, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAsJsonPath jp + +pgFmtCondition :: QualifiedIdentifier -> Filter -> SqlFragment pgFmtCondition table (Filter (col,jp) ops val) = notOp <> " " <> sqlCol <> " " <> pgFmtOperator opCode <> " " <> if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue @@ -142,24 +392,59 @@ _ -> "" valToStr v = case v of VText s -> pgFmtValue opCode s - VForeignKey (QualifiedIdentifier s _) (ForeignKey ft fc) -> pgFmtColumn (QualifiedIdentifier s ft) fc + VForeignKey (QualifiedIdentifier s _) (ForeignKey Column{colTable=Table{tableName=ft}, colName=fc}) -> pgFmtColumn qi fc + where qi = QualifiedIdentifier (if ft == sourceSubqueryName then "" else s) ft + _ -> "" -pgFmtColumn :: QualifiedIdentifier -> Text -> Text -pgFmtColumn table "*" = fromQi table <> ".*" -pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c +pgFmtValue :: Text -> Text -> SqlFragment +pgFmtValue opCode val = + case opCode of + "like" -> unknownLiteral $ T.map star val + "ilike" -> unknownLiteral $ T.map star val + "in" -> "(" <> intercalate ", " (map unknownLiteral $ split (==',') val) <> ") " + "notin" -> "(" <> intercalate ", " (map unknownLiteral $ split (==',') val) <> ") " + "@@" -> "to_tsquery(" <> unknownLiteral val <> ") " + _ -> unknownLiteral val + where + star c = if c == '*' then '%' else c + unknownLiteral = (<> "::unknown ") . pgFmtLit -pgFmtJsonPath :: Maybe JsonPath -> Text +pgFmtOperator :: Text -> SqlFragment +pgFmtOperator opCode = fromMaybe "=" $ M.lookup opCode operatorsMap + where + operatorsMap = M.fromList operators + +pgFmtJsonPath :: Maybe JsonPath -> SqlFragment pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs ) pgFmtJsonPath _ = "" -pgFmtTable :: Table -> Text -pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n +pgFmtAsJsonPath :: Maybe JsonPath -> SqlFragment +pgFmtAsJsonPath Nothing = "" +pgFmtAsJsonPath (Just xx) = " AS " <> last xx -pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text -pgFmtSelectItem table ((c, jp), Nothing) = pgFmtColumn table c <> pgFmtJsonPath jp <> asJsonPath jp -pgFmtSelectItem table ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp +trimNullChars :: Text -> Text +trimNullChars = T.takeWhile (/= '\x0') -asJsonPath :: Maybe JsonPath -> Text -asJsonPath Nothing = "" -asJsonPath (Just xx) = " AS " <> last xx +withSourceF :: SqlFragment -> SqlFragment +withSourceF s = "WITH " <> sourceSubqueryName <> " AS (" <> s <>")" + +fromF :: SqlFragment -> SqlFragment -> SqlFragment +fromF sel limit = "FROM (" <> sel <> " " <> limit <> ") t" + +limitF :: Maybe NonnegRange -> SqlFragment +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 ) diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -1,97 +1,125 @@ 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 as BS +import qualified Data.Vector as V import Data.Aeson data DbStructure = DbStructure { - tables :: [Table] -, columns :: [Column] -, relations :: [Relation] -, primaryKeys :: [PrimaryKey] -} + dbTables :: [Table] +, dbColumns :: [Column] +, dbRelations :: [Relation] +, dbPrimaryKeys :: [PrimaryKey] +} deriving (Show, Eq) +type Schema = Text +type TableName = Text +type SqlQuery = Text +type SqlFragment = Text +type RequestBody = BL.ByteString data Table = Table { - tableSchema :: Text -, tableName :: Text + tableSchema :: Schema +, tableName :: TableName , tableInsertable :: Bool -, tableAcl :: [Text] -} deriving (Show) +} deriving (Show, Ord) -data ForeignKey = ForeignKey { - fkTable::Text, fkCol::Text -} deriving (Show, Eq) +data ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord) +data Column = + Column { + colTable :: Table + , colName :: Text + , colPosition :: Int + , colNullable :: Bool + , colType :: Text + , colUpdatable :: Bool + , colMaxLen :: Maybe Int + , colPrecision :: Maybe Int + , colDefault :: Maybe Text + , colEnum :: [Text] + , colFK :: Maybe ForeignKey + } + | Star { colTable :: Table } + deriving (Show, Ord) -data Column = Column { - colSchema :: Text -, colTable :: Text -, colName :: Text -, colPosition :: Int -, colNullable :: Bool -, colType :: Text -, colUpdatable :: Bool -, colMaxLen :: Maybe Int -, colPrecision :: Maybe Int -, colDefault :: Maybe Text -, colEnum :: [Text] -, colFK :: Maybe ForeignKey -} | Star {colSchema :: Text, colTable :: Text } deriving (Show) +type Synonym = (Column,Column) data PrimaryKey = PrimaryKey { - pkSchema::Text, pkTable::Text, pkName::Text -} + pkTable :: Table + , pkName :: Text +} deriving (Show, Eq) +data OrderDirection = OrderAsc | OrderDesc deriving (Eq) +instance Show OrderDirection where + show OrderAsc = "asc" + show OrderDesc = "desc" + +data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq) +instance Show OrderNulls where + show OrderNullsFirst = "nulls first" + show OrderNullsLast = "nulls last" + data OrderTerm = OrderTerm { - otTerm :: Text -, otDirection :: BS.ByteString -, otNullOrder :: Maybe BS.ByteString + otTerm :: Text +, otDirection :: OrderDirection +, otNullOrder :: Maybe OrderNulls } deriving (Show, Eq) data QualifiedIdentifier = QualifiedIdentifier { - qiSchema :: Text -, qiName :: Text + qiSchema :: Schema +, qiName :: TableName } deriving (Show, Eq) data RelationType = Child | Parent | Many deriving (Show, Eq) data Relation = Relation { - relSchema :: Text -, relTable :: Text -, relColumns :: [Text] -, relFTable :: Text -, relFColumns :: [Text] -, relType :: RelationType -, relLTable :: Maybe Text -, relLCols1 :: Maybe [Text] -, relLCols2 :: Maybe [Text] + relTable :: Table +, relColumns :: [Column] +, relFTable :: Table +, relFColumns :: [Column] +, relType :: RelationType +, relLTable :: Maybe Table +, relLCols1 :: Maybe [Column] +, 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 UniformObjects + | PayloadParseError BS.ByteString + deriving (Show, Eq) + type Operator = Text data FValue = VText Text | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq) type FieldName = Text type JsonPath = [Text] type Field = (FieldName, Maybe JsonPath) type Cast = Text +type NodeName = Text type SelectItem = (Field, Maybe Cast) type Path = [Text] -data Query = Select { - mainTable::Text -, fields::[SelectItem] -, joinTables::[Text] -, filters::[Filter] -, order::Maybe [OrderTerm] -, relation::Maybe Relation -} 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 ApiRequest = Tree Query +type ReadNode = (ReadQuery, (NodeName, Maybe Relation)) +type ReadRequest = Tree ReadNode +type MutateRequest = MutateQuery +data DbRequest = DbRead ReadRequest | DbMutate MutateRequest instance ToJSON Column where toJSON c = object [ - "schema" .= colSchema c + "schema" .= tableSchema t , "name" .= colName c , "position" .= colPosition c , "nullable" .= colNullable c @@ -102,12 +130,27 @@ , "references".= colFK c , "default" .= colDefault c , "enum" .= colEnum c ] + where + t = colTable c instance ToJSON ForeignKey where - toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk] + toJSON fk = object [ + "schema" .= tableSchema t + , "table" .= tableName t + , "column" .= colName c ] + where + c = fkCol fk + t = colTable c instance ToJSON Table where toJSON v = object [ "schema" .= tableSchema v , "name" .= tableName v , "insertable" .= tableInsertable v ] + +instance Eq Table where + Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2 + +instance Eq Column where + Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2 + _ == _ = False diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/AuthSpec.hs @@ -0,0 +1,70 @@ +module Feature.AuthSpec where + +-- {{{ Imports +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON +import Network.HTTP.Types + +import SpecHelper +-- }}} + +spec :: Spec +spec = beforeAll + (clearTable "postgrest.auth") . afterAll_ (clearTable "postgrest.auth") + $ around withApp + $ describe "authorization" $ do + + it "hides tables that anonymous does not own" $ + get "/authors_only" `shouldRespondWith` 404 + + it "returns jwt functions as jwt tokens" $ + post "/rpc/login" [json| { "id": "jdoe", "pass": "1234" } |] + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"} |] + , matchStatus = 200 + , matchHeaders = ["Content-Type" <:> "application/json"] + } + + it "allows users with permissions to see their tables" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 200 + + it "works with tokens which have extra fields" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIiwia2V5MSI6InZhbHVlMSIsImtleTIiOiJ2YWx1ZTIiLCJrZXkzIjoidmFsdWUzIiwiYSI6MSwiYiI6MiwiYyI6M30.GfydCh-F4wnM379xs0n1zUgalwJIsb6YoBapCo8HlFk" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 200 + + -- this test will stop working 9999999999s after the UNIX EPOCH + it "succeeds with an unexpired token" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.QaPPLWTuyydMu_q7H4noMT7Lk6P4muet1OpJXF6ofhc" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 200 + + it "fails with an expired token" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjE0NDY2NzgxNDksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.enk_qZ_u6gZsXY4R8bREKB_HNExRpM0lIWSLktk9JJQ" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 400 + + it "hides tables from users with invalid JWT" $ do + let auth = authHeaderJWT "ey9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 400 + + it "should fail when jwt contains no claims" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.MKYc_lOECtB0LJOiykilAdlHodB-I0_id2qHKq35dmc" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 400 + + it "hides tables from users with JWT that contain no claims about role" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.zyohGMnrDy4_8eJTl6I2AUXO3MeCCiwR24aGWRkTE9o" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 400 + + it "recovers after 400 error with logged in user" $ do + _ <- post "/authors_only" [json| { "owner": "jdoe", "secret": "test content" } |] + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" + _ <- request methodPost "/rpc/problem" [auth] "" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 200 diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/CorsSpec.hs @@ -0,0 +1,70 @@ +module Feature.CorsSpec where + +-- {{{ Imports +import Test.Hspec +import Test.Hspec.Wai +import Network.Wai.Test (SResponse(simpleHeaders, simpleBody)) +import qualified Data.ByteString.Lazy as BL + +import SpecHelper + +import Network.HTTP.Types +-- }}} + +spec :: Spec +spec = around withApp $ describe "CORS" $ do + let preflightHeaders = [ + ("Accept", "*/*"), + ("Origin", "http://example.com"), + ("Access-Control-Request-Method", "POST"), + ("Access-Control-Request-Headers", "Foo,Bar") ] + let normalCors = [ + ("Host", "localhost:3000"), + ("User-Agent", "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.9; rv:32.0) Gecko/20100101 Firefox/32.0"), + ("Origin", "http://localhost:8000"), + ("Accept", "text/csv, */*; q=0.01"), + ("Accept-Language", "en-US,en;q=0.5"), + ("Accept-Encoding", "gzip, deflate"), + ("Referer", "http://localhost:8000/"), + ("Connection", "keep-alive") ] + + describe "preflight request" $ do + it "replies naively and permissively to preflight request" $ do + r <- request methodOptions "/items" preflightHeaders "" + liftIO $ do + let respHeaders = simpleHeaders r + respHeaders `shouldSatisfy` matchHeader + "Access-Control-Allow-Origin" + "http://example.com" + respHeaders `shouldSatisfy` matchHeader + "Access-Control-Allow-Credentials" + "true" + respHeaders `shouldSatisfy` matchHeader + "Access-Control-Allow-Methods" + "GET, POST, PATCH, DELETE, OPTIONS, HEAD" + respHeaders `shouldSatisfy` matchHeader + "Access-Control-Allow-Headers" + "Authentication, Foo, Bar, Accept, Accept-Language, Content-Language" + respHeaders `shouldSatisfy` matchHeader + "Access-Control-Max-Age" + "86400" + + it "suppresses body in response" $ do + r <- request methodOptions "/" preflightHeaders "" + liftIO $ simpleBody r `shouldBe` "" + + describe "regular request" $ + it "exposes necesssary response headers" $ do + r <- request methodGet "/items" [("Origin", "http://example.com")] "" + liftIO $ simpleHeaders r `shouldSatisfy` matchHeader + "Access-Control-Expose-Headers" + "Content-Encoding, Content-Location, Content-Range, Content-Type, \ + \Date, Location, Server, Transfer-Encoding, Range-Unit" + + describe "postflight request" $ + it "allows INFO body through even with CORS request headers present" $ do + r <- request methodOptions "/items" normalCors "" + liftIO $ do + simpleHeaders r `shouldSatisfy` matchHeader + "Access-Control-Allow-Origin" "\\*" + simpleBody r `shouldSatisfy` not . BL.null diff --git a/test/Feature/DeleteSpec.hs b/test/Feature/DeleteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/DeleteSpec.hs @@ -0,0 +1,37 @@ +module Feature.DeleteSpec where + +import Test.Hspec +import Test.Hspec.Wai +import SpecHelper + +import Network.HTTP.Types + +spec :: Spec +spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items") + . around withApp $ + describe "Deleting" $ do + context "existing record" $ do + it "succeeds with 204 and deletion count" $ + request methodDelete "/items?id=eq.1" [] "" + `shouldRespondWith` ResponseMatcher { + matchBody = Nothing + , matchStatus = 204 + , matchHeaders = ["Content-Range" <:> "*/1"] + } + + it "actually clears items ouf the db" $ do + _ <- request methodDelete "/items?id=lt.15" [] "" + get "/items" + `shouldRespondWith` ResponseMatcher { + matchBody = Just "[{\"id\":15}]" + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-0/1"] + } + + context "known route, unknown record" $ + it "fails with 404" $ + request methodDelete "/items?id=eq.101" [] "" `shouldRespondWith` 404 + + context "totally unknown route" $ + it "fails with 404" $ + request methodDelete "/foozle?id=eq.101" [] "" `shouldRespondWith` 404 diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/InsertSpec.hs @@ -0,0 +1,377 @@ +module Feature.InsertSpec where + +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON +import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus)) + +import SpecHelper + +import qualified Data.Aeson as JSON +import Data.Maybe (fromJust) +import Text.Heredoc +import Network.HTTP.Types.Header +import Network.HTTP.Types +import Control.Monad (replicateM_) + +import TestTypes(IncPK(..), CompoundPK(..)) + +spec :: Spec +spec = afterAll_ resetDb $ around withApp $ do + describe "Posting new record" $ do + after_ (clearTable "menagerie") . context "disparate csv types" $ do + it "accepts disparate json types" $ do + p <- post "/menagerie" + [json| { + "integer": 13, "double": 3.14159, "varchar": "testing!" + , "boolean": false, "date": "1900-01-01", "money": "$3.99" + , "enum": "foo" + } |] + liftIO $ do + simpleBody p `shouldBe` "" + simpleStatus p `shouldBe` created201 + + it "filters columns in result using &select" $ + request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")] + [json| { + "integer": 14, "double": 3.14159, "varchar": "testing!" + , "boolean": false, "date": "1900-01-01", "money": "$3.99" + , "enum": "foo" + } |] `shouldRespondWith` ResponseMatcher { + matchBody = Just [str|{"integer":14,"varchar":"testing!"}|] + , matchStatus = 201 + , matchHeaders = ["Content-Type" <:> "application/json"] + } + + it "includes related data after insert" $ + 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 + , matchHeaders = ["Content-Type" <:> "application/json", "Location" <:> "/projects?id=eq.5"] + } + + + context "with no pk supplied" $ do + context "into a table with auto-incrementing pk" . after_ (clearTable "auto_incrementing_pk") $ + it "succeeds with 201 and link" $ do + p <- post "/auto_incrementing_pk" [json| { "non_nullable_string":"not null"} |] + liftIO $ do + simpleBody p `shouldBe` "" + simpleHeaders p `shouldSatisfy` matchHeader hLocation "/auto_incrementing_pk\\?id=eq\\.[0-9]+" + simpleStatus p `shouldBe` created201 + let Just location = lookup hLocation $ simpleHeaders p + r <- get location + let [record] = fromJust (JSON.decode $ simpleBody r :: Maybe [IncPK]) + liftIO $ do + incStr record `shouldBe` "not null" + incNullableStr record `shouldBe` Nothing + + context "into a table with simple pk" $ + it "fails with 400 and error" $ + post "/simple_pk" [json| { "extra":"foo"} |] + `shouldRespondWith` 400 + + context "into a table with no pk" . after_ (clearTable "no_pk") $ do + it "succeeds with 201 and a link including all fields" $ do + p <- post "/no_pk" [json| { "a":"foo", "b":"bar" } |] + liftIO $ do + simpleBody p `shouldBe` "" + simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.foo&b=eq.bar" + simpleStatus p `shouldBe` created201 + + it "returns full details of inserted record if asked" $ do + p <- request methodPost "/no_pk" + [("Prefer", "return=representation")] + [json| { "a":"bar", "b":"baz" } |] + liftIO $ do + simpleBody p `shouldBe` [json| { "a":"bar", "b":"baz" } |] + simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.bar&b=eq.baz" + simpleStatus p `shouldBe` created201 + + it "can post nulls" $ do + p <- request methodPost "/no_pk" + [("Prefer", "return=representation")] + [json| { "a":null, "b":"foo" } |] + liftIO $ do + simpleBody p `shouldBe` [json| { "a":null, "b":"foo" } |] + simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=is.null&b=eq.foo" + simpleStatus p `shouldBe` created201 + + context "with compound pk supplied" . after_ (clearTable "compound_pk") $ + it "builds response location header appropriately" $ + post "/compound_pk" [json| { "k1":12, "k2":42 } |] + `shouldRespondWith` ResponseMatcher { + matchBody = Nothing, + matchStatus = 201, + matchHeaders = ["Location" <:> "/compound_pk?k1=eq.12&k2=eq.42"] + } + + context "with invalid json payload" $ + it "fails with 400 and error" $ + post "/simple_pk" "}{ x = 2" `shouldRespondWith` 400 + + context "jsonb" . after_ (clearTable "json") $ do + it "serializes nested object" $ do + let inserted = [json| { "data": { "foo":"bar" } } |] + request methodPost "/json" + [("Prefer", "return=representation")] + inserted + `shouldRespondWith` ResponseMatcher { + matchBody = Just inserted + , matchStatus = 201 + , matchHeaders = ["Location" <:> [str|/json?data=eq.{"foo":"bar"}|]] + } + + -- TODO! the test above seems right, why was the one below working before and not now + -- p <- request methodPost "/json" [("Prefer", "return=representation")] inserted + -- liftIO $ do + -- simpleBody p `shouldBe` inserted + -- simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%7B%22foo%22%3A%22bar%22%7D" + -- simpleStatus p `shouldBe` created201 + + it "serializes nested array" $ do + let inserted = [json| { "data": [1,2,3] } |] + request methodPost "/json" + [("Prefer", "return=representation")] + inserted + `shouldRespondWith` ResponseMatcher { + matchBody = Just inserted + , matchStatus = 201 + , matchHeaders = ["Location" <:> [str|/json?data=eq.[1,2,3]|]] + } + -- TODO! the test above seems right, why was the one below working before and not now + -- p <- request methodPost "/json" [("Prefer", "return=representation")] inserted + -- liftIO $ do + -- simpleBody p `shouldBe` inserted + -- simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%5B1%2C2%2C3%5D" + -- simpleStatus p `shouldBe` created201 + + describe "CSV insert" $ do + + after_ (clearTable "menagerie") . context "disparate csv types" $ + it "succeeds with multipart response" $ do + pendingWith "Decide on what to do with CSV insert" + let inserted = [str|integer,double,varchar,boolean,date,money,enum + |13,3.14159,testing!,false,1900-01-01,$3.99,foo + |12,0.1,a string,true,1929-10-01,12,bar + |] + request methodPost "/menagerie" [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")] inserted + + `shouldRespondWith` ResponseMatcher { + matchBody = Just inserted + , matchStatus = 201 + , matchHeaders = ["Content-Type" <:> "text/csv"] + } + -- p <- request methodPost "/menagerie" [("Content-Type", "text/csv")] + -- [str|integer,double,varchar,boolean,date,money,enum + -- |13,3.14159,testing!,false,1900-01-01,$3.99,foo + -- |12,0.1,a string,true,1929-10-01,12,bar + -- |] + -- liftIO $ do + -- simpleBody p `shouldBe` "Content-Type: application/json\nLocation: /menagerie?integer=eq.13\n\n\n--postgrest_boundary\nContent-Type: application/json\nLocation: /menagerie?integer=eq.12\n\n" + -- simpleStatus p `shouldBe` created201 + + after_ (clearTable "no_pk") . context "requesting full representation" $ do + it "returns full details of inserted record" $ + request methodPost "/no_pk" + [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")] + "a,b\nbar,baz" + `shouldRespondWith` ResponseMatcher { + matchBody = Just "a,b\nbar,baz" + , matchStatus = 201 + , matchHeaders = ["Content-Type" <:> "text/csv", + "Location" <:> "/no_pk?a=eq.bar&b=eq.baz"] + } + + -- it "can post nulls (old way)" $ do + -- pendingWith "changed the response when in csv mode" + -- request methodPost "/no_pk" + -- [("Content-Type", "text/csv"), ("Prefer", "return=representation")] + -- "a,b\nNULL,foo" + -- `shouldRespondWith` ResponseMatcher { + -- matchBody = Just [json| { "a":null, "b":"foo" } |] + -- , matchStatus = 201 + -- , matchHeaders = ["Content-Type" <:> "application/json", + -- "Location" <:> "/no_pk?a=is.null&b=eq.foo"] + -- } + it "can post nulls" $ + request methodPost "/no_pk" + [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")] + "a,b\nNULL,foo" + `shouldRespondWith` ResponseMatcher { + matchBody = Just "a,b\n,foo" + , matchStatus = 201 + , matchHeaders = ["Content-Type" <:> "text/csv", + "Location" <:> "/no_pk?a=is.null&b=eq.foo"] + } + + + 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 + -- 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 + + context "to unkonwn uri" $ + it "gives a 404" $ do + pendingWith "Decide on PUT usefullness" + request methodPut "/fake" [] + [json| { "real": false } |] + `shouldRespondWith` 404 + + context "to a known uri" $ do + context "without a fully-specified primary key" $ + it "is not an allowed operation" $ do + pendingWith "Decide on PUT usefullness" + request methodPut "/compound_pk?k1=eq.12" [] + [json| { "k1":12, "k2":42 } |] + `shouldRespondWith` 405 + + context "with a fully-specified primary key" $ do + + context "not specifying every column in the table" $ + it "is rejected for lack of idempotence" $ do + pendingWith "Decide on PUT usefullness" + request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] + [json| { "k1":12, "k2":42 } |] + `shouldRespondWith` 400 + + context "specifying every column in the table" . after_ (clearTable "compound_pk") $ do + it "can create a new record" $ do + pendingWith "Decide on PUT usefullness" + p <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] + [json| { "k1":12, "k2":42, "extra":3 } |] + liftIO $ do + simpleBody p `shouldBe` "" + simpleStatus p `shouldBe` status204 + + r <- get "/compound_pk?k1=eq.12&k2=eq.42" + let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK]) + liftIO $ do + length rows `shouldBe` 1 + let record = head rows + compoundK1 record `shouldBe` 12 + compoundK2 record `shouldBe` 42 + compoundExtra record `shouldBe` Just 3 + + it "can update an existing record" $ do + pendingWith "Decide on PUT usefullness" + _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] + [json| { "k1":12, "k2":42, "extra":4 } |] + _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] + [json| { "k1":12, "k2":42, "extra":5 } |] + + r <- get "/compound_pk?k1=eq.12&k2=eq.42" + let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK]) + liftIO $ do + length rows `shouldBe` 1 + let record = head rows + compoundExtra record `shouldBe` Just 5 + + context "with an auto-incrementing primary key" . after_ (clearTable "auto_incrementing_pk") $ + + it "succeeds with 204" $ do + pendingWith "Decide on PUT usefullness" + request methodPut "/auto_incrementing_pk?id=eq.1" [] + [json| { + "id":1, + "nullable_string":"hi", + "non_nullable_string":"bye", + "inserted_at": "2020-11-11" + } |] + `shouldRespondWith` ResponseMatcher { + matchBody = Nothing, + matchStatus = 204, + matchHeaders = [] + } + + describe "Patching record" $ do + + context "to unkonwn uri" $ + it "gives a 404" $ + request methodPatch "/fake" [] + [json| { "real": false } |] + `shouldRespondWith` 404 + + context "on an empty table" $ + it "indicates no records found to update" $ + request methodPatch "/simple_pk" [] + [json| { "extra":20 } |] + `shouldRespondWith` 404 + + context "in a nonempty table" . before_ (clearTable "items" >> createItems 15) . + after_ (clearTable "items") $ do + it "can update a single item" $ do + g <- get "/items?id=eq.42" + liftIO $ simpleHeaders g + `shouldSatisfy` matchHeader "Content-Range" "\\*/0" + request methodPatch "/items?id=eq.1" [] + [json| { "id":42 } |] + `shouldRespondWith` ResponseMatcher { + matchBody = Nothing, + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "0-0/1"] + } + g' <- get "/items?id=eq.42" + liftIO $ simpleHeaders g' + `shouldSatisfy` matchHeader "Content-Range" "0-0/1" + + it "can update multiple items" $ do + replicateM_ 10 $ post "/auto_incrementing_pk" + [json| { non_nullable_string: "a" } |] + replicateM_ 10 $ post "/auto_incrementing_pk" + [json| { non_nullable_string: "b" } |] + _ <- request methodPatch + "/auto_incrementing_pk?non_nullable_string=eq.a" [] + [json| { non_nullable_string: "c" } |] + g <- get "/auto_incrementing_pk?non_nullable_string=eq.c" + liftIO $ simpleHeaders g + `shouldSatisfy` matchHeader "Content-Range" "0-9/10" + + it "can set a column to NULL" $ do + _ <- post "/no_pk" [json| { a: "keepme", b: "nullme" } |] + _ <- request methodPatch "/no_pk?b=eq.nullme" [] [json| { b: null } |] + get "/no_pk?a=eq.keepme" `shouldRespondWith` + [json| [{ a: "keepme", b: null }] |] + + it "can update based on a computed column" $ + request methodPatch + "/items?always_true=eq.false" + [("Prefer", "return=representation")] + [json| { id: 100 } |] + `shouldRespondWith` 404 + it "can provide a representation" $ do + _ <- post "/items" + [json| { id: 1 } |] + request methodPatch + "/items?id=eq.1" + [("Prefer", "return=representation")] + [json| { id: 99 } |] + `shouldRespondWith` [json| [{id:99}] |] + + describe "Row level permission" $ + it "set user_id when inserting rows" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" + _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |] + _ <- post "/postgrest/users" [json| { "id":"jroe", "pass": "1234", "role": "postgrest_test_author" } |] + + p1 <- request methodPost "/authors_only" + [ auth, ("Prefer", "return=representation") ] + [json| { "secret": "nyancat" } |] + liftIO $ do + simpleBody p1 `shouldBe` [str|{"owner":"jdoe","secret":"nyancat"}|] + simpleStatus p1 `shouldBe` created201 + + p2 <- request methodPost "/authors_only" + -- jwt token for jroe + [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.YuF_VfmyIxWyuceT7crnNKEprIYXsJAyXid3rjPjIow", ("Prefer", "return=representation") ] + [json| { "secret": "lolcat", "owner": "hacker" } |] + liftIO $ do + simpleBody p2 `shouldBe` [str|{"owner":"jroe","secret":"lolcat"}|] + simpleStatus p2 `shouldBe` created201 diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/QuerySpec.hs @@ -0,0 +1,364 @@ +module Feature.QuerySpec where + +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON +import Network.HTTP.Types +import Network.Wai.Test (SResponse(simpleHeaders)) + +import SpecHelper +import Text.Heredoc + + +spec :: Spec +spec = + beforeAll (clearTable "items" >> createItems 15) + . beforeAll clearProjectsTable + . beforeAll (clearTable "complex_items" >> createComplexItems) + . beforeAll (clearTable "nullable_integer" >> createNullInteger) + . beforeAll ( + clearTable "no_pk" >> + createNulls 2 >> + createLikableStrings >> + createJsonData) + . afterAll_ (clearTable "items" >> clearTable "complex_items" >> clearTable "no_pk" >> clearTable "simple_pk") + . around withApp $ do + + describe "Querying a table with a column called count" $ + it "should not confuse count column with pg_catalog.count aggregate" $ + get "/has_count_column" `shouldRespondWith` 200 + + describe "Querying a nonexistent table" $ + it "causes a 404" $ + get "/faketable" `shouldRespondWith` 404 + + describe "Filtering response" $ do + it "matches with equality" $ + get "/items?id=eq.5" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":5}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-0/1"] + } + + it "matches with equality using not operator" $ + get "/items?id=not.eq.5" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-13/14"] + } + + it "matches with more than one condition using not operator" $ + get "/simple_pk?k=like.*yx&extra=not.eq.u" `shouldRespondWith` "[]" + + it "matches with inequality using not operator" $ do + get "/items?id=not.lt.14&order=id.asc" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":14},{"id":15}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-1/2"] + } + get "/items?id=not.gt.2&order=id.asc" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":1},{"id":2}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-1/2"] + } + + it "matches items IN" $ + get "/items?id=in.1,3,5" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":1},{"id":3},{"id":5}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-2/3"] + } + + it "matches items NOT IN" $ + get "/items?id=notin.2,4,6,7,8,9,10,11,12,13,14,15" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":1},{"id":3},{"id":5}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-2/3"] + } + + it "matches items NOT IN using not operator" $ + get "/items?id=not.in.2,4,6,7,8,9,10,11,12,13,14,15" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":1},{"id":3},{"id":5}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-2/3"] + } + + it "matches nulls using not operator" $ + get "/no_pk?a=not.is.null" `shouldRespondWith` + [json| [{"a":"1","b":"0"},{"a":"2","b":"0"}] |] + + it "matches nulls in varchar and numeric fields alike" $ do + get "/no_pk?a=is.null" `shouldRespondWith` + [json| [{"a": null, "b": null}] |] + + get "/nullable_integer?a=is.null" `shouldRespondWith` "[{\"a\":null}]" + + it "matches with like" $ do + get "/simple_pk?k=like.*yx" `shouldRespondWith` + "[{\"k\":\"xyyx\",\"extra\":\"u\"}]" + get "/simple_pk?k=like.xy*" `shouldRespondWith` + "[{\"k\":\"xyyx\",\"extra\":\"u\"}]" + get "/simple_pk?k=like.*YY*" `shouldRespondWith` + "[{\"k\":\"xYYx\",\"extra\":\"v\"}]" + + it "matches with like using not operator" $ + get "/simple_pk?k=not.like.*yx" `shouldRespondWith` + "[{\"k\":\"xYYx\",\"extra\":\"v\"}]" + + it "matches with ilike" $ do + get "/simple_pk?k=ilike.xy*&order=extra.asc" `shouldRespondWith` + "[{\"k\":\"xyyx\",\"extra\":\"u\"},{\"k\":\"xYYx\",\"extra\":\"v\"}]" + get "/simple_pk?k=ilike.*YY*&order=extra.asc" `shouldRespondWith` + "[{\"k\":\"xyyx\",\"extra\":\"u\"},{\"k\":\"xYYx\",\"extra\":\"v\"}]" + + it "matches with ilike using not operator" $ + get "/simple_pk?k=not.ilike.xy*&order=extra.asc" `shouldRespondWith` "[]" + + it "matches with tsearch @@" $ + get "/tsearch?text_search_vector=@@.foo" `shouldRespondWith` + [json| [{"text_search_vector":"'bar':2 'foo':1"}] |] + + it "matches with tsearch @@ using not operator" $ + get "/tsearch?text_search_vector=not.@@.foo" `shouldRespondWith` + [json| [{"text_search_vector":"'baz':1 'qux':2"}] |] + + it "matches with computed column" $ + get "/items?always_true=eq.true" `shouldRespondWith` + [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` + "[{\"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" $ + get "/complex_items?select=id&arr_data=@>.{2}" `shouldRespondWith` + [str|[{"id":2},{"id":3}]|] + + it "matches with <@ operator" $ + get "/complex_items?select=id&arr_data=<@.{1,2,4}" `shouldRespondWith` + [str|[{"id":1},{"id":2}]|] + + + describe "Shaping response with select parameter" $ do + + it "selectStar works in absense of parameter" $ + get "/complex_items?id=eq.3" `shouldRespondWith` + [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3]}]|] + + it "one simple column" $ + get "/complex_items?select=id" `shouldRespondWith` + [json| [{"id":1},{"id":2},{"id":3}] |] + + it "one simple column with casting (text)" $ + get "/complex_items?select=id::text" `shouldRespondWith` + [json| [{"id":"1"},{"id":"2"},{"id":"3"}] |] + + it "json column" $ + get "/complex_items?id=eq.1&select=settings" `shouldRespondWith` + [json| [{"settings":{"foo":{"int":1,"bar":"baz"}}}] |] + + it "json subfield one level with casting (json)" $ + get "/complex_items?id=eq.1&select=settings->>foo::json" `shouldRespondWith` + [json| [{"foo":{"int":1,"bar":"baz"}}] |] -- the value of foo here is of type "text" + + it "fails on bad casting (data of the wrong format)" $ + get "/complex_items?select=settings->foo->>bar::integer" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for integer: \"baz\""} |] + , matchStatus = 400 + , matchHeaders = [] + } + + it "fails on bad casting (wrong cast type)" $ + get "/complex_items?select=id::fakecolumntype" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| {"hint":null,"details":null,"code":"42704","message":"type \"fakecolumntype\" does not exist"} |] + , matchStatus = 400 + , matchHeaders = [] + } + + + it "json subfield two levels (string)" $ + get "/complex_items?id=eq.1&select=settings->foo->>bar" `shouldRespondWith` + [json| [{"bar":"baz"}] |] + + + it "json subfield two levels with casting (int)" $ + get "/complex_items?id=eq.1&select=settings->foo->>int::integer" `shouldRespondWith` + [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` + "[{\"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` + "[{\"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` + "[{\"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` + "[{\"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` + "[{\"user_id\":2,\"task_id\":6,\"comments\":[{\"content\":\"Needs to be delivered ASAP\"}]}]" + + describe "Plurality singular" $ do + it "will select an existing object" $ + request methodGet "/items?id=eq.5" [("Prefer","plurality=singular")] "" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| {"id":5} |] + , matchStatus = 200 + , matchHeaders = [] + } + + it "works in the presence of a range header" $ + let headers = ("Prefer","plurality=singular") : + rangeHdrs (ByteRangeFromTo 0 9) in + request methodGet "/items" headers "" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| {"id":1} |] + , matchStatus = 200 + , matchHeaders = [] + } + + it "will respond with 404 when not found" $ + request methodGet "/items?id=eq.9999" [("Prefer","plurality=singular")] "" + `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")] "" + `shouldRespondWith` + "{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}" + + + describe "ordering response" $ do + it "by a column asc" $ + get "/items?id=lte.2&order=id.asc" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":1},{"id":2}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-1/2"] + } + it "by a column desc" $ + get "/items?id=lte.2&order=id.desc" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":2},{"id":1}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-1/2"] + } + + it "by a column asc with nulls last" $ + get "/no_pk?order=a.asc.nullslast" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"a":"1","b":"0"}, + {"a":"2","b":"0"}, + {"a":null,"b":null}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-2/3"] + } + + it "by a column desc with nulls first" $ + get "/no_pk?order=a.desc.nullsfirst" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"a":null,"b":null}, + {"a":"2","b":"0"}, + {"a":"1","b":"0"}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-2/3"] + } + + it "by a column desc with nulls last" $ + get "/no_pk?order=a.desc.nullslast" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"a":"2","b":"0"}, + {"a":"1","b":"0"}, + {"a":null,"b":null}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-2/3"] + } + + it "without other constraints" $ + get "/items?order=id.asc" `shouldRespondWith` 200 + + describe "Accept headers" $ do + it "should respond an unknown accept type with 415" $ + request methodGet "/simple_pk" + (acceptHdrs "text/unknowntype") "" + `shouldRespondWith` 415 + + it "should respond correctly to */* in accept header" $ + request methodGet "/simple_pk" + (acceptHdrs "*/*") "" + `shouldRespondWith` 200 + + it "should respond correctly to multiple types in accept header" $ + request methodGet "/simple_pk" + (acceptHdrs "text/unknowntype, text/csv") "" + `shouldRespondWith` 200 + + it "should respond with CSV to 'text/csv' request" $ + request methodGet "/simple_pk" + (acceptHdrs "text/csv; version=1") "" + `shouldRespondWith` ResponseMatcher { + matchBody = Just "k,extra\nxyyx,u\nxYYx,v" + , matchStatus = 200 + , matchHeaders = ["Content-Type" <:> "text/csv"] + } + + describe "Canonical location" $ do + it "Sets Content-Location with alphabetized params" $ + get "/no_pk?b=eq.1&a=eq.1" + `shouldRespondWith` ResponseMatcher { + matchBody = Just "[]" + , matchStatus = 200 + , matchHeaders = ["Content-Location" <:> "/no_pk?a=eq.1&b=eq.1"] + } + + it "Omits question mark when there are no params" $ do + r <- get "/simple_pk" + liftIO $ do + let respHeaders = simpleHeaders r + respHeaders `shouldSatisfy` matchHeader + "Content-Location" "/simple_pk" + + describe "jsonb" $ do + it "can filter by properties inside json column" $ do + get "/json?data->foo->>bar=eq.baz" `shouldRespondWith` + [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |] + get "/json?data->foo->>bar=eq.fake" `shouldRespondWith` + [json| [] |] + it "can filter by properties inside json column using not" $ + get "/json?data->foo->>bar=not.eq.baz" `shouldRespondWith` + [json| [] |] + it "can filter by properties inside json column using ->>" $ + get "/json?data->>id=eq.1" `shouldRespondWith` + [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |] + + describe "remote procedure call" $ do + context "a proc that returns a set" . before_ (clearTable "items" >> createItems 10) . + after_ (clearTable "items") $ + it "returns proper json" $ + post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith` + [json| [ {"id": 3}, {"id":4} ] |] + + context "a proc that returns an empty rowset" $ + it "returns empty json array" $ + post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith` + [json| [] |] + + context "a proc that returns plain text" $ + it "returns proper json" $ + post "/rpc/sayhello" [json| { "name": "world" } |] `shouldRespondWith` + [json| [{"sayhello":"Hello, world"}] |] diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/RangeSpec.hs @@ -0,0 +1,112 @@ +module Feature.RangeSpec where + +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON +import Network.HTTP.Types +import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus)) + +import SpecHelper + +spec :: Spec +spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items") + . around withApp $ + describe "GET /items" $ do + + context "without range headers" $ do + context "with response under server size limit" $ + it "returns whole range with status 200" $ + get "/items" `shouldRespondWith` 200 + + context "when I don't want the count" $ do + it "returns range Content-Range with /*" $ + request methodGet "/menagerie" + [("Prefer", "count=none")] "" + `shouldRespondWith` ResponseMatcher { + matchBody = Just "[]" + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "*/*"] + } + + it "returns range Content-Range with range/*" $ + request methodGet "/items?order=id" + [("Prefer", "count=none")] "" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [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}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-14/*"] + } + + it "returns range Content-Range with range/* even using other filters" $ + request methodGet "/items?id=eq.1&order=id" + [("Prefer", "count=none")] "" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| [{"id":1}] |] + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-0/*"] + } + + context "with range headers" $ do + + context "of acceptable range" $ do + it "succeeds with partial content" $ do + r <- request methodGet "/items" + (rangeHdrs $ ByteRangeFromTo 0 1) "" + liftIO $ do + simpleHeaders r `shouldSatisfy` + matchHeader "Content-Range" "0-1/15" + simpleStatus r `shouldBe` partialContent206 + + it "understands open-ended ranges" $ + request methodGet "/items" + (rangeHdrs $ ByteRangeFrom 0) "" + `shouldRespondWith` 200 + + it "returns an empty body when there are no results" $ + request methodGet "/menagerie" + (rangeHdrs $ ByteRangeFromTo 0 1) "" + `shouldRespondWith` ResponseMatcher { + matchBody = Just "[]" + , matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "*/0"] + } + + it "allows one-item requests" $ do + r <- request methodGet "/items" + (rangeHdrs $ ByteRangeFromTo 0 0) "" + liftIO $ do + simpleHeaders r `shouldSatisfy` + matchHeader "Content-Range" "0-0/15" + simpleStatus r `shouldBe` partialContent206 + + it "handles ranges beyond collection length via truncation" $ do + r <- request methodGet "/items" + (rangeHdrs $ ByteRangeFromTo 10 100) "" + liftIO $ do + simpleHeaders r `shouldSatisfy` + matchHeader "Content-Range" "10-14/15" + simpleStatus r `shouldBe` partialContent206 + + context "of invalid range" $ do + it "fails with 416 for offside range" $ + request methodGet "/items" + (rangeHdrs $ ByteRangeFromTo 1 0) "" + `shouldRespondWith` 416 + + it "refuses a range with nonzero start when there are no items" $ + request methodGet "/menagerie" + (rangeHdrs $ ByteRangeFromTo 1 2) "" + `shouldRespondWith` ResponseMatcher { + matchBody = Nothing + , matchStatus = 416 + , matchHeaders = ["Content-Range" <:> "*/0"] + } + + it "refuses a range requesting start past last item" $ + request methodGet "/items" + (rangeHdrs $ ByteRangeFromTo 100 199) "" + `shouldRespondWith` ResponseMatcher { + matchBody = Nothing + , matchStatus = 416 + , matchHeaders = ["Content-Range" <:> "*/15"] + } diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/StructureSpec.hs @@ -0,0 +1,318 @@ +module Feature.StructureSpec where + +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON + +import SpecHelper + +import Network.HTTP.Types + +spec :: Spec +spec = around withApp $ do + describe "GET /" $ do + it "lists views in schema" $ + request methodGet "/" [] "" + `shouldRespondWith` [json| [ + {"schema":"test","name":"articleStars","insertable":true} + , {"schema":"test","name":"articles","insertable":true} + , {"schema":"test","name":"auto_incrementing_pk","insertable":true} + , {"schema":"test","name":"clients","insertable":true} + , {"schema":"test","name":"comments","insertable":true} + , {"schema":"test","name":"complex_items","insertable":true} + , {"schema":"test","name":"compound_pk","insertable":true} + , {"schema":"test","name":"has_count_column","insertable":false} + , {"schema":"test","name":"has_fk","insertable":true} + , {"schema":"test","name":"insertable_view_with_join","insertable":true} + , {"schema":"test","name":"items","insertable":true} + , {"schema":"test","name":"json","insertable":true} + , {"schema":"test","name":"materialized_view","insertable":false} + , {"schema":"test","name":"menagerie","insertable":true} + , {"schema":"test","name":"no_pk","insertable":true} + , {"schema":"test","name":"nullable_integer","insertable":true} + , {"schema":"test","name":"projects","insertable":true} + , {"schema":"test","name":"projects_view","insertable":true} + , {"schema":"test","name":"simple_pk","insertable":true} + , {"schema":"test","name":"tasks","insertable":true} + , {"schema":"test","name":"tsearch","insertable":true} + , {"schema":"test","name":"users","insertable":true} + , {"schema":"test","name":"users_projects","insertable":true} + , {"schema":"test","name":"users_tasks","insertable":true} + ] |] + {matchStatus = 200} + + it "lists only views user has permission to see" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" + + request methodGet "/" [auth] "" + `shouldRespondWith` [json| [ + {"schema":"test","name":"authors_only","insertable":true} + ] |] + {matchStatus = 200} + + describe "Table info" $ do + it "is available with OPTIONS verb" $ + request methodOptions "/menagerie" [] "" `shouldRespondWith` + [json| + { + "pkey":["integer"], + "columns":[ + { + "default": null, + "precision": 32, + "updatable": true, + "schema": "test", + "name": "integer", + "type": "integer", + "maxLen": null, + "enum": [], + "nullable": false, + "position": 1, + "references": null, + "default": null + }, { + "default": null, + "precision": 53, + "updatable": true, + "schema": "test", + "name": "double", + "type": "double precision", + "maxLen": null, + "enum": [], + "nullable": false, + "references": null, + "position": 2 + }, { + "default": null, + "precision": null, + "updatable": true, + "schema": "test", + "name": "varchar", + "type": "character varying", + "maxLen": null, + "enum": [], + "nullable": false, + "position": 3, + "references": null, + "default": null + }, { + "default": null, + "precision": null, + "updatable": true, + "schema": "test", + "name": "boolean", + "type": "boolean", + "maxLen": null, + "enum": [], + "nullable": false, + "references": null, + "position": 4 + }, { + "default": null, + "precision": null, + "updatable": true, + "schema": "test", + "name": "date", + "type": "date", + "maxLen": null, + "enum": [], + "nullable": false, + "references": null, + "position": 5 + }, { + "default": null, + "precision": null, + "updatable": true, + "schema": "test", + "name": "money", + "type": "money", + "maxLen": null, + "enum": [], + "nullable": false, + "position": 6, + "references": null, + "default": null + }, { + "default": null, + "precision": null, + "updatable": true, + "schema": "test", + "name": "enum", + "type": "USER-DEFINED", + "maxLen": null, + "enum": [ + "foo", + "bar" + ], + "nullable": false, + "position": 7, + "references": null, + "default": null + } + ] + } + |] + + it "it includes primary and foreign keys for views" $ + request methodOptions "/projects_view" [] "" `shouldRespondWith` + [json| + { + "pkey":[ + "id" + ], + "columns":[ + { + "references":null, + "default":null, + "precision":32, + "updatable":true, + "schema":"test", + "name":"id", + "type":"integer", + "maxLen":null, + "enum":[], + "nullable":true, + "position":1 + }, + { + "references":null, + "default":null, + "precision":null, + "updatable":true, + "schema":"test", + "name":"name", + "type":"text", + "maxLen":null, + "enum":[], + "nullable":true, + "position":2 + }, + { + "references": { + "schema":"test", + "column":"id", + "table":"clients" + }, + "default":null, + "precision":32, + "updatable":true, + "schema":"test", + "name":"client_id", + "type":"integer", + "maxLen":null, + "enum":[], + "nullable":true, + "position":3 + } + ] + } + |] + + it "includes foreign key data" $ do + pendingWith "have to resolve issue #107" + + request methodOptions "/has_fk" [] "" + `shouldRespondWith` [json| + { + "pkey": ["id"], + "columns":[ + { + "default": "nextval('\"1\".has_fk_id_seq'::regclass)", + "precision": 64, + "updatable": true, + "schema": "test", + "name": "id", + "type": "bigint", + "maxLen": null, + "nullable": false, + "position": 1, + "enum": [], + "references": null + }, { + "default": null, + "precision": 32, + "updatable": true, + "schema": "test", + "name": "auto_inc_fk", + "type": "integer", + "maxLen": null, + "nullable": true, + "position": 2, + "enum": [], + "references": {"table": "auto_incrementing_pk", "column": "id"} + }, { + "default": null, + "precision": null, + "updatable": true, + "schema": "test", + "name": "simple_fk", + "type": "character varying", + "maxLen": 255, + "nullable": true, + "position": 3, + "enum": [], + "references": {"table": "simple_pk", "column": "k"} + } + ] + } + |] + + it "includes all information on views for renamed columns, and raises relations to correct schema" $ + request methodOptions "/articleStars" [] "" + `shouldRespondWith` [json| + { + "pkey": [ + "articleId", + "userId" + ], + "columns": [ + { + "references": { + "schema": "test", + "column": "id", + "table": "articles" + }, + "default": null, + "precision": 32, + "updatable": true, + "schema": "test", + "name": "articleId", + "type": "integer", + "maxLen": null, + "enum": [], + "nullable": true, + "position": 1 + }, + { + "references": { + "schema": "test", + "column": "id", + "table": "users" + }, + "default": null, + "precision": 32, + "updatable": true, + "schema": "test", + "name": "userId", + "type": "integer", + "maxLen": null, + "enum": [], + "nullable": true, + "position": 2 + }, + { + "references": null, + "default": null, + "precision": null, + "updatable": true, + "schema": "test", + "name": "createdAt", + "type": "timestamp without time zone", + "maxLen": null, + "enum": [], + "nullable": true, + "position": 3 + } + ] + } + |] diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -23,32 +23,31 @@ 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 import PostgREST.App (app) import PostgREST.Config (AppConfig(..)) import PostgREST.Middleware -import PostgREST.Error(errResponse) -import PostgREST.PgStructure -import PostgREST.Types +import PostgREST.Error(pgErrResponse) +import PostgREST.DbStructure +dbString :: String +dbString = "postgres://postgrest_test@localhost:5432/postgrest_test" + isLeft :: Either a b -> Bool isLeft (Left _ ) = True isLeft _ = False cfg :: AppConfig -cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 "1" "safe" +cfg = AppConfig dbString 3000 "postgrest_anonymous" "test" (secret "safe") 10 testPoolOpts :: PoolSettings testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30 pgSettings :: P.Settings -pgSettings = P.ParamSettings (cs $ configDbHost cfg) - (fromIntegral $ configDbPort cfg) - (cs $ configDbUser cfg) - (cs $ configDbPass cfg) - (cs $ configDbName cfg) +pgSettings = P.StringSettings $ cs dbString withApp :: ActionWith Application -> IO () withApp perform = do @@ -56,30 +55,16 @@ <- H.acquirePool pgSettings testPoolOpts let txSettings = Just (H.ReadCommitted, Just True) - metadata <- H.session pool $ H.tx txSettings $ do - tabs <- allTables - rels <- allRelations - cols <- allColumns rels - keys <- allPrimaryKeys - return (tabs, rels, cols, keys) - - dbstructure <- case metadata of - Left e -> fail $ show e - Right (tabs, rels, cols, keys) -> - return $ DbStructure { - tables=tabs - , columns=cols - , relations=rels - , primaryKeys=keys - } + dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema cfg) + db <- either (fail . show) return dbOrError perform $ middle $ \req resp -> do body <- strictRequestBody req result <- liftIO $ H.session pool $ H.tx txSettings - $ authenticated cfg (app dbstructure cfg body) req - either (resp . errResponse) resp result + $ runWithClaims cfg (app db cfg body) req + either (resp . pgErrResponse) resp result - where middle = defaultMiddle False + where middle = defaultMiddle resetDb :: IO () @@ -88,7 +73,7 @@ <- H.acquirePool pgSettings testPoolOpts void . liftIO $ H.session pool $ H.tx Nothing $ do - H.unitEx [H.stmt| drop schema if exists "1" cascade |] + H.unitEx [H.stmt| drop schema if exists test cascade |] H.unitEx [H.stmt| drop schema if exists private cascade |] H.unitEx [H.stmt| drop schema if exists postgrest cascade |] @@ -129,15 +114,22 @@ clearTable table = do pool <- testPool void . liftIO $ H.session pool $ H.tx Nothing $ - H.unitEx $ B.Stmt ("delete from \"1\"."<>table) V.empty True + H.unitEx $ B.Stmt ("delete from test."<>table) V.empty True +clearProjectsTable :: IO () +clearProjectsTable = do + pool <- testPool + void . liftIO $ H.session pool $ H.tx Nothing $ + H.unitEx $ B.Stmt "delete from test.projects where id > 4" V.empty True + + createItems :: Int -> IO () createItems n = do pool <- testPool void . liftIO $ H.session pool $ H.tx Nothing txn where txn = mapM_ H.unitEx stmts - stmts = map [H.stmt|insert into "1".items (id) values (?)|] [1..n] + stmts = map [H.stmt|insert into test.items (id) values (?)|] [1..n] createComplexItems :: IO () createComplexItems = do @@ -145,11 +137,12 @@ void . liftIO $ H.session pool $ H.tx Nothing txn where txn = mapM_ H.unitEx stmts - stmts = getZipList $ [H.stmt|insert into "1".complex_items (id, name, settings) values (?,?,?)|] + stmts = getZipList $ [H.stmt|insert into test.complex_items (id, name, settings, arr_data) values (?,?,?,?)|] <$> ZipList ([1..3]::[Int]) <*> ZipList (["One", "Two", "Three"]::[Text]) - <*> ZipList ([jobj,jobj,jobj]) - jobj = (J.object [("foo", J.object [("int", J.Number 1),("bar", J.String "baz")])]) + <*> ZipList [jobj,jobj,jobj] + <*> ZipList ([[1], [1,2], [1,2,3]]::[[Int]]) + jobj = J.object [("foo", J.object [("int", J.Number 1),("bar", J.String "baz")])] createNulls :: Int -> IO () createNulls n = do @@ -157,14 +150,14 @@ void . liftIO $ H.session pool $ H.tx Nothing txn where txn = mapM_ H.unitEx (stmt':stmts) - stmt' = [H.stmt|insert into "1".no_pk (a,b) values (null,null)|] - stmts = map [H.stmt|insert into "1".no_pk (a,b) values (?,0)|] [1..n] + stmt' = [H.stmt|insert into test.no_pk (a,b) values (null,null)|] + stmts = map [H.stmt|insert into test.no_pk (a,b) values (?,0)|] [1..n] createNullInteger :: IO () createNullInteger = do pool <- testPool void . liftIO $ H.session pool $ H.tx Nothing $ - H.unitEx $ [H.stmt| insert into "1".nullable_integer (a) values (null) |] + H.unitEx $ [H.stmt| insert into "test".nullable_integer (a) values (null) |] createLikableStrings :: IO () createLikableStrings = do @@ -174,7 +167,7 @@ H.unitEx $ insertSimplePk "xYYx" "v" where insertSimplePk :: Text -> Text -> H.Stmt P.Postgres - insertSimplePk = [H.stmt|insert into "1".simple_pk (k, extra) values (?,?)|] + insertSimplePk = [H.stmt|insert into test.simple_pk (k, extra) values (?,?)|] createJsonData :: IO () createJsonData = do @@ -182,7 +175,7 @@ void . liftIO $ H.session pool $ H.tx Nothing $ H.unitEx $ [H.stmt| - insert into "1".json (data) values (?) + insert into test.json (data) values (?) |] (J.object [("id", J.Number 1) ,("foo", J.object [("bar", J.String "baz")]) diff --git a/test/TestTypes.hs b/test/TestTypes.hs new file mode 100644 --- /dev/null +++ b/test/TestTypes.hs @@ -0,0 +1,55 @@ +module TestTypes ( + IncPK(..) +, CompoundPK(..) +-- , incFromList +-- , compoundFromList +) where + +import qualified Data.Aeson as JSON +import Data.Aeson ((.:)) +-- import Data.Maybe (fromJust) +import Control.Applicative +import Control.Monad (mzero) + +import Prelude + +data IncPK = IncPK { + incId :: Int +, incNullableStr :: Maybe String +, incStr :: String +, incInsert :: String +} deriving (Eq, Show) + +instance JSON.FromJSON IncPK where + parseJSON (JSON.Object r) = IncPK <$> + r .: "id" <*> + r .: "nullable_string" <*> + r .: "non_nullable_string" <*> + r .: "inserted_at" + parseJSON _ = mzero + +-- incFromList :: [(String, SqlValue)] -> IncPK +-- incFromList row = IncPK +-- (fromSql . fromJust $ lookup "id" row) +-- (fromSql . fromJust $ lookup "nullable_string" row) +-- (fromSql . fromJust $ lookup "non_nullable_string" row) +-- (fromSql . fromJust $ lookup "inserted_at" row) + +data CompoundPK = CompoundPK { + compoundK1 :: Int +, compoundK2 :: Int +, compoundExtra :: Maybe Int +} + +instance JSON.FromJSON CompoundPK where + parseJSON (JSON.Object r) = CompoundPK <$> + r .: "k1" <*> + r .: "k2" <*> + r .: "extra" + parseJSON _ = mzero + +-- compoundFromList :: [(String, SqlValue)] -> CompoundPK +-- compoundFromList row = CompoundPK +-- (fromSql . fromJust $ lookup "k1" row) +-- (fromSql . fromJust $ lookup "k2" row) +-- (fromSql . fromJust $ lookup "extra" row)