Refactor error type and fix nested error message [fix #791] (#829)

PostgREST · Mar 13, 2017 · 206ab16 · 206ab16
1 parent 2aabbba
commit 206ab16
Show file tree

Hide file tree

Showing 11 changed files with 157 additions and 129 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -10,6 +10,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ### Fixed
 
+- #791, malformed nested JSON error - @diogob
 - Resource embedding in views referencing tables in public schema - @fab1an
 
 ## [0.4.0.0] - 2017-01-19

diff --git a/main/Main.hs b/main/Main.hs
@@ -9,7 +9,7 @@ import           PostgREST.Config                     (AppConfig (..),
                                                        minimumPgVersion,
                                                        prettyVersion,
                                                        readOptions)
-import           PostgREST.Error                      (prettyUsageError)
+import           PostgREST.Error                      (encodeError)
 import           PostgREST.OpenAPI                    (isMalformedProxyUri)
 import           PostgREST.DbStructure
 
@@ -74,7 +74,7 @@ main = do
     getDbStructure (toS $ configSchema conf)
 
   forM_ (lefts [result]) $ \e -> do
-    hPutStrLn stderr (prettyUsageError e)
+    hPutStrLn stderr (toS $ encodeError e)
     exitFailure
 
   refDbStructure <- newIORef $ either (panic . show) id result
@@ -124,4 +124,3 @@ loadSecretFile conf = extractAndTransform mSecret
     setSecret bs = conf { configJwtSecret = Just bs }
 
     replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="
-
diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs
@@ -3,15 +3,12 @@ Module      : PostgREST.ApiRequest
 Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
 -}
 module PostgREST.ApiRequest ( ApiRequest(..)
-                            , ApiRequestError(..)
                             , ContentType(..)
                             , Action(..)
                             , Target(..)
                             , PreferRepresentation (..)
                             , mutuallyAgreeable
-                            , toHeader
                             , userApiRequest
-                            , toMime
                             ) where
 
 import           Protolude
@@ -29,15 +26,18 @@ import           Control.Arrow             ((***))
 import qualified Data.Text                 as T
 import qualified Data.Vector               as V
 import           Network.HTTP.Base         (urlEncodeVars)
-import           Network.HTTP.Types.Header (hAuthorization, hContentType, Header)
+import           Network.HTTP.Types.Header (hAuthorization)
 import           Network.HTTP.Types.URI    (parseSimpleQuery)
 import           Network.Wai               (Request (..))
 import           Network.Wai.Parse         (parseHttpAccept)
 import           PostgREST.RangeQuery      (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)
 import           Data.Ranged.Boundaries
-import           PostgREST.Types           (QualifiedIdentifier (..),
-                                            Schema,
-                                            PayloadJSON(..))
+import           PostgREST.Types           ( QualifiedIdentifier (..)
+                                           , Schema
+                                           , PayloadJSON(..)
+                                           , ContentType(..)
+                                           , ApiRequestError(..)
+                                           , toMime)
 import           Data.Ranged.Ranges        (Range(..), rangeIntersection, emptyRange)
 
 type RequestBody = BL.ByteString
@@ -57,30 +57,6 @@ data Target = TargetIdent QualifiedIdentifier
 -- | How to return the inserted data
 data PreferRepresentation = Full | HeadersOnly | None deriving Eq
                           --
