WIP: put requests

src/Dbapi.hs

@@ -16,6 +16,7 @@ import Text.Read (readMaybe)
 import Text.Regex.TDFA ((=~))
 import Data.Map (intersection, fromList, toList)
 import Data.List (sort)
+import qualified Data.Set as S
 import Data.Convertible.Base (convert)
 
 import Network.HTTP.Types.Status
@@ -69,9 +70,11 @@ app conn req respond = do
     case (path, verb) of
       ([], _) ->
         responseLBS status200 [jsonContentType] <$> printTables ver conn
+
       ([table], "OPTIONS") ->
         responseLBS status200 [jsonContentType] <$>
           printColumns ver (unpack table) conn
+
       ([table], "GET") ->
         if range == Just emptyRange
         then return $ responseLBS status416 [] "HTTP Range error"
@@ -85,6 +88,7 @@ app conn req respond = do
             ("Content-Location",
              "/" <> encodeUtf8 table <> "?" <> BS.pack canonical
             )] r
+
       ([table], "POST") ->
         jsonBodyAction req (\row -> do
           allvals <- insert ver table row conn
@@ -98,6 +102,25 @@ app conn req respond = do
             , (hLocation, "/" <> encodeUtf8 table <> "?" <> BS.pack params)
             ] ""
         )
+
+      ([table], "PUT") ->
+        jsonBodyAction req (\row -> do
+          keys <- primaryKeyColumns ver (unpack table) conn
+          let specifiedKeys = map (BS.unpack . fst) qq
+          if S.fromList keys /= S.fromList specifiedKeys
+              then return $ responseLBS status405 []
+                   "You must speficy all and only primary keys as params"
+              else do
+                _ <- upsert ver table row qq conn
+                return $ responseLBS status201 [] "hi"
+          -- allvals <- insert ver table row conn
+          -- let keyvals = allvals `intersection` fromList (zip keys $ repeat SqlNull)
+          -- let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList keyvals
+            -- [ jsonContentType
+            -- , (hLocation, "/" <> encodeUtf8 table <> "?" <> BS.pack params)
+            -- ] ""
+        )
+
       (_, _) ->
         return $ responseLBS status404 [] ""
 

src/PgQuery.hs

@@ -20,7 +20,7 @@ import Database.HDBC.PostgreSQL
 
 import qualified Network.HTTP.Types.URI as Net
 
-import Types (SqlRow, getRow)
+import Types (SqlRow, getRow, sqlRowColumns, sqlRowValues)
 
 -- }}}
 
@@ -105,16 +105,58 @@ jsonArrayRows q =
 
 insert :: Int -> Text -> SqlRow -> Connection -> IO (M.Map String SqlValue)
 insert schema table row conn = do
-  query  <- populateSql conn  ("insert into %I.%I ("++colIds++")",
+  sql    <- populateSql conn $ insertClause schema table row
-                        map toSql $ (pack . show $ schema):table:cols)
+  stmt   <- prepare conn sql
-  stmt   <- prepare conn (query ++ " values ("++phs++") returning *")
+  _      <- execute stmt $ sqlRowValues row
-  _      <- execute stmt values
   Just m <- fetchRowMap stmt
   return m
-  where
+
-    (cols, values) = unzip . getRow $ row
+upsert :: Int -> Text -> SqlRow -> Net.Query -> Connection -> IO (M.Map String SqlValue)
-    colIds = intercalate ", " $ map (const "%I") cols
+upsert schema table row qq conn = do
-    phs = intercalate ", " $ map (const "?") values
+  sql    <- populateSql conn $ upsertClause schema table row qq
+  stmt   <- prepare conn sql
+  _      <- execute stmt $ sqlRowValues row
+  Just m <- fetchRowMap stmt
+  return m
+
+placeholders :: String -> SqlRow -> String
+placeholders symbol = intercalate ", " . map (const symbol) . getRow
+
+insertClause :: Int -> Text -> SqlRow -> QuotedSql
+insertClause schema table row =
+    ("insert into %I.%I (" ++ placeholders "%I" row ++ ")",
+     map toSql $ (pack . show $ schema) : table : sqlRowColumns row)
+  <> (" values (" ++ placeholders "?" row ++ ") returning *", sqlRowValues row)
+
+updateClause :: Int -> Text -> SqlRow -> QuotedSql
+updateClause schema table row =
+    ("update %I.%I set (" ++ placeholders "%I" row ++ ")",
+     map toSql $ (pack . show $ schema) : table : sqlRowColumns row)
+  <> (" = (" ++ placeholders "?" row ++ ")", sqlRowValues row)
+
+upsertClause :: Int -> Text -> SqlRow -> Net.Query -> QuotedSql
+upsertClause schema table row qq =
+  ("with upsert as ", []) <> updateClause schema table row
+  <> whereClause qq
+  <> (" returning *) ", []) <> insertClause schema table row
+  <> (" where not exists (select * from upsert)", [])
+
+-- WITH upsert AS ($update RETURNING *) $insert WHERE NOT EXISTS (SELECT * FROM upsert);
+
+-- $insert = "INSERT INTO spider_count (spider, tally) SELECT 'Googlebot', 1";
+-- $update = "UPDATE spider_count SET tally=tally+1 WHERE date='today' AND spider='Googlebot'";
+
+-- UPDATE weather SET (temp_lo, temp_hi, prcp) = (temp_lo+1, temp_lo+15, DEFAULT)
+--   WHERE city = 'San Francisco' AND date = '2003-07-03';
+
+-- upsert :: Int -> Text -> SqlRow -> Connection -> IO (M.Map String SqlValue)
+-- upsert schema table row conn = do
+--   query  <- populateSql conn  ("update %I.%I ("++colIds++")",
+--                         map toSql $ (pack . show $ schema):table:cols)
+--   where
+--     (cols, values) = unzip . getRow $ row
+--     colIds = intercalate ", " $ map (const "%I") cols
+--     phs = intercalate ", " $ map (const "?") values
 
 populateSql :: Connection -> QuotedSql -> IO String
 populateSql conn sql = do
