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

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,7 +180,7 @@ 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
@@ -193,9 +188,9 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
           | 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]