Include location header in post response

dbapi.cabal

@@ -14,9 +14,11 @@ library
                      , HDBC, HDBC-postgresql
                      , warp, wai >= 3.0.1 && < 3.0.2
                      , http-types, scientific, time
+                     , HTTP, convertible
                      , bytestring, aeson, network
                      , text, optparse-applicative
                      , unordered-containers
+                     , containers
                      , regex-base
                      , http-media, regex-tdfa
                      , Ranged-sets
@@ -34,9 +36,11 @@ executable dbapi
   build-depends:       base >=4.6 && <5
                      , HDBC, HDBC-postgresql
                      , warp, wai >= 3.0.1 && < 3.0.2
+                     , HTTP, convertible
                      , http-types, scientific, time
                      , bytestring, aeson, network
                      , text, optparse-applicative
+                     , containers
                      , unordered-containers
                      , regex-base
                      , http-media, regex-tdfa
@@ -57,7 +61,8 @@ Test-Suite spec
                      , hspec-wai
                      , HDBC, HDBC-postgresql
                      , warp, wai >= 3.0.1 && < 3.0.2
-                     , wai-extra
+                     , HTTP, convertible
+                     , wai-extra, containers
                      , http-types, scientific, time
                      , bytestring, aeson, network
                      , text, optparse-applicative

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

test/Feature/RangeSpec.hs

@@ -8,11 +8,9 @@ import Test.Hspec.Wai.JSON
 import SpecHelper
 
 import Network.HTTP.Types
-import Network.Wai.Test (SResponse(..))
 
 import qualified Data.Aeson as JSON
 import Data.Aeson ((.:))
-import Data.Maybe (fromJust)
 import Control.Applicative ((<$>), (<*>))
 import Control.Monad (mzero)
 
@@ -102,12 +100,11 @@ spec = around appWithFixture $ do
           { "non_nullable_string":"not null"} |]
           `shouldRespondWith` 201
 
-      it "responds with the created row" $ do
-        r <- post "/auto_incrementing_pk" [json|
+      it "links to the created resource" $ do
+        post "/auto_incrementing_pk" [json|
           { "non_nullable_string":"not null"} |]
-        let row = fromJust (JSON.decode $ simpleBody r :: Maybe IncPK)
-        liftIO $ do
-          incStr row `shouldBe` "not null"
-          incNullableStr row `shouldBe` Nothing
-        -- Add assertions to check timestamp and id
-        -- OR: change behavior to return no body at all
+          `shouldRespondWith` ResponseMatcher {
+            matchBody = Nothing,
+            matchStatus = 201,
+            matchHeaders = [("Location", "/auto_incrementing_pk?id=eq.2")]
+          }