@@ -122,7 +164,7 @@ populateSql conn sql = do
   return $ fromSql escaped
 
   where
-    q = concat [ "select format('", fst sql, "', ", placeholders (snd sql), ")" ]
+    q = concat [ "select format('", fst sql, "', ", ph (snd sql), ")" ]
 
-    placeholders :: [a] -> String
+    ph :: [a] -> String
-    placeholders = intercalate ", " . map (const "?::varchar")
+    ph = intercalate ", " . map (const "?::varchar")

src/Types.hs

@@ -1,6 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module Types(SqlRow(SqlRow), getRow) where
+module Types where
 
 import Database.HDBC (toSql, iToSql, SqlValue(..))
 
@@ -44,6 +44,12 @@ instance JSON.ToJSON SqlValue where
 
 newtype SqlRow = SqlRow {getRow :: [(Text, SqlValue)] } deriving (Show)
 
+sqlRowColumns :: SqlRow -> [Text]
+sqlRowColumns = map fst . getRow
+
+sqlRowValues :: SqlRow -> [SqlValue]
+sqlRowValues = map snd . getRow
+
 instance JSON.FromJSON SqlRow where
   parseJSON (JSON.Object m) = foldlWithKey' add (return $ SqlRow []) m
     where

test/Feature/InsertSpec.hs

@@ -20,7 +20,7 @@ import TestTypes(IncPK, incStr, incNullableStr)
 -- }}}
 
 spec :: Spec
-spec = around appWithFixture $
+spec = around appWithFixture $ do
   describe "Posting new record" $ do
     it "accepts disparate json types" $
       post "/menagerie"
@@ -66,3 +66,43 @@ spec = around appWithFixture $
             matchStatus  = 201,
             matchHeaders = [("Location", "/compound_pk?k1=eq.12&k2=eq.42")]
           }
+
+  describe "Putting record" $ do
+
+    context "to unkonwn uri" $
+      it "gives a 404" $
+        request methodPut "/fake" []
+          [json| { "real": false } |]
+            `shouldRespondWith` 404
+
+    context "to a known uri" $ do
+      context "without a fully-specified primary key" $
+        it "is not an allowed operation" $
+          request methodPut "/compound_pk?k1=eq.12" []
+            [json| { "k1":12, "k2":42 } |]
+              `shouldRespondWith` 405
+
+      context "with a fully-specified primary key" $ do
+
+        context "with Content-Range header" $
+          it "fails as per RFC7231" $
+            request methodPut "/compound_pk?k1=eq.1&k2=eq.2"
+              [("Content-Range", "0-0")]
+              [json| { "k1":1, "k2":2, "extra":3 } |]
+                `shouldRespondWith` 400
+
+        context "not specifying every column in the table" $
+          it "is rejected for lack of idempotence" $
+            request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
+              [json| { "k1":12, "k2":42 } |]
+                `shouldRespondWith` 400
+
+        context "specifying every column in the table" $
+          it "succeeds with 201 and link" $ do
+            p <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
+                 [json| { "k1":12, "k2":42, "extra":3 } |]
+            liftIO $ do
+              simpleStatus p `shouldBe` created201
+              simpleHeaders p `shouldSatisfy` matchHeader
+                hLocation "/compound_pk\\?k1=eq\\.12&k2=eq\\.42"
+              simpleBody p `shouldBe` ""