From ca4138df2aee0549c67dbbd59a7015917fca46de Mon Sep 17 00:00:00 2001
From: Joe Nelson <cred+github@begriffs.com>
Date: Sat, 22 Nov 2014 17:50:49 -0800
Subject: [PATCH] Send back Location header on insert

---
 src/App.hs     | 14 ++++++++++----
 src/PgQuery.hs |  7 ++++++-
 2 files changed, 16 insertions(+), 5 deletions(-)

diff --git a/src/App.hs b/src/App.hs
index 8e2130132..6d29b5513 100644
--- a/src/App.hs
+++ b/src/App.hs
@@ -15,6 +15,7 @@ import Data.Ranged.Ranges (emptyRange)
 import Data.HashMap.Strict (keys, elems, filterWithKey, toList)
 import Data.String.Conversions (cs)
 import Data.List (sortBy)
+import Data.Functor.Identity
 import qualified Data.Set as S
 
 import Network.HTTP.Types.Status
@@ -104,12 +105,17 @@ app req =
     ([table], "POST") ->
       handleJsonObj req $ \obj -> H.tx Nothing $ do
         let qt = QualifiedTable schema (cs table)
-        H.unit . coerce $ insertInto qt (map cs $ keys obj) (elems obj)
+            query = coerce $
+              insertInto qt (map cs $ keys obj) (elems obj)
+        row <- H.single query
+        let (Identity insertedJson) = fromMaybe (Identity "{}" :: Identity Text) row
+            Just inserted = decode (cs insertedJson) :: Maybe Object
+
         primaryKeys <- map cs <$> primaryKeyColumns qt
-        let primaries = filterWithKey (const . (`elem` primaryKeys)) obj
+        let primaries = filterWithKey (const . (`elem` primaryKeys)) inserted
         let params = urlEncodeVars
               $ map (\t -> (cs $ fst t, "eq." <> cs (encode $ snd t)))
-              $ toList primaries
+              $ sortBy (comparing fst) $ toList primaries
         return $ responseLBS status201
           [ jsonH
           , (hLocation, "/" <> cs table <> "?" <> cs params)
@@ -165,7 +171,7 @@ isSqlError (HB.ErroneousResult x) = Just $ HB.ErroneousResult x
 isSqlError _ = Nothing
 
 sqlErrHandler :: HB.Error -> IO Response
-sqlErrHandler (HB.ErroneousResult err) = do
+sqlErrHandler (HB.ErroneousResult err) =
   return $ if "42P01" `isInfixOf` err
     then responseLBS status404 [] ""
     else responseLBS status400 [] (cs err)
diff --git a/src/PgQuery.hs b/src/PgQuery.hs
index 24c04da31..0651029ac 100644
--- a/src/PgQuery.hs
+++ b/src/PgQuery.hs
@@ -83,6 +83,11 @@ asJsonWithCount (sql, params, pre) = (
   , params, pre
   )
 
+asJsonRow :: StatementT
+asJsonRow (sql, params, pre) = (
+    "row_to_json(t) from (" <> sql <> ") t", params, pre
+  )
+
 selectStar :: QualifiedTable -> DynamicSQL
 selectStar t =
   ("select * from " <> fromQt t, [], mempty)
@@ -95,7 +100,7 @@ insertInto t cols vals =
     cs (intercalate ", " (map pgFmtIdent cols)) <>
     ") values (" <>
     cs (intercalate ", " (map (const "?") vals)) <>
-    ")"
+    ") returning row_to_json(" <> fromQt t <> ".*)"
   , map pgParam vals
   , mempty
   )