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

HTML Errors

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-04-14 12:49:54 +02:00
parent 4ecc8a8f4d
commit f8bb2c5c9e
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
5 changed files with 173 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
src/Aggreact/Authorization.hs
View file

@ -34,13 +34,13 @@ where
import Protolude
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)
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

6
src/Aggreact/Comments/Server.hs
View file

@ -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
View 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

8
src/Aggreact/Slugs/Server.hs
View file

@ -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

2
src/Servant/Errors.hs
View file

@ -36,6 +36,8 @@ data HTTPError =
, details :: Text
} deriving (Generic,ToJSON)
throwJSONErr :: (MonadError ServantErr m)
=> ServantErr -> Text -> m a
throwJSONErr err msg =