error formatting for parsers and relation

src/PostgREST/App.hs

@@ -10,7 +10,6 @@ module PostgREST.App (
 , TableOptions(..)
 ) where
 
-
 import qualified Blaze.ByteString.Builder  as BB
 import           Control.Applicative
 import           Control.Arrow             (second, (***))
@@ -29,9 +28,11 @@ import           Data.Ord                  (comparing)
 import           Data.Ranged.Ranges        (emptyRange)
 import qualified Data.Set                  as S
 import           Data.String.Conversions   (cs)
-import           Data.Text                 (Text)
+import           Data.Text                 (Text, replace, strip)
 import           Text.Regex.TDFA           ((=~))
 
+import           Text.Parsec.Error
+
 import           Network.HTTP.Base         (urlEncodeVars)
 import           Network.HTTP.Types.Header
 import           Network.HTTP.Types.Status
@@ -77,7 +78,7 @@ app dbstructure conf reqBody dbrole req =
       then return $ responseLBS status416 [] "HTTP Range error"
       else
         case queries of
-          Left e -> return $ responseLBS status400 [("Content-Type", "text/plain")] $ cs e
+          Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
           Right (qs, cqs) -> do
             let qt = qualify table
                 count = if hasPrefer "count=none"
@@ -111,9 +112,22 @@ app dbstructure conf reqBody dbrole req =
         where
             from = fromMaybe 0 $ rangeOffset <$> range
             apiRequest = first formatParserError (parseGetRequest req)
-                     >>= addRelations schema allRels Nothing
+                     >>= first formatRelationError . addRelations schema allRels Nothing
                      >>= addJoinConditions schema allCols
-                     where formatParserError = cs.show
+                     where
+                       formatRelationError :: Text -> Text
+                       formatRelationError e = cs $ encode $ object [
+                         "mesage" .= ("could not find foreign keys between these entities"::String),
+                         "details" .= e]
+                       formatParserError :: ParseError -> Text
+                       formatParserError e = cs $ encode $ object [
+                         "message" .= message,
+                         "details" .= details]
+                         where
+                           message = show (errorPos e)
+                           details = strip $ replace "\n" " " $ cs
+                             $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
+
             query = requestToQuery schema <$> apiRequest
             countQuery = requestToCountQuery schema <$> apiRequest
             queries = (,) <$> query <*> countQuery

src/PostgREST/Parsers.hs

@@ -22,13 +22,13 @@ parseGetRequest :: Request -> Either ParseError ApiRequest
 parseGetRequest httpRequest =
   foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
   where
-    apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr
+    apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
     addOrder (Node r f) o = Node r{order=o} f
     flts = mapM pRequestFilter whereFilters
     rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
     qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
     orderStr = join $ lookup "order" qString
-    ord = traverse (parse pOrder ("failed to parse order ("++fromMaybe "" orderStr++")")) orderStr
+    ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr
     selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to *
     whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ]