From a213ce9ba56f707d5b2c213e4c7ecbdee01e7f9b Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Fri, 5 Apr 2019 00:10:48 +0200 Subject: [PATCH] Better Auth Strategy algorithm --- .envrc | 1 - src/Aggreact/Authorization.hs | 90 ++++++++++++++++++++++----------- src/Aggreact/Comments/Server.hs | 8 +-- src/Aggreact/User.hs | 24 ++------- 4 files changed, 67 insertions(+), 56 deletions(-) delete mode 100644 .envrc diff --git a/.envrc b/.envrc deleted file mode 100644 index 4a4726a..0000000 --- a/.envrc +++ /dev/null @@ -1 +0,0 @@ -use_nix diff --git a/src/Aggreact/Authorization.hs b/src/Aggreact/Authorization.hs index 8f96aa7..f2b0ec5 100644 --- a/src/Aggreact/Authorization.hs +++ b/src/Aggreact/Authorization.hs @@ -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) diff --git a/src/Aggreact/Comments/Server.hs b/src/Aggreact/Comments/Server.hs index d0382b6..44ea446 100644 --- a/src/Aggreact/Comments/Server.hs +++ b/src/Aggreact/Comments/Server.hs @@ -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 })) diff --git a/src/Aggreact/User.hs b/src/Aggreact/User.hs index 192023f..3a7b748 100644 --- a/src/Aggreact/User.hs +++ b/src/Aggreact/User.hs @@ -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