updated and compiling
This commit is contained in:
parent
fb40bb3f30
commit
bdd21806dc
5 changed files with 54 additions and 30 deletions
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: cd60f98ce5adc1993e4769824e33298d5d80b96bd03e156d69698fae38f4ef5c
|
-- hash: 1163db1a07517ee5befaea65db6a11d03a31e0d35b88dd576c76cf3c9506866c
|
||||||
|
|
||||||
name: aggreact
|
name: aggreact
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -39,6 +39,7 @@ library
|
||||||
Aggreact.Css
|
Aggreact.Css
|
||||||
Aggreact.Homepage
|
Aggreact.Homepage
|
||||||
Aggreact.Html
|
Aggreact.Html
|
||||||
|
Aggreact.Scopes
|
||||||
Aggreact.User
|
Aggreact.User
|
||||||
Database.Store
|
Database.Store
|
||||||
Database.Store.Backend.SQLite
|
Database.Store.Backend.SQLite
|
||||||
|
|
|
@ -40,7 +40,7 @@ import qualified Data.Set as Set
|
||||||
import qualified Data.Text as Text
|
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 (forbidden)
|
||||||
|
|
||||||
data AuthorizationStrategy =
|
data AuthorizationStrategy =
|
||||||
Anybody
|
Anybody
|
||||||
|
@ -56,8 +56,11 @@ data AuthorizationHandler =
|
||||||
newAuthorizationHandler :: AuthorizationStrategy -> IO AuthorizationHandler
|
newAuthorizationHandler :: AuthorizationStrategy -> IO AuthorizationHandler
|
||||||
newAuthorizationHandler as = pure
|
newAuthorizationHandler as = pure
|
||||||
AuthorizationHandler
|
AuthorizationHandler
|
||||||
{ filterAccess = _filterAccess as
|
{ filterAccess = \ s mu ->
|
||||||
, hasScope = _hasScope as
|
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
|
strToScope :: Text -> Maybe Scope
|
||||||
|
@ -88,7 +91,8 @@ unloggedScopes LoggedInOnly =
|
||||||
& fmap Set.fromList
|
& fmap Set.fromList
|
||||||
& fromMaybe Set.empty
|
& fromMaybe Set.empty
|
||||||
|
|
||||||
scopesFor u Anybody =
|
scopesFor :: NewUser -> AuthorizationStrategy -> Set Scope
|
||||||
|
scopesFor _ Anybody =
|
||||||
[ "comment"
|
[ "comment"
|
||||||
, "homepage"]
|
, "homepage"]
|
||||||
& traverse strToScope
|
& traverse strToScope
|
||||||
|
@ -107,6 +111,6 @@ scopesFor u LoggedInOnly =
|
||||||
& fmap Set.fromList
|
& fmap Set.fromList
|
||||||
& fromMaybe Set.empty
|
& fromMaybe Set.empty
|
||||||
|
|
||||||
_hasScope :: AuthorizationStrategy -> Scope -> Maybe User -> Bool
|
hasScope' :: AuthorizationStrategy -> Scope -> Maybe User -> Bool
|
||||||
_hasScope authStrat s Nothing = Set.member s (unloggedScopes authStrat)
|
hasScope' authStrat s Nothing = Set.member s (unloggedScopes authStrat)
|
||||||
_hasScope authStrat s (Just (Entity _ u _)) = Set.member s (scopesFor u authStrat)
|
hasScope' authStrat s (Just (Entity _ u _)) = Set.member s (scopesFor u authStrat)
|
||||||
|
|
|
@ -36,11 +36,11 @@ import Protolude
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Aggreact.Authorization (Access (..),
|
import Aggreact.Authorization (Access (..),
|
||||||
AuthorizationHandler (..),
|
AuthorizationHandler (..))
|
||||||
Scope (..))
|
|
||||||
import Aggreact.Comments.StoreService (CommentHandler (..))
|
import Aggreact.Comments.StoreService (CommentHandler (..))
|
||||||
import Aggreact.Comments.Types
|
import Aggreact.Comments.Types
|
||||||
import Aggreact.Comments.Views
|
import Aggreact.Comments.Views
|
||||||
|
import Aggreact.Scopes (Scope (..))
|
||||||
import Aggreact.User (User, UserHandler (..))
|
import Aggreact.User (User, UserHandler (..))
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -93,6 +93,7 @@ showComments muser AuthorizationHandler{..} CommentHandler{..} s = do
|
||||||
, viewTime = now
|
, viewTime = now
|
||||||
, comments = IxSet.fromList cvs
|
, comments = IxSet.fromList cvs
|
||||||
, muser = muser
|
, muser = muser
|
||||||
|
, canComment = hasScope (Scope "comment" Read) muser
|
||||||
}
|
}
|
||||||
|
|
||||||
showSlugs :: Maybe User -> AuthorizationHandler -> CommentHandler -> Handler [Slug]
|
showSlugs :: Maybe User -> AuthorizationHandler -> CommentHandler -> Handler [Slug]
|
||||||
|
@ -113,6 +114,7 @@ showComment muser AuthorizationHandler{..} CommentHandler{..} i = do
|
||||||
, commentPageViewTime = now
|
, commentPageViewTime = now
|
||||||
, commentPageComment = c
|
, commentPageComment = c
|
||||||
, muser = muser
|
, muser = muser
|
||||||
|
, canComment = hasScope (Scope "comment" Read) muser
|
||||||
}
|
}
|
||||||
_ -> notFound ""
|
_ -> notFound ""
|
||||||
|
|
||||||
|
|
|
@ -84,7 +84,7 @@ instance H.ToMarkup CommentPage where
|
||||||
H.text " for "
|
H.text " for "
|
||||||
extlink sl sl
|
extlink sl sl
|
||||||
displayComment commentPageComment commentPageViewTime (pure ())
|
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
|
-- * Created Comment Page
|
||||||
|
@ -120,6 +120,7 @@ data CommentsPage =
|
||||||
, viewTime :: UTCTime
|
, viewTime :: UTCTime
|
||||||
, comments :: CommentViews
|
, comments :: CommentViews
|
||||||
, muser :: Maybe User
|
, muser :: Maybe User
|
||||||
|
, canComment :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
instance ToJSON CommentsPage where
|
instance ToJSON CommentsPage where
|
||||||
|
@ -132,12 +133,12 @@ instance H.ToMarkup CommentsPage where
|
||||||
H.h2 $ do
|
H.h2 $ do
|
||||||
H.text "Comments for "
|
H.text "Comments for "
|
||||||
H.a ! A.href (cvt url) $ H.text url
|
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)
|
H.ul $ traverse_ (showChildren comments viewTime) (IxSet.toList roots)
|
||||||
|
|
||||||
commentForm :: StringConv a [Char] => Bool -> a -> Maybe Text -> Maybe H.AttributeValue -> H.Html
|
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 False _ _ _ = H.div (H.i (H.text "Please login to comment."))
|
||||||
commentForm True slug Nothing mparent = commentForm True slug "anonymous coward" mparent
|
commentForm True slug Nothing mparent = commentForm True slug (Just "anonymous coward") mparent
|
||||||
commentForm True slug (Just userNick) mparent =
|
commentForm True slug (Just userNick) mparent =
|
||||||
H.form ! A.action "/comments" ! A.method "post" $ do
|
H.form ! A.action "/comments" ! A.method "post" $ do
|
||||||
H.input ! A.type_ "hidden" ! A.name "userid" ! A.value (cvt userNick)
|
H.input ! A.type_ "hidden" ! A.name "userid" ! A.value (cvt userNick)
|
||||||
|
|
|
@ -42,15 +42,12 @@ where
|
||||||
|
|
||||||
import Protolude hiding (pass)
|
import Protolude hiding (pass)
|
||||||
|
|
||||||
import Aggreact.Scopes (Access (..), Scope (..), Scopes)
|
|
||||||
|
|
||||||
import Aggreact.Html (boilerplate, cvt, urlEncode)
|
import Aggreact.Html (boilerplate, cvt, urlEncode)
|
||||||
|
|
||||||
|
|
||||||
import qualified Crypto.Scrypt as Crypt
|
import qualified Crypto.Scrypt as Crypt
|
||||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||||
import Data.Data (Data (..))
|
import Data.Data (Data (..))
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Text as Text
|
||||||
import qualified Data.UUID as UUID
|
import qualified Data.UUID as UUID
|
||||||
import Database.SQLite.Simple (NamedParam (..),
|
import Database.SQLite.Simple (NamedParam (..),
|
||||||
SQLData (..))
|
SQLData (..))
|
||||||
|
@ -85,7 +82,7 @@ data NewUser =
|
||||||
NewUser { nick :: Nick
|
NewUser { nick :: Nick
|
||||||
, email :: Email
|
, email :: Email
|
||||||
, password :: HashedPassword
|
, password :: HashedPassword
|
||||||
, scopes :: Scopes
|
, role :: Role
|
||||||
, trust :: Int
|
, 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
|
||||||
|
@ -103,6 +100,28 @@ instance StringConv Nick Text where strConv l (Nick sl) = strConv l sl
|
||||||
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Nick ': rest) where
|
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Nick ': rest) where
|
||||||
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 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
|
newtype Email = Email Text
|
||||||
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
deriving (Eq,Ord,Data,Typeable,Generic,Show)
|
||||||
deriving anyclass instance FromJSON Email
|
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
|
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Email ': rest) where
|
||||||
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
|
||||||
|
|
||||||
adminScopes = Set.fromList [ Scope "user" Write
|
|
||||||
, Scope "comment" Write
|
|
||||||
, Scope "admin" Write ]
|
|
||||||
|
|
||||||
defaultAdminUser :: NewUser
|
defaultAdminUser :: NewUser
|
||||||
defaultAdminUser = NewUser { scopes = adminScopes
|
defaultAdminUser = NewUser { role = Admin
|
||||||
|
, trust = 100
|
||||||
, nick = Nick "admin"
|
, nick = Nick "admin"
|
||||||
, email = Email "admin@dev.null"
|
, email = Email "admin@dev.null"
|
||||||
, password = HashedPassword "admin"}
|
, password = HashedPassword "admin"}
|
||||||
|
|
Loading…
Reference in a new issue