postgrest 0.2.7.0 → 0.2.8.0
raw patch · 5 files changed
+199/−72 lines, 5 filesdep +cassavadep +heredocdep ~hasqldep ~hasql-backenddep ~hasql-postgres
Dependencies added: cassava, heredoc
Dependency ranges changed: hasql, hasql-backend, hasql-postgres
Files
- postgrest.cabal +8/−5
- src/App.hs +64/−26
- src/Main.hs +2/−1
- src/PgQuery.hs +83/−21
- test/SpecHelper.hs +42/−19
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.7.0+version: 0.2.8.0 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE@@ -19,8 +19,8 @@ default-language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes build-depends: base >=4.6 && <5- , hasql == 0.7.*, hasql-backend- , hasql-postgres == 0.10.*+ , hasql == 0.7.3, hasql-backend == 0.4.1+ , hasql-postgres == 0.10.3 , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0@@ -42,6 +42,7 @@ , blaze-builder , vector , mtl+ , cassava Other-Modules: App , Auth , Config@@ -73,8 +74,8 @@ , SpecHelper Build-Depends: base, hspec >= 2.1.2, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json- , hasql, hasql-backend- , hasql-postgres+ , hasql == 0.7.3, hasql-backend == 0.4.1+ , hasql-postgres == 0.10.3 , warp, wai , packdeps, hlint , HTTP, convertible@@ -98,4 +99,6 @@ , blaze-builder , vector , mtl+ , cassava , process+ , heredoc
src/App.hs view
@@ -2,26 +2,30 @@ module App (app, sqlError, isSqlError) where import Control.Monad (join)-import Control.Arrow ((***))+import Control.Arrow ((***), second) import Control.Applicative import Data.Text hiding (map)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange)-import Data.HashMap.Strict (keys, elems, filterWithKey, toList)+import qualified Data.HashMap.Strict as M import Data.String.Conversions (cs)+import Data.CaseInsensitive (original) import Data.List (sortBy) import Data.Functor.Identity import qualified Data.Set as S import qualified Data.ByteString.Lazy as BL+import qualified Blaze.ByteString.Builder as BB+import qualified Data.Csv as CSV import Network.HTTP.Types.Status import Network.HTTP.Types.Header import Network.HTTP.Types.URI (parseSimpleQuery) import Network.HTTP.Base (urlEncodeVars) import Network.Wai+import Network.Wai.Internal (Response(..)) import Data.Aeson import Data.Monoid@@ -98,26 +102,40 @@ , (hLocation, "/postgrest/users?id=eq." <> cs (userId u)) ] "" - ([table], "POST") ->- handleJsonObj reqBody $ \obj -> do- let qt = QualifiedTable schema (cs table)- query = insertInto qt (map cs $ keys obj) (elems obj)- echoRequested = lookup "Prefer" hdrs == Just "return=representation"- row <- H.maybeEx query- let (Identity insertedJson) = fromMaybe (Identity "{}" :: Identity Text) row- Just inserted = decode (cs insertedJson) :: Maybe Object-- primaryKeys <- map cs <$> primaryKeyColumns qt- let primaries = if Prelude.null primaryKeys- then inserted- else filterWithKey (const . (`elem` primaryKeys)) inserted- let params = urlEncodeVars- $ map (\t -> (cs $ fst t, "eq." <> cs (unquoted $ snd t)))- $ sortBy (comparing fst) $ toList primaries- return $ responseLBS status201- [ jsonH- , (hLocation, "/" <> cs table <> "?" <> cs params)- ] $ if echoRequested then cs insertedJson else ""+ ([table], "POST") -> do+ let qt = QualifiedTable schema (cs table)+ echoRequested = lookup "Prefer" hdrs == Just "return=representation"+ parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))+ parsed = if lookup "Content-Type" hdrs == Just "text/csv"+ 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+ primaryKeys <- primaryKeyColumns qt+ let responses = flip map inserted $ \obj -> do+ let primaries =+ if Prelude.null primaryKeys+ then obj+ else M.filterWithKey (const . (`elem` primaryKeys)) 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 ([table], "PUT") -> handleJsonObj reqBody $ \obj -> do@@ -129,10 +147,10 @@ "You must speficy all and only primary keys as params" else do tableCols <- map (cs . colName) <$> columns qt- let cols = map cs $ keys obj+ let cols = map cs $ M.keys obj if S.fromList tableCols == S.fromList cols then do- let vals = elems obj+ let vals = M.elems obj H.unitEx $ iffNotT (whereT qq $ update qt cols vals) (insertSelect qt cols vals)@@ -148,7 +166,7 @@ let qt = QualifiedTable schema (cs table) H.unitEx $ whereT qq- $ update qt (map cs $ keys obj) (elems obj)+ $ update qt (map cs $ M.keys obj) (M.elems obj) return $ responseLBS status204 [ jsonH ] "" ([table], "DELETE") -> do@@ -227,6 +245,26 @@ jErr = encode . object $ [("message", String "Expecting a JSON object")] +parseCsvCell :: BL.ByteString -> Value+parseCsvCell s = if s == "NULL" then Null else String $ cs s++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)++ where+ renderHeader :: Header -> BL.ByteString+ renderHeader (k, v) = cs (original k) <> ": " <> cs v++ 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" data TableOptions = TableOptions { tblOptcolumns :: [Column]
src/Main.hs view
@@ -32,7 +32,8 @@ <> prettyVersion <> " / create a REST API to an existing Postgres database" )- conf <- execParser opts+ parserPrefs = prefs showHelpOnError+ conf <- customExecParser parserPrefs opts let port = configPort conf unless (configSecure conf) $
src/PgQuery.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module PgQuery where@@ -22,6 +22,7 @@ import Data.String.Conversions (cs) import qualified Data.Aeson as JSON import qualified Data.List as L+import qualified Data.Vector as V import Data.Scientific (isInteger, formatScientific, FPFormat(..)) type PStmt = H.Stmt P.Postgres@@ -39,6 +40,7 @@ data OrderTerm = OrderTerm { otTerm :: T.Text , otDirection :: BS.ByteString+, otNullOrder :: Maybe BS.ByteString } limitT :: Maybe NonnegRange -> StatementT@@ -67,7 +69,8 @@ queryTerm :: OrderTerm -> PStmt queryTerm t = B.Stmt (" " <> cs (pgFmtIdent $ otTerm t) <> " "- <> cs (otDirection t) <> " ")+ <> cs (otDirection t) <> " "+ <> maybe "" cs (otNullOrder t) <> " ") empty True parentheticT :: StatementT@@ -106,16 +109,24 @@ deleteFrom :: QualifiedTable -> PStmt deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True -insertInto :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt-insertInto t [] _ = B.Stmt- ("insert into " <> fromQt t <> " default values returning *") empty True-insertInto t cols vals = B.Stmt- ("insert into " <> fromQt t <> " (" <>- T.intercalate ", " (map pgFmtIdent cols) <>- ") values ("- <> T.intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)- <> ") returning row_to_json(" <> fromQt t <> ".*)")- empty True+insertInto :: QualifiedTable+ -> V.Vector T.Text+ -> V.Vector (V.Vector JSON.Value)+ -> PStmt+insertInto t cols vals+ | V.null cols = B.Stmt ("insert into " <> fromQt t <> " default values returning *") empty True+ | otherwise = B.Stmt+ ("insert into " <> fromQt 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(" <> fromQt t <> ".*)")+ empty True insertSelect :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt insertSelect t [] _ = B.Stmt@@ -124,7 +135,7 @@ ("insert into " <> fromQt t <> " (" <> T.intercalate ", " (map pgFmtIdent cols) <> ") select "- <> T.intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals))+ <> T.intercalate ", " (map insertableValue vals)) empty True update :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt@@ -132,19 +143,23 @@ ("update " <> fromQt t <> " set (" <> T.intercalate ", " (map pgFmtIdent cols) <> ") = ("- <> T.intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)+ <> T.intercalate ", " (map insertableValue vals) <> ")") empty True wherePred :: Net.QueryItem -> PStmt-wherePred (col, predicate) = B.Stmt- (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs sqlValue)- empty True+wherePred (col, predicate) =+ B.Stmt (" " <> pgFmtJsonbPath (cs col) <> " " <> op <> " " <>+ if opCode `elem` ["is","isnot"] then whiteList value+ else cs sqlValue)+ empty True where opCode:rest = T.split (=='.') $ cs $ fromMaybe "." predicate value = T.intercalate "." rest-+ whiteList val = fromMaybe (cs (pgFmtLit val) <> "::unknown ")+ (L.find ((==) . T.toLower $ val)+ ["null","true","false"]) star c = if c == '*' then '%' else c unknownLiteral = (<> "::unknown ") . pgFmtLit @@ -164,6 +179,8 @@ "like"-> "like" "ilike"-> "ilike" "in" -> "in"+ "is" -> "is"+ "isnot" -> "is not" _ -> "=" orderParse :: Net.Query -> [OrderTerm]@@ -175,10 +192,16 @@ orderParseTerm :: T.Text -> Maybe OrderTerm orderParseTerm s = case T.split (=='.') s of- [c,d] ->+ (c:d:nls) -> if d `elem` ["asc", "desc"]- then Just $ OrderTerm c $- if d == "asc" then "asc" else "desc"+ then Just $ OrderTerm c+ ( if d == "asc" then "asc" else "desc" )+ ( case nls of+ [n] -> if | n == "nullsfirst" -> Just "nulls first"+ | n == "nullslast" -> Just "nulls last"+ | otherwise -> Nothing+ _ -> Nothing+ ) else Nothing _ -> Nothing @@ -188,6 +211,34 @@ 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 :: T.Text -> T.Text+pgFmtJsonbPath p =+ pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p)+ where+ pgFmtJsonbPath' (ColIdentifier i) = 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@@ -218,3 +269,14 @@ cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n unquoted (JSON.Bool b) = cs . show $ b unquoted _ = ""++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
test/SpecHelper.hs view
@@ -5,8 +5,8 @@ import Test.Hspec.Wai import Hasql as H-import Hasql.Backend as H-import Hasql.Postgres as H+import Hasql.Backend as B+import Hasql.Postgres as P import Data.String.Conversions (cs) import Data.Monoid@@ -24,11 +24,12 @@ import Network.Wai.Middleware.Cors (cors) import System.Process (readProcess) +import qualified Data.Aeson.Types as J+ import App (app) import Config (AppConfig(..), corsPolicy) import Middleware import Error(errResponse)--- import Auth (addUser) isLeft :: Either a b -> Bool isLeft (Left _ ) = True@@ -40,8 +41,8 @@ testPoolOpts :: PoolSettings testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30 -pgSettings :: H.Settings-pgSettings = H.ParamSettings (cs $ configDbHost cfg)+pgSettings :: P.Settings+pgSettings = P.ParamSettings (cs $ configDbHost cfg) (fromIntegral $ configDbPort cfg) (cs $ configDbUser cfg) (cs $ configDbPass cfg)@@ -51,7 +52,7 @@ withApp perform = do let anonRole = cs $ configAnonRole cfg currRole = cs $ configDbUser cfg- pool :: H.Pool H.Postgres+ pool :: H.Pool P.Postgres <- H.acquirePool pgSettings testPoolOpts perform $ middle $ \req resp -> do@@ -65,7 +66,7 @@ resetDb :: IO () resetDb = do- pool :: H.Pool H.Postgres+ pool :: H.Pool P.Postgres <- H.acquirePool pgSettings testPoolOpts void . liftIO $ H.session pool $ H.tx Nothing $ do@@ -96,26 +97,48 @@ authHeader u p = (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p)) +testPool :: IO(H.Pool P.Postgres)+testPool = H.acquirePool pgSettings testPoolOpts+ clearTable :: Text -> IO () clearTable table = do- pool :: H.Pool H.Postgres- <- H.acquirePool pgSettings testPoolOpts+ pool <- testPool void . liftIO $ H.session pool $ H.tx Nothing $- H.unitEx $ H.Stmt ("delete from \"1\"."<>table) V.empty True+ H.unitEx $ B.Stmt ("delete from \"1\"."<>table) V.empty True createItems :: Int -> IO () createItems n = do- pool :: H.Pool H.Postgres- <- H.acquirePool pgSettings testPoolOpts+ pool <- testPool void . liftIO $ H.session pool $ H.tx Nothing txn where- txn = sequence_ $ map H.unitEx stmts+ txn = mapM_ H.unitEx stmts stmts = map [H.stmt|insert into "1".items (id) values (?)|] [1..n] --- for hspec-wai-pending_ :: WaiSession ()-pending_ = liftIO Test.Hspec.pending+createNulls :: Int -> IO ()+createNulls n = do+ pool <- testPool+ 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] --- for hspec-wai-pendingWith_ :: String -> WaiSession ()-pendingWith_ = liftIO . Test.Hspec.pendingWith+createLikableStrings :: IO ()+createLikableStrings = do+ pool <- testPool+ void . liftIO $ H.session pool $ H.tx Nothing $ do+ H.unitEx $ insertSimplePk "xyyx" "u"+ H.unitEx $ insertSimplePk "xYYx" "v"+ where+ insertSimplePk :: Text -> Text -> H.Stmt P.Postgres+ insertSimplePk = [H.stmt|insert into "1".simple_pk (k, extra) values (?,?)|]++createJsonData :: IO ()+createJsonData = do+ pool <- testPool+ void . liftIO $ H.session pool $ H.tx Nothing $+ H.unitEx $+ [H.stmt|+ insert into "1".json (data) values (?)+ |]+ (J.object [("foo", J.object [("bar", J.String "baz")])])