Use Permissions type in the API

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
     }
 

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)

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

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

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

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
         }
 

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

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!

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)