From bdd21806dc1e4a9fd2e98572d9ce39059f5e8de7 Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Sat, 13 Apr 2019 15:10:46 +0200 Subject: [PATCH] updated and compiling --- aggreact.cabal | 3 ++- src/Aggreact/Authorization.hs | 18 ++++++++++------ src/Aggreact/Comments/Server.hs | 6 ++++-- src/Aggreact/Comments/Views.hs | 19 +++++++++-------- src/Aggreact/User.hs | 38 +++++++++++++++++++++++---------- 5 files changed, 54 insertions(+), 30 deletions(-) diff --git a/aggreact.cabal b/aggreact.cabal index 3e24a61..981f5a4 100644 --- a/aggreact.cabal +++ b/aggreact.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: cd60f98ce5adc1993e4769824e33298d5d80b96bd03e156d69698fae38f4ef5c +-- hash: 1163db1a07517ee5befaea65db6a11d03a31e0d35b88dd576c76cf3c9506866c name: aggreact version: 0.1.0.0 @@ -39,6 +39,7 @@ library Aggreact.Css Aggreact.Homepage Aggreact.Html + Aggreact.Scopes Aggreact.User Database.Store Database.Store.Backend.SQLite diff --git a/src/Aggreact/Authorization.hs b/src/Aggreact/Authorization.hs index 2b8f614..7946230 100644 --- a/src/Aggreact/Authorization.hs +++ b/src/Aggreact/Authorization.hs @@ -40,7 +40,7 @@ import qualified Data.Set as Set import qualified Data.Text as Text import Database.Store (Entity (..)) import Servant (Handler) -import Servant.Errors (unauthorized) +import Servant.Errors (forbidden) data AuthorizationStrategy = Anybody @@ -56,8 +56,11 @@ data AuthorizationHandler = newAuthorizationHandler :: AuthorizationStrategy -> IO AuthorizationHandler newAuthorizationHandler as = pure AuthorizationHandler - { filterAccess = _filterAccess as - , hasScope = _hasScope as + { filterAccess = \ s mu -> + if hasScope' as s mu + then return () + else forbidden "You don't have the permission to do that" + , hasScope = hasScope' as } strToScope :: Text -> Maybe Scope @@ -88,7 +91,8 @@ unloggedScopes LoggedInOnly = & fmap Set.fromList & fromMaybe Set.empty -scopesFor u Anybody = +scopesFor :: NewUser -> AuthorizationStrategy -> Set Scope +scopesFor _ Anybody = [ "comment" , "homepage"] & traverse strToScope @@ -107,6 +111,6 @@ scopesFor u LoggedInOnly = & 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) +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 44ea446..f117b13 100644 --- a/src/Aggreact/Comments/Server.hs +++ b/src/Aggreact/Comments/Server.hs @@ -36,11 +36,11 @@ import Protolude -------------------------------------------------------------------------------- import Aggreact.Authorization (Access (..), - AuthorizationHandler (..), - Scope (..)) + AuthorizationHandler (..)) import Aggreact.Comments.StoreService (CommentHandler (..)) import Aggreact.Comments.Types import Aggreact.Comments.Views +import Aggreact.Scopes (Scope (..)) import Aggreact.User (User, UserHandler (..)) -------------------------------------------------------------------------------- @@ -93,6 +93,7 @@ showComments muser AuthorizationHandler{..} CommentHandler{..} s = do , viewTime = now , comments = IxSet.fromList cvs , muser = muser + , canComment = hasScope (Scope "comment" Read) muser } showSlugs :: Maybe User -> AuthorizationHandler -> CommentHandler -> Handler [Slug] @@ -113,6 +114,7 @@ showComment muser AuthorizationHandler{..} CommentHandler{..} i = do , commentPageViewTime = now , commentPageComment = c , muser = muser + , canComment = hasScope (Scope "comment" Read) muser } _ -> notFound "" diff --git a/src/Aggreact/Comments/Views.hs b/src/Aggreact/Comments/Views.hs index ddd8411..50437cf 100644 --- a/src/Aggreact/Comments/Views.hs +++ b/src/Aggreact/Comments/Views.hs @@ -1,4 +1,4 @@ - {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -84,7 +84,7 @@ instance H.ToMarkup CommentPage where H.text " for " extlink sl sl displayComment commentPageComment commentPageViewTime (pure ()) - commentForm sl (fmap (nick . val) muser) (Just (cvt cid)) + commentForm canComment sl (fmap (toS. nick . val) muser) (Just (cvt cid)) -- * Created Comment Page @@ -116,10 +116,11 @@ instance H.ToMarkup CreatedComment where data CommentsPage = CommentsPage - { url :: Text - , viewTime :: UTCTime - , comments :: CommentViews - , muser :: Maybe User + { url :: Text + , viewTime :: UTCTime + , comments :: CommentViews + , muser :: Maybe User + , canComment :: Bool } instance ToJSON CommentsPage where @@ -132,12 +133,12 @@ instance H.ToMarkup CommentsPage where H.h2 $ do H.text "Comments for " H.a ! A.href (cvt url) $ H.text url - commentForm url (fmap (nick . val) muser) Nothing + commentForm canComment url (fmap (toS . nick . val) muser) Nothing H.ul $ traverse_ (showChildren comments viewTime) (IxSet.toList roots) commentForm :: StringConv a [Char] => Bool -> a -> Maybe Text -> Maybe H.AttributeValue -> H.Html -commentForm False _ _ = H.div (H.i (H.text "Please login to comment.")) -commentForm True slug Nothing mparent = commentForm True slug "anonymous coward" mparent +commentForm False _ _ _ = H.div (H.i (H.text "Please login to comment.")) +commentForm True slug Nothing mparent = commentForm True slug (Just "anonymous coward") mparent commentForm True slug (Just userNick) mparent = H.form ! A.action "/comments" ! A.method "post" $ do H.input ! A.type_ "hidden" ! A.name "userid" ! A.value (cvt userNick) diff --git a/src/Aggreact/User.hs b/src/Aggreact/User.hs index affc6dd..86e6215 100644 --- a/src/Aggreact/User.hs +++ b/src/Aggreact/User.hs @@ -42,15 +42,12 @@ where import Protolude hiding (pass) -import Aggreact.Scopes (Access (..), Scope (..), Scopes) - import Aggreact.Html (boilerplate, cvt, urlEncode) - import qualified Crypto.Scrypt as Crypt import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Data (Data (..)) -import qualified Data.Set as Set +import qualified Data.Text as Text import qualified Data.UUID as UUID import Database.SQLite.Simple (NamedParam (..), SQLData (..)) @@ -85,7 +82,7 @@ data NewUser = NewUser { nick :: Nick , email :: Email , password :: HashedPassword - , scopes :: Scopes + , role :: Role , trust :: Int } deriving (Eq,Ord,Data,Typeable,Generic,Show) instance Form.FromForm NewUser where @@ -103,6 +100,28 @@ instance StringConv Nick Text where strConv l (Nick sl) = strConv l sl instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Nick ': rest) where 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 x = + case fmap Text.toLower (FormI.parseUrlPiece x) of + Right "user" -> return User + Right "admin" -> return Admin + Right _ -> Left "Should be either user or admin" + Left err -> Left err +instance FromField Role where + fromField f = case fieldData f of + SQLText "User" -> return User + SQLText "Admin" -> return Admin + _ -> returnError ConversionFailed f "need a text containing User or Admin" +instance ToField Role where + toField Admin = SQLText "Admin" + toField User = SQLText "User" +instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Role ': rest) where + toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) + newtype Email = Email Text deriving (Eq,Ord,Data,Typeable,Generic,Show) deriving anyclass instance FromJSON Email @@ -116,12 +135,9 @@ instance StringConv Email Text where strConv l (Email sl) = strConv l sl instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Email ': rest) where toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest) -adminScopes = Set.fromList [ Scope "user" Write - , Scope "comment" Write - , Scope "admin" Write ] - -defaultAdminUser :: NewUser -defaultAdminUser = NewUser { scopes = adminScopes +defaultAdminUser :: NewUser +defaultAdminUser = NewUser { role = Admin + , trust = 100 , nick = Nick "admin" , email = Email "admin@dev.null" , password = HashedPassword "admin"}