Error refactors

src/PostgREST/App.hs

@@ -46,6 +46,11 @@ import qualified Hasql.Postgres            as P
 import           PostgREST.Config          (AppConfig (..))
 import           PostgREST.Parsers
 import           PostgREST.DbStructure
+import           PostgREST.RangeQuery
+import           PostgREST.Types
+import           PostgREST.Auth            (tokenJWT)
+import           PostgREST.Error           (errResponse)
+
 import           PostgREST.QueryBuilder ( asJson
                                         , callProc
                                         , asCsvF
@@ -62,9 +67,6 @@ import           PostgREST.QueryBuilder ( asJson
                                         , countNoneF
                                         , addRelations
                                         )
-import           PostgREST.RangeQuery
-import           PostgREST.Types
-import           PostgREST.Auth (tokenJWT)
 
 import           Prelude
 
@@ -86,7 +88,7 @@ app dbStructure conf reqBody req =
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (selectQuery, Nothing) -> -- should we do sanity check to make sure its a GET request?
           if range == Just emptyRange
-          then return $ responseLBS status416 [] "HTTP Range error"
+          then return $ errResponse status416 "HTTP Range error"
           else do
             let q = createReadStatement selectQuery range (not $ hasPrefer "count=none") isCsv
             row <- H.maybeEx q
@@ -135,9 +137,9 @@ app dbStructure conf reqBody req =
               row <- H.maybeEx q
               let (_, queryTotal, _, _) = extractQueryResult row
               return $ if queryTotal == 0
-                then responseLBS status404 [] ""
+                then notFound
                 else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
-            _         -> return $ responseLBS status404 [] ""
+            _         -> return notFound
 
     (["rpc", proc], "POST") -> do
       let qi = QualifiedIdentifier schema (cs proc)
@@ -153,7 +155,7 @@ app dbStructure conf reqBody req =
                     if returnJWT
                     then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
                     else cs $ encode body)
-        else return $ responseLBS status404 [] ""
+        else return notFound
 
       -- check that proc exists
       -- check that arg names are all specified
@@ -164,9 +166,10 @@ app dbStructure conf reqBody req =
       return $ responseLBS status200 [jsonH] $ cs body
 
     (_, _) ->
-      return $ responseLBS status404 [] ""
+      return notFound
 
   where
+    notFound = responseLBS status404 [] ""
     allPrKeys = dbPrimaryKeys dbStructure
     filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
     path          = pathInfo req

src/PostgREST/Error.hs

@@ -2,13 +2,14 @@
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 
-module PostgREST.Error (PgError, errResponse) where
+module PostgREST.Error (PgError, pgErrResponse, errResponse) where
 
 
 import           Data.Aeson                ((.=))
 import qualified Data.Aeson                as JSON
 import           Data.String.Conversions   (cs)
 import           Data.String.Utils         (replace)
+import           Data.Text                 (Text)
 import qualified Data.Text                 as T
 import qualified Hasql                     as H
 import qualified Hasql.Postgres            as P
@@ -18,8 +19,11 @@ import           Network.Wai               (Response, responseLBS)
 
 type PgError = H.SessionError P.Postgres
 
-errResponse :: PgError -> Response
-errResponse e = responseLBS (httpStatus e)
+errResponse :: HT.Status -> Text -> Response
+errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"])
+
+pgErrResponse :: PgError -> Response
+pgErrResponse e = responseLBS (httpStatus e)
   [(hContentType, "application/json")] (JSON.encode e)
 
 instance JSON.ToJSON PgError where

src/PostgREST/Main.hs

@@ -6,7 +6,7 @@ import           PostgREST.Config                     (AppConfig (..),
                                                        minimumPgVersion,
                                                        prettyVersion,
                                                        readOptions)
-import           PostgREST.Error                      (errResponse, PgError)
+import           PostgREST.Error                      (pgErrResponse, PgError)
 import           PostgREST.Middleware
 import           PostgREST.DbStructure
 
@@ -75,4 +75,4 @@ main = do
     body <- strictRequestBody req
     resOrError <- liftIO $ H.session pool $ H.tx txSettings $
       runWithClaims conf (app dbStructure conf body) req
-    either (respond . errResponse) respond resOrError
+    either (respond . pgErrResponse) respond resOrError

src/PostgREST/Middleware.hs

@@ -13,7 +13,7 @@ import qualified Hasql.Postgres                as P
 import           Network.HTTP.Types.Header     (hAccept, hAuthorization)
 import           Network.HTTP.Types.Status     (status415, status400)
 import           Network.Wai                   (Application, Request (..), Response,
-                                                requestHeaders, responseLBS)
+                                                requestHeaders)
 import           Network.Wai.Middleware.Cors   (cors)
 import           Network.Wai.Middleware.Gzip   (def, gzip)
 import           Network.Wai.Middleware.Static (only, staticPolicy)
@@ -21,6 +21,7 @@ import           Network.Wai.Middleware.Static (only, staticPolicy)
 import           PostgREST.App                 (contentTypeForAccept)
 import           PostgREST.Auth                (setRole, jwtClaims, claimsToSQL)
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
+import           PostgREST.Error               (errResponse)
 
 import           System.IO.Unsafe              (unsafePerformIO)
 
@@ -54,14 +55,14 @@ runWithClaims conf app req = do
     auth = fromMaybe "" $ lookup hAuthorization hdrs
     anon = cs $ configAnonRole conf
     setAnon = setRole anon
-    invalidJWT = return $ responseLBS status400 [("Content-Type","application/json")] "{\"message\":\"Invalid JWT\"}"
+    invalidJWT = return $ errResponse status400 "Invalid JWT"
 
 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"
+  then respond $ errResponse status415 "Unsupported Accept header, try: application/json"
   else app req respond
 
 defaultMiddle :: Application -> Application

test/SpecHelper.hs

@@ -29,7 +29,7 @@ import qualified Data.Aeson.Types as J
 import PostgREST.App (app)
 import PostgREST.Config (AppConfig(..))
 import PostgREST.Middleware
-import PostgREST.Error(errResponse)
+import PostgREST.Error(pgErrResponse)
 import PostgREST.DbStructure
 
 dbString :: String
@@ -61,7 +61,7 @@ withApp perform = do
     body <- strictRequestBody req
     result <- liftIO $ H.session pool $ H.tx txSettings
       $ runWithClaims cfg (app db cfg body) req
-    either (resp . errResponse) resp result
+    either (resp . pgErrResponse) resp result
 
   where middle = defaultMiddle