postgrest 0.2.12.1 → 0.3.0.0
raw patch · 23 files changed
+2994/−1437 lines, 23 filesdep +aeson-prettydep ~basedep ~hspec
Dependencies added: aeson-pretty
Dependency ranges changed: base, hspec
Files
- postgrest.cabal +78/−38
- src/PostgREST/ApiRequest.hs +216/−0
- src/PostgREST/App.hs +243/−325
- src/PostgREST/Auth.hs +76/−96
- src/PostgREST/Config.hs +13/−22
- src/PostgREST/DbStructure.hs +353/−0
- src/PostgREST/Error.hs +7/−3
- src/PostgREST/Main.hs +24/−42
- src/PostgREST/Middleware.hs +48/−81
- src/PostgREST/Parsers.hs +22/−70
- src/PostgREST/PgQuery.hs +0/−306
- src/PostgREST/PgStructure.hs +0/−264
- src/PostgREST/QueryBuilder.hs +382/−97
- src/PostgREST/Types.hs +97/−54
- test/Feature/AuthSpec.hs +70/−0
- test/Feature/CorsSpec.hs +70/−0
- test/Feature/DeleteSpec.hs +37/−0
- test/Feature/InsertSpec.hs +377/−0
- test/Feature/QuerySpec.hs +364/−0
- test/Feature/RangeSpec.hs +112/−0
- test/Feature/StructureSpec.hs +318/−0
- test/SpecHelper.hs +32/−39
- test/TestTypes.hs +55/−0
postgrest.cabal view
@@ -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
+ src/PostgREST/ApiRequest.hs view
@@ -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
src/PostgREST/App.hs view
@@ -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 "")
src/PostgREST/Auth.hs view
@@ -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
src/PostgREST/Config.hs view
@@ -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
+ src/PostgREST/DbStructure.hs view
@@ -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
src/PostgREST/Error.hs view
@@ -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
src/PostgREST/Main.hs view
@@ -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
src/PostgREST/Middleware.hs view
@@ -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
src/PostgREST/Parsers.hs view
@@ -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
− src/PostgREST/PgQuery.hs
@@ -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
− src/PostgREST/PgStructure.hs
@@ -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
src/PostgREST/QueryBuilder.hs view
@@ -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 )
src/PostgREST/Types.hs view
@@ -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
+ test/Feature/AuthSpec.hs view
@@ -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
+ test/Feature/CorsSpec.hs view
@@ -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
+ test/Feature/DeleteSpec.hs view
@@ -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
+ test/Feature/InsertSpec.hs view
@@ -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
+ test/Feature/QuerySpec.hs view
@@ -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"}] |]
+ test/Feature/RangeSpec.hs view
@@ -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"]+ }
+ test/Feature/StructureSpec.hs view
@@ -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+ }+ ]+ }+ |]
test/SpecHelper.hs view
@@ -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")])
+ test/TestTypes.hs view
@@ -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)