Stricter pattern matching & case branches rearangement + remove a few small functions

src/PostgREST/App.hs

@@ -4,20 +4,17 @@
 --module PostgREST.App where
 module PostgREST.App (
   app
-, contentTypeForAccept
 ) where
 
 import           Control.Applicative
 import           Control.Arrow             ((***))
 import           Control.Monad             (join)
 import           Data.Bifunctor            (first)
-import qualified Data.ByteString.Char8     as BS
 import qualified Data.ByteString.Lazy      as BL
---import qualified Data.Csv                  as CSV
 import           Data.Functor.Identity
 import qualified Data.HashMap.Strict       as HM
 import           Data.List                 (find, sortBy, delete, transpose)
-import           Data.Maybe                (fromMaybe, fromJust, isJust, isNothing, mapMaybe)
+import           Data.Maybe                (fromMaybe, fromJust, isNothing, mapMaybe)
 import           Data.Ord                  (comparing)
 import           Data.Ranged.Ranges        (emptyRange, singletonRange)
 import           Data.String.Conversions   (cs)
@@ -34,7 +31,6 @@ import           Network.HTTP.Types.Header
 import           Network.HTTP.Types.Status
 import           Network.HTTP.Types.URI    (parseSimpleQuery)
 import           Network.Wai
-import           Network.Wai.Parse         (parseHttpAccept)
 
 import           Data.Aeson
 import           Data.Aeson.Types (emptyArray)
@@ -77,7 +73,7 @@ import           Prelude
 app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response
 app dbStructure conf reqBody req =
   let
-      -- TODO: blow up for Left values
+      -- TODO: blow up for Left values (there is a middleware that checks the headers)
       contentType = either (const ApplicationJSON) id (iAccepts intent)
       contentTypeS ct = case ct of
         ApplicationJSON -> "application/json"
@@ -85,47 +81,8 @@ app dbStructure conf reqBody req =
       contentTypeH = (hContentType, contentTypeS contentType) in
 
   case (iAction intent, iTarget intent, iPayload intent) of
-    (ActionUnknown _, _, _) -> return notFound
-    (_, TargetUnknown _, _) -> return notFound
-    (_, _, Just (PayloadParseError e)) ->
-      return $ responseLBS status400 [jsonH] $
-        cs (formatGeneralError "Cannot parse request payload" (cs e))
 
-    (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), _) -> do
+    (ActionRead, TargetIdent qi, Nothing) ->
-      let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
-          pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
-          body = encode (TableOptions cols pkeys)
-          filterCol :: Schema -> TableName -> Column -> Bool
-          filterCol sc tb (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && t==tb
-          filterCol _ _ _ =  False
-      return $ responseLBS status200 [jsonH, allOrigins] $ cs body
-
-    (ActionRead, TargetRoot, _) -> do
-      body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure))
-      return $ responseLBS status200 [jsonH] $ cs body
-
-    (ActionInvoke, TargetIdent qi, Just (PayloadJSON payload)) -> do
-      exists <- doesProcExist qi
-      if exists
-        then do
-          let p = case pp of
-                    JSON.Object o -> o
-                    _ -> undefined
-                  where pp = V.head payload
-              call = B.Stmt "select " V.empty True <>
-                asJson (callProc qi p)
-              jwtSecret = configJwtSecret conf
-
-          bodyJson :: Maybe (Identity Value) <- H.maybeEx call
-          returnJWT <- doesProcReturnJWT qi
-          return $ responseLBS status200 [jsonH]
-                 (let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in
-                    if returnJWT
-                    then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
-                    else cs $ encode body)
-        else return notFound
-
-    (ActionRead, TargetIdent qi, _) ->
       case selectQuery of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right q -> do
@@ -159,7 +116,8 @@ app dbStructure conf reqBody req =
                       if Prelude.null canonical then "" else "?" <> cs canonical
                   )
                 ] (fromMaybe "[]" body)
-    (ActionCreate, TargetIdent (QualifiedIdentifier _ table), _) ->
+
+    (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just (PayloadJSON _)) ->
       case queries of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (sq,mq,isSingle) -> do
@@ -173,7 +131,8 @@ app dbStructure conf reqBody req =
               (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
             ]
             $ if iPreferRepresentation intent then fromMaybe "[]" body else ""
-    (ActionUpdate, TargetIdent _, _) ->
+
+    (ActionUpdate, TargetIdent _, Just (PayloadJSON _)) ->
       case queries of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (sq,mq,_) -> do
@@ -186,7 +145,8 @@ app dbStructure conf reqBody req =
                                | otherwise -> status204
           return $ responseLBS s [contentTypeH, r]
             $ if iPreferRepresentation intent then fromMaybe "[]" body else ""
