Include location header in post response

src/Dbapi.hs

@@ -12,7 +12,10 @@ import Options.Applicative hiding (columns)
 import Data.Maybe (fromMaybe)
 import Text.Read (readMaybe)
 import Text.Regex.TDFA ((=~))
+import Data.Map (intersection, fromList, toList)
+import Data.Convertible.Base (convert)
 
+import Network.HTTP.Base (urlEncodeVars)
 import Network.HTTP.Types.Status
 import Network.HTTP.Types.Header
 
@@ -23,10 +26,12 @@ import qualified Data.ByteString.Char8 as BS
 
 import Database.HDBC.PostgreSQL (Connection)
 import Database.HDBC.Types (SqlError, seErrorMsg)
-import PgStructure (printTables, printColumns)
+import Database.HDBC.SqlValue (SqlValue(..))
+import PgStructure (printTables, printColumns, primaryKeyColumns)
 
 import qualified Data.Aeson as JSON
 import Data.Text (pack, unpack)
+import Data.Text.Encoding (encodeUtf8)
 
 import PgQuery
 import RangeQuery
@@ -50,26 +55,33 @@ jsonBodyAction req handler = do
     Right body -> handler body
 
 jsonBody :: Request -> IO (Either String SqlRow)
-jsonBody = (fmap JSON.eitherDecode) . strictRequestBody
+jsonBody = fmap JSON.eitherDecode . strictRequestBody
 
 app :: Connection -> Application
 app conn req respond = do
   r <- try $
     case (path, verb) of
       ([], _) ->
-        responseLBS status200 [jsonContentType] <$> (printTables ver conn)
+        responseLBS status200 [jsonContentType] <$> printTables ver conn
       ([table], "OPTIONS") ->
-        responseLBS status200 [jsonContentType] <$> (
-          printColumns ver (unpack table) conn)
+        responseLBS status200 [jsonContentType] <$>
+          printColumns ver (unpack table) conn
       ([table], "GET") ->
         if range == Just emptyRange
         then return $ responseLBS status416 [] "HTTP Range error"
         else respondWithRangedResult <$>
-          (getRows (show ver) (unpack table) qq range conn)
+          getRows (show ver) (unpack table) qq range conn
       ([table], "POST") ->
-        jsonBodyAction req (\row ->
-          responseLBS status201 [jsonContentType] <$> (
-            insert ver table row conn))
+        jsonBodyAction req (\row -> do
+          allvals <- insert ver table row conn
+          keys <- primaryKeyColumns ver (unpack table) conn
+          let keyvals = allvals `intersection` fromList (zip keys $ repeat SqlNull)
+          let params = urlEncodeVars $ map (\t -> (fst t, "eq." <> convert (snd t) :: String)) $ toList keyvals
+          return $ responseLBS status201
+            [ jsonContentType
+            , (hLocation, "/" <> encodeUtf8 table <> "?" <> BS.pack params)
+            ] ""
+        )
       (_, _) ->
         return $ responseLBS status404 [] ""
 

src/PgQuery.hs

@@ -9,8 +9,7 @@ import Data.Functor ( (<$>) )
 import Data.Maybe (fromMaybe)
 import Data.List (intersperse, intercalate)
 import Data.Monoid ((<>), mconcat)
-import Data.HashMap.Strict (fromList)
-import qualified Data.Aeson as JSON
+import qualified Data.Map as M
 
 import qualified RangeQuery as R
 import qualified Data.ByteString.Char8 as BS
@@ -66,8 +65,8 @@ wherePred (column, predicate) =
   ("%I " <> op <> "%L", map toSql [column, value])
 
   where
-    opCode:rest = BS.split ':' $ fromMaybe ":" predicate
-    value = BS.intercalate ":" rest
+    opCode:rest = BS.split '.' $ fromMaybe "." predicate
+    value = BS.intercalate "." rest
     op = case opCode of
               "eq"  -> "="
               "gt"  -> ">"
@@ -104,15 +103,14 @@ jsonArrayRows :: QuotedSql -> QuotedSql
 jsonArrayRows q =
   ("array_to_json(array_agg(row_to_json(t))) from (", []) <> q <> (") t", [])
 
-insert :: Int -> Text -> SqlRow -> Connection -> IO BL.ByteString
+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
-  keys <- getColumnNames stmt
-  Just vals <- fetchRow stmt
-  let rowMap = fromList $ zip keys vals
-  return $ JSON.encode rowMap
+  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
+  Just m <- fetchRowMap stmt
+  return m
   where
     (cols, values) = unzip . getRow $ row
     colIds = intercalate ", " $ map (const "%I") cols

src/PgStructure.hs

@@ -69,7 +69,7 @@ data TableOptions = TableOptions {
 instance JSON.ToJSON TableOptions where
   toJSON t = JSON.object [
       "columns" .= tblOptcolumns t
-    , "pkey"   .= tblOptpkey t ]
+    , "pkey"    .= tblOptpkey t ]
 
 tables :: String -> Connection -> IO [Table]
 tables s conn = do