--- | Enumeration of currently supported response content types
-data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
-                 | CTSingularJSON | CTOctetStream
-                 | CTAny | CTOther BS.ByteString deriving Eq
-
-data ApiRequestError = ErrorActionInappropriate
-                     | ErrorInvalidBody ByteString
-                     | ErrorInvalidRange
-                     deriving (Show, Eq)
-
--- | Convert from ContentType to a full HTTP Header
-toHeader :: ContentType -> Header
-toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
-
--- | Convert from ContentType to a ByteString representing the mime type
-toMime :: ContentType -> ByteString
-toMime CTApplicationJSON = "application/json"
-toMime CTTextCSV         = "text/csv"
-toMime CTOpenAPI         = "application/openapi+json"
-toMime CTSingularJSON    = "application/vnd.pgrst.object+json"
-toMime CTOctetStream     = "application/octet-stream"
-toMime CTAny             = "*/*"
-toMime (CTOther ct)      = ct
-
 {-|
   Describes what the user wants to do. This data type is a
   translation of the raw elements of an HTTP request into domain
@@ -120,9 +96,9 @@ data ApiRequest = ApiRequest {
 -- | Examines HTTP request and translates it into user intent.
 userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest
 userApiRequest schema req reqBody
-  | isTargetingProc && method /= "POST" = Left ErrorActionInappropriate
-  | topLevelRange == emptyRange = Left ErrorInvalidRange
-  | shouldParsePayload && isLeft payload = either (Left . ErrorInvalidBody . toS) undefined payload
+  | isTargetingProc && method /= "POST" = Left ActionInappropriate
+  | topLevelRange == emptyRange = Left InvalidRange
+  | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) undefined payload
   | otherwise = Right ApiRequest {
       iAction = action
       , iTarget = target

diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs
@@ -33,9 +33,7 @@ import           PostgREST.ApiRequest   ( ApiRequest(..), ContentType(..)
                                         , Action(..), Target(..)
                                         , PreferRepresentation (..)
                                         , mutuallyAgreeable
-                                        , toHeader
                                         , userApiRequest
-                                        , toMime
                                         )
 import           PostgREST.Auth            (jwtClaims, containsRole)
 import           PostgREST.Config          (AppConfig (..))
@@ -44,8 +42,8 @@ import           PostgREST.DbRequestBuilder( readRequest
                                            , mutateRequest
                                            , fieldNames
                                            )
-import           PostgREST.Error           ( errResponse, pgErrResponse
-                                           , apiRequestErrResponse
+import           PostgREST.Error           ( simpleError, pgError
+                                           , apiRequestError
                                            , singularityError, binaryFieldError
                                            )
 import           PostgREST.RangeQuery      (allRange, rangeOffset)
@@ -75,15 +73,15 @@ postgrest conf refDbStructure pool getTime =
     dbStructure <- readIORef refDbStructure
 
     response <- case userApiRequest (configSchema conf) req body of
-      Left err -> return $ apiRequestErrResponse err
+      Left err -> return $ apiRequestError err
       Right apiRequest -> do
         let jwtSecret = binarySecret <$> configJwtSecret conf
             eClaims = jwtClaims jwtSecret (iJWT apiRequest) time
             authed = containsRole eClaims
             handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
             txMode = transactionMode $ iAction apiRequest
         response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
-        return $ either (pgErrResponse authed) identity response
+        return $ either (pgError authed) identity response
     respond response
 
 transactionMode :: Action -> H.Mode
@@ -104,7 +102,7 @@ app dbStructure conf apiRequest =
           case partsField of
             Left errorResponse -> return errorResponse
             Right ((q, cq), bField) -> do
-              let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount 
+              let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount
                                             (contentType == CTTextCSV) bField
               row <- H.query () stm
               let (tableTotal, queryTotal, _ , body) = row
@@ -293,12 +291,12 @@ responseContentTypeOrError accepts action = serves contentTypesForRequest accept
       case mutuallyAgreeable sProduces cAccepts of
         Nothing -> do
           let failed = intercalate ", " $ map (toS . toMime) cAccepts
-          Left $ errResponse status415 $
+          Left $ simpleError status415 $
             "None of these Content-Types are available: " <> failed
         Just ct -> Right ct
 
 binaryField :: ContentType -> [FieldName] -> Either Response (Maybe FieldName)
-binaryField CTOctetStream fldNames = 
+binaryField CTOctetStream fldNames =
   if length fldNames == 1 && fieldName /= Just "*"
     then Right fieldName
     else Left binaryFieldError

diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/DbRequestBuilder.hs
@@ -15,20 +15,17 @@ import           Data.Text                 (isInfixOf, dropWhile, drop)
 import           Data.Tree
 import           Data.Either.Combinators   (mapLeft)
 
-import           Text.Parsec.Error
-
-import           Network.HTTP.Types.Status
 import           Network.Wai
 
 import           Data.Foldable (foldr1)
 import qualified Data.HashMap.Strict       as M
 
-import           PostgREST.ApiRequest   ( ApiRequest(..) 
+import           PostgREST.ApiRequest   ( ApiRequest(..)
                                         , PreferRepresentation(..)
                                         , Action(..), Target(..)
                                         , PreferRepresentation (..)
                                         )
-import           PostgREST.Error           (errResponse, formatParserError)
+import           PostgREST.Error           (apiRequestError)
 import           PostgREST.Parsers
 import           PostgREST.RangeQuery      (NonnegRange, restrictRange)
 import           PostgREST.QueryBuilder (getJoinConditions, sourceCTEName)
@@ -40,10 +37,10 @@ import           Unsafe                  (unsafeHead)
 
 readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest
 readRequest maxRows allRels allProcs apiRequest  =
-  mapLeft (errResponse status400) $
+  mapLeft apiRequestError $
   treeRestrictRange maxRows =<<
   augumentRequestWithJoin schema relations =<<
-  first formatParserError parseReadRequest
+  parseReadRequest
   where
     (schema, rootTableName) = fromJust $ -- Make it safe
       let target = iTarget apiRequest in
@@ -62,7 +59,7 @@ readRequest maxRows allRels allProcs apiRequest  =
     action :: Action
     action = iAction apiRequest
 
-    parseReadRequest :: Either ParseError ReadRequest
+    parseReadRequest :: Either ApiRequestError ReadRequest
     parseReadRequest = addFiltersOrdersRanges apiRequest <*>
       pRequestSelect rootName selStr
       where
@@ -80,20 +77,18 @@ readRequest maxRows allRels allProcs apiRequest  =
       _       -> allRels
       where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
 
-treeRestrictRange :: Maybe Integer -> ReadRequest -> Either Text ReadRequest
+treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest
 treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request
   where
     nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
     nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)
 
-augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either Text ReadRequest
+augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either ApiRequestError ReadRequest
 augumentRequestWithJoin schema allRels request =
-  (first formatRelationError . addRelations schema allRels Nothing) request
+  addRelations schema allRels Nothing request
   >>= addJoinConditions schema
-  where
-    formatRelationError = ("could not find foreign keys between these entities, " <>)
 
-addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest
+addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest
 addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias)) forest) =
   case parentNode of
     (Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) ->
