Adds 415 response for any non-empty Accept header different from application/json or text/csv. Uses apropriate Content-Type header when sending CSV format.

2015-08-20 20:47:36 -07:00
parent cb7d00b839
commit 3b017dfdf6
6 changed files with 81 additions and 43 deletions
@@ -1,19 +1,19 @@
 {-# LANGUAGE FlexibleContexts #-}
-module PostgREST.App (app, sqlError, isSqlError) where
+module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept) where

 import Control.Monad (join)
 import Control.Arrow ((***), second)
 import Control.Applicative

-import Data.Text hiding (map)
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Text hiding (map, find)
+import Data.Maybe (fromMaybe, mapMaybe, isJust, isNothing)
 import Text.Regex.TDFA ((=~))
 import Data.Ord (comparing)
 import Data.Ranged.Ranges (emptyRange)
 import qualified Data.HashMap.Strict as M
 import Data.String.Conversions (cs)
 import Data.CaseInsensitive (original)
-import Data.List (sortBy)
+import Data.List (sortBy, find)
 import Data.Functor.Identity
 import qualified Data.Set as S
 import qualified Data.ByteString.Lazy as BL
@@ -26,6 +26,7 @@ import Network.HTTP.Types.Header
 import Network.HTTP.Types.URI (parseSimpleQuery)
 import Network.HTTP.Base (urlEncodeVars)
 import Network.Wai
+import Network.Wai.Parse (parseHttpAccept)
 import Network.Wai.Internal (Response(..))

 import Data.Aeson
