From a22cf82688d894b3898ef516d561c95383900d1d Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 28 Feb 2015 12:42:32 -0800 Subject: [PATCH 1/9] Build sql for inserting multiple rows --- src/App.hs | 2 +- src/PgQuery.hs | 13 +++++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/App.hs b/src/App.hs index 00b3b3cf5..dd9dcd107 100644 --- a/src/App.hs +++ b/src/App.hs @@ -101,7 +101,7 @@ app v1schema reqBody req = ([table], "POST") -> handleJsonObj reqBody $ \obj -> do let qt = QualifiedTable schema (cs table) - query = insertInto qt (map cs $ keys obj) (elems obj) + 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 diff --git a/src/PgQuery.hs b/src/PgQuery.hs index bbccfd93a..1f7ef7b65 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -108,15 +108,20 @@ 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 :: 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 <> ".*)") + ") values " + <> T.intercalate ", " + (map (\v -> "(" + <> T.intercalate ", " (map insertableValue v) + <> ")" + ) vals + ) + <> " returning row_to_json(" <> fromQt t <> ".*)") empty True insertSelect :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt From 87acee924e5eeba7fd2addac9963df7eae356044 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 5 Apr 2015 17:13:16 -0700 Subject: [PATCH 2/9] WIP: parsing csv --- postgrest.cabal | 2 ++ src/App.hs | 54 +++++++++++++++++++++++++++++++------------------ src/PgQuery.hs | 41 +++++++++++++++++++++---------------- 3 files changed, 60 insertions(+), 37 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 1ea29e463..0b9de07cf 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,5 @@ Test-Suite spec , blaze-builder , vector , mtl + , cassava , process diff --git a/src/App.hs b/src/App.hs index dd9dcd107..c90111a91 100644 --- a/src/App.hs +++ b/src/App.hs @@ -10,12 +10,14 @@ import Data.Maybe (fromMaybe) import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) -import Data.HashMap.Strict (keys, elems, filterWithKey, toList) +import Data.HashMap.Strict (HashMap, keys, elems, filterWithKey, toList, fromList) import Data.String.Conversions (cs) import Data.List (sortBy) import Data.Functor.Identity import qualified Data.Set as S import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BS +import qualified Data.Csv as CSV import Network.HTTP.Types.Status import Network.HTTP.Types.Header @@ -98,26 +100,38 @@ 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 + ([table], "POST") -> do + let qt = QualifiedTable schema (cs table) + echoRequested = lookup "Prefer" hdrs == Just "return=representation" + records :: Either String (CSV.Header, V.Vector (HashMap BS.ByteString BS.ByteString)) + records = if lookup "Content-Type" hdrs == Just "text/csv" + then CSV.decodeByName reqBody + else eitherDecode reqBody >>= \val -> + case val of + Object obj -> Right ( + V.fromList $ map cs $ keys obj + , V.singleton . fromList . map (\(k,v) -> (cs k, cs $ unquoted v)) $ toList obj + ) + _ -> Left "Expecting single JSON object or CSV rows" + rows = insertInto qt records + undefined + -- else do + -- query = insertInto qt (map cs $ keys obj) [(elems obj)] + -- 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 "" + -- 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], "PUT") -> handleJsonObj reqBody $ \obj -> do diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 1f7ef7b65..76009c98f 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,21 +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 (\v -> "(" - <> T.intercalate ", " (map insertableValue v) - <> ")" - ) vals - ) - <> " returning row_to_json(" <> fromQt t <> ".*)") - empty True +insertInto :: QualifiedTable + -> V.Vector T.Text + -> V.Vector (V.Vector T.Text) + -> 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 insertableText v) + <> ")" + ) vals + ) + <> " returning row_to_json(" <> fromQt t <> ".*)") + empty True insertSelect :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt insertSelect t [] _ = B.Stmt @@ -264,11 +268,14 @@ 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 JSON.Null = "null" 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 = insertableText . unquoted paramFilter :: JSON.Value -> T.Text paramFilter JSON.Null = "is.null" From 4dbcf455553fe5b0721bd1f47d2da913fb6bac9d Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 11 Apr 2015 20:42:38 -0700 Subject: [PATCH 3/9] WIP: typechecking but not yet sending back links Rather amazing how well this actually works given it only type checked --- src/App.hs | 52 +++++++++++++++++++--------------------------------- 1 file changed, 19 insertions(+), 33 deletions(-) diff --git a/src/App.hs b/src/App.hs index c90111a91..3fc80d51d 100644 --- a/src/App.hs +++ b/src/App.hs @@ -2,7 +2,7 @@ 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) @@ -10,13 +10,12 @@ import Data.Maybe (fromMaybe) import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) -import Data.HashMap.Strict (HashMap, keys, elems, filterWithKey, toList, fromList) +import qualified Data.HashMap.Strict as M import Data.String.Conversions (cs) import Data.List (sortBy) import Data.Functor.Identity import qualified Data.Set as S import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString as BS import qualified Data.Csv as CSV import Network.HTTP.Types.Status @@ -102,36 +101,23 @@ app v1schema reqBody req = ([table], "POST") -> do let qt = QualifiedTable schema (cs table) - echoRequested = lookup "Prefer" hdrs == Just "return=representation" - records :: Either String (CSV.Header, V.Vector (HashMap BS.ByteString BS.ByteString)) - records = if lookup "Content-Type" hdrs == Just "text/csv" - then CSV.decodeByName reqBody + --echoRequested = lookup "Prefer" hdrs == Just "return=representation" + parsed :: Either String (V.Vector Text, V.Vector (V.Vector Text)) + 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.tail rows) else eitherDecode reqBody >>= \val -> case val of - Object obj -> Right ( - V.fromList $ map cs $ keys obj - , V.singleton . fromList . map (\(k,v) -> (cs k, cs $ unquoted v)) $ toList obj - ) + Object obj -> Right . second V.singleton . V.unzip . V.fromList $ + M.toList (M.map unquoted obj) _ -> Left "Expecting single JSON object or CSV rows" - rows = insertInto qt records - undefined - -- else do - -- query = insertInto qt (map cs $ keys obj) [(elems obj)] - -- 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 "" + case parsed of + Left err -> return $ responseLBS status400 [] (cs err) + Right records -> do + H.unitEx $ uncurry (insertInto qt) records + return $ responseLBS status201 [] "" ([table], "PUT") -> handleJsonObj reqBody $ \obj -> do @@ -143,10 +129,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) @@ -162,7 +148,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 From 70d33445db2e974e33ffbef9be52796bb981def5 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 12 Apr 2015 13:02:55 -0700 Subject: [PATCH 4/9] WIP: nice but doomed approach to making multipart response --- src/App.hs | 36 +++++++++++++++++++++++++++++++----- 1 file changed, 31 insertions(+), 5 deletions(-) diff --git a/src/App.hs b/src/App.hs index 3fc80d51d..dc8ec8c86 100644 --- a/src/App.hs +++ b/src/App.hs @@ -6,7 +6,7 @@ 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) @@ -16,6 +16,7 @@ import Data.List (sortBy) import Data.Functor.Identity import qualified Data.Set as S import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Builder as BB import qualified Data.Csv as CSV import Network.HTTP.Types.Status @@ -101,7 +102,7 @@ app v1schema reqBody req = ([table], "POST") -> do let qt = QualifiedTable schema (cs table) - --echoRequested = lookup "Prefer" hdrs == Just "return=representation" + echoRequested = lookup "Prefer" hdrs == Just "return=representation" parsed :: Either String (V.Vector Text, V.Vector (V.Vector Text)) parsed = if lookup "Content-Type" hdrs == Just "text/csv" then do @@ -115,9 +116,23 @@ app v1schema reqBody req = _ -> Left "Expecting single JSON object or CSV rows" case parsed of Left err -> return $ responseLBS status400 [] (cs err) - Right records -> do - H.unitEx $ uncurry (insertInto qt) records - return $ responseLBS status201 [] "" + 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 responses ([table], "PUT") -> handleJsonObj reqBody $ \obj -> do @@ -227,6 +242,17 @@ handleJsonObj reqBody handler = do jErr = encode . object $ [("message", String "Expecting a JSON object")] +multipart :: [Response] -> Response +multipart rs = + undefined + + where + renderHeader :: Header -> BL.ByteString + renderHeader (k, v) = k <> ": " <> v + + renderResponse (ResponseBuilder _ headers b) = + BL.intercalate "\n" $ map renderHeader headers + <> BB.toLazyByteString b data TableOptions = TableOptions { tblOptcolumns :: [Column] From 7d03a71fedcfa1475dd6ad9fe7a879e765ded22a Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 12 Apr 2015 19:56:33 -0700 Subject: [PATCH 5/9] All tests but one are passing --- src/App.hs | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/src/App.hs b/src/App.hs index dc8ec8c86..6a4d2aa76 100644 --- a/src/App.hs +++ b/src/App.hs @@ -16,7 +16,7 @@ import Data.List (sortBy) import Data.Functor.Identity import qualified Data.Set as S import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Builder as BB +import qualified Blaze.ByteString.Builder as BB import qualified Data.Csv as CSV import Network.HTTP.Types.Status @@ -24,6 +24,7 @@ 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 @@ -115,7 +116,8 @@ app v1schema reqBody req = M.toList (M.map unquoted obj) _ -> Left "Expecting single JSON object or CSV rows" case parsed of - Left err -> return $ responseLBS status400 [] (cs err) + 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 @@ -132,7 +134,7 @@ app v1schema reqBody req = [ jsonH , (hLocation, "/" <> cs table <> "?" <> cs params) ] $ if echoRequested then encode obj else "" - return $ multipart responses + return $ multipart status201 responses ([table], "PUT") -> handleJsonObj reqBody $ \obj -> do @@ -242,17 +244,23 @@ handleJsonObj reqBody handler = do jErr = encode . object $ [("message", String "Expecting a JSON object")] -multipart :: [Response] -> Response -multipart rs = - undefined +multipart :: Status -> [Response] -> Response +multipart _ [] = responseLBS status204 [] "" +multipart _ [r] = r +multipart s rs = + responseLBS s [(hContentType, "Multipart/mixed; boundary=postgrest_boundary")] $ + BL.intercalate "\n\n--postgrest_boundary\n" (map renderResponseBody rs) where renderHeader :: Header -> BL.ByteString - renderHeader (k, v) = k <> ": " <> v + renderHeader (k, v) = cs (show k) <> ": " <> cs v - renderResponse (ResponseBuilder _ headers b) = - BL.intercalate "\n" $ map renderHeader headers - <> BB.toLazyByteString b + 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] From a87f13f9bb98bf821f14e372f9217ab151dae3d6 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 16 Apr 2015 10:45:24 -0700 Subject: [PATCH 6/9] Fix original tests --- src/App.hs | 10 +++++++--- src/PgQuery.hs | 8 ++++---- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/App.hs b/src/App.hs index 6a4d2aa76..888fd0412 100644 --- a/src/App.hs +++ b/src/App.hs @@ -104,16 +104,16 @@ app v1schema reqBody req = ([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 Text)) + 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.tail rows) + 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 (M.map unquoted obj) + M.toList obj _ -> Left "Expecting single JSON object or CSV rows" case parsed of Left err -> return $ responseLBS status400 [] $ @@ -244,6 +244,10 @@ handleJsonObj reqBody handler = do jErr = encode . object $ [("message", String "Expecting a JSON object")] +parseCsvCell :: BL.ByteString -> Value +parseCsvCell s = + either (const $ String "") id (eitherDecode s) + multipart :: Status -> [Response] -> Response multipart _ [] = responseLBS status204 [] "" multipart _ [r] = r diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 76009c98f..9e97decfe 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -111,7 +111,7 @@ deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True insertInto :: QualifiedTable -> V.Vector T.Text - -> V.Vector (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 @@ -121,7 +121,7 @@ insertInto t cols vals ") values " <> T.intercalate ", " (V.toList $ V.map (\v -> "(" - <> T.intercalate ", " (V.toList $ V.map insertableText v) + <> T.intercalate ", " (V.toList $ V.map insertableValue v) <> ")" ) vals ) @@ -268,14 +268,14 @@ 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 JSON.Null = "null" unquoted _ = "" insertableText :: T.Text -> T.Text insertableText = (<> "::unknown") . pgFmtLit insertableValue :: JSON.Value -> T.Text -insertableValue = insertableText . unquoted +insertableValue JSON.Null = "null" +insertableValue v = insertableText $ unquoted v paramFilter :: JSON.Value -> T.Text paramFilter JSON.Null = "is.null" From f4c49f03f43afe09f4473eaa3cd4cc0ed84a6935 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 16 Apr 2015 12:43:22 -0700 Subject: [PATCH 7/9] Allow NULL in csv field and unquote the multipart headers --- src/App.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/App.hs b/src/App.hs index 888fd0412..bb5f52a5c 100644 --- a/src/App.hs +++ b/src/App.hs @@ -12,6 +12,7 @@ import Data.Ord (comparing) import Data.Ranged.Ranges (emptyRange) 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 @@ -245,19 +246,18 @@ handleJsonObj reqBody handler = do [("message", String "Expecting a JSON object")] parseCsvCell :: BL.ByteString -> Value -parseCsvCell s = - either (const $ String "") id (eitherDecode s) +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\n--postgrest_boundary\n" (map renderResponseBody 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 (show k) <> ": " <> cs v + renderHeader (k, v) = cs (original k) <> ": " <> cs v renderResponseBody :: Response -> BL.ByteString renderResponseBody (ResponseBuilder _ headers b) = From fbc90bdb846bff2b890af7358a3d41c866a6b9ab Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 17 Apr 2015 15:19:29 -0700 Subject: [PATCH 8/9] Tests for csv bulk import Fixes #17 --- postgrest.cabal | 1 + test/Feature/InsertSpec.hs | 45 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 46 insertions(+) diff --git a/postgrest.cabal b/postgrest.cabal index 0b9de07cf..38ed2e451 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -101,3 +101,4 @@ Test-Suite spec , mtl , cassava , process + , heredoc 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" $ From ad8700e996a0726ff1045f7232f6f873b1c2e642 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 17 Apr 2015 15:52:57 -0700 Subject: [PATCH 9/9] bulk insert in changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) 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