updated and compiling

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

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
+  { 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
@@ -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' :: 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)

src/Aggreact/Comments/Server.hs

@@ -36,11 +36,11 @@ import           Protolude
 
 --------------------------------------------------------------------------------
 import           Aggreact.Authorization         (Access (..),
-                                                 AuthorizationHandler (..),
+                                                 AuthorizationHandler (..))
-                                                 Scope (..))
 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 ""
 

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
@@ -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 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 =
   H.form ! A.action "/comments" ! A.method "post" $ do
     H.input ! A.type_ "hidden" ! A.name "userid" ! A.value (cvt userNick)

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