HTML Errors
This commit is contained in:
parent
4ecc8a8f4d
commit
f8bb2c5c9e
5 changed files with 173 additions and 23 deletions
|
@ -33,14 +33,14 @@ where
|
|||
|
||||
import Protolude
|
||||
|
||||
import Aggreact.Scopes (Access (..), Scope (..), Scopes)
|
||||
import Aggreact.User (NewUser (..), Role (..), User)
|
||||
import Aggreact.Scopes (Access (..), Scope (..), Scopes)
|
||||
import Aggreact.Servant.Errors (forbidden)
|
||||
import Aggreact.User (NewUser (..), Role (..), User)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import Database.Store (Entity (..))
|
||||
import Servant (Handler)
|
||||
import Servant.Errors (forbidden)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import Database.Store (Entity (..))
|
||||
import Servant (Handler)
|
||||
|
||||
data AuthorizationStrategy =
|
||||
Anybody
|
||||
|
@ -56,12 +56,20 @@ data AuthorizationHandler =
|
|||
newAuthorizationHandler :: AuthorizationStrategy -> IO AuthorizationHandler
|
||||
newAuthorizationHandler as = pure
|
||||
AuthorizationHandler
|
||||
{ filterAccess = \ s mu ->
|
||||
if hasScope' as s mu
|
||||
then return ()
|
||||
else forbidden "You don't have the permission to do that"
|
||||
{ filterAccess = filterAccess'
|
||||
, hasScope = hasScope' as
|
||||
}
|
||||
where
|
||||
filterAccess' s mu =
|
||||
if hasScope' as s mu
|
||||
then return ()
|
||||
else forbidden ("You are not allowed to do that."
|
||||
<> " You need to have the following scope: "
|
||||
<> "\"" <> displayScope s <> "\"."
|
||||
) mu
|
||||
displayScope Scope{..} = resource <> (case access of
|
||||
Read -> ":read"
|
||||
Write -> ":write")
|
||||
|
||||
strToScope :: Text -> Maybe Scope
|
||||
strToScope txt =
|
||||
|
@ -78,7 +86,8 @@ strToScope txt =
|
|||
|
||||
unloggedScopes :: AuthorizationStrategy -> Scopes
|
||||
unloggedScopes Anybody =
|
||||
[ "comment"
|
||||
[ "comment:read"
|
||||
, "comment:write"
|
||||
, "slug:read"]
|
||||
& traverse strToScope
|
||||
& fmap Set.fromList
|
||||
|
@ -93,7 +102,8 @@ unloggedScopes LoggedInOnly =
|
|||
|
||||
scopesFor :: NewUser -> AuthorizationStrategy -> Set Scope
|
||||
scopesFor _ Anybody =
|
||||
[ "comment"
|
||||
[ "comment:read"
|
||||
, "comment:write"
|
||||
, "slug:read"]
|
||||
& traverse strToScope
|
||||
& fmap Set.fromList
|
||||
|
@ -101,10 +111,13 @@ scopesFor _ Anybody =
|
|||
|
||||
scopesFor u LoggedInOnly =
|
||||
let scs = case role u of
|
||||
User -> [ "comment"
|
||||
User -> [ "comment:read"
|
||||
, "comment:write"
|
||||
, "slug:read"]
|
||||
Admin -> [ "comment"
|
||||
, "slug"]
|
||||
Admin -> [ "comment:read"
|
||||
, "comment:write"
|
||||
, "slug:read"
|
||||
, "slug:write"]
|
||||
in
|
||||
scs
|
||||
& traverse strToScope
|
||||
|
|
|
@ -41,6 +41,7 @@ import Aggreact.Comments.StoreService (CommentHandler (..))
|
|||
import Aggreact.Comments.Types
|
||||
import Aggreact.Comments.Views
|
||||
import Aggreact.Scopes (Scope (..))
|
||||
import Aggreact.Servant.Errors
|
||||
import Aggreact.User (User, UserHandler (..),
|
||||
UserId (..))
|
||||
|
||||
|
@ -52,7 +53,6 @@ import Database.Store (Entity (..), Id (..),
|
|||
minimalId)
|
||||
import Servant
|
||||
import Servant.Auth.Server (AuthResult (..))
|
||||
import Servant.Errors
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
|
||||
type CommentAPI =
|
||||
|
@ -106,7 +106,7 @@ showComment :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> H
|
|||
showComment muser AuthorizationHandler{..} CommentHandler{..} i = do
|
||||
_ <- filterAccess (Scope "comment" Read) muser
|
||||
case UUID.fromText i of
|
||||
Nothing -> notFound ""
|
||||
Nothing -> notFound "" muser
|
||||
Just uuid -> do
|
||||
cs <- liftIO . readComment . Id $ uuid
|
||||
now <- liftIO getCurrentTime
|
||||
|
@ -117,7 +117,7 @@ showComment muser AuthorizationHandler{..} CommentHandler{..} i = do
|
|||
, muser = muser
|
||||
, canComment = hasScope (Scope "comment" Read) muser
|
||||
}
|
||||
_ -> notFound ""
|
||||
_ -> notFound "" muser
|
||||
|
||||
muserToUserId :: Maybe User -> UserId
|
||||
muserToUserId Nothing = UserId (toS minimalId)
|
||||
|
|
135
src/Aggreact/Servant/Errors.hs
Normal file
135
src/Aggreact/Servant/Errors.hs
Normal file
|
@ -0,0 +1,135 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
module Aggreact.Servant.Errors where
|
||||
|
||||
import Aggreact.Html (boilerplate)
|
||||
import Aggreact.User (User, loginWidget)
|
||||
|
||||
import Network.HTTP.Types (hContentType)
|
||||
import Protolude
|
||||
import Servant
|
||||
import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
|
||||
htmlErr :: H.ToMarkup j => ServantErr -> j -> ServantErr
|
||||
htmlErr err j = err { errBody = Utf8.renderHtml (H.toMarkup j)
|
||||
, errHeaders = [ (hContentType
|
||||
, "text/html;charset=utf-8") ]
|
||||
}
|
||||
|
||||
data HTTPError =
|
||||
HTTPError
|
||||
{ code :: Int
|
||||
, error :: Text
|
||||
, details :: Text
|
||||
, muser :: Maybe User
|
||||
} deriving (Generic)
|
||||
|
||||
instance H.ToMarkup HTTPError where
|
||||
toMarkup HTTPError{..} = boilerplate (loginWidget muser) $ do
|
||||
H.h1 (H.text ("Error " <> show code <> ": " <> error))
|
||||
H.p (H.text details)
|
||||
|
||||
|
||||
throwHTMLErr :: (MonadError ServantErr m)
|
||||
=> ServantErr -> Text -> Maybe User -> m a
|
||||
throwHTMLErr err msg muser =
|
||||
throwError (htmlErr err
|
||||
(HTTPError
|
||||
errcode
|
||||
(toS (errReasonPhrase err) <> complementary errcode)
|
||||
msg
|
||||
muser))
|
||||
where
|
||||
errcode = errHTTPCode err
|
||||
complementary :: Int -> Text
|
||||
complementary c
|
||||
| 100 <= c && c < 200 = " (Informational)"
|
||||
| 300 <= c && c < 400 = " (Redirection)"
|
||||
| 400 <= c && c < 500 = " (Client Error)"
|
||||
| 500 <= c && c < 600 = " (Server Error)"
|
||||
| otherwise = " (Urepertoried HTTP Error Kind)"
|
||||
|
||||
badRequest :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
badRequest = throwHTMLErr err400
|
||||
|
||||
unauthorized :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
unauthorized = throwHTMLErr err401
|
||||
|
||||
|
||||
paymentRequired :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
paymentRequired = throwHTMLErr err402
|
||||
|
||||
forbidden :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
forbidden = throwHTMLErr err403
|
||||
|
||||
notFound :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
notFound = throwHTMLErr err404
|
||||
|
||||
methodNotAllowed :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
methodNotAllowed = throwHTMLErr err405
|
||||
|
||||
notAcceptable :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
notAcceptable = throwHTMLErr err406
|
||||
|
||||
proxyAuthenticationRequired :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
proxyAuthenticationRequired = throwHTMLErr err407
|
||||
|
||||
err408 :: ServantErr
|
||||
err408 = ServantErr { errHTTPCode = 408
|
||||
, errReasonPhrase = "Request Timeout"
|
||||
, errBody = ""
|
||||
, errHeaders = []
|
||||
}
|
||||
|
||||
requestTimeout :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
requestTimeout = throwHTMLErr err408
|
||||
|
||||
conflict :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
conflict = throwHTMLErr err409
|
||||
|
||||
gone :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
gone = throwHTMLErr err410
|
||||
|
||||
lengthRequired :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
lengthRequired = throwHTMLErr err411
|
||||
|
||||
preconditionFailed :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
preconditionFailed = throwHTMLErr err412
|
||||
|
||||
requestEntityTooLarge :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
requestEntityTooLarge = throwHTMLErr err413
|
||||
|
||||
requestURITooLong :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
requestURITooLong = throwHTMLErr err414
|
||||
|
||||
internalServerError :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
internalServerError = throwHTMLErr err500
|
||||
|
||||
notImplemented :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
notImplemented = throwHTMLErr err501
|
||||
|
||||
badGateway :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
badGateway = throwHTMLErr err502
|
||||
|
||||
serviceUnavailable :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
serviceUnavailable = throwHTMLErr err503
|
||||
|
||||
gatewayTimeout :: MonadError ServantErr m => Text -> Maybe User -> m a
|
||||
gatewayTimeout = throwHTMLErr err504
|
|
@ -38,6 +38,7 @@ import Protolude
|
|||
import Aggreact.Authorization (Access (..),
|
||||
AuthorizationHandler (..))
|
||||
import Aggreact.Scopes (Scope (..))
|
||||
import Aggreact.Servant.Errors
|
||||
import Aggreact.Slugs.StoreService (SlugHandler (..))
|
||||
import Aggreact.Slugs.Types
|
||||
import Aggreact.Slugs.Views
|
||||
|
@ -53,7 +54,6 @@ import Database.Store.Backend.SQLite (SearchQuery (Filter),
|
|||
import qualified Database.Store.Backend.SQLite as SQL
|
||||
import Servant
|
||||
import Servant.Auth.Server (AuthResult (..))
|
||||
import Servant.Errors
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
|
||||
type SlugAPI =
|
||||
|
@ -98,7 +98,7 @@ showSlug muser AuthorizationHandler{..} SlugHandler{..} slUrl = do
|
|||
_ <- filterAccess (Scope "slug" Read) muser
|
||||
(SR (SQL.Paginated slugs _ _)) <- liftIO $ searchSlugs (Filter {params = ["slugUrl" := slUrl]})
|
||||
case slugs of
|
||||
[] -> notFound "Cannot find the slug you're looking for"
|
||||
[] -> notFound "Cannot find the slug you're looking for" muser
|
||||
(s:[]) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
return SlugPage
|
||||
|
@ -107,7 +107,7 @@ showSlug muser AuthorizationHandler{..} SlugHandler{..} slUrl = do
|
|||
, muser = muser
|
||||
, canCreateSlug = hasScope (Scope "slug" Write) muser
|
||||
}
|
||||
_ -> internalServerError "Something went wrong, duplicate slugs..."
|
||||
_ -> internalServerError "Something went wrong, duplicate slugs..." muser
|
||||
|
||||
muserToUserId :: Maybe User -> UserId
|
||||
muserToUserId Nothing = UserId (toS minimalId)
|
||||
|
@ -126,4 +126,4 @@ postNewSlug muser AuthorizationHandler{..} SlugHandler{..} ns = do
|
|||
<$> liftIO getCurrentTime
|
||||
<*> liftIO (createSlug (ns { userid = muserToUserId muser }))
|
||||
<*> return muser
|
||||
else forbidden "This slug already exists."
|
||||
else forbidden "This slug already exists." muser
|
||||
|
|
|
@ -36,6 +36,8 @@ data HTTPError =
|
|||
, details :: Text
|
||||
} deriving (Generic,ToJSON)
|
||||
|
||||
|
||||
|
||||
throwJSONErr :: (MonadError ServantErr m)
|
||||
=> ServantErr -> Text -> m a
|
||||
throwJSONErr err msg =
|
||||
|
|
Loading…
Reference in a new issue