diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits. -version: 0.2.5.1 +version: 0.2.5.2 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE @@ -46,10 +46,12 @@ Other-Modules: App , Auth , Config - , PgStructure + , Error + , Middleware , PgQuery + , PgStructure , RangeQuery - , Middleware + , Types hs-source-dirs: src Test-Suite spec @@ -60,7 +62,17 @@ Hs-Source-Dirs: test, src ghc-options: -Wall -W -Werror Main-Is: Main.hs - Other-Modules: App, Auth, Config, Spec, SpecHelper + Other-Modules: App + , Auth + , Config + , Error + , Middleware + , PgQuery + , PgStructure + , RangeQuery + , Types + , Spec + , SpecHelper Build-Depends: base, hspec >= 2.1.2, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json , hasql == 0.7.*, hasql-backend diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 --- /dev/null +++ b/src/Error.hs @@ -0,0 +1,71 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} + +module Error (PgError, errResponse) where + +import qualified Hasql as H +import qualified Hasql.Postgres as P +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) +import Network.HTTP.Types.Header + +type PgError = H.SessionError P.Postgres + +errResponse :: PgError -> Response +errResponse e = responseLBS (httpStatus e) + [(hContentType, "application/json")] (JSON.encode e) + +instance JSON.ToJSON PgError where + toJSON (H.TxError (P.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 (P.NoResult d)) = JSON.object [ + "message" .= ("No response from server"::T.Text), + "details" .= (fmap cs d::Maybe T.Text)] + toJSON (H.TxError (P.UnexpectedResult m)) = JSON.object ["message" .= m] + toJSON (H.TxError P.NotInTransaction) = JSON.object [ + "message" .= ("Not in transaction"::T.Text)] + toJSON (H.CxError (P.CantConnect d)) = JSON.object [ + "message" .= ("Can't connect to the database"::T.Text), + "details" .= (fmap cs d::Maybe T.Text)] + toJSON (H.CxError (P.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 (P.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 (P.NoResult _)) = HT.status503 +httpStatus _ = HT.status500 diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,57 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Types where + +import qualified Data.Aeson as JSON +import Data.Aeson.Types (Parser) + +import Data.Scientific (floatingOrInteger) +import Data.HashMap.Strict (foldlWithKey') +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Calendar (showGregorian) +import Control.Monad (mzero) + +instance JSON.FromJSON SqlValue where + parseJSON (JSON.Number n) = return $ either toSql iToSql (floatingOrInteger n :: Either Double Int) + parseJSON (JSON.String s) = return $ toSql s + parseJSON (JSON.Bool b) = return $ toSql b + parseJSON JSON.Null = return SqlNull + parseJSON (JSON.Object o) = return . toSql $ JSON.encode o + parseJSON (JSON.Array a) = return . toSql $ JSON.encode a + +instance JSON.ToJSON SqlValue where + toJSON (SqlString s) = JSON.toJSON s + toJSON (SqlByteString s) = JSON.toJSON $ decodeUtf8 s + toJSON (SqlWord32 w) = JSON.toJSON w + toJSON (SqlWord64 w) = JSON.toJSON w + toJSON (SqlInt32 i) = JSON.toJSON i + toJSON (SqlInt64 i) = JSON.toJSON i + toJSON (SqlInteger i) = JSON.toJSON i + toJSON (SqlChar c) = JSON.toJSON c + toJSON (SqlBool b) = JSON.toJSON b + toJSON (SqlDouble n) = JSON.toJSON n + toJSON (SqlRational n) = JSON.toJSON n + toJSON (SqlLocalDate d) = JSON.toJSON $ showGregorian d + toJSON (SqlLocalTimeOfDay t) = JSON.toJSON $ show t + toJSON (SqlLocalTime t) = JSON.toJSON $ show t + toJSON SqlNull = JSON.Null + toJSON x = JSON.toJSON $ show x + + +newtype SqlRow = SqlRow {getRow :: [(Text, SqlValue)] } deriving (Show) + +sqlRowColumns :: SqlRow -> [Text] +sqlRowColumns = map fst . getRow + +sqlRowValues :: SqlRow -> [SqlValue] +sqlRowValues = map snd . getRow + +instance JSON.FromJSON SqlRow where + parseJSON (JSON.Object m) = foldlWithKey' add (return $ SqlRow []) m + where + add :: Parser SqlRow -> Text -> JSON.Value -> Parser SqlRow + add parser k v = do + SqlRow l <- parser + sqlV <- JSON.parseJSON v + return . SqlRow $ (k, sqlV) : l + parseJSON _ = mzero