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 Aggreact.User (NewUser (..), Role (..), User)
|
||||||
|
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import qualified Data.Text as Text
|
||||||
import Database.Store (Entity (..))
|
import Database.Store (Entity (..))
|
||||||
import Servant (Handler)
|
import Servant (Handler)
|
||||||
import Servant.Errors (unauthorized)
|
import Servant.Errors (unauthorized)
|
||||||
|
@ -43,48 +45,76 @@ import Servant.Errors (unauthorized)
|
||||||
data AuthorizationStrategy =
|
data AuthorizationStrategy =
|
||||||
Anybody
|
Anybody
|
||||||
| LoggedInOnly
|
| LoggedInOnly
|
||||||
| ProgressiveTrust
|
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
newtype AuthorizationHandler =
|
data AuthorizationHandler =
|
||||||
AuthorizationHandler
|
AuthorizationHandler
|
||||||
{ checkAccess :: Scope -> Maybe User -> Handler ()
|
{ filterAccess :: Scope -> Maybe User -> Handler ()
|
||||||
|
, hasScope :: Scope -> Maybe User -> Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
data Scope = Scope { resource :: Text
|
data Scope = Scope { resource :: Text
|
||||||
, access :: Access }
|
, 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 :: AuthorizationStrategy -> IO AuthorizationHandler
|
||||||
newAuthorizationHandler as = pure
|
newAuthorizationHandler as = pure
|
||||||
AuthorizationHandler
|
AuthorizationHandler
|
||||||
{ checkAccess = _checkAccess as
|
{ filterAccess = _filterAccess as
|
||||||
|
, hasScope = _hasScope as
|
||||||
}
|
}
|
||||||
|
|
||||||
_checkAccess :: AuthorizationStrategy -> Scope -> Maybe User -> Handler ()
|
strToScope :: Text -> Maybe Scope
|
||||||
_checkAccess Anybody (Scope _ Read) _ = pure ()
|
strToScope txt =
|
||||||
_checkAccess Anybody (Scope _ Write) _ = pure ()
|
Scope <$> Just (Text.takeWhile (/= sep) txt)
|
||||||
_checkAccess Anybody (Scope _ AdminAccess) (Just (Entity _ u _)) =
|
<*> accessValue
|
||||||
case role u of
|
where
|
||||||
Admin -> pure ()
|
accessTxt = Text.dropWhile (/= sep) txt
|
||||||
_ -> unauthorized "Need admin privilege"
|
sep = ':'
|
||||||
_checkAccess Anybody (Scope _ AdminAccess) _ =
|
accessValue = case accessTxt of
|
||||||
unauthorized "Need admin privilege"
|
":read" -> Just Read
|
||||||
|
":write" -> Just Write
|
||||||
|
"" -> Just Write
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
_checkAccess LoggedInOnly (Scope _ Read) Nothing = pure ()
|
unloggedScopes :: AuthorizationStrategy -> Scopes
|
||||||
_checkAccess LoggedInOnly (Scope _ _) Nothing = unauthorized "You must log in"
|
unloggedScopes Anybody =
|
||||||
_checkAccess LoggedInOnly (Scope _ Read) (Just _) = pure ()
|
[ "comment"
|
||||||
_checkAccess LoggedInOnly (Scope _ Write) (Just _) = pure ()
|
, "stub"]
|
||||||
_checkAccess LoggedInOnly (Scope _ AdminAccess) (Just (Entity _ u _)) =
|
& traverse strToScope
|
||||||
case role u of
|
& fmap Set.fromList
|
||||||
Admin -> pure ()
|
& fromMaybe Set.empty
|
||||||
_ -> unauthorized "Only for admins"
|
|
||||||
|
|
||||||
_checkAccess ProgressiveTrust (Scope _ Read) Nothing = pure ()
|
unloggedScopes LoggedInOnly =
|
||||||
_checkAccess ProgressiveTrust (Scope _ _) Nothing = unauthorized "You must log in"
|
[ "comment:read"
|
||||||
_checkAccess ProgressiveTrust (Scope _ Read) (Just _) = pure ()
|
, "stub:read"]
|
||||||
_checkAccess ProgressiveTrust (Scope _ Write) (Just _) = pure ()
|
& traverse strToScope
|
||||||
_checkAccess ProgressiveTrust (Scope _ AdminAccess) (Just (Entity _ u _)) =
|
& fmap Set.fromList
|
||||||
case role u of
|
& fromMaybe Set.empty
|
||||||
Admin -> pure ()
|
|
||||||
_ -> unauthorized "Only for admins"
|
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 :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler CommentsPage
|
||||||
showComments muser AuthorizationHandler{..} CommentHandler{..} s = do
|
showComments muser AuthorizationHandler{..} CommentHandler{..} s = do
|
||||||
_ <- checkAccess (Scope "comment" Read) muser
|
_ <- filterAccess (Scope "comment" Read) muser
|
||||||
cvs <- liftIO $ commentsView (Slug s)
|
cvs <- liftIO $ commentsView (Slug s)
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
liftIO $ print cvs
|
liftIO $ print cvs
|
||||||
|
@ -97,12 +97,12 @@ showComments muser AuthorizationHandler{..} CommentHandler{..} s = do
|
||||||
|
|
||||||
showSlugs :: Maybe User -> AuthorizationHandler -> CommentHandler -> Handler [Slug]
|
showSlugs :: Maybe User -> AuthorizationHandler -> CommentHandler -> Handler [Slug]
|
||||||
showSlugs muser AuthorizationHandler{..} ch = do
|
showSlugs muser AuthorizationHandler{..} ch = do
|
||||||
_ <- checkAccess (Scope "comment" Read) muser
|
_ <- filterAccess (Scope "comment" Read) muser
|
||||||
liftIO (getSlugs ch)
|
liftIO (getSlugs ch)
|
||||||
|
|
||||||
showComment :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler CommentPage
|
showComment :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler CommentPage
|
||||||
showComment muser AuthorizationHandler{..} CommentHandler{..} i = do
|
showComment muser AuthorizationHandler{..} CommentHandler{..} i = do
|
||||||
_ <- checkAccess (Scope "comment" Read) muser
|
_ <- filterAccess (Scope "comment" Read) muser
|
||||||
case UUID.fromText i of
|
case UUID.fromText i of
|
||||||
Nothing -> notFound ""
|
Nothing -> notFound ""
|
||||||
Just uuid -> do
|
Just uuid -> do
|
||||||
|
@ -123,7 +123,7 @@ muserToUserId (Just (Entity i _ _)) = UserId (toS i)
|
||||||
|
|
||||||
postNewComment :: Maybe User -> AuthorizationHandler -> CommentHandler -> NewComment -> Handler CreatedComment
|
postNewComment :: Maybe User -> AuthorizationHandler -> CommentHandler -> NewComment -> Handler CreatedComment
|
||||||
postNewComment muser AuthorizationHandler{..} ch nc = do
|
postNewComment muser AuthorizationHandler{..} ch nc = do
|
||||||
_ <- checkAccess (Scope "comment" Write) muser
|
_ <- filterAccess (Scope "comment" Write) muser
|
||||||
let uid = muserToUserId muser
|
let uid = muserToUserId muser
|
||||||
CreatedComment <$> liftIO getCurrentTime
|
CreatedComment <$> liftIO getCurrentTime
|
||||||
<*> liftIO (createComment ch (nc { userid = uid }))
|
<*> liftIO (createComment ch (nc { userid = uid }))
|
||||||
|
|
|
@ -42,6 +42,7 @@ where
|
||||||
|
|
||||||
import Protolude hiding (pass)
|
import Protolude hiding (pass)
|
||||||
|
|
||||||
|
import Aggreact.Authorization (Scopes)
|
||||||
import Aggreact.Html (boilerplate, cvt, urlEncode)
|
import Aggreact.Html (boilerplate, cvt, urlEncode)
|
||||||
|
|
||||||
|
|
||||||
|
@ -82,7 +83,8 @@ data NewUser =
|
||||||
NewUser { nick :: Nick
|
NewUser { nick :: Nick
|
||||||
, email :: Email
|
, email :: Email
|
||||||
, password :: HashedPassword
|
, password :: HashedPassword
|
||||||
, role :: Role
|
, scopes :: Scopes
|
||||||
|
, trust :: Int
|
||||||
} deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
} deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||||
instance Form.FromForm NewUser where
|
instance Form.FromForm NewUser where
|
||||||
fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
|
fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
|
||||||
|
@ -136,26 +138,6 @@ instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (HashedPassword '
|
||||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
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
|
-- For HTTP
|
||||||
deriving anyclass instance ToJSON NewUser
|
deriving anyclass instance ToJSON NewUser
|
||||||
deriving anyclass instance FromJSON NewUser
|
deriving anyclass instance FromJSON NewUser
|
||||||
|
|
Loading…
Reference in a new issue