Enable updating applications

backend/src/Datarekisteri/Backend/API.hs

@@ -82,12 +82,14 @@ sendVerificationSecret DBUser {..} = do
           sendVerificationEmail secret' pendingEmail' >> pure True
       _ -> pure False
 
-updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m) =>
+updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB 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
+    when (isMember && isJust application) $ throwError "Members can't update their applications"
     passwordHash <- sequence $ hashPassword <$> password
     updateTime <- currentTime
     verificationSecret <- genVerificationSecret
@@ -200,6 +202,7 @@ data UpdateArgs = UpdateArgs
     , name :: Maybe Text
     , nickname :: Maybe Text
     , homeplace :: Maybe Text
+    , application :: Maybe Text
     } deriving (Generic, GQLType, Eq, Show)
 
 data NewKeyArgs = NewKeyArgs { comment :: Maybe Text, keyData :: Base64, expires :: Maybe Time }

backend/src/Datarekisteri/Backend/Sql.hs

@@ -29,6 +29,7 @@ dbUpdateUser UpdateData {..} = do
             , SetUserNickname . Just <$> nickname
             , SetUserHomeplace <$> homeplace
             , SetUserPhoneNumber <$> phoneNumber
+            , SetUserApplication <$> application
             ]
         userUpdates = maybeToList $ (SqlUserPasswordCrypt =.) <$> passwordHash
     sqlUser <- runQuery $ do

backend/src/Datarekisteri/Backend/Sql/Queries.hs

@@ -229,9 +229,11 @@ updateUserData user updates memberDataUpdates = do
         updateData (SetUserNickname x) memberData = memberData { nickname = x }
         updateData (SetUserHomeplace x) memberData = memberData { homeplace = x }
         updateData (SetUserPhoneNumber x) memberData = memberData { phoneNumber = x }
+        updateData (SetUserApplication x) memberData = memberData { application = x }
     Persist.update key (userUpdates <> updates)
 
 data UserUpdate = SetUserName Text
                 | SetUserNickname (Maybe Text)
                 | SetUserHomeplace Text
                 | SetUserPhoneNumber PhoneNumber
+                | SetUserApplication Text

backend/src/Datarekisteri/Backend/Types.hs

@@ -74,6 +74,7 @@ data UpdateData = UpdateData
     , name :: Maybe Text
     , nickname :: Maybe Text
     , homeplace :: Maybe Text
+    , application :: Maybe Text
     , user :: UserID
     , updateTime :: Time
     , verificationSecret :: Text

frontend/schema.gql

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

frontend/src/Datarekisteri/Frontend/FormFields.hs

@@ -42,6 +42,9 @@ telephoneField = Field
     , fieldEnctype = UrlEncoded
     }
 
+textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
+    Textarea textareaField
+
 verifiedPasswordField :: Field Handler Text
 verifiedPasswordField = Field
     { fieldParse = \rawValues _ ->

frontend/src/Datarekisteri/Frontend/Handlers/Apply.hs

@@ -48,8 +48,6 @@ applyForm = renderDivs $ ApplyArgs
         where dayField' :: Field Handler Date
               dayField' = checkMMap (pure . Right . Date :: Day -> Handler (Either Text Date))
                   (\(Date x) -> x) dayField
-              textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
-                  Textarea textareaField
               nameSettings = "Nimi" {fsAttrs = [("placeholder","Erkki Juhani Esimerkki")]}
               nicknameSettings = "Kutsumanimi" {fsAttrs = [("placeholder","Juhani")]}
               homeplaceSettings = "Kotipaikka" {fsAttrs = [("placeholder","Espoo")]}

frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs

@@ -37,14 +37,15 @@ query ProfilePage($id: UserID) {
     birthdate
     phoneNumber
     isMember
+    application
   }
   permissions
 }
 |]
 
 declareLocalTypesInline "schema.gql" [raw|
-mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email, $phoneNumber: PhoneNumber) {
+mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email, $phoneNumber: PhoneNumber, $application: String) {
-  update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber) {
+  update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber, application: $application) {
     id
   }
 }
@@ -73,9 +74,12 @@ profileForm userID user extraHtml = do
         (maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in email) user)
     (phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero"
         (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in phoneNumber) user)
+    (applicationRes, applicationView) <- mopt textareaField' "Jäsenhakemus"
+        (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in application) user)
     let profileUpdateRes = UpdateProfileArgs userID <$>
-            nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes
+            nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes <*> applicationRes
         maybePendingEmail = user >>= \x -> let ProfilePageUser {..} = x in pendingEmail
+        canUpdateApplication = maybe False (\x -> let ProfilePageUser {..} = x in not isMember) user
         inputField FieldView {..} = [whamlet|
             <label for="#{fvId}">
                 ^{fvLabel}
@@ -93,6 +97,8 @@ profileForm userID user extraHtml = do
                     <a href="mailto:#{renderEmail pendingEmail}">#{renderEmail pendingEmail}
                     odottaa vahvistusta. #
                     <a href="@{VerifyEmailR}">Siirry vahvistamaan
+            $if canUpdateApplication
+                ^{inputField applicationView}
             |]
     return (profileUpdateRes, widget)