yogsototh/aggreact
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

LTS 14.3

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-09-10 23:10:51 +02:00
parent 038a7dc56b
commit e5dae59d49
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
3 changed files with 53 additions and 58 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

50
src/Aggreact/Servant/Errors.hs
View file

@ -28,7 +28,7 @@ import Servant
import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8 import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5 as H
htmlErr :: H.ToMarkup j => ServantErr -> j -> ServantErr htmlErr :: H.ToMarkup j => ServerError -> j -> ServerError
htmlErr err j = err { errBody = Utf8.renderHtml (H.toMarkup j) htmlErr err j = err { errBody = Utf8.renderHtml (H.toMarkup j)
, errHeaders = [ (hContentType , errHeaders = [ (hContentType
, "text/html;charset=utf-8") ] , "text/html;charset=utf-8") ]
@ -48,8 +48,8 @@ instance H.ToMarkup HTTPError where
H.p (H.text details) H.p (H.text details)
throwHTMLErr :: (MonadError ServantErr m) throwHTMLErr :: (MonadError ServerError m)
=> ServantErr -> Text -> Maybe User -> m a => ServerError -> Text -> Maybe User -> m a
throwHTMLErr err msg muser = throwHTMLErr err msg muser =
throwError (htmlErr err throwError (htmlErr err
(HTTPError (HTTPError
@ -67,70 +67,70 @@ throwHTMLErr err msg muser =
| 500 <= c && c < 600 = " (Server Error)" | 500 <= c && c < 600 = " (Server Error)"
| otherwise = " (Urepertoried HTTP Error Kind)" | otherwise = " (Urepertoried HTTP Error Kind)"
badRequest :: MonadError ServantErr m => Text -> Maybe User -> m a badRequest :: MonadError ServerError m => Text -> Maybe User -> m a
badRequest = throwHTMLErr err400 badRequest = throwHTMLErr err400
unauthorized :: MonadError ServantErr m => Text -> Maybe User -> m a unauthorized :: MonadError ServerError m => Text -> Maybe User -> m a
unauthorized = throwHTMLErr err401 unauthorized = throwHTMLErr err401
paymentRequired :: MonadError ServantErr m => Text -> Maybe User -> m a paymentRequired :: MonadError ServerError m => Text -> Maybe User -> m a
paymentRequired = throwHTMLErr err402 paymentRequired = throwHTMLErr err402
forbidden :: MonadError ServantErr m => Text -> Maybe User -> m a forbidden :: MonadError ServerError m => Text -> Maybe User -> m a
forbidden = throwHTMLErr err403 forbidden = throwHTMLErr err403
notFound :: MonadError ServantErr m => Text -> Maybe User -> m a notFound :: MonadError ServerError m => Text -> Maybe User -> m a
notFound = throwHTMLErr err404 notFound = throwHTMLErr err404
methodNotAllowed :: MonadError ServantErr m => Text -> Maybe User -> m a methodNotAllowed :: MonadError ServerError m => Text -> Maybe User -> m a
methodNotAllowed = throwHTMLErr err405 methodNotAllowed = throwHTMLErr err405
notAcceptable :: MonadError ServantErr m => Text -> Maybe User -> m a notAcceptable :: MonadError ServerError m => Text -> Maybe User -> m a
notAcceptable = throwHTMLErr err406 notAcceptable = throwHTMLErr err406
proxyAuthenticationRequired :: MonadError ServantErr m => Text -> Maybe User -> m a proxyAuthenticationRequired :: MonadError ServerError m => Text -> Maybe User -> m a
proxyAuthenticationRequired = throwHTMLErr err407 proxyAuthenticationRequired = throwHTMLErr err407
err408 :: ServantErr err408 :: ServerError
err408 = ServantErr { errHTTPCode = 408 err408 = ServerError { errHTTPCode = 408
, errReasonPhrase = "Request Timeout" , errReasonPhrase = "Request Timeout"
, errBody = "" , errBody = ""
, errHeaders = [] , errHeaders = []
} }
requestTimeout :: MonadError ServantErr m => Text -> Maybe User -> m a requestTimeout :: MonadError ServerError m => Text -> Maybe User -> m a
requestTimeout = throwHTMLErr err408 requestTimeout = throwHTMLErr err408
conflict :: MonadError ServantErr m => Text -> Maybe User -> m a conflict :: MonadError ServerError m => Text -> Maybe User -> m a
conflict = throwHTMLErr err409 conflict = throwHTMLErr err409
gone :: MonadError ServantErr m => Text -> Maybe User -> m a gone :: MonadError ServerError m => Text -> Maybe User -> m a
gone = throwHTMLErr err410 gone = throwHTMLErr err410
lengthRequired :: MonadError ServantErr m => Text -> Maybe User -> m a lengthRequired :: MonadError ServerError m => Text -> Maybe User -> m a
lengthRequired = throwHTMLErr err411 lengthRequired = throwHTMLErr err411
preconditionFailed :: MonadError ServantErr m => Text -> Maybe User -> m a preconditionFailed :: MonadError ServerError m => Text -> Maybe User -> m a
preconditionFailed = throwHTMLErr err412 preconditionFailed = throwHTMLErr err412
requestEntityTooLarge :: MonadError ServantErr m => Text -> Maybe User -> m a requestEntityTooLarge :: MonadError ServerError m => Text -> Maybe User -> m a
requestEntityTooLarge = throwHTMLErr err413 requestEntityTooLarge = throwHTMLErr err413
requestURITooLong :: MonadError ServantErr m => Text -> Maybe User -> m a requestURITooLong :: MonadError ServerError m => Text -> Maybe User -> m a
requestURITooLong = throwHTMLErr err414 requestURITooLong = throwHTMLErr err414
internalServerError :: MonadError ServantErr m => Text -> Maybe User -> m a internalServerError :: MonadError ServerError m => Text -> Maybe User -> m a
internalServerError = throwHTMLErr err500 internalServerError = throwHTMLErr err500
notImplemented :: MonadError ServantErr m => Text -> Maybe User -> m a notImplemented :: MonadError ServerError m => Text -> Maybe User -> m a
notImplemented = throwHTMLErr err501 notImplemented = throwHTMLErr err501
badGateway :: MonadError ServantErr m => Text -> Maybe User -> m a badGateway :: MonadError ServerError m => Text -> Maybe User -> m a
badGateway = throwHTMLErr err502 badGateway = throwHTMLErr err502
serviceUnavailable :: MonadError ServantErr m => Text -> Maybe User -> m a serviceUnavailable :: MonadError ServerError m => Text -> Maybe User -> m a
serviceUnavailable = throwHTMLErr err503 serviceUnavailable = throwHTMLErr err503
gatewayTimeout :: MonadError ServantErr m => Text -> Maybe User -> m a gatewayTimeout :: MonadError ServerError m => Text -> Maybe User -> m a
gatewayTimeout = throwHTMLErr err504 gatewayTimeout = throwHTMLErr err504

50
src/Servant/Errors.hs
View file

@ -23,7 +23,7 @@ import Servant
import Network.HTTP.Types (hContentType) import Network.HTTP.Types (hContentType)
import Data.Aeson (encode, ToJSON) import Data.Aeson (encode, ToJSON)
jsonErr :: ToJSON j => ServantErr -> j -> ServantErr jsonErr :: ToJSON j => ServerError -> j -> ServerError
jsonErr err j = err { errBody = encode j jsonErr err j = err { errBody = encode j
, errHeaders = [ (hContentType , errHeaders = [ (hContentType
, "application/json;charset=utf-8") ] , "application/json;charset=utf-8") ]
@ -38,8 +38,8 @@ data HTTPError =
throwJSONErr :: (MonadError ServantErr m) throwJSONErr :: (MonadError ServerError m)
=> ServantErr -> Text -> m a => ServerError -> Text -> m a
throwJSONErr err msg = throwJSONErr err msg =
throwError (jsonErr err throwError (jsonErr err
(HTTPError (HTTPError
@ -56,70 +56,70 @@ throwJSONErr err msg =
| 500 <= c && c < 600 = " (Server Error)" | 500 <= c && c < 600 = " (Server Error)"
| otherwise = " (Urepertoried HTTP Error Kind)" | otherwise = " (Urepertoried HTTP Error Kind)"
badRequest :: MonadError ServantErr m => Text -> m a badRequest :: MonadError ServerError m => Text -> m a
badRequest = throwJSONErr err400 badRequest = throwJSONErr err400
unauthorized :: MonadError ServantErr m => Text -> m a unauthorized :: MonadError ServerError m => Text -> m a
unauthorized = throwJSONErr err401 unauthorized = throwJSONErr err401
paymentRequired :: MonadError ServantErr m => Text -> m a paymentRequired :: MonadError ServerError m => Text -> m a
paymentRequired = throwJSONErr err402 paymentRequired = throwJSONErr err402
forbidden :: MonadError ServantErr m => Text -> m a forbidden :: MonadError ServerError m => Text -> m a
forbidden = throwJSONErr err403 forbidden = throwJSONErr err403
notFound :: MonadError ServantErr m => Text -> m a notFound :: MonadError ServerError m => Text -> m a
notFound = throwJSONErr err404 notFound = throwJSONErr err404
methodNotAllowed :: MonadError ServantErr m => Text -> m a methodNotAllowed :: MonadError ServerError m => Text -> m a
methodNotAllowed = throwJSONErr err405 methodNotAllowed = throwJSONErr err405
notAcceptable :: MonadError ServantErr m => Text -> m a notAcceptable :: MonadError ServerError m => Text -> m a
notAcceptable = throwJSONErr err406 notAcceptable = throwJSONErr err406
proxyAuthenticationRequired :: MonadError ServantErr m => Text -> m a proxyAuthenticationRequired :: MonadError ServerError m => Text -> m a
proxyAuthenticationRequired = throwJSONErr err407 proxyAuthenticationRequired = throwJSONErr err407
err408 :: ServantErr err408 :: ServerError
err408 = ServantErr { errHTTPCode = 408 err408 = ServerError { errHTTPCode = 408
, errReasonPhrase = "Request Timeout" , errReasonPhrase = "Request Timeout"
, errBody = "" , errBody = ""
, errHeaders = [] , errHeaders = []
} }
requestTimeout :: MonadError ServantErr m => Text -> m a requestTimeout :: MonadError ServerError m => Text -> m a
requestTimeout = throwJSONErr err408 requestTimeout = throwJSONErr err408
conflict :: MonadError ServantErr m => Text -> m a conflict :: MonadError ServerError m => Text -> m a
conflict = throwJSONErr err409 conflict = throwJSONErr err409
gone :: MonadError ServantErr m => Text -> m a gone :: MonadError ServerError m => Text -> m a
gone = throwJSONErr err410 gone = throwJSONErr err410
lengthRequired :: MonadError ServantErr m => Text -> m a lengthRequired :: MonadError ServerError m => Text -> m a
lengthRequired = throwJSONErr err411 lengthRequired = throwJSONErr err411
preconditionFailed :: MonadError ServantErr m => Text -> m a preconditionFailed :: MonadError ServerError m => Text -> m a
preconditionFailed = throwJSONErr err412 preconditionFailed = throwJSONErr err412
requestEntityTooLarge :: MonadError ServantErr m => Text -> m a requestEntityTooLarge :: MonadError ServerError m => Text -> m a
requestEntityTooLarge = throwJSONErr err413 requestEntityTooLarge = throwJSONErr err413
requestURITooLong :: MonadError ServantErr m => Text -> m a requestURITooLong :: MonadError ServerError m => Text -> m a
requestURITooLong = throwJSONErr err414 requestURITooLong = throwJSONErr err414
internalServerError :: MonadError ServantErr m => Text -> m a internalServerError :: MonadError ServerError m => Text -> m a
internalServerError = throwJSONErr err500 internalServerError = throwJSONErr err500
notImplemented :: MonadError ServantErr m => Text -> m a notImplemented :: MonadError ServerError m => Text -> m a
notImplemented = throwJSONErr err501 notImplemented = throwJSONErr err501
badGateway :: MonadError ServantErr m => Text -> m a badGateway :: MonadError ServerError m => Text -> m a
badGateway = throwJSONErr err502 badGateway = throwJSONErr err502
serviceUnavailable :: MonadError ServantErr m => Text -> m a serviceUnavailable :: MonadError ServerError m => Text -> m a
serviceUnavailable = throwJSONErr err503 serviceUnavailable = throwJSONErr err503
gatewayTimeout :: MonadError ServantErr m => Text -> m a gatewayTimeout :: MonadError ServerError m => Text -> m a
gatewayTimeout = throwJSONErr err504 gatewayTimeout = throwJSONErr err504

11
stack.yaml
View file

@ -18,7 +18,7 @@
# #
# resolver: ./custom-snapshot.yaml # resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-13.11 resolver: lts-14.3
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.
@ -39,12 +39,7 @@ packages:
# Dependency packages to be pulled from upstream that are not in the resolver # Dependency packages to be pulled from upstream that are not in the resolver
# using the same syntax as the packages field. # using the same syntax as the packages field.
# (e.g., acme-missiles-0.3) # (e.g., acme-missiles-0.3)
extra-deps: extra-deps: []
- ixset-1.1.1
- human-readable-duration-0.2.1.2
- beam-core-0.8.0.0
- beam-migrate-0.4.0.0
- beam-sqlite-0.4.0.0
# Override default flag values for local packages and extra-deps # Override default flag values for local packages and extra-deps
@ -72,4 +67,4 @@ extra-deps:
# compiler-check: newer-minor # compiler-check: newer-minor
# for intero and 8.6.1 # for intero and 8.6.1
allow-newer: true # allow-newer: true