Add Content-Location header to GET responses

Fixes #26

src/Dbapi.hs

@@ -6,6 +6,8 @@ module Dbapi where
 import Types (SqlRow)
 
 import Control.Exception (try)
+import Control.Monad (join)
+import Control.Arrow ((***))
 import Control.Applicative
 import Options.Applicative hiding (columns)
 
@@ -13,13 +15,17 @@ import Data.Maybe (fromMaybe)
 import Text.Read (readMaybe)
 import Text.Regex.TDFA ((=~))
 import Data.Map (intersection, fromList, toList)
+import Data.List (sort)
 import Data.Convertible.Base (convert)
 
-import Network.HTTP.Base (urlEncodeVars)
 import Network.HTTP.Types.Status
 import Network.HTTP.Types.Header
+import Network.HTTP.Types.URI
+
+import Network.HTTP.Base (urlEncodeVars)
 
 import Network.Wai
+import Network.Wai.Internal
 
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Char8 as BS
@@ -69,8 +75,16 @@ app conn req respond = do
       ([table], "GET") ->
         if range == Just emptyRange
         then return $ responseLBS status416 [] "HTTP Range error"
-        else respondWithRangedResult <$>
-          getRows (show ver) (unpack table) qq range conn
+        else do
+          r <- respondWithRangedResult <$> getRows (show ver) (unpack table) qq range conn
+          let canonical = urlEncodeVars $ sort $
+                          map (join (***) BS.unpack) $
+                          parseSimpleQuery $
+                          rawQueryString req
+          return $ addHeaders [
+            ("Content-Location",
+             "/" <> encodeUtf8 table <> "?" <> BS.pack canonical
+            )] r
       ([table], "POST") ->
         jsonBodyAction req (\row -> do
           allvals <- insert ver table row conn
@@ -132,3 +146,13 @@ requestedVersion hdrs =
 sqlErrorHandler :: SqlError -> Response
 sqlErrorHandler e =
   responseLBS status400 [] $ BL.fromChunks [BS.pack (seErrorMsg e)]
+
+addHeaders :: ResponseHeaders -> Response -> Response
+addHeaders hdrs (ResponseFile    s headers fp m) =
+                 ResponseFile    s (headers ++ hdrs) fp m
+addHeaders hdrs (ResponseBuilder s headers b)    =
+                 ResponseBuilder s (headers ++ hdrs) b
+addHeaders hdrs (ResponseStream  s headers b)    =
+                 ResponseStream  s (headers ++ hdrs) b
+addHeaders hdrs (ResponseRaw     s resp)         =
+                 ResponseRaw     s (addHeaders hdrs resp)

test/Feature/QuerySpec.hs

@@ -0,0 +1,30 @@
+
+{-# LANGUAGE OverloadedStrings #-}
+module Feature.QuerySpec where
+
+import Test.Hspec
+import Test.Hspec.Wai
+
+import SpecHelper
+
+spec :: Spec
+spec = around appWithFixture $ do
+  describe "Filtering response" $
+    context "column equality" $
+
+      it "matches the predicate" $
+        get "/items?id=eq.5"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just "[{\"id\":5}]"
+          , matchStatus  = 200
+          , matchHeaders = [("Content-Range", "0-0/1")]
+          }
+
+  describe "Canonical location" $
+    it "Sets Content-Location with alphabetized params" $
+      get "/no_pk?b=eq.1&a=eq.1"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Nothing
+        , matchStatus  = 204
+        , matchHeaders = [("Content-Location", "/no_pk?a=eq.1&b=eq.1")]
+        }