From 22114532e6ec75989ccf5560038c07bd4d87affa Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 7 Sep 2014 22:03:45 -0700 Subject: [PATCH] WIP: put requests --- src/Dbapi.hs | 23 +++++++++++++ src/PgQuery.hs | 66 +++++++++++++++++++++++++++++++------- src/Types.hs | 8 ++++- test/Feature/InsertSpec.hs | 42 +++++++++++++++++++++++- 4 files changed, 125 insertions(+), 14 deletions(-) diff --git a/src/Dbapi.hs b/src/Dbapi.hs index 0aa594958..babaa3206 100644 --- a/src/Dbapi.hs +++ b/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 [] "" diff --git a/src/PgQuery.hs b/src/PgQuery.hs index daa6a34f0..e8a38c379 100644 --- a/src/PgQuery.hs +++ b/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++")", - map toSql $ (pack . show $ schema):table:cols) - stmt <- prepare conn (query ++ " values ("++phs++") returning *") - _ <- execute stmt values + sql <- populateSql conn $ insertClause schema table row + stmt <- prepare conn sql + _ <- execute stmt $ sqlRowValues row Just m <- fetchRowMap stmt return m - where - (cols, values) = unzip . getRow $ row - colIds = intercalate ", " $ map (const "%I") cols - phs = intercalate ", " $ map (const "?") values + +upsert :: Int -> Text -> SqlRow -> Net.Query -> Connection -> IO (M.Map String SqlValue) +upsert schema table row qq conn = do + 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 - placeholders = intercalate ", " . map (const "?::varchar") + ph :: [a] -> String + ph = intercalate ", " . map (const "?::varchar") diff --git a/src/Types.hs b/src/Types.hs index 86f9173ea..9140a8d2d 100644 --- a/src/Types.hs +++ b/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 diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index fd4835c8c..403ae2950 100644 --- a/test/Feature/InsertSpec.hs +++ b/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` ""