Better Auth Strategy algorithm

.envrc

@@ -1 +0,0 @@
-use_nix

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 ()
+strToScope :: Text -> Maybe Scope
-_checkAccess Anybody (Scope _ Read) _ = pure ()
+strToScope txt =
-_checkAccess Anybody (Scope _ Write) _ = pure ()
+  Scope <$> Just (Text.takeWhile (/= sep) txt)
-_checkAccess Anybody (Scope _ AdminAccess) (Just (Entity _ u _)) =
+        <*> accessValue
-  case role u of
+  where
-    Admin -> pure ()
+    accessTxt = Text.dropWhile (/= sep) txt
-    _     -> unauthorized "Need admin privilege"
+    sep = ':'
-_checkAccess Anybody (Scope _ AdminAccess) _ =
+    accessValue = case accessTxt of
-  unauthorized "Need admin privilege"
+      ":read" -> Just Read
+      ":write" -> Just Write
+      "" -> Just Write
+      _ -> Nothing
 
-_checkAccess LoggedInOnly (Scope _ Read) Nothing = pure ()
+unloggedScopes :: AuthorizationStrategy -> Scopes
-_checkAccess LoggedInOnly (Scope _ _) Nothing = unauthorized "You must log in"
+unloggedScopes Anybody =
-_checkAccess LoggedInOnly (Scope _ Read) (Just _) = pure ()
+  [ "comment"
-_checkAccess LoggedInOnly (Scope _ Write) (Just _) = pure ()
+  , "stub"]
-_checkAccess LoggedInOnly (Scope _ AdminAccess) (Just (Entity _ u _)) =
+  & traverse strToScope
-  case role u of
+  & fmap Set.fromList
-    Admin -> pure ()
+  & fromMaybe Set.empty
-    _     -> unauthorized "Only for admins"
 
-_checkAccess ProgressiveTrust (Scope _ Read) Nothing = pure ()
+unloggedScopes LoggedInOnly =
-_checkAccess ProgressiveTrust (Scope _ _) Nothing = unauthorized "You must log in"
+  [ "comment:read"
-_checkAccess ProgressiveTrust (Scope _ Read) (Just _) = pure ()
+  , "stub:read"]
-_checkAccess ProgressiveTrust (Scope _ Write) (Just _) = pure ()
+  & traverse strToScope
-_checkAccess ProgressiveTrust (Scope _ AdminAccess) (Just (Entity _ u _)) =
+  & fmap Set.fromList
-  case role u of
+  & fromMaybe Set.empty
-    Admin -> pure ()
+
-    _     -> unauthorized "Only for admins"
+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)

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

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