@@ -102,8 +97,8 @@ addRelations schema allRelations parentNode (Node readNode@(query, (name, _, ali
         forest' = updateForest $ hush node'
         node' = Node <$> readNode' <*> pure forest
         readNode' = addRel readNode <$> rel
-        rel :: Either Text Relation
-        rel = note ("no relation between " <> parentNodeTable <> " and " <> name)
+        rel :: Either ApiRequestError Relation
+        rel = note (NoRelationBetween parentNodeTable name)
             $ findRelation schema name parentNodeTable
 
             where
@@ -155,10 +150,10 @@ addRelations schema allRelations parentNode (Node readNode@(query, (name, _, ali
         t = Table schema name True -- !!! TODO find another way to get the table from the query
         r = Relation t [] t [] Root Nothing Nothing Nothing
   where
-    updateForest :: Maybe ReadRequest -> Either Text [ReadRequest]
+    updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
     updateForest n = mapM (addRelations schema allRelations n) forest
 
-addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest
+addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest
 addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =
   case r of
     Just Relation{relType=Root} -> Node nn  <$> updatedForest -- this is the root node
@@ -169,12 +164,12 @@ addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =
       where
          query' = addCond query (getJoinConditions rel)
          qq = query'{from=tableName linkTable : from query'}
-    _ -> Left "unknown relation"
+    _ -> Left UnknownRelation
   where
     updatedForest = mapM (addJoinConditions schema) forest
     addCond query' con = query'{flt_=con ++ flt_ query'}
 
-addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest)
+addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest)
 addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
     flip (foldr addFilter) <$> filters,
     flip (foldr addOrder) <$> orders,
@@ -185,17 +180,17 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
   of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context
   -}
   where
-    filters :: Either ParseError [(Path, Filter)]
+    filters :: Either ApiRequestError [(Path, Filter)]
     filters = mapM pRequestFilter flts
       where
         action = iAction apiRequest
         flts
           | action == ActionRead = iFilters apiRequest
           | action == ActionInvoke = iFilters apiRequest
           | otherwise = filter (( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update
-    orders :: Either ParseError [(Path, [OrderTerm])]
+    orders :: Either ApiRequestError [(Path, [OrderTerm])]
     orders = mapM pRequestOrder $ iOrder apiRequest
-    ranges :: Either ParseError [(Path, NonnegRange)]
+    ranges :: Either ApiRequestError [(Path, NonnegRange)]
     ranges = mapM pRequestRange $ M.toList $ iRange apiRequest
 
 addFilterToNode :: Filter -> ReadRequest -> ReadRequest
@@ -250,12 +245,12 @@ toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
   | otherwise = Nothing
 
 mutateRequest :: ApiRequest -> [FieldName] -> Either Response MutateRequest
-mutateRequest apiRequest fldNames = mapLeft (errResponse status400) $
+mutateRequest apiRequest fldNames = mapLeft apiRequestError $
   case action of
     ActionCreate -> Right $ Insert rootTableName payload returnings
     ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> pure returnings
     ActionDelete -> Delete rootTableName <$> filters <*> pure returnings
-    _        -> Left "Unsupported HTTP verb"
+    _        -> Left UnsupportedVerb
   where
     action = iAction apiRequest
     payload = fromJust $ iPayload apiRequest
@@ -265,7 +260,7 @@ mutateRequest apiRequest fldNames = mapLeft (errResponse status400) $
         (TargetIdent (QualifiedIdentifier _ t) ) -> t
         _ -> undefined
     returnings = if iPreferRepresentation apiRequest == None then [] else fldNames
-    filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
+    filters = map snd <$> mapM pRequestFilter mutateFilters
       where mutateFilters = filter (not . ( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
 
 fieldNames :: ReadRequest -> [FieldName]