yogsototh/aggreact
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

updated and compiling

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-04-13 15:10:46 +02:00
parent fb40bb3f30
commit bdd21806dc
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
5 changed files with 54 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
aggreact.cabal
View file

@ -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

18
src/Aggreact/Authorization.hs
View file

@ -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)

6
src/Aggreact/Comments/Server.hs
View file

@ -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 ""

11
src/Aggreact/Comments/Views.hs
View file

@ -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
@ -120,6 +120,7 @@ data CommentsPage =
, 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)

36
src/Aggreact/User.hs
View file

@ -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 { role = Admin
, trust = 100
, nick = Nick "admin"
, email = Email "admin@dev.null"
, password = HashedPassword "admin"}