-    (ActionDelete, TargetIdent _, _) ->
+
+    (ActionDelete, TargetIdent _, Nothing) ->
       case queries of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (sq,mq,_) -> do
@@ -197,6 +157,48 @@ app dbStructure conf reqBody req =
             then notFound
             else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
 
+    (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> do
+      let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
+          pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
+          body = encode (TableOptions cols pkeys)
+          filterCol :: Schema -> TableName -> Column -> Bool
+          filterCol sc tb (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && t==tb
+          filterCol _ _ _ =  False
+      return $ responseLBS status200 [jsonH, allOrigins] $ cs body
+
+    (ActionInvoke, TargetIdent qi, Just (PayloadJSON payload)) -> do
+      exists <- doesProcExist qi
+      if exists
+        then do
+          let p = case pp of
+                    JSON.Object o -> o
+                    _ -> undefined
+                  where pp = V.head payload
+              call = B.Stmt "select " V.empty True <>
+                asJson (callProc qi p)
+              jwtSecret = configJwtSecret conf
+
+          bodyJson :: Maybe (Identity Value) <- H.maybeEx call
+          returnJWT <- doesProcReturnJWT qi
+          return $ responseLBS status200 [jsonH]
+                 (let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in
+                    if returnJWT
+                    then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
+                    else cs $ encode body)
+        else return notFound
+
+    (ActionRead, TargetRoot, Nothing) -> do
+      body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure))
+      return $ responseLBS status200 [jsonH] $ cs body
+
+    (ActionUnknown _, _, _) -> return notFound
+
+    (_, TargetUnknown _, _) -> return notFound
+
+    (_, _, Just (PayloadParseError e)) ->
+      return $ responseLBS status400 [jsonH] $
+        cs (formatGeneralError "Cannot parse request payload" (cs e))
+
     (_, _, _) -> return notFound
 
  where
@@ -233,27 +235,8 @@ contentRangeH frm to total =
       totalNotZero  = fromMaybe True ((/=) 0 <$> total)
       fromInRange   = frm <= to
 
-jsonMT :: BS.ByteString
-jsonMT = "application/json"
-
-csvMT :: BS.ByteString
-csvMT = "text/csv"
-
-allMT :: BS.ByteString
-allMT = "*/*"
-
 jsonH :: Header
-jsonH = (hContentType, jsonMT)
+jsonH = (hContentType, "application/json")
-
-contentTypeForAccept :: Maybe BS.ByteString -> Maybe BS.ByteString
-contentTypeForAccept accept
-  | isNothing accept || has allMT || has jsonMT = Just jsonMT
-  | has csvMT = Just csvMT
-  | otherwise = Nothing
-  where
-    Just acceptH = accept
-    findInAccept = flip find $ parseHttpAccept acceptH
-    has          = isJust . findInAccept . BS.isPrefixOf
 
 formatRelationError :: Text -> Text
 formatRelationError = formatGeneralError

src/PostgREST/Middleware.hs

@@ -3,7 +3,7 @@
 
 module PostgREST.Middleware where
 
-import           Data.Maybe                    (fromMaybe, isNothing)
+import           Data.Maybe                    (fromMaybe)
 import           Data.Text
 import           Data.String.Conversions       (cs)
 import           Data.Time.Clock.POSIX         (getPOSIXTime)
@@ -18,7 +18,7 @@ import           Network.Wai.Middleware.Cors   (cors)
 import           Network.Wai.Middleware.Gzip   (def, gzip)
 import           Network.Wai.Middleware.Static (only, staticPolicy)
 
-import           PostgREST.App                 (contentTypeForAccept)
+import           PostgREST.RequestIntent       (pickContentType)
 import           PostgREST.Auth                (setRole, jwtClaims, claimsToSQL)
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
 import           PostgREST.Error               (errResponse)
@@ -58,12 +58,11 @@ runWithClaims conf app req = do
     invalidJWT = return $ errResponse status400 "Invalid JWT"
 
 unsupportedAccept :: Application -> Application
-unsupportedAccept app req respond = do
+unsupportedAccept app req respond =
-  let
+  case accept of
-    accept = lookup hAccept $ requestHeaders req
+    Left _ -> respond $ errResponse status415 "Unsupported Accept header, try: application/json"
-  if isNothing $ contentTypeForAccept accept
+    Right _ -> app req respond
-  then respond $ errResponse status415 "Unsupported Accept header, try: application/json"
+  where accept = pickContentType $ lookup hAccept $ requestHeaders req
-  else app req respond
 
 defaultMiddle :: Application -> Application
 defaultMiddle =