WIP: do crazy postgres upsert

src/Dbapi.hs

@@ -112,7 +112,7 @@ app conn req respond = do
                    "You must speficy all and only primary keys as params"
               else do
                 _ <- upsert ver table row qq conn
-                return $ responseLBS status201 [] "hi"
+                return $ responseLBS status201 [] ""
           -- 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

src/PgQuery.hs

@@ -11,6 +11,8 @@ import Data.List (intersperse, intercalate)
 import Data.Monoid ((<>), mconcat)
 import qualified Data.Map as M
 
+import Control.Monad (join)
+
 import qualified RangeQuery as R
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy as BL
@@ -22,6 +24,8 @@ import qualified Network.HTTP.Types.URI as Net
 
 import Types (SqlRow, getRow, sqlRowColumns, sqlRowValues)
 
+import Debug.Trace
+
 -- }}}
 
 data RangedResult = RangedResult {
@@ -114,10 +118,10 @@ insert schema table row conn = do
 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
+  stmt   <- prepare conn (traceShow sql sql)
-  _      <- execute stmt $ sqlRowValues row
+  _      <- execute stmt $ join $ replicate 2 $ sqlRowValues row
   Just m <- fetchRowMap stmt
-  return m
+  return (traceShow m m)
 
 placeholders :: String -> SqlRow -> String
 placeholders symbol = intercalate ", " . map (const symbol) . getRow
@@ -128,18 +132,33 @@ insertClause schema table row =
      map toSql $ (pack . show $ schema) : table : sqlRowColumns row)
   <> (" values (" ++ placeholders "?" row ++ ") returning *", sqlRowValues row)
 
+
+insertClauseViaSelect :: Int -> Text -> SqlRow -> QuotedSql
+insertClauseViaSelect schema table row =
+    ("insert into %I.%I (" ++ placeholders "%I" row ++ ")",
+     map toSql $ (pack . show $ schema) : table : sqlRowColumns row)
+  <> (" select " ++ placeholders "?" row, 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)
+  <> (" = (" ++ placeholders "?" row ++ ")", [])
+
+--sqlRowValues row
 
 upsertClause :: Int -> Text -> SqlRow -> Net.Query -> QuotedSql
 upsertClause schema table row qq =
-  ("with upsert as ", []) <> updateClause schema table row
+  ("with upsert as (", []) <> updateClause schema table row
   <> whereClause qq
-  <> (" returning *) ", []) <> insertClause schema table row
+  <> (" returning *) ", []) <> insertClauseViaSelect schema table row
-  <> (" where not exists (select * from upsert)", [])
+  <> (" where not exists (select * from upsert) returning *", [])
+
+-- with upsert as
+-- (update "1".compound_pk set (k1, k2, extra) = (?, ?, ?)
+--   where k1 ='12' and k2 ='42' returning *)
+-- insert into "1".compound_pk (k1, k2, extra) values (?, ?, ?) returning *
+-- where not exists (select * from upsert)
 
 -- WITH upsert AS ($update RETURNING *) $insert WHERE NOT EXISTS (SELECT * FROM upsert);
 

test/Feature/InsertSpec.hs

@@ -102,7 +102,7 @@ spec = around appWithFixture $ 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` created201
               simpleHeaders p `shouldSatisfy` matchHeader
                 hLocation "/compound_pk\\?k1=eq\\.12&k2=eq\\.42"
-              simpleBody p `shouldBe` ""