diff --git a/src/Dbapi.hs b/src/Dbapi.hs index 59d818c10..0aa594958 100644 --- a/src/Dbapi.hs +++ b/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) diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs new file mode 100644 index 000000000..765ee9728 --- /dev/null +++ b/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")] + }