diff --git a/CHANGELOG.md b/CHANGELOG.md index 0364599de..9abaa9f32 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ This project adheres to [Semantic Versioning](http://semver.org/). - Option to specify nulls first or last, eg `/people?order=age.desc.nullsfirst` - Filter nulls, `?col=is.null` and `?col=isnot.null` - Filter within jsonb, `?col->a->>b=eq.c` +- Accept CSV in post body for bulk inserts ### Fixed - Allow NULL values in posts diff --git a/postgrest.cabal b/postgrest.cabal index 1ea29e463..38ed2e451 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -42,6 +42,7 @@ executable postgrest , blaze-builder , vector , mtl + , cassava Other-Modules: App , Auth , Config @@ -98,4 +99,6 @@ Test-Suite spec , blaze-builder , vector , mtl + , cassava , process + , heredoc diff --git a/src/App.hs b/src/App.hs index 00b3b3cf5..bb5f52a5c 100644 --- 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 @@ app v1schema reqBody req = , (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, cs (paramFilter $ 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 @@ app v1schema reqBody req = "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 @@ app v1schema reqBody req = 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 @@ handleJsonObj reqBody handler = do 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/PgQuery.hs b/src/PgQuery.hs index bbccfd93a..9e97decfe 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -22,6 +22,7 @@ import Control.Monad (join) 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 @@ -108,16 +109,24 @@ returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" } 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 insertableValue 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 @@ -261,9 +270,12 @@ unquoted (JSON.Number 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 = ((<> "::unknown") . pgFmtLit . unquoted) v +insertableValue v = insertableText $ unquoted v paramFilter :: JSON.Value -> T.Text paramFilter JSON.Null = "is.null" diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 3117791ed..b8ffa831c 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -9,6 +9,7 @@ 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_) @@ -93,6 +94,50 @@ spec = afterAll_ resetDb $ around withApp $ do , matchHeaders = [] } + describe "CSV insert" $ do + + after_ (clearTable "menagerie") . context "disparate csv types" $ + it "succeeds with multipart response" $ do + 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"), ("Prefer", "return=representation")] + "a,b\nbar,baz" + `shouldRespondWith` ResponseMatcher { + matchBody = Just [json| { "a":"bar", "b":"baz" } |] + , matchStatus = 201 + , matchHeaders = ["Content-Type" <:> "application/json", + "Location" <:> "/no_pk?a=eq.bar&b=eq.baz"] + } + + it "can post nulls" $ + 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"] + } + + after_ (clearTable "no_pk") . context "with wrong number of columns" $ do + 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 "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" $