fixes
This commit is contained in:
Yann Esposito (Yogsototh)
parent
e0310fe4af
commit
7b9bb20dc6
GPG key ID:
7B19A4C650D59646
2 changed files with 76 additions and 45 deletions
|
|
@ -26,16 +26,19 @@ Depending on the user provide different trust mechanism
|
|||
module Aggreact.Authorization
|
||||
( AuthorizationStrategy (..)
|
||||
, AuthorizationHandler (..)
|
||||
, Scope(..)
|
||||
, Access(..)
|
||||
, newAuthorizationHandler
|
||||
)
|
||||
where
|
||||
|
||||
import Protolude
|
||||
|
||||
import Aggreact.User (User)
|
||||
import Aggreact.User (User,NewUser(..),Role(..))
|
||||
|
||||
import Servant (Handler)
|
||||
import Servant.Errors (forbidden)
|
||||
import Servant.Errors (unauthorized)
|
||||
import Database.Store (Entity(..))
|
||||
|
||||
data AuthorizationStrategy =
|
||||
Anybody
|
||||
|
|
@ -45,12 +48,12 @@ data AuthorizationStrategy =
|
|||
|
||||
newtype AuthorizationHandler =
|
||||
AuthorizationHandler
|
||||
{ checkAccess :: Maybe User -> Handler Trust
|
||||
{ checkAccess :: Scope -> Maybe User -> Handler ()
|
||||
}
|
||||
|
||||
data Trust =
|
||||
Bad | New | Observation | Trusted
|
||||
deriving (Eq,Ord,Show)
|
||||
data Scope = Scope { resource :: Text
|
||||
, access :: Access }
|
||||
data Access = Read | Write | AdminAccess
|
||||
|
||||
newAuthorizationHandler :: AuthorizationStrategy -> IO AuthorizationHandler
|
||||
newAuthorizationHandler as = pure
|
||||
|
|
@ -58,12 +61,30 @@ newAuthorizationHandler as = pure
|
|||
{ checkAccess = _checkAccess as
|
||||
}
|
||||
|
||||
_checkAccess :: AuthorizationStrategy -> Maybe User -> Handler Trust
|
||||
_checkAccess Anybody _ = pure Trusted
|
||||
_checkAccess :: AuthorizationStrategy -> Scope -> Maybe User -> Handler ()
|
||||
_checkAccess Anybody (Scope _ Read) _ = pure ()
|
||||
_checkAccess Anybody (Scope _ Write) _ = pure ()
|
||||
_checkAccess Anybody (Scope _ AdminAccess) (Just (Entity _ u _)) =
|
||||
case role u of
|
||||
Admin -> pure ()
|
||||
_ -> unauthorized "Need admin privilege"
|
||||
_checkAccess Anybody (Scope _ AdminAccess) _ =
|
||||
unauthorized "Need admin privilege"
|
||||
|
||||
_checkAccess LoggedInOnly Nothing = forbidden "You must log in"
|
||||
_checkAccess LoggedInOnly (Scope _ Read) Nothing = pure ()
|
||||
_checkAccess LoggedInOnly (Scope _ _) Nothing = unauthorized "You must log in"
|
||||
_checkAccess LoggedInOnly (Scope _ Read) (Just _) = pure ()
|
||||
_checkAccess LoggedInOnly (Scope _ Write) (Just _) = pure ()
|
||||
_checkAccess LoggedInOnly (Scope _ AdminAccess) (Just (Entity _ u _)) =
|
||||
case role u of
|
||||
Admin -> pure ()
|
||||
_ -> unauthorized "Only for admins"
|
||||
|
||||
_checkAccess LoggedInOnly (Just _) = pure Trusted
|
||||
|
||||
_checkAccess ProgressiveTrust Nothing = forbidden "You must log in"
|
||||
_checkAccess ProgressiveTrust (Just _) = pure Trusted
|
||||
_checkAccess ProgressiveTrust (Scope _ Read) Nothing = pure ()
|
||||
_checkAccess ProgressiveTrust (Scope _ _) Nothing = unauthorized "You must log in"
|
||||
_checkAccess ProgressiveTrust (Scope _ Read) (Just _) = pure ()
|
||||
_checkAccess ProgressiveTrust (Scope _ Write) (Just _) = pure ()
|
||||
_checkAccess ProgressiveTrust (Scope _ AdminAccess) (Just (Entity _ u _)) =
|
||||
case role u of
|
||||
Admin -> pure ()
|
||||
_ -> unauthorized "Only for admins"
|
||||
|
|
|
|||
|
|
@ -1,20 +1,20 @@
|
|||
-- Local Pragmas
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
-- Common Pragmas (already stated in cabal file but repeated here for some tools)
|
||||
{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ...
|
||||
{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies
|
||||
{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b
|
||||
{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _
|
||||
{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example
|
||||
{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000
|
||||
{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set
|
||||
{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type
|
||||
{-# LANGUAGE PartialTypeSignatures #-} -- write foo :: (_) => a -> Bool
|
||||
{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ...
|
||||
{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE NamedWildCards #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{- |
|
||||
Module : Aggreact.Comments.StoreService
|
||||
Description : CommentStore service
|
||||
|
|
@ -35,21 +35,24 @@ where
|
|||
import Protolude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Aggreact.Comments.Types
|
||||
import Aggreact.Comments.StoreService (CommentHandler(..))
|
||||
import Aggreact.Comments.Views
|
||||
import Aggreact.User (UserHandler(..),User)
|
||||
import Aggreact.Authorization (AuthorizationHandler(..))
|
||||
import Aggreact.Authorization (Access (..),
|
||||
AuthorizationHandler (..),
|
||||
Scope (..))
|
||||
import Aggreact.Comments.StoreService (CommentHandler (..))
|
||||
import Aggreact.Comments.Types
|
||||
import Aggreact.Comments.Views
|
||||
import Aggreact.User (User, UserHandler (..))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Data.Time (getCurrentTime)
|
||||
import Database.Store (Entity(..), Id (..))
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import qualified Data.IxSet.Typed as IxSet
|
||||
import Data.Time (getCurrentTime)
|
||||
import qualified Data.UUID as UUID
|
||||
import Database.Store (Entity (..), Id (..),
|
||||
minimalId)
|
||||
import Servant
|
||||
import Servant.Auth.Server (AuthResult (..))
|
||||
import Servant.Errors
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
import Servant.Auth.Server (AuthResult(..))
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
|
||||
type CommentAPI =
|
||||
"comments"
|
||||
|
|
@ -73,15 +76,16 @@ commentAPI :: Handlers -> AuthResult User -> Server CommentAPI
|
|||
commentAPI Handlers{..} authResult =
|
||||
let muser = case authResult of
|
||||
(Authenticated user) -> Just user
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
in
|
||||
showComments muser commentHandler
|
||||
showComments muser authorizationHandler commentHandler
|
||||
:<|> liftIO (getSlugs commentHandler)
|
||||
:<|> postNewComment muser commentHandler
|
||||
:<|> postNewComment muser authorizationHandler commentHandler
|
||||
:<|> showComment muser commentHandler
|
||||
|
||||
showComments :: Maybe User -> CommentHandler -> Text -> Handler CommentsPage
|
||||
showComments muser CommentHandler{..} s = do
|
||||
showComments :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler CommentsPage
|
||||
showComments muser AuthorizationHandler{..} CommentHandler{..} s = do
|
||||
_ <- checkAccess (Scope "comment" Read) muser
|
||||
cvs <- liftIO $ commentsView (Slug s)
|
||||
now <- liftIO getCurrentTime
|
||||
liftIO $ print cvs
|
||||
|
|
@ -106,9 +110,15 @@ showComment muser CommentHandler{..} i =
|
|||
}
|
||||
_ -> notFound ""
|
||||
|
||||
postNewComment :: Maybe User -> CommentHandler -> NewComment -> Handler CreatedComment
|
||||
postNewComment Nothing _ch _ = unauthorized "You must log in to post new comments"
|
||||
postNewComment muser@(Just (Entity i _ _)) ch nc =
|
||||
muserToUserId :: Maybe User -> UserId
|
||||
muserToUserId Nothing = UserId (toS minimalId)
|
||||
muserToUserId (Just (Entity i _ _)) = UserId (toS i)
|
||||
|
||||
|
||||
postNewComment :: Maybe User -> AuthorizationHandler -> CommentHandler -> NewComment -> Handler CreatedComment
|
||||
postNewComment muser AuthorizationHandler{..} ch nc = do
|
||||
_ <- checkAccess (Scope "comment" Write) muser
|
||||
let uid = muserToUserId muser
|
||||
CreatedComment <$> liftIO getCurrentTime
|
||||
<*> liftIO (createComment ch (nc { userid = UserId (toS i) }))
|
||||
<*> liftIO (createComment ch (nc { userid = uid }))
|
||||
<*> return muser
|
||||
|
|
|
|||
Loading…
Reference in a new issue