@@ -67,7 +68,7 @@ app conf reqBody req =
                  parentheticT (
                    whereT qt qq $ countRows qt
                  ) <> commaq <> (
-                  bodyForAccept accept qt
+                  bodyForAccept contentType qt
                  . limitT range
                  . orderT (orderParse qq)
                  . whereT qt qq
@@ -85,7 +86,7 @@ app conf reqBody req =
                          . parseSimpleQuery
                          $ rawQueryString req
        return $ responseLBS status
-          [if accept == Just "text/csv" then csvH else jsonH, contentRange,
+          [contentTypeH, contentRange,
            ("Content-Location",
             "/" <> cs table <>
                if Prelude.null canonical then "" else "?" <> cs canonical
@@ -131,7 +132,7 @@ app conf reqBody req =
      let qt = qualify table
          echoRequested = lookupHeader "Prefer" == Just "return=representation"
          parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
-          parsed = if lookupHeader "Content-Type" == Just "text/csv"
+          parsed = if lookupHeader "Content-Type" == Just csvMT
                    then do
                      rows <- CSV.decode CSV.NoHeader reqBody
                      if V.null rows then Left "CSV requires header"
@@ -227,13 +228,15 @@ app conf reqBody req =
    qq            = queryString req
    qualify       = QualifiedTable schema
    hdrs          = requestHeaders req
-    schema        = requestedSchema (cs $ configV1Schema conf) hdrs
+    lookupHeader  = flip lookup hdrs
+    accept        = lookupHeader hAccept
+    schema        = requestedSchema (cs $ configV1Schema conf) accept
    authenticator = cs $ configDbUser conf
    jwtSecret     = cs $ configJwtSecret conf
    range         = rangeRequested hdrs
    allOrigins    = ("Access-Control-Allow-Origin", "*") :: Header
-    lookupHeader  = flip lookup hdrs
-    accept        = lookupHeader hAccept
+    contentType   = fromMaybe "application/json" $ contentTypeForAccept accept
+    contentTypeH  = (hContentType, contentType)

 sqlError :: t
 sqlError = undefined
@@ -247,12 +250,6 @@ rangeStatus from to total
  | (1 + to - from) < total = status206
  | otherwise               = status200

-bodyForAccept :: Maybe BS.ByteString -> QualifiedTable -> StatementT
-bodyForAccept accept table =
-    case accept of
-      Just "text/csv" -> asCsvWithCount table
-      _ -> asJsonWithCount -- defaults to JSON
-
 contentRangeH :: Int -> Int -> Int -> Header
 contentRangeH from to total =
  ("Content-Range",
@@ -263,21 +260,41 @@ contentRangeH from to total =
       <> cs (show total)
  )

-requestedSchema :: Text -> RequestHeaders -> Text
-requestedSchema v1schema hdrs =
+requestedSchema :: Text -> Maybe BS.ByteString -> Text
+requestedSchema v1schema accept =
  case verStr of
       Just [[_, ver]] -> if ver == "1" then v1schema else cs ver
       _ -> v1schema

  where verRegex = "version[ ]*=[ ]*([0-9]+)" :: BS.ByteString
-        accept = cs <$> lookup hAccept hdrs :: Maybe BS.ByteString
        verStr = (=~ verRegex) <$> accept :: Maybe [[BS.ByteString]]

-jsonH :: Header
-jsonH = (hContentType, "application/json")

-csvH :: Header
-csvH = (hContentType, "text/csv")
+jsonMT :: BS.ByteString
+jsonMT = "application/json"
+
+csvMT :: BS.ByteString
+csvMT = "text/csv"
+
+jsonH :: Header
+jsonH = (hContentType, jsonMT)
+
+contentTypeForAccept :: Maybe BS.ByteString -> Maybe BS.ByteString
+contentTypeForAccept accept 
+  | isNothing accept || hasJson = Just jsonMT
+  | hasCsv = Just csvMT
+  | otherwise = Nothing
+  where
+    Just acceptH = accept
+    findInAccept = flip find $ parseHttpAccept acceptH
+    hasJson  = isJust $ findInAccept $ BS.isPrefixOf jsonMT
+    hasCsv   = isJust $ findInAccept $ BS.isPrefixOf csvMT
+
+bodyForAccept :: BS.ByteString -> QualifiedTable -> StatementT
+bodyForAccept contentType table
+  | contentType == csvMT = asCsvWithCount table
+  | otherwise = asJsonWithCount -- defaults to JSON
+

 handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
              -> H.Tx P.Postgres s Response
@@ -11,10 +11,7 @@ import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Data.String.Conversions (cs)
 import Network.Wai (strictRequestBody)
-import Network.Wai.Middleware.Cors (cors)
 import Network.Wai.Handler.Warp hiding (Connection)
-import Network.Wai.Middleware.Gzip (gzip, def)
-import Network.Wai.Middleware.Static (staticPolicy, only)
 import Network.Wai.Middleware.RequestLogger (logStdout)
 import Data.List (intercalate)
 import Data.Version (versionBranch)
@@ -26,7 +23,7 @@ import Options.Applicative hiding (columns)

 import System.IO (stderr, stdin, stdout, hSetBuffering, BufferMode(..))

-import PostgREST.Config (AppConfig(..), argParser, corsPolicy)
+import PostgREST.Config (AppConfig(..), argParser)

 isServerVersionSupported = do
  Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|]
@@ -64,10 +61,7 @@ main = do
      appSettings = setPort port
                  . setServerName (cs $ "postgrest/" <> prettyVersion)
                  $ defaultSettings
-      middle = logStdout
-        . (if configSecure conf then redirectInsecure else id)
-        . gzip def . cors corsPolicy
-        . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
+      middle = logStdout . defaultMiddle (configSecure conf)

  poolSettings <- maybe (fail "Improper session settings") return $
                H.poolSettings (fromIntegral $ configPool conf) 30
@@ -3,7 +3,7 @@

 module PostgREST.Middleware where

-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isNothing)
 import Data.Monoid
 import Data.Text
 -- import Data.Pool(withResource, Pool)
@@ -12,15 +12,19 @@ import qualified Hasql as H
 import qualified Hasql.Postgres as P
 import Data.String.Conversions(cs)

-import Network.HTTP.Types.Header (hLocation, hAuthorization)
+import Network.HTTP.Types.Header (hLocation, hAuthorization, hAccept)
 import Network.HTTP.Types (RequestHeaders)
-import Network.HTTP.Types.Status (status400, status401, status301)
+import Network.HTTP.Types.Status (status400, status401, status301, status415)
 import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
                   rawQueryString, isSecure, Request(..), Response)
+import Network.Wai.Middleware.Gzip (gzip, def)
+import Network.Wai.Middleware.Cors (cors)
+import Network.Wai.Middleware.Static (staticPolicy, only)
 import Network.URI (URI(..), parseURI)

-import PostgREST.Config (AppConfig(..))
+import PostgREST.Config (AppConfig(..), corsPolicy)
 import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, resetRole, setUserId, resetUserId)
+import PostgREST.App (contentTypeForAccept)
 import Codec.Binary.Base64.String (decode)

 import Prelude
@@ -84,3 +88,17 @@ redirectInsecure app req respond = do
              Nothing ->
                respond $ responseLBS status400 [] "SSL is required"
    else app req respond
+
+unsupportedAccept :: Application -> Application
+unsupportedAccept app req respond = do
+  let
+    accept = lookup hAccept $ requestHeaders req
+  if isNothing $ contentTypeForAccept accept 
+  then respond $ responseLBS status415 [] "Unsupported Accept header, try: application/json"
+  else app req respond
+
+defaultMiddle :: Bool -> Application -> Application
+defaultMiddle secure = (if secure then redirectInsecure else id)
+        . gzip def . cors corsPolicy
+        . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
+        . unsupportedAccept