postgrest 0.3.1.0 → 0.3.1.1
raw patch · 19 files changed
+352/−206 lines, 19 filesdep +lensdep +lens-aesondep ~waidep ~wai-middleware-static
Dependencies added: lens, lens-aeson
Dependency ranges changed: wai, wai-middleware-static
Files
- postgrest.cabal +13/−5
- src/PostgREST/ApiRequest.hs +8/−4
- src/PostgREST/App.hs +1/−1
- src/PostgREST/Auth.hs +32/−30
- src/PostgREST/Config.hs +1/−1
- src/PostgREST/DbStructure.hs +81/−72
- src/PostgREST/Error.hs +1/−1
- src/PostgREST/Main.hs +5/−4
- src/PostgREST/Middleware.hs +23/−20
- src/PostgREST/Parsers.hs +2/−2
- src/PostgREST/QueryBuilder.hs +21/−13
- src/PostgREST/Types.hs +8/−8
- test/Feature/AuthSpec.hs +17/−1
- test/Feature/InsertSpec.hs +33/−42
- test/Feature/QuerySpec.hs +20/−2
- test/Feature/StructureSpec.hs +56/−0
- test/Feature/UnicodeSpec.hs +20/−0
- test/Main.hs +6/−0
- test/SpecHelper.hs +4/−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.3.1.0+version: 0.3.1.1 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE@@ -40,6 +40,8 @@ , http-types , interpolatedstring-perl6 , jwt+ , lens >=3.8 && < 5.0+ , lens-aeson >= 1.0.0.0 && < 1.1.0.0 , mtl , optparse-applicative >= 0.11 && < 0.13 , parsec@@ -93,6 +95,8 @@ , http-types , interpolatedstring-perl6 , jwt+ , lens+ , lens-aeson , mtl , optparse-applicative , parsec@@ -104,12 +108,13 @@ , time , unordered-containers , vector- , wai- , wai-cors- , wai-extra- , wai-middleware-static , HTTP , Ranged-sets+ , wai >= 3.0.1+ , wai-cors+ , wai-extra+ , wai-middleware-static >= 0.6.0+ , warp >= 3.1.0 Other-Modules: Paths_postgrest Exposed-Modules: PostgREST.App@@ -141,6 +146,7 @@ , Feature.QueryLimitedSpec , Feature.RangeSpec , Feature.StructureSpec+ , Feature.UnicodeSpec , Paths_postgrest , PostgREST.App , PostgREST.Auth@@ -175,6 +181,8 @@ , http-types , interpolatedstring-perl6 , jwt+ , lens+ , lens-aeson , monad-control , mtl , optparse-applicative
src/PostgREST/ApiRequest.hs view
@@ -41,8 +41,8 @@ -- route responses and upload payloads data ContentType = ApplicationJSON | TextCSV deriving Eq instance Show ContentType where- show ApplicationJSON = "application/json"- show TextCSV = "text/csv"+ show ApplicationJSON = "application/json; charset=utf-8"+ show TextCSV = "text/csv; charset=utf-8" {-| Describes what the user wants to do. This data type is a@@ -130,7 +130,7 @@ , iPayload = relevantPayload , iPreferRepresentation = representation , iPreferSingular = singular- , iPreferCount = not $ hasPrefer "count=none"+ , iPreferCount = not $ singular || hasPrefer "count=none" , iFilters = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ] , iSelect = if method == "DELETE" then "*"@@ -145,7 +145,11 @@ 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+ hasPrefer :: T.Text -> Bool+ hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs+ where+ split :: BS.ByteString -> [T.Text]+ split = map T.strip . T.split (==';') . cs singular = hasPrefer "plurality=singular" representation | hasPrefer "return=representation" = Full
src/PostgREST/App.hs view
@@ -249,7 +249,7 @@ fromInRange = frm <= to jsonH :: Header-jsonH = (hContentType, "application/json")+jsonH = (hContentType, "application/json; charset=utf-8") formatRelationError :: Text -> Text formatRelationError = formatGeneralError
src/PostgREST/Auth.hs view
@@ -18,19 +18,20 @@ , tokenJWT ) where -import Control.Monad (join)-import Data.Aeson (Value (..), Object)-import Data.Aeson.Types (emptyObject, emptyArray)+import Control.Lens+import Data.Aeson (Value (..), parseJSON, toJSON)+import Data.Aeson.Lens+import Data.Aeson.Types (parseMaybe, emptyObject, emptyArray) import qualified Data.ByteString as BS-import Data.Vector as V (null, head)-import Data.Map as M (fromList, toList)+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as M+import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.String.Conversions (cs) import Data.Text (Text) import Data.Time.Clock (NominalDiffTime)-import PostgREST.QueryBuilder (pgFmtLit, pgFmtIdent, unquoted)+import PostgREST.QueryBuilder (pgFmtIdent, pgFmtLit, unquoted) import qualified Web.JWT as JWT-import qualified Data.HashMap.Lazy as H {-| Receives a map of JWT claims and returns a list@@ -39,12 +40,12 @@ this one is mapped to a SET ROLE statement. In case there is any problem decoding the JWT it returns Nothing. -}-claimsToSQL :: JWT.ClaimsMap -> [BS.ByteString]-claimsToSQL = map setVar . toList+claimsToSQL :: M.HashMap Text Value -> [BS.ByteString]+claimsToSQL = map setVar . M.toList where setVar ("role", String val) = setRole val- setVar (k, val) = "set local postgrest.claims." <> cs (pgFmtIdent k) <>- " = " <> cs (valueToVariable val) <> ";"+ setVar (k, val) = "set local " <> cs (pgFmtIdent $ "postgrest.claims." <> k)+ <> " = " <> cs (valueToVariable val) <> ";" valueToVariable = pgFmtLit . unquoted {-|@@ -52,19 +53,22 @@ 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 :: JWT.Secret -> Text -> NominalDiffTime -> Either Text (M.HashMap Text Value) 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+ case mClaims of+ Nothing -> Right M.empty+ Just claims -> do+ let mExp = claims ^? key "exp" . _Integer+ expired = fromMaybe False $ (<= time) . fromInteger <$> mExp+ if expired+ then Left "JWT expired"+ else Right (value2map claims)+ where+ mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature secret input+ value2map (Object o) = o+ value2map _ = M.empty {-| Receives the name of a role and returns a SET ROLE statement -} setRole :: Text -> BS.ByteString@@ -76,10 +80,8 @@ 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+tokenJWT secret (Array arr) =+ let obj = if V.null arr then emptyObject else V.head arr+ jcs = parseMaybe parseJSON obj :: Maybe JWT.JWTClaimsSet in+ JWT.encodeSigned JWT.HS256 secret $ fromMaybe JWT.def jcs+tokenJWT secret _ = tokenJWT secret emptyArray
src/PostgREST/Config.hs view
@@ -30,9 +30,9 @@ import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) import Options.Applicative import Paths_postgrest (version)+import Prelude import Safe (readMay) import Web.JWT (Secret, secret)-import Prelude -- | Data type to store all command line options data AppConfig = AppConfig {
src/PostgREST/DbStructure.hs view
@@ -10,23 +10,25 @@ , doesProcReturnJWT ) where -import qualified Hasql.Query as H-import qualified Hasql.Encoders as HE-import qualified Hasql.Decoders as HD+import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Query as H import Control.Applicative-import Control.Monad (join, replicateM)-import Data.Functor.Contravariant (contramap)-import Text.InterpolatedString.Perl6 (q)-import Data.List (elemIndex, find, subsequences, sort, transpose)-import Data.Maybe (fromMaybe, fromJust, isJust, mapMaybe, listToMaybe)+import Control.Monad (join, replicateM)+import Data.Functor.Contravariant (contramap)+import Data.List (elemIndex, find, sort,+ subsequences, transpose)+import Data.Maybe (fromJust, fromMaybe, isJust,+ listToMaybe, mapMaybe) import Data.Monoid-import Data.Text (Text, split)-import qualified Hasql.Session as H+import Data.Text (Text, split)+import qualified Hasql.Session as H import PostgREST.Types+import Text.InterpolatedString.Perl6 (q) -import GHC.Exts (groupWith)-import Data.Int (Int32)+import Data.Int (Int32)+import GHC.Exts (groupWith) import Prelude getDbStructure :: Schema -> H.Session DbStructure@@ -556,69 +558,76 @@ allSynonyms cols = H.statement sql HE.unit (decodeSynonyms cols) True where+ -- query explanation at https://gist.github.com/ruslantalpa/2eab8c930a65e8043d8f sql = [q|- WITH synonyms AS (- /*- -- CTE to replace the view from information_schema because the information in it depended on the logged in role- -- notice the commented line- */- WITH view_column_usage AS (- SELECT DISTINCT- CAST(current_database() AS character varying) AS view_catalog,- CAST(nv.nspname AS character varying) AS view_schema,- CAST(v.relname AS character varying) AS view_name,- CAST(current_database() AS character varying) AS table_catalog,- CAST(nt.nspname AS character varying) AS table_schema,- CAST(t.relname AS character varying) AS table_name,- CAST(a.attname AS character varying) AS column_name- FROM pg_namespace nv, pg_class v, pg_depend dv,- pg_depend dt, pg_class t, pg_namespace nt,- pg_attribute a- WHERE nv.oid = v.relnamespace- AND v.relkind = 'v'- AND v.oid = dv.refobjid- AND dv.refclassid = 'pg_catalog.pg_class'::regclass- AND dv.classid = 'pg_catalog.pg_rewrite'::regclass- AND dv.deptype = 'i'- AND dv.objid = dt.objid- AND dv.refobjid <> dt.refobjid- AND dt.classid = 'pg_catalog.pg_rewrite'::regclass- AND dt.refclassid = 'pg_catalog.pg_class'::regclass- AND dt.refobjid = t.oid- AND t.relnamespace = nt.oid- AND t.relkind IN ('r', 'v', 'f')- AND t.oid = a.attrelid- AND dt.refobjsubid = a.attnum- /*--AND pg_has_role(t.relowner, 'USAGE')*/- )- SELECT- vcu.table_schema AS src_table_schema,- vcu.table_name AS src_table_name,- vcu.column_name AS src_column_name,- view.schemaname AS syn_table_schema,- view.viewname AS syn_table_name,- view.definition AS view_definition- FROM- pg_catalog.pg_views AS view,- view_column_usage AS vcu- WHERE- view.schemaname = vcu.view_schema AND- view.viewname = vcu.view_name AND- view.schemaname NOT IN ('pg_catalog', 'information_schema')- /*--AND (SELECT COUNT(*) FROM information_schema.view_table_usage WHERE view_schema = view.schemaname AND view_name = view.viewname) = 1*/+ WITH view_columns AS (+ SELECT+ c.oid AS view_oid,+ a.attname::information_schema.sql_identifier AS column_name+ FROM pg_attribute a+ JOIN pg_class c ON a.attrelid = c.oid+ JOIN pg_namespace nc ON c.relnamespace = nc.oid+ WHERE+ NOT pg_is_other_temp_schema(nc.oid)+ AND a.attnum > 0+ AND NOT a.attisdropped+ AND (c.relkind = 'v'::"char")+ AND nc.nspname NOT IN ('information_schema', 'pg_catalog')+ ),+ view_column_usage AS (+ SELECT DISTINCT+ v.oid as view_oid,+ nv.nspname::information_schema.sql_identifier AS view_schema,+ v.relname::information_schema.sql_identifier AS view_name,+ nt.nspname::information_schema.sql_identifier AS table_schema,+ t.relname::information_schema.sql_identifier AS table_name,+ a.attname::information_schema.sql_identifier AS column_name,+ pg_get_viewdef(v.oid)::information_schema.character_data AS view_definition+ FROM pg_namespace nv+ JOIN pg_class v ON nv.oid = v.relnamespace+ JOIN pg_depend dv ON v.oid = dv.refobjid+ JOIN pg_depend dt ON dv.objid = dt.objid+ JOIN pg_class t ON dt.refobjid = t.oid+ JOIN pg_namespace nt ON t.relnamespace = nt.oid+ JOIN pg_attribute a ON t.oid = a.attrelid AND dt.refobjsubid = a.attnum++ WHERE+ nv.nspname not in ('information_schema', 'pg_catalog')+ AND v.relkind = 'v'::"char"+ AND dv.refclassid = 'pg_class'::regclass::oid+ AND dv.classid = 'pg_rewrite'::regclass::oid+ AND dv.deptype = 'i'::"char"+ AND dv.refobjid <> dt.refobjid+ AND dt.classid = 'pg_rewrite'::regclass::oid+ AND dt.refclassid = 'pg_class'::regclass::oid+ AND (t.relkind = ANY (ARRAY['r'::"char", 'v'::"char", 'f'::"char"]))+ ),+ candidates AS (+ SELECT+ vcu.*,+ (+ SELECT CASE WHEN match IS NOT NULL THEN coalesce(match[7], match[4]) END+ FROM REGEXP_MATCHES(+ CONCAT('SELECT ', SPLIT_PART(vcu.view_definition, 'SELECT', 2)),+ CONCAT('SELECT.*?((',vcu.table_name,')|(\w+))\.(', vcu.column_name, ')(\sAS\s(")?([^"]+)\6)?.*?FROM.*?',vcu.table_schema,'\.(\2|',vcu.table_name,'\s+(AS\s)?\3)'),+ 'ns'+ ) match+ ) AS view_column_name+ FROM view_column_usage AS vcu ) 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] AS syn_column_name- 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] AS syn_column_name /* " <- for syntax highlighting */- FROM synonyms- ) |]+ c.table_schema,+ c.table_name,+ c.column_name AS table_column_name,+ c.view_schema,+ c.view_name,+ c.view_column_name+ FROM view_columns AS vc, candidates AS c+ WHERE+ vc.view_oid = c.view_oid AND+ vc.column_name = c.view_column_name+ ORDER BY c.view_schema, c.view_name, c.table_name, c.view_column_name+ |] synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column) synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2
src/PostgREST/Error.hs view
@@ -12,8 +12,8 @@ import Data.String.Conversions (cs) import Data.Text (Text) import qualified Data.Text as T-import qualified Hasql.Session as H import qualified Hasql.Pool as P+import qualified Hasql.Session as H import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT import Network.Wai (Response, responseLBS)
src/PostgREST/Main.hs view
@@ -60,10 +60,11 @@ #ifndef mingw32_HOST_OS tid <- myThreadId- void $ installHandler keyboardSignal (Catch $ do- P.release pool- throwTo tid UserInterrupt- ) Nothing+ forM_ [sigINT, sigTERM] $ \sig ->+ void $ installHandler sig (Catch $ do+ P.release pool+ throwTo tid UserInterrupt+ ) Nothing #endif result <- P.use pool $ do
src/PostgREST/Middleware.hs view
@@ -3,52 +3,55 @@ module PostgREST.Middleware where +import Control.Monad (unless)+import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe)-import Data.Text import Data.String.Conversions (cs)+import Data.Text import Data.Time.Clock (NominalDiffTime) import qualified Hasql.Transaction as H import Network.HTTP.Types.Header (hAccept, hAuthorization)-import Network.HTTP.Types.Status (status415, status400)-import Network.Wai (Application, Request (..), Response,- requestHeaders)+import Network.HTTP.Types.Status (status400, status415)+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 PostgREST.ApiRequest (pickContentType)+import PostgREST.ApiRequest (pickContentType) import PostgREST.Auth (setRole, jwtClaims, claimsToSQL) import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (errResponse) -import Prelude hiding(concat)--import qualified Data.Map.Lazy as M+import Prelude hiding (concat, null) runWithClaims :: AppConfig -> NominalDiffTime -> (Request -> H.Transaction Response) -> Request -> H.Transaction Response runWithClaims conf time app req = do H.sql setAnon- case split (== ' ') (cs auth) of- ("Bearer" : tokenStr : _) ->- case jwtClaims jwtSecret tokenStr time of- Just claims ->- if M.member "role" claims- then do- mapM_ H.sql $ claimsToSQL claims- app req- else invalidJWT- _ -> invalidJWT- _ -> app req+ let tokenStr = case split (== ' ') (cs auth) of+ ("Bearer" : t : _) -> t+ _ -> ""+ eClaims = jwtClaims jwtSecret tokenStr time+ case eClaims of+ Left e -> clientErr e+ Right claims ->+ if M.null claims && not (null tokenStr)+ then clientErr "Invalid JWT"+ else do+ let cmdBatch = mconcat $ claimsToSQL claims+ unless (BS.null cmdBatch) (H.sql cmdBatch)+ app req where hdrs = requestHeaders req jwtSecret = configJwtSecret conf auth = fromMaybe "" $ lookup hAuthorization hdrs anon = cs $ configAnonRole conf setAnon = setRole anon- invalidJWT = return $ errResponse status400 "Invalid JWT"+ clientErr = return . errResponse status400 unsupportedAccept :: Application -> Application unsupportedAccept app req respond =
src/PostgREST/Parsers.hs view
@@ -3,14 +3,14 @@ -- ) where -import Control.Applicative hiding ((<$>))+import Control.Applicative hiding ((<$>)) import Data.Monoid import Data.String.Conversions (cs) import Data.Text (Text) import Data.Tree+import PostgREST.QueryBuilder (operators) import PostgREST.Types import Text.ParserCombinators.Parsec hiding (many, (<|>))-import PostgREST.QueryBuilder (operators) pRequestSelect :: Text -> Parser ReadRequest pRequestSelect rootNodeName = do
src/PostgREST/QueryBuilder.hs view
@@ -43,6 +43,7 @@ import Data.Monoid ((<>)) import Data.Text (Text, intercalate, unwords, replace, isInfixOf, toLower, split) import qualified Data.Text as T (map, takeWhile)+import qualified Data.Text.Encoding as T import Data.String.Conversions (cs) import Control.Applicative ((<|>)) import Control.Monad (join)@@ -93,7 +94,7 @@ createReadStatement :: SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool -> H.Query () ResultsWithCount createReadStatement selectQuery countQuery range isSingle countTotal asCsv =- H.statement sql HE.unit decodeStandard True+ unicodeStatement sql HE.unit decodeStandard True where sql = [qc| WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}@@ -116,7 +117,7 @@ createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined createWriteStatement _ _ mutateQuery _ None _ _ (PayloadJSON (UniformObjects _)) =- H.statement sql encodeUniformObjs decodeStandardMay True+ unicodeStatement sql encodeUniformObjs decodeStandardMay True where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery})@@ -124,7 +125,7 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly pKeys _ (PayloadJSON (UniformObjects _)) =- H.statement sql encodeUniformObjs decodeStandardMay True+ unicodeStatement sql encodeUniformObjs decodeStandardMay True where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*)@@ -139,7 +140,7 @@ createWriteStatement qi selectQuery mutateQuery isSingle Full pKeys asCsv (PayloadJSON (UniformObjects _)) =- H.statement sql encodeUniformObjs decodeStandardMay True+ unicodeStatement sql encodeUniformObjs decodeStandardMay True where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*)@@ -206,20 +207,24 @@ type ProcResults = (Maybe Int64, Int64, JSON.Value) callProc :: QualifiedIdentifier -> JSON.Object -> NonnegRange -> Bool -> H.Query () (Maybe ProcResults) callProc qi params range countTotal =- H.statement sql HE.unit decodeProc True+ unicodeStatement sql HE.unit decodeProc True where- sql = [qc| SELECT- {countQuery} as countTotal,- {countResult} as countResult,+ sql = [qc|+ WITH t AS (select * {_callSql})+ SELECT+ {_countExpr} as countTotal,+ pg_catalog.count(1) as countResult, array_to_json(- coalesce(array_agg(row_to_json(t)), '\{}')+ coalesce(array_agg(row_to_json(r)), '\{}') )::character varying- from (select * {_callSql} {limitF range}) t |]+ FROM (select * from t {limitF range}) r;+ |] _args = intercalate "," $ map _assignment (HM.toList params) _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v- _callSql = [qc| from {fromQi qi}({_args}) |] :: BS.ByteString- countQuery = if countTotal then [qc| (select pg_catalog.count(1) {_callSql} c) |] else "null::bigint" :: BS.ByteString- countResult = "pg_catalog.count(t)" :: BS.ByteString+ _callSql = [qc| from {fromQi qi}({_args}) |] :: Text+ _countExpr = if countTotal+ then "(select pg_catalog.count(1) from t)"+ else "null::bigint" :: Text decodeProc = HD.maybeRow procRow procRow = (,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8 <*> HD.value HD.json@@ -434,6 +439,9 @@ 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}}))++unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Query a b+unicodeStatement = H.statement . T.encodeUtf8 emptyOnNull :: Text -> [a] -> Text emptyOnNull val x = if null x then "" else val
src/PostgREST/Types.hs view
@@ -1,16 +1,16 @@ module PostgREST.Types where-import Data.Text-import Data.Tree-import qualified Data.ByteString.Lazy as BL+import Data.Aeson import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Int (Int32)+import Data.Text+import Data.Tree import qualified Data.Vector as V-import Data.Aeson-import Data.Int (Int32) data DbStructure = DbStructure {- dbTables :: [Table]-, dbColumns :: [Column]-, dbRelations :: [Relation]+ dbTables :: [Table]+, dbColumns :: [Column]+, dbRelations :: [Relation] , dbPrimaryKeys :: [PrimaryKey] } deriving (Show, Eq)
test/Feature/AuthSpec.hs view
@@ -21,8 +21,24 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"} |] , matchStatus = 200- , matchHeaders = ["Content-Type" <:> "application/json"]+ , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"] }++ it "sql functions can encode custom and standard claims" $+ post "/rpc/jwt_test" "{}"+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6MTMwMDgxOTM4MCwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3QiLCJpYXQiOjEzMDA4MTkzODAsImF1ZCI6ImV2ZXJ5b25lIn0._tQCF79-ZZGMlLktd3csM_bVaiMg7A8YvIb6K2hcu5w"} |]+ , matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]+ }++ it "sql functions can read custom and standard claims variables" $ do+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6OTk5OTk5OTk5OSwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWF0IjoxMzAwODE5MzgwLCJhdWQiOiJldmVyeW9uZSJ9.AQmCA7CMScvfaDRMqRPeUY6eNf--69gpW-kxaWfq9X0"+ request methodPost "/rpc/reveal_big_jwt" [auth] "{}"+ `shouldRespondWith` [json| [+ {"sub":"fun", "jti":"foo", "nbf":1300819380, "exp":9999999999,+ "http://postgrest.com/foo":true, "iss":"joe", "iat":1300819380,+ "aud":"everyone"}] |] it "allows users with permissions to see their tables" $ do let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
test/Feature/InsertSpec.hs view
@@ -9,10 +9,11 @@ import qualified Data.Aeson as JSON import Data.Maybe (fromJust)+import Data.Monoid ((<>)) import Text.Heredoc import Network.HTTP.Types.Header import Network.HTTP.Types-import Control.Monad (replicateM_)+import Control.Monad (replicateM_, void) import TestTypes(IncPK(..), CompoundPK(..)) import Network.Wai (Application)@@ -41,7 +42,7 @@ } |] `shouldRespondWith` ResponseMatcher { matchBody = Just [str|{"integer":14,"varchar":"testing!"}|] , matchStatus = 201- , matchHeaders = ["Content-Type" <:> "application/json"]+ , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"] } it "includes related data after insert" $@@ -49,7 +50,7 @@ [str|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher { matchBody = Just [str|{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}|] , matchStatus = 201- , matchHeaders = ["Content-Type" <:> "application/json", "Location" <:> "/projects?id=eq.6"]+ , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8", "Location" <:> "/projects?id=eq.6"] } @@ -145,13 +146,6 @@ , 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"@@ -162,12 +156,6 @@ , 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 @@ -183,16 +171,8 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just inserted , matchStatus = 201- , matchHeaders = ["Content-Type" <:> "text/csv"]+ , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"] }- -- 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 context "requesting full representation" $ do it "returns full details of inserted record" $@@ -202,21 +182,10 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just "a,b\nbar,baz" , matchStatus = 201- , matchHeaders = ["Content-Type" <:> "text/csv",+ , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8", "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")]@@ -224,7 +193,7 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just "a,b\n,foo" , matchStatus = 201- , matchHeaders = ["Content-Type" <:> "text/csv",+ , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8", "Location" <:> "/no_pk?a=is.null&b=eq.foo"] } @@ -233,11 +202,22 @@ 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 + context "with unicode values" $+ it "succeeds and returns usable location header" $ do+ let payload = [json| { "a":"圍棋", "b":"￥" } |]+ p <- request methodPost "/no_pk"+ [("Prefer", "return=representation")]+ payload+ liftIO $ do+ simpleBody p `shouldBe` payload+ simpleStatus p `shouldBe` created201++ let Just location = lookup hLocation $ simpleHeaders p+ r <- get location+ liftIO $ simpleBody r `shouldBe` "["<>payload<>"]"++ describe "Putting record" $ do context "to unknown uri" $@@ -386,6 +366,17 @@ , matchStatus = 200 , matchHeaders = [] }++ context "with unicode values" $+ it "succeeds and returns values intact" $ do+ void $ request methodPost "/no_pk" []+ [json| { "a":"patchme", "b":"patchme" } |]+ let payload = [json| { "a":"圍棋", "b":"￥" } |]+ p <- request methodPatch "/no_pk?a=eq.patchme&b=eq.patchme"+ [("Prefer", "return=representation")] payload+ liftIO $ do+ simpleBody p `shouldBe` "["<>payload<>"]"+ simpleStatus p `shouldBe` ok200 describe "Row level permission" $ it "set user_id when inserting rows" $ do
test/Feature/QuerySpec.hs view
@@ -246,6 +246,14 @@ , matchHeaders = [] } + it "can combine multiple prefer values" $+ request methodGet "/items?id=eq.5" [("Prefer","plurality=singular ; future=new; count=none")] ""+ `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@@ -337,7 +345,7 @@ `shouldRespondWith` ResponseMatcher { matchBody = Just "k,extra\nxyyx,u\nxYYx,v" , matchStatus = 200- , matchHeaders = ["Content-Type" <:> "text/csv"]+ , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"] } describe "Canonical location" $ do@@ -390,11 +398,15 @@ post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith` [json| [] |] - context "a proc that returns plain text" $+ context "a proc that returns plain text" $ do it "returns proper json" $ post "/rpc/sayhello" [json| { "name": "world" } |] `shouldRespondWith` [json| [{"sayhello":"Hello, world"}] |] + it "can handle unicode" $+ post "/rpc/sayhello" [json| { "name": "￥" } |] `shouldRespondWith`+ [json| [{"sayhello":"Hello, ￥"}] |]+ context "improper input" $ do it "rejects unknown content type even if payload is good" $ request methodPost "/rpc/sayhello"@@ -421,6 +433,12 @@ get "/rpc/fake" `shouldRespondWith` 405 it "GET with 405 on known procs" $ get "/rpc/sayhello" `shouldRespondWith` 405++ it "executes the proc exactly once per request" $ do+ post "/rpc/callcounter" [json| {} |] `shouldRespondWith`+ [json| [{"callcounter":1}] |]+ post "/rpc/callcounter" [json| {} |] `shouldRespondWith`+ [json| [{"callcounter":2}] |] describe "weird requests" $ do it "can query as normal" $ do
test/Feature/StructureSpec.hs view
@@ -24,6 +24,7 @@ , {"schema":"test","name":"comments","insertable":true} , {"schema":"test","name":"complex_items","insertable":true} , {"schema":"test","name":"compound_pk","insertable":true}+ , {"schema":"test","name":"filtered_tasks","insertable":true} , {"schema":"test","name":"ghostBusters","insertable":true} , {"schema":"test","name":"has_count_column","insertable":false} , {"schema":"test","name":"has_fk","insertable":true}@@ -57,6 +58,61 @@ {matchStatus = 200} describe "Table info" $ do+ it "The structure of complex views is correctly detected" $+ request methodOptions "/filtered_tasks" [] "" `shouldRespondWith`+ [json|+ {+ "pkey": [+ "myId"+ ],+ "columns": [+ {+ "references": null,+ "default": null,+ "precision": 32,+ "updatable": true,+ "schema": "test",+ "name": "myId",+ "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": "projects"+ },+ "default": null,+ "precision": 32,+ "updatable": true,+ "schema": "test",+ "name": "projectID",+ "type": "integer",+ "maxLen": null,+ "enum": [],+ "nullable": true,+ "position": 3+ }+ ]+ }+ |]+ it "is available with OPTIONS verb" $ request methodOptions "/menagerie" [] "" `shouldRespondWith` [json|
+ test/Feature/UnicodeSpec.hs view
@@ -0,0 +1,20 @@+module Feature.UnicodeSpec where++import Test.Hspec+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON+import Network.Wai (Application)+import Control.Monad (void)++spec :: SpecWith Application+spec =+ describe "Reading and writing to unicode schema and table names" $+ it "Can read and write values" $ do+ get "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"+ `shouldRespondWith` "[]"++ void $ post "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"+ [json| { "هویت": 1 } |]++ get "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"+ `shouldRespondWith` [json| [{ "هویت": 1 }] |]
test/Main.hs view
@@ -18,6 +18,7 @@ import qualified Feature.QuerySpec import qualified Feature.RangeSpec import qualified Feature.StructureSpec+import qualified Feature.UnicodeSpec main :: IO () main = do@@ -29,6 +30,7 @@ let dbStructure = either (error.show) id result withApp = return $ postgrest testCfg dbStructure pool ltdApp = return $ postgrest testLtdRowsCfg dbStructure pool+ unicodeApp = return $ postgrest testUnicodeCfg dbStructure pool hspec $ do mapM_ (beforeAll_ resetDb . before withApp) specs@@ -36,6 +38,10 @@ -- this test runs with a different server flag beforeAll_ resetDb . before ltdApp $ describe "Feature.QueryLimitedSpec" Feature.QueryLimitedSpec.spec++ -- this test runs with a different schema+ beforeAll_ resetDb . before unicodeApp $+ describe "Feature.UnicodeSpec" Feature.UnicodeSpec.spec where specs = map (uncurry describe) [
test/SpecHelper.hs view
@@ -21,6 +21,10 @@ testCfg = AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 Nothing True +testUnicodeCfg :: AppConfig+testUnicodeCfg =+ AppConfig testDbConn "postgrest_test_anonymous" "تست" 3000 (secret "safe") 10 Nothing True+ testLtdRowsCfg :: AppConfig testLtdRowsCfg = AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 (Just 3) True