Better Auth Strategy algorithm
This commit is contained in:
parent
30e7c65955
commit
a213ce9ba5
4 changed files with 67 additions and 56 deletions
1
.envrc
1
.envrc
|
@ -1 +0,0 @@
|
|||
use_nix
|
|
@ -36,6 +36,8 @@ import Protolude
|
|||
|
||||
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 (unauthorized)
|
||||
|
@ -43,48 +45,76 @@ import Servant.Errors (unauthorized)
|
|||
data AuthorizationStrategy =
|
||||
Anybody
|
||||
| LoggedInOnly
|
||||
| ProgressiveTrust
|
||||
deriving (Eq, Show)
|
||||
|
||||
newtype AuthorizationHandler =
|
||||
data AuthorizationHandler =
|
||||
AuthorizationHandler
|
||||
{ checkAccess :: Scope -> Maybe User -> Handler ()
|
||||
{ filterAccess :: Scope -> Maybe User -> Handler ()
|
||||
, hasScope :: Scope -> Maybe User -> Bool
|
||||
}
|
||||
|
||||
data Scope = Scope { resource :: Text
|
||||
, access :: Access }
|
||||
data Access = Read | Write | AdminAccess
|
||||
deriving (Eq, Ord, Show)
|
||||
data Access = Read | Write
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
type Scopes = Set Scope
|
||||
|
||||
newAuthorizationHandler :: AuthorizationStrategy -> IO AuthorizationHandler
|
||||
newAuthorizationHandler as = pure
|
||||
AuthorizationHandler
|
||||
{ checkAccess = _checkAccess as
|
||||
{ filterAccess = _filterAccess as
|
||||
, hasScope = _hasScope as
|
||||
}
|
||||
|
||||
_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"
|
||||
strToScope :: Text -> Maybe Scope
|
||||
strToScope txt =
|
||||
Scope <$> Just (Text.takeWhile (/= sep) txt)
|
||||
<*> accessValue
|
||||
where
|
||||
accessTxt = Text.dropWhile (/= sep) txt
|
||||
sep = ':'
|
||||
accessValue = case accessTxt of
|
||||
":read" -> Just Read
|
||||
":write" -> Just Write
|
||||
"" -> Just Write
|
||||
_ -> Nothing
|
||||
|
||||
_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"
|
||||
unloggedScopes :: AuthorizationStrategy -> Scopes
|
||||
unloggedScopes Anybody =
|
||||
[ "comment"
|
||||
, "stub"]
|
||||
& traverse strToScope
|
||||
& fmap Set.fromList
|
||||
& fromMaybe Set.empty
|
||||
|
||||
_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"
|
||||
unloggedScopes LoggedInOnly =
|
||||
[ "comment:read"
|
||||
, "stub:read"]
|
||||
& traverse strToScope
|
||||
& fmap Set.fromList
|
||||
& fromMaybe Set.empty
|
||||
|
||||
scopesFor u Anybody =
|
||||
[ "comment"
|
||||
, "homepage"]
|
||||
& traverse strToScope
|
||||
& fmap Set.fromList
|
||||
& fromMaybe Set.empty
|
||||
|
||||
scopesFor u LoggedInOnly =
|
||||
let scs = case role u of
|
||||
User -> [ "comment"
|
||||
, "stub:read"]
|
||||
Admin -> [ "comment"
|
||||
, "stub"]
|
||||
in
|
||||
scs
|
||||
& traverse strToScope
|
||||
& fmap Set.fromList
|
||||
& fromMaybe Set.empty
|
||||
|
||||
_hasScope :: AuthorizationStrategy -> Scope -> Maybe User -> Bool
|
||||
_hasScope authStrat s Nothing = Set.member s (unloggedScopes authStrat)
|
||||
_hasScope authStrat s (Just (Entity _ u _)) = Set.member s (scopesFor u authStrat)
|
||||
|
|
|
@ -85,7 +85,7 @@ commentAPI Handlers{..} authResult =
|
|||
|
||||
showComments :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler CommentsPage
|
||||
showComments muser AuthorizationHandler{..} CommentHandler{..} s = do
|
||||
_ <- checkAccess (Scope "comment" Read) muser
|
||||
_ <- filterAccess (Scope "comment" Read) muser
|
||||
cvs <- liftIO $ commentsView (Slug s)
|
||||
now <- liftIO getCurrentTime
|
||||
liftIO $ print cvs
|
||||
|
@ -97,12 +97,12 @@ showComments muser AuthorizationHandler{..} CommentHandler{..} s = do
|
|||
|
||||
showSlugs :: Maybe User -> AuthorizationHandler -> CommentHandler -> Handler [Slug]
|
||||
showSlugs muser AuthorizationHandler{..} ch = do
|
||||
_ <- checkAccess (Scope "comment" Read) muser
|
||||
_ <- filterAccess (Scope "comment" Read) muser
|
||||
liftIO (getSlugs ch)
|
||||
|
||||
showComment :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler CommentPage
|
||||
showComment muser AuthorizationHandler{..} CommentHandler{..} i = do
|
||||
_ <- checkAccess (Scope "comment" Read) muser
|
||||
_ <- filterAccess (Scope "comment" Read) muser
|
||||
case UUID.fromText i of
|
||||
Nothing -> notFound ""
|
||||
Just uuid -> do
|
||||
|
@ -123,7 +123,7 @@ 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
|
||||
_ <- filterAccess (Scope "comment" Write) muser
|
||||
let uid = muserToUserId muser
|
||||
CreatedComment <$> liftIO getCurrentTime
|
||||
<*> liftIO (createComment ch (nc { userid = uid }))
|
||||
|
|
|
@ -42,6 +42,7 @@ where
|
|||
|
||||
import Protolude hiding (pass)
|
||||
|
||||
import Aggreact.Authorization (Scopes)
|
||||
import Aggreact.Html (boilerplate, cvt, urlEncode)
|
||||
|
||||
|
||||
|
@ -82,7 +83,8 @@ data NewUser =
|
|||
NewUser { nick :: Nick
|
||||
, email :: Email
|
||||
, password :: HashedPassword
|
||||
, role :: Role
|
||||
, scopes :: Scopes
|
||||
, trust :: Int
|
||||
} deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
instance Form.FromForm NewUser where
|
||||
fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
|
||||
|
@ -136,26 +138,6 @@ instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (HashedPassword '
|
|||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
|
||||
|
||||
data Role = User | Admin
|
||||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||
deriving anyclass instance FromJSON Role
|
||||
deriving anyclass instance ToJSON Role
|
||||
instance FormI.FromHttpApiData Role where
|
||||
parseUrlPiece "Admin" = pure Admin
|
||||
parseUrlPiece "admin" = pure Admin
|
||||
parseUrlPiece "User" = pure User
|
||||
parseUrlPiece "user" = pure User
|
||||
parseUrlPiece _ = Left "Should be admin or user"
|
||||
|
||||
instance FromField Role where
|
||||
fromField f = case fieldData f of
|
||||
SQLText "User" -> pure User
|
||||
SQLText "Admin" -> pure Admin
|
||||
_ -> returnError ConversionFailed f "need a text containing User or Admin"
|
||||
instance ToField Role where toField = toField . (show :: Role -> Text)
|
||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Role ': rest) where
|
||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||
|
||||
-- For HTTP
|
||||
deriving anyclass instance ToJSON NewUser
|
||||
deriving anyclass instance FromJSON NewUser
|
||||
|
|
Loading…
Reference in a new issue