reporting errors, but not passing tests.

postgrest.cabal

@@ -36,7 +36,7 @@ executable postgrest
                      , regex-base, regex-tdfa
                      , regex-tdfa-text
                      , Ranged-sets
-                     , transformers
+                     , transformers, MissingH
                      , bcrypt, base64-string
                      , network-uri >= 2.6
                      , resource-pool
@@ -80,10 +80,8 @@ Test-Suite spec
                      , http-media, regex-tdfa
                      , regex-tdfa-text
                      , Ranged-sets
-                     , transformers
-                     , bcrypt
-                     , base64-string
-                     , split
+                     , transformers, MissingH, split
+                     , bcrypt, base64-string
                      , network-uri >= 2.6
                      , resource-pool
                      , blaze-builder

src/Error.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+module Error (PgError, errResponse) where
+
+import qualified Hasql as H
+import qualified Hasql.Postgres as H
+import qualified Network.HTTP.Types.Status as HT
+import qualified Data.Aeson as JSON
+import qualified Data.Text as T
+import Data.Aeson ((.=))
+import Data.String.Conversions (cs)
+import Data.String.Utils(replace)
+import Network.Wai(Response, responseLBS)
+
+type PgError = H.SessionError H.Postgres
+
+errResponse :: PgError -> Response
+errResponse e = responseLBS (httpStatus e) [] (JSON.encode e)
+
+instance JSON.ToJSON PgError where
+  toJSON (H.TxError (H.ErroneousResult c m d h)) = JSON.object [
+    "code" .= (cs c::T.Text),
+    "message" .= (cs m::T.Text),
+    "details" .= (fmap cs d::Maybe T.Text),
+    "hint" .= (fmap cs h::Maybe T.Text)]
+  toJSON (H.TxError (H.NoResult d)) = JSON.object [
+    "message" .= ("No response from server"::T.Text),
+    "details" .= (fmap cs d::Maybe T.Text)]
+  toJSON (H.TxError (H.UnexpectedResult m)) = JSON.object ["message" .= m]
+  toJSON (H.TxError H.NotInTransaction) = JSON.object [
+    "message" .= ("Not in transaction"::T.Text)]
+  toJSON (H.CxError (H.CantConnect d)) = JSON.object [
+    "message" .= ("Can't connect to the database"::T.Text),
+    "details" .= (fmap cs d::Maybe T.Text)]
+  toJSON (H.CxError (H.UnsupportedVersion v)) = JSON.object [
+    "message" .= ("Postgres version "++version++" is not supported") ]
+      where version = replace "0" "." (show v)
+  toJSON (H.ResultError m) = JSON.object ["message" .= m]
+
+httpStatus :: PgError -> HT.Status
+httpStatus (H.TxError (H.ErroneousResult codeBS _ _ _)) =
+  let code = cs codeBS in
+  case code of
+    '0':'8':_ -> HT.status503 -- pg connection err
+    '0':'9':_ -> HT.status500 -- triggered action exception
+    '0':'L':_ -> HT.status403 -- invalid grantor
+    '0':'P':_ -> HT.status403 -- invalid role specification
+    '2':'5':_ -> HT.status500 -- invalid tx state
+    '2':'8':_ -> HT.status403 -- invalid auth specification
+    '2':'D':_ -> HT.status500 -- invalid tx termination
+    '3':'8':_ -> HT.status500 -- external routine exception
+    '3':'9':_ -> HT.status500 -- external routine invocation
+    '3':'B':_ -> HT.status500 -- savepoint exception
+    '4':'0':_ -> HT.status500 -- tx rollback
+    '5':'3':_ -> HT.status503 -- insufficient resources
+    '5':'4':_ -> HT.status413 -- too complex
+    '5':'5':_ -> HT.status500 -- obj not on prereq state
+    '5':'7':_ -> HT.status500 -- operator intervention
+    '5':'8':_ -> HT.status500 -- system error
+    'F':'0':_ -> HT.status500 -- conf file error
+    'H':'V':_ -> HT.status500 -- foreign data wrapper error
+    'P':'0':_ -> HT.status500 -- PL/pgSQL Error
+    'X':'X':_ -> HT.status500 -- internal Error
+    "42P01" -> HT.status404 -- undefined table
+    "42501" -> HT.status404 -- insufficient privilege
+    _ -> HT.status400
+httpStatus (H.TxError (H.NoResult _)) = HT.status503
+httpStatus _ = HT.status500

src/Main.hs

@@ -54,10 +54,9 @@ main = do
 
   runSettings appSettings $ middle $ \req respond -> do
     body <- strictRequestBody req
-    thing <- liftIO $ H.session pool $ H.tx Nothing $ authenticated currRole anonRole (app body) req
-    case thing of
-      Right r -> respond r
-      Left _ -> undefined
+    resOrError <- liftIO $ H.session pool $ H.tx Nothing $
+      authenticated currRole anonRole (app body) req
+    either (undefined) respond resOrError
 
   where
     describe = progDesc "create a REST API to an existing Postgres database"

test/SpecHelper.hs

@@ -31,6 +31,7 @@ import System.Process (readProcess)
 import App (app, sqlError, isSqlError)
 import Config (AppConfig(..), corsPolicy)
 import Middleware
+import Error(errResponse)
 -- import Auth (addUser)
 
 isLeft :: Either a b -> Bool
@@ -54,13 +55,9 @@ withApp perform = do
 
   perform $ middle $ \req resp -> do
     body <- strictRequestBody req
-    result <- liftIO
-      $ H.session pool
-      $ H.tx Nothing
+    result <- liftIO $ H.session pool $ H.tx Nothing
       $ authenticated currRole anonRole (app body) req
-    resp $ case result of
-      Right r -> r
-      Left _ -> error "hahahaha"
+    either (resp . errResponse) resp result
 
   where middle = cors corsPolicy