diff --git a/backend/src/Datarekisteri/Backend.hs b/backend/src/Datarekisteri/Backend.hs index c9db1e1..0ff2f3e 100644 --- a/backend/src/Datarekisteri/Backend.hs +++ b/backend/src/Datarekisteri/Backend.hs @@ -114,7 +114,7 @@ authBearer Nothing m = m authBearer (Just (BearerToken bearer)) m = do let getUserPermissions = do Right DBToken {..} <- lift $ dbGetTokenBySecret bearer - permissions' <- fromMaybe mempty . readPermission <$> lift dbTokenPermissions + permissions' <- lift dbTokenPermissions DBUser {..} <- lift dbTokenUser userID <- lift dbUserId pure (Just userID, permissions') @@ -140,8 +140,7 @@ authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a authBasic Nothing m = m authBasic (Just basic) m = do DBUser {..} <- verifyBasic basic - permissions <- readPermission <$> lift dbUserPermissions >>= - fromMaybeFail status500 "Internal server error" + permissions <- lift dbUserPermissions userID <- lift dbUserId flip local m $ \state -> state { stateCurrentUser = Just userID @@ -166,7 +165,7 @@ newtype APIM a = APIM (ReaderT RequestState IO a) data RequestState = RequestState { stateCurrentUser :: Maybe UserID - , statePermissions :: Map Scope Permission + , statePermissions :: Permissions , stateConfig :: Config } @@ -214,28 +213,13 @@ instance MonadRandom APIM where getRandomBytes = liftIO . getRandomBytes instance MonadPermissions APIM where - currentPermissions = show <$> asks statePermissions - defaultPermissions = pure $ show $ (fromList [(OwnProfile, ReadWrite)] :: Map Scope Permission) - toPermissions = pure . fmap show . readPermission - hasPermission scope permission = (>= permission) <$> findPermission scope - where findPermission :: Scope -> APIM Permission - findPermission scope@(Profile user) = selfPermissions scope user OwnProfile - findPermission scope@(Tokens user) = selfPermissions scope user OwnTokens - findPermission scope = findPermission' scope <$> asks statePermissions - findPermission' :: Scope -> Map Scope Permission -> Permission - findPermission' = findWithDefault None - selfPermissions :: Scope -> UserID -> Scope -> APIM Permission - selfPermissions scope user own = do - isSelf <- (Just user ==) <$> currentUser - let f = if isSelf then max <$> findPermission' own <*> findPermission' scope - else findPermission' scope - - f <$> asks statePermissions + currentPermissions = asks statePermissions + defaultPermissions = pure $ Permissions $ fromList [(OwnProfile, ReadWrite)] runAPIM :: Config -> APIM a -> IO a runAPIM config (APIM m) = runReaderT m RequestState { stateCurrentUser = Nothing - , statePermissions = fromList [] + , statePermissions = Permissions $ fromList [] , stateConfig = config } diff --git a/backend/src/Datarekisteri/Backend/API.hs b/backend/src/Datarekisteri/Backend/API.hs index e559dd0..6e9d6cf 100644 --- a/backend/src/Datarekisteri/Backend/API.hs +++ b/backend/src/Datarekisteri/Backend/API.hs @@ -24,6 +24,7 @@ import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom) import qualified "base64" Data.ByteString.Base64 as B64 import Control.Monad.Except (MonadError, throwError, catchError) +import qualified Data.Map as Map import Data.Morpheus.Server (deriveApp, runApp) import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined) import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App) @@ -108,7 +109,7 @@ newTokenArgsToData :: (MonadRandom m, MonadTime m, MonadPermissions m) => newTokenArgsToData NewTokenArgs {..} user = do tokenData <- B64.encodeBase64 <$> getRandomBytes 128 issued <- currentTime - permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions + permissions <- maybe currentPermissions pure $ inputPermissionsToPermissions <$> permissions let expires = Nothing pure NewTokenData {..} @@ -155,7 +156,7 @@ resolveQuery = Query , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >> (Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing) , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications - , permissions = currentPermissions + , permissions = fromPermissions <$> currentPermissions } resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m, @@ -209,7 +210,7 @@ data NewKeyArgs = NewKeyArgs { comment :: Maybe Text, keyData :: Base64, expires deriving (Generic, GQLType, Eq, Show) data NewTokenArgs = NewTokenArgs - { comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe Text } + { comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe [InputScopePermission] } deriving (Generic, GQLType) data User m = User @@ -223,7 +224,7 @@ data User m = User , homeplace :: m Text , registered :: m Time , accepted :: m (Maybe Time) - , permissions :: m Text + , permissions :: m [ScopePermission] , isMember :: m Bool , application :: m Text , tokens :: m [Token m] @@ -246,14 +247,14 @@ data Token m = Token , comment :: m Text , issued :: m Time , expires :: m (Maybe Time) - , permissions :: m Text + , permissions :: m [ScopePermission] } deriving (Generic, GQLType) data Query m = Query { users :: m [User m] , user :: Arg "id" (Maybe UserID) -> m (Maybe (User m)) , applications :: m [User m] - , permissions :: m Text + , permissions :: m [ScopePermission] } deriving (Generic, GQLType) data Mutation m = Mutation @@ -279,7 +280,7 @@ dbUserToUser DBUser {..} = User , homeplace = dbUserHomeplace , registered = dbUserRegistered , accepted = dbUserAccepted - , permissions = dbUserPermissions + , permissions = fromPermissions <$> dbUserPermissions , isMember = isJust <$> dbUserAccepted , application = dbUserApplication , tokens = dbUserId >>= flip requirePermission ReadOnly . Tokens >> map dbTokenToToken <$> dbUserTokens @@ -304,5 +305,19 @@ dbTokenToToken DBToken {..} = Token , comment = dbTokenComment , issued = dbTokenIssued , expires = dbTokenExpires - , permissions = dbTokenPermissions + , permissions = fromPermissions <$> dbTokenPermissions } + +inputPermissionsToPermissions :: [InputScopePermission] -> Permissions +inputPermissionsToPermissions = Permissions . + Map.fromList . map (\InputScopePermission {..} -> (scope, permission)) + +fromPermissions :: Permissions -> [ScopePermission] +fromPermissions (Permissions perms) = + map (\(scope, permission) -> ScopePermission scope permission) $ Map.toList perms + +data InputScopePermission = InputScopePermission {scope :: Scope, permission :: Permission} + deriving (Generic, GQLType, Eq, Show) + +data ScopePermission = ScopePermission {scope :: Scope, permission :: Permission} + deriving (Generic, GQLType) diff --git a/backend/src/Datarekisteri/Backend/Sql/Queries.hs b/backend/src/Datarekisteri/Backend/Sql/Queries.hs index 3a8f010..ab70dd6 100644 --- a/backend/src/Datarekisteri/Backend/Sql/Queries.hs +++ b/backend/src/Datarekisteri/Backend/Sql/Queries.hs @@ -6,6 +6,7 @@ module Datarekisteri.Backend.Sql.Queries where +import Control.Monad (void) import Control.Monad.Logger (LoggingT) import Data.Aeson (fromJSON, toJSON, Result(..)) import Data.Maybe (listToMaybe) @@ -46,11 +47,11 @@ getKeys user = select $ do getKey :: KeyID -> SqlM (Maybe SqlKey) getKey = get . fromID -getPermissions :: UserID -> SqlM (Maybe Text) +getPermissions :: UserID -> SqlM (Maybe Permissions) getPermissions user = fmap (fmap sqlUserPermissions) $ get $ fromID user -setPermissions :: UserID -> Text -> SqlM () -setPermissions user txt = updateUserData user [SqlUserPermissions Persist.=. txt] [] >> return () +setPermissions :: UserID -> Permissions -> SqlM () +setPermissions user permissions = void $ updateUserData user [SqlUserPermissions Persist.=. permissions] [] getPrimaryKey :: UserID -> SqlM (Maybe (Entity SqlKey)) getPrimaryKey user = fmap listToMaybe $ select $ do diff --git a/backend/src/Datarekisteri/Backend/Sql/Types.hs b/backend/src/Datarekisteri/Backend/Sql/Types.hs index 95ab18a..ad5f03d 100644 --- a/backend/src/Datarekisteri/Backend/Sql/Types.hs +++ b/backend/src/Datarekisteri/Backend/Sql/Types.hs @@ -28,7 +28,7 @@ mkPersist sqlSettings [persistUpperCase| SqlUser sql=users registered Time passwordCrypt PasswordHash - permissions Text + permissions Permissions accepted (Maybe Time) memberData Value sqltype=jsonb @@ -68,7 +68,7 @@ SqlToken sql=tokens comment Text issued Time expires (Maybe Time) - permissions Text + permissions Permissions UniqueNameUid name uid UniqueData data diff --git a/backend/src/Datarekisteri/Backend/Types.hs b/backend/src/Datarekisteri/Backend/Types.hs index 73b98da..01c7536 100644 --- a/backend/src/Datarekisteri/Backend/Types.hs +++ b/backend/src/Datarekisteri/Backend/Types.hs @@ -36,7 +36,7 @@ forward :: Monad m => [a] -> m [Maybe a] forward = pure . map Just requirePermission :: (MonadPermissions m, MonadError GQLError m) => Scope -> Permission -> m () -requirePermission scope permission = unlessM (hasPermission scope permission) $ +requirePermission scope permission = unlessM (hasPermission scope permission <$> currentPermissions) $ throwError $ "Insufficient permissions, " <> show permission <> " for " <> show scope <> " required." @@ -64,7 +64,7 @@ data ApplicationData = ApplicationData , registered :: Time , verificationSecret :: Text , passwordHash :: PasswordHash - , permissions :: Text + , permissions :: Permissions } deriving (Generic, Eq, Show) data UpdateData = UpdateData @@ -99,7 +99,7 @@ data Page a m = Page { pageData :: m a, cursor :: m (Maybe Cursor) } data NewTokenData = NewTokenData { comment :: Maybe Text , name :: Maybe Text - , permissions :: Text + , permissions :: Permissions , tokenData :: Text , issued :: Time , expires :: Maybe Time @@ -122,7 +122,7 @@ data DBUser m = DBUser , dbUserHomeplace :: m Text , dbUserRegistered :: m Time , dbUserAccepted :: m (Maybe Time) - , dbUserPermissions :: m Text + , dbUserPermissions :: m Permissions , dbUserApplication :: m Text , dbUserPasswordHash :: m PasswordHash , dbUserTokens :: m [DBToken m] @@ -146,7 +146,7 @@ data DBToken m = DBToken , dbTokenComment :: m Text , dbTokenIssued :: m Time , dbTokenExpires :: m (Maybe Time) - , dbTokenPermissions :: m Text + , dbTokenPermissions :: m Permissions } class Monad m => MonadTime m where @@ -180,10 +180,8 @@ class Monad m => MonadRequest m where currentUser :: m (Maybe UserID) class Monad m => MonadPermissions m where - hasPermission :: Scope -> Permission -> m Bool - currentPermissions :: m Text - defaultPermissions :: m Text - toPermissions :: Text -> m (Maybe Text) + currentPermissions :: m Permissions + defaultPermissions :: m Permissions instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where dbUpdateUser = fmap (fmap liftUser) . lift . dbUpdateUser @@ -204,10 +202,8 @@ instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) whe currentUser = lift currentUser instance (MonadPermissions m, LiftOperation o) => MonadPermissions (Resolver o () m) where - hasPermission scope permission = lift $ hasPermission scope permission defaultPermissions = lift defaultPermissions currentPermissions = lift currentPermissions - toPermissions = lift . toPermissions instance (MonadEmail m, LiftOperation o) => MonadEmail (Resolver o () m) where sendEmail = lift . sendEmail diff --git a/backend/src/Datarekisteri/CLI.hs b/backend/src/Datarekisteri/CLI.hs index 9662402..7f6cf34 100644 --- a/backend/src/Datarekisteri/CLI.hs +++ b/backend/src/Datarekisteri/CLI.hs @@ -43,7 +43,7 @@ addUserMain AddUserOpts {..} = do userID <- Sql.addUser $ SqlUser { sqlUserRegistered = time , sqlUserPasswordCrypt = passwordHash - , sqlUserPermissions = show addUserPermissions + , sqlUserPermissions = addUserPermissions , sqlUserAccepted = Just time , sqlUserMemberData = toJSON $ MemberData { nickname = addUserNickname @@ -82,7 +82,7 @@ updateUserMain UpdateUserOpts {..} = runQuery $ do Just application -> Sql.updateUserData updateUserId [] [Sql.SetUserApplication application] case updateUserPermissions of Nothing -> pure () - Just permissions -> Sql.setPermissions updateUserId $ show permissions + Just permissions -> Sql.setPermissions updateUserId permissions cliOptions :: Parser CLIOptions cliOptions = CLIOptions @@ -114,8 +114,8 @@ updateUserCommand = fmap UpdateUser $ UpdateUserOpts <*> optional (strOption (long "application" <> metavar "TEXT")) <*> optional permissionsParser -permissionsParser :: Parser (Map Scope Permission) -permissionsParser = fromList <$> many permissionParser +permissionsParser :: Parser Permissions +permissionsParser = Permissions . fromList <$> many permissionParser permissionParser :: Parser (Scope, Permission) permissionParser = (,) @@ -136,7 +136,7 @@ data CLISubCommand = AddUser AddUserOpts data UpdateUserOpts = UpdateUserOpts { updateUserId :: UserID , updateUserApplication :: Maybe Text - , updateUserPermissions :: Maybe (Map Scope Permission) + , updateUserPermissions :: Maybe Permissions } data AddUserOpts = AddUserOpts @@ -146,7 +146,7 @@ data AddUserOpts = AddUserOpts , addUserHomeplace :: Text , addUserPhoneNumber :: PhoneNumber , addUserEmail :: Email - , addUserPermissions :: Map Scope Permission + , addUserPermissions :: Permissions , addUserApplication :: Text } diff --git a/core/src/Datarekisteri/Core/Types.hs b/core/src/Datarekisteri/Core/Types.hs index 39de52e..48d4d42 100644 --- a/core/src/Datarekisteri/Core/Types.hs +++ b/core/src/Datarekisteri/Core/Types.hs @@ -22,7 +22,7 @@ module Datarekisteri.Core.Types , addTime , base64Decode , base64Encode - , readPermission + , hasPermission , renderDate , renderEmail , renderPhoneNumber @@ -40,6 +40,7 @@ import qualified "base64" Data.ByteString.Base64 as B64 import Data.Aeson (Value, ToJSON(..), FromJSON(..), Result(..), ToJSONKey(..), FromJSONKey(..), FromJSONKeyFunction(..), ToJSONKeyFunction(..), fromJSON, eitherDecodeStrict) import Data.Aeson.Encoding (string) import Data.Char (isSpace) +import qualified Data.Map as Map import Data.Morpheus.Server.Types (SCALAR, TYPE) import Data.Morpheus.Types (GQLType, DecodeScalar(..), KIND, EncodeScalar(..), ScalarValue(..)) import Data.Morpheus.Types.GQLScalar (scalarToJSON, scalarFromJSON) @@ -120,6 +121,10 @@ instance GQLType Permission where type KIND Permission = SCALAR instance ToJSON Permission where toJSON = scalarToJSON instance FromJSON Permission where parseJSON = scalarFromJSON <=< parseJSON +hasPermission :: Scope -> Permission -> Permissions -> Bool +hasPermission scope permission (Permissions permissionMap) = + Map.findWithDefault None scope permissionMap >= permission + newtype Permissions = Permissions (Map Scope Permission) deriving (Show, Eq, Read, Generic, ToJSON, FromJSON, Semigroup, Monoid) @@ -137,9 +142,6 @@ instance Ord Permissions where (Permissions a) <= (Permissions b) = and $ Map.intersectionWith (<=) a $ b <> (const None <$> Map.difference a b) -readPermission :: Text -> Maybe Permissions -readPermission = rightToMaybe . readEither . toString - newtype PhoneNumber = PhoneNumber Text deriving (Show, Generic) renderPhoneNumber :: PhoneNumber -> Text diff --git a/frontend/schema.gql b/frontend/schema.gql index 6a4e652..6395c25 100644 --- a/frontend/schema.gql +++ b/frontend/schema.gql @@ -6,8 +6,12 @@ scalar Email scalar KeyID +scalar Permission + scalar PhoneNumber +scalar Scope + scalar Time scalar TokenID @@ -19,6 +23,11 @@ enum Unit { Unit2 } +input InputScopePermission { + scope: Scope! + permission: Permission! +} + type PGPKey { id: KeyID! pgpKeyData: Base64! @@ -27,6 +36,11 @@ type PGPKey { comment: String! } +type ScopePermission { + scope: Scope! + permission: Permission! +} + type Token { id: TokenID! name: String @@ -34,7 +48,7 @@ type Token { comment: String! issued: Time! expires: Time - permissions: String! + permissions: [ScopePermission!]! } type User { @@ -48,7 +62,7 @@ type User { homeplace: String! registered: Time! accepted: Time - permissions: String! + permissions: [ScopePermission!]! isMember: Boolean! application: String! tokens: [Token!]! @@ -60,7 +74,7 @@ type Query { users: [User!]! user(id: UserID): User applications: [User!]! - permissions: String! + permissions: [ScopePermission!]! } type Mutation { @@ -68,7 +82,7 @@ type Mutation { verifyEmail(secret: String!): Boolean! resendVerificationEmail(user: UserID): Unit! update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, application: String, user: UserID): User! - newToken(comment: String, name: String, permissions: String): Token! + newToken(comment: String, name: String, permissions: [InputScopePermission!]): Token! newKey(comment: String, keyData: Base64!, expires: Time): PGPKey! accept(user: UserID!): Unit! reject(user: UserID!): Unit! diff --git a/frontend/src/Datarekisteri/Frontend/Types.hs b/frontend/src/Datarekisteri/Frontend/Types.hs index edd08b2..62d7a73 100644 --- a/frontend/src/Datarekisteri/Frontend/Types.hs +++ b/frontend/src/Datarekisteri/Frontend/Types.hs @@ -29,10 +29,12 @@ import Yesod import Yesod.Auth import Yesod.Static -import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission) +import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), Permissions(..)) import Datarekisteri.Frontend.ApiRequests import Datarekisteri.Frontend.Auth +import qualified Datarekisteri.Core.Types as Core + data DataIdClient = DataIdClient { getStatic :: Static , getConfig :: Config @@ -70,7 +72,10 @@ mkYesodData "DataIdClient" [parseRoutes| declareLocalTypesInline "schema.gql" [raw| query GetPermissions { - permissions + permissions { + scope + permission + } user { id } @@ -98,18 +103,20 @@ instance YesodAuth DataIdClient where withAuthenticated :: (AuthId DataIdClient -> Handler AuthResult) -> Handler AuthResult withAuthenticated m = maybeAuthId >>= maybe (pure AuthenticationRequired) m +readPermissions :: [GetPermissionsPermissions] -> Permissions +readPermissions = Permissions . fromList . map (\GetPermissionsPermissions {..} -> (scope, permission)) + hasPermission :: Scope -> Permission -> Handler Bool hasPermission scope permission = do GetPermissions {..} <- apiRequest @GetPermissions False () - let permissionMap = fromMaybe mempty $ readPermission permissions - findPermission scope = findWithDefault None scope permissionMap + let permissions' = readPermissions permissions userID = (\x -> id (x :: GetPermissionsUser)) <$> user scopes = scope :| case scope of Tokens uid | Just uid == userID -> [OwnTokens] Profile uid | Just uid == userID -> [OwnProfile] _ -> [] -- TODO add Members and Applications to Profile Scopes if profile owner is member/applicant - pure $ (>= permission) $ maximum1 $ findPermission <$> scopes + pure $ any (\scope -> Core.hasPermission scope permission permissions') scopes requirePermission :: Scope -> Permission -> Handler AuthResult requirePermission scope permission = ifM (hasPermission scope permission)