From 76ea92bfce891a1f8e1dc150733bca97368c04b5 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 6 Nov 2014 18:31:13 -0800 Subject: [PATCH 1/2] Derp, actually put the data on a put request --- src/Dbapi.hs | 7 +++--- src/PgQuery.hs | 4 ++-- test/Feature/InsertSpec.hs | 45 +++++++++++++++++++++++++++++++++----- test/TestTypes.hs | 29 ++++++++++++++++++++---- test/Unit/PgQuerySpec.hs | 6 ++--- 5 files changed, 73 insertions(+), 18 deletions(-) diff --git a/src/Dbapi.hs b/src/Dbapi.hs index 0d09dbcab..d327d8767 100644 --- a/src/Dbapi.hs +++ b/src/Dbapi.hs @@ -146,10 +146,11 @@ app conn req respond = cols <- columns ver (cs table) conn let colNames = S.fromList $ map (cs . colName) cols let specifiedCols = S.fromList $ map fst $ getRow row - return $ if colNames == specifiedCols then - responseLBS status200 [ jsonContentType ] "" + if colNames == specifiedCols then do + _ <- upsert ver table row qq conn + return $ responseLBS status204 [ jsonContentType ] "" - else if S.null colNames then responseLBS status404 [] "" + else return $ if S.null colNames then responseLBS status404 [] "" else responseLBS status400 [] "You must specify all columns in PUT request" ) diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 8fb7e3ed0..94fe888c9 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -191,8 +191,8 @@ upsert :: Schema -> Text -> SqlRow -> Net.Query -> Connection -> IO (M.Map Strin upsert schema table row qq conn = do stmt <- prepare conn $ cs sql _ <- execute stmt $ join $ replicate 2 $ sqlRowValues row - Just m <- fetchRowMap stmt - return m + m <- fetchRowMap stmt + return $ fromMaybe M.empty m where sql = upsertClause schema table row qq diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 4fa68bbf8..2bf48b870 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -14,7 +14,7 @@ import Data.Maybe (fromJust) import Network.HTTP.Types.Header import Network.HTTP.Types -import TestTypes(IncPK, incStr, incNullableStr) +import TestTypes(IncPK(..), CompoundPK(..)) -- }}} @@ -106,17 +106,39 @@ spec = around appWithFixture $ do [json| { "k1":12, "k2":42 } |] `shouldRespondWith` 400 - context "specifying every column in the table" $ - it "succeeds with 201 and link" $ do + context "specifying every column in the table" $ do + it "can create a new record" $ do p <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] [json| { "k1":12, "k2":42, "extra":3 } |] liftIO $ do simpleBody p `shouldBe` "" - simpleStatus p `shouldBe` status200 + simpleStatus p `shouldBe` status204 + + r <- get "/compound_pk?k1=eq.12&k2=eq.42" + let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK]) + liftIO $ do + length rows `shouldBe` 1 + let record = head rows + compoundK1 record `shouldBe` 12 + compoundK2 record `shouldBe` 42 + compoundExtra record `shouldBe` Just 3 + + it "can update an existing record" $ do + _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] + [json| { "k1":12, "k2":42, "extra":4 } |] + _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" [] + [json| { "k1":12, "k2":42, "extra":5 } |] + + r <- get "/compound_pk?k1=eq.12&k2=eq.42" + let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK]) + liftIO $ do + length rows `shouldBe` 1 + let record = head rows + compoundExtra record `shouldBe` Just 5 context "with an auto-incrementing primary key" $ - it "succeeds with 201 and link" $ + it "succeeds with 204" $ request methodPut "/auto_incrementing_pk?id=eq.1" [] [json| { "id":1, @@ -126,6 +148,17 @@ spec = around appWithFixture $ do } |] `shouldRespondWith` ResponseMatcher { matchBody = Nothing, - matchStatus = 200, + matchStatus = 204, matchHeaders = [] } + + describe "Patching record" $ + + context "to unkonwn uri" $ + it "gives a 404" $ + request methodPatch "/fake" [] + [json| { "real": false } |] + `shouldRespondWith` 404 + + -- context "on an empty table" $ + -- it "succeeds diff --git a/test/TestTypes.hs b/test/TestTypes.hs index 6e997ab5b..95998406d 100644 --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -1,6 +1,8 @@ module TestTypes ( - IncPK(..), - fromList + IncPK(..) +, CompoundPK(..) +, incFromList +, compoundFromList ) where import qualified Data.Aeson as JSON @@ -26,9 +28,28 @@ instance JSON.FromJSON IncPK where r .: "inserted_at" parseJSON _ = mzero -fromList :: [(String, SqlValue)] -> IncPK -fromList row = IncPK +incFromList :: [(String, SqlValue)] -> IncPK +incFromList row = IncPK (fromSql . fromJust $ lookup "id" row) (fromSql . fromJust $ lookup "nullable_string" row) (fromSql . fromJust $ lookup "non_nullable_string" row) (fromSql . fromJust $ lookup "inserted_at" row) + +data CompoundPK = CompoundPK { + compoundK1 :: Int +, compoundK2 :: Int +, compoundExtra :: Maybe Int +} + +instance JSON.FromJSON CompoundPK where + parseJSON (JSON.Object r) = CompoundPK <$> + r .: "k1" <*> + r .: "k2" <*> + r .: "extra" + parseJSON _ = mzero + +compoundFromList :: [(String, SqlValue)] -> CompoundPK +compoundFromList row = CompoundPK + (fromSql . fromJust $ lookup "k1" row) + (fromSql . fromJust $ lookup "k2" row) + (fromSql . fromJust $ lookup "extra" row) diff --git a/test/Unit/PgQuerySpec.hs b/test/Unit/PgQuerySpec.hs index 948e8e17c..9e0f2c7c2 100644 --- a/test/Unit/PgQuerySpec.hs +++ b/test/Unit/PgQuerySpec.hs @@ -10,7 +10,7 @@ import Database.HDBC (IConnection, SqlValue, toSql, prepare, import PgQuery (LoginAttempt(..), insert, addUser, signInRole, checkPass , pgFmtIdent, pgFmtLit) import Types (SqlRow(SqlRow)) -import TestTypes (fromList, incStr, incNullableStr, incInsert, incId) +import TestTypes (incFromList, incStr, incNullableStr, incInsert, incId) import Data.Map (toList) import Data.String.Conversions (cs) import Data.Monoid ((<>)) @@ -34,13 +34,13 @@ spec = around dbWithSchema $ do it "inserts and responds with a full object description" $ \conn -> do r <- insert "1" "auto_incrementing_pk" (SqlRow [ ("non_nullable_string", toSql ("a string"::String))]) conn - let returnRow = fromList . toList $ r + let returnRow = incFromList . toList $ r incStr returnRow `shouldBe` "a string" incNullableStr returnRow `shouldBe` Nothing incInsert returnRow `shouldSatisfy` not . null incId returnRow `shouldSatisfy` (>= 0) tRows <- quickALQuery conn "select * from \"1\".auto_incrementing_pk" [] - [returnRow] `shouldBe` map fromList tRows + [returnRow] `shouldBe` map incFromList tRows it "throws an exception if the PK is not unique" $ \conn -> do r <- insert "1" "auto_incrementing_pk" (SqlRow [ From 58adb5e828fd6e5dfdf3a6aaff97bd83b2827a66 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 6 Nov 2014 23:49:29 -0800 Subject: [PATCH 2/2] Allow patch requests Fixes #87 --- src/Dbapi.hs | 6 ++++++ src/PgQuery.hs | 22 +++++++++++++++------- test/Feature/InsertSpec.hs | 34 +++++++++++++++++++++++++++++++--- test/Unit/ErrorsSpec.hs | 1 - 4 files changed, 52 insertions(+), 11 deletions(-) diff --git a/src/Dbapi.hs b/src/Dbapi.hs index d327d8767..26e22276a 100644 --- a/src/Dbapi.hs +++ b/src/Dbapi.hs @@ -155,6 +155,12 @@ app conn req respond = "You must specify all columns in PUT request" ) + ([table], "PATCH") -> + jsonBodyAction req (\row -> do + _ <- update ver table row qq conn + return $ responseLBS status204 [ jsonContentType ] "" + ) + (_, _) -> return $ responseLBS status404 [] "" diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 94fe888c9..f3b193b76 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -2,6 +2,7 @@ module PgQuery ( getRows , insert +, update , upsert , addUser , signInRole @@ -187,14 +188,21 @@ signInRole user pass conn = do checkPass :: BS.ByteString -> BS.ByteString -> Bool checkPass = validatePassword -upsert :: Schema -> Text -> SqlRow -> Net.Query -> Connection -> IO (M.Map String SqlValue) +upsert :: Schema -> Text -> SqlRow -> Net.Query -> Connection -> + IO (M.Map String SqlValue) upsert schema table row qq conn = do - stmt <- prepare conn $ cs sql + stmt <- prepare conn $ cs $ upsertClause schema table row qq _ <- execute stmt $ join $ replicate 2 $ sqlRowValues row m <- fetchRowMap stmt return $ fromMaybe M.empty m - where sql = upsertClause schema table row qq +update :: Schema -> Text -> SqlRow -> Net.Query -> Connection -> + IO (M.Map String SqlValue) +update schema table row qq conn = do + stmt <- prepare conn $ cs $ updateClause schema table row qq + _ <- execute stmt $ sqlRowValues row + m <- fetchRowMap stmt + return $ fromMaybe M.empty m placeholders :: Text -> SqlRow -> Text placeholders symbol = intercalate ", " . map (const symbol) . getRow @@ -213,16 +221,16 @@ insertClauseViaSelect schema table row = intercalate ", " (map pgFmtIdent (sqlRowColumns row)) <> ") select " <> placeholders "?" row -updateClause :: Schema -> Text -> SqlRow -> Text -updateClause schema table row = +updateClause :: Schema -> Text -> SqlRow -> Net.Query -> Text +updateClause schema table row qq = "update " <> pgFmtIdent schema <> "." <> pgFmtIdent table <> " set (" <> intercalate ", " (map pgFmtIdent (sqlRowColumns row)) <> ") = (" <> placeholders "?" row <> ")" + <> whereClause qq upsertClause :: Schema -> Text -> SqlRow -> Net.Query -> Text upsertClause schema table row qq = - "with upsert as (" <> updateClause schema table row - <> whereClause qq + "with upsert as (" <> updateClause schema table row qq <> " returning *) " <> insertClauseViaSelect schema table row <> " where not exists (select * from upsert) returning *" diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 2bf48b870..8f047dc69 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -13,6 +13,7 @@ import qualified Data.Aeson as JSON import Data.Maybe (fromJust) import Network.HTTP.Types.Header import Network.HTTP.Types +import Control.Monad (replicateM_) import TestTypes(IncPK(..), CompoundPK(..)) @@ -152,7 +153,7 @@ spec = around appWithFixture $ do matchHeaders = [] } - describe "Patching record" $ + describe "Patching record" $ do context "to unkonwn uri" $ it "gives a 404" $ @@ -160,5 +161,32 @@ spec = around appWithFixture $ do [json| { "real": false } |] `shouldRespondWith` 404 - -- context "on an empty table" $ - -- it "succeeds + context "on an empty table" $ + it "succeeds with no effect" $ + request methodPatch "/simple_pk" [] + [json| { "extra":20 } |] + `shouldRespondWith` 204 + + context "in a nonempty table" $ do + it "can update a single item" $ do + g <- get "/items?id=eq.42" + liftIO $ simpleHeaders g + `shouldSatisfy` matchHeader "Content-Range" "\\*/0" + request methodPatch "/items?id=eq.1" [] + [json| { "id":42 } |] + `shouldRespondWith` 204 + g' <- get "/items?id=eq.42" + liftIO $ simpleHeaders g' + `shouldSatisfy` matchHeader "Content-Range" "0-0/1" + + it "can update multiple items" $ do + replicateM_ 10 $ post "/auto_incrementing_pk" + [json| { non_nullable_string: "a" } |] + replicateM_ 10 $ post "/auto_incrementing_pk" + [json| { non_nullable_string: "b" } |] + _ <- request methodPatch + "/auto_incrementing_pk?non_nullable_string=eq.a" [] + [json| { non_nullable_string: "c" } |] + g <- get "/auto_incrementing_pk?non_nullable_string=eq.c" + liftIO $ simpleHeaders g + `shouldSatisfy` matchHeader "Content-Range" "0-9/10" diff --git a/test/Unit/ErrorsSpec.hs b/test/Unit/ErrorsSpec.hs index d7ef231e2..0241dc890 100644 --- a/test/Unit/ErrorsSpec.hs +++ b/test/Unit/ErrorsSpec.hs @@ -15,7 +15,6 @@ import Network.HTTP.Types.Status (ok200) spec :: Spec spec = let dbErrApp conn _ res = do - putStrLn "In fake app" _ <- insert "1" "items" (SqlRow []) conn runRaw conn "select 1/0" _ <- insert "1" "items" (SqlRow []) conn