diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits. -version: 0.2.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 diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -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] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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) $ diff --git a/src/PgQuery.hs b/src/PgQuery.hs --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -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 diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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")])])