Merge branch 'patch'

src/Dbapi.hs

@@ -146,14 +146,21 @@ 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
+              if colNames == specifiedCols then do
-                responseLBS status200 [ jsonContentType ] ""
+                _ <- 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"
       )
 
+    ([table], "PATCH") ->
+      jsonBodyAction req (\row -> do
+        _ <- update ver table row qq conn
+        return $ responseLBS status204 [ jsonContentType ] ""
+      )
+
     (_, _) ->
       return $ responseLBS status404 [] ""
 

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
-  Just m <- fetchRowMap stmt
+  m <- fetchRowMap stmt
-  return m
+  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 -> Text -> SqlRow -> Net.Query -> Text
-updateClause schema table row =
+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
+  "with upsert as (" <> updateClause schema table row qq
-  <> whereClause qq
   <> " returning *) " <> insertClauseViaSelect schema table row
   <> " where not exists (select * from upsert) returning *"
 

test/Feature/InsertSpec.hs

@@ -13,8 +13,9 @@ 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, incStr, incNullableStr)
+import TestTypes(IncPK(..), CompoundPK(..))
 
 -- }}}
 
@@ -106,17 +107,39 @@ spec = around appWithFixture $ do
               [json| { "k1":12, "k2":42 } |]
                 `shouldRespondWith` 400
 
-        context "specifying every column in the table" $
+        context "specifying every column in the table" $ do
-          it "succeeds with 201 and link" $ 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 +149,44 @@ spec = around appWithFixture $ do
                } |]
             `shouldRespondWith` ResponseMatcher {
               matchBody    = Nothing,
-              matchStatus  = 200,
+              matchStatus  = 204,
               matchHeaders = []
             }
+
+  describe "Patching record" $ do
+
+    context "to unkonwn uri" $
+      it "gives a 404" $
+        request methodPatch "/fake" []
+          [json| { "real": false } |]
+            `shouldRespondWith` 404
+
+    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"

test/TestTypes.hs

@@ -1,6 +1,8 @@
 module TestTypes (
-  IncPK(..),
+  IncPK(..)
-  fromList
+, 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
+incFromList :: [(String, SqlValue)] -> IncPK
-fromList row = 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)

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

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 [