Implement updating permissions

backend/src/Datarekisteri/Backend/API.hs

@@ -83,18 +83,24 @@ sendVerificationSecret DBUser {..} = do
           sendVerificationEmail secret' pendingEmail' >> pure True
       _ -> pure False
 
-updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m) =>
+updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m, MonadPermissions m) =>
     UpdateArgs -> UserID -> m UpdateData
 updateArgsToData UpdateArgs {..} user = do
     when (maybe False T.null name) $ throwError "Name must not be empty"
     when (maybe False T.null password) $ throwError "Password must not be empty"
     when (maybe False T.null homeplace) $ throwError "Homeplace must not be empty"
-    isMember <- dbGetUser user >>= liftDBEither >>= fmap isJust . dbUserAccepted
+    requestPermissions <- currentPermissions
+    let permissions' = inputPermissionsToPermissions <$> permissions
+    when (maybe False (> requestPermissions) permissions') $ throwError "Permissions must not be greater than the request's"
+    dbUser <- dbGetUser user >>= liftDBEither
+    isMember <- fmap isJust $ dbUserAccepted $ dbUser
     when (isMember && isJust application) $ throwError "Members can't update their applications"
     passwordHash <- sequence $ hashPassword <$> password
     updateTime <- currentTime
     verificationSecret <- genVerificationSecret
-    pure UpdateData {..}
+    oldPermissions <- dbUserPermissions dbUser
+    pure UpdateData {permissions = (<> oldPermissions) <$> permissions', ..}
+      -- Map's (and thus Permissions') <> prefers values from the left operand
 
 updateUser :: (MonadRandom m, MonadDB m, MonadEmail m,
     MonadError GQLError m, MonadTime m, MonadPermissions m) => UserID -> UpdateArgs -> m (User m)
@@ -204,6 +210,7 @@ data UpdateArgs = UpdateArgs
     , nickname :: Maybe Text
     , homeplace :: Maybe Text
     , application :: Maybe Text
+    , permissions :: Maybe [InputScopePermission]
     } deriving (Generic, GQLType, Eq, Show)
 
 data NewKeyArgs = NewKeyArgs { comment :: Maybe Text, keyData :: Base64, expires :: Maybe Time }

backend/src/Datarekisteri/Backend/Sql.hs

@@ -31,7 +31,10 @@ dbUpdateUser UpdateData {..} = do
             , SetUserPhoneNumber <$> phoneNumber
             , SetUserApplication <$> application
             ]
-        userUpdates = maybeToList $ (SqlUserPasswordCrypt =.) <$> passwordHash
+        userUpdates = catMaybes
+            [ (SqlUserPasswordCrypt =.) <$> passwordHash
+            , (SqlUserPermissions =.) <$> permissions
+            ]
     sqlUser <- runQuery $ do
         Sql.updateUserData user userUpdates memberDataUpdates
         case email of

backend/src/Datarekisteri/Backend/Types.hs

@@ -78,6 +78,7 @@ data UpdateData = UpdateData
     , user :: UserID
     , updateTime :: Time
     , verificationSecret :: Text
+    , permissions :: Maybe Permissions
     } deriving (Generic, Eq, Show)
 
 data NewKeyData = NewKeyData

frontend/schema.gql

@@ -81,7 +81,7 @@ type Mutation {
   apply(email: Email!, phoneNumber: PhoneNumber!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User!
   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!
+  update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, application: String, permissions: [InputScopePermission!], user: UserID): User!
   newToken(comment: String, name: String, permissions: [InputScopePermission!]): Token!
   newKey(comment: String, keyData: Base64!, expires: Time): PGPKey!
   accept(user: UserID!): Unit!