From 58adb5e828fd6e5dfdf3a6aaff97bd83b2827a66 Mon Sep 17 00:00:00 2001
From: Joe Nelson <cred+github@begriffs.com>
Date: Thu, 6 Nov 2014 23:49:29 -0800
Subject: [PATCH] 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