datarekisteri/Client/Handlers/Profile.hs

145 lines
5.6 KiB
Haskell
Raw Normal View History

2023-01-20 09:20:06 +02:00
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Client.Handlers.Profile where
import Relude hiding (id)
import Client.ApiRequests
import Client.Types
import Client.FormFields
import Data.Morpheus.Client
import Server.Types
import Yesod hiding (emailField)
import Yesod.Auth
declareLocalTypesInline "schema.gql" [raw|
query ProfilePage($id: UserID) {
user(id: $id) {
id
name
nickname
email
pendingEmail
homeplace
birthdate
2023-04-10 11:37:43 +03:00
phoneNumber
2023-01-20 09:20:06 +02:00
}
permissions
}
|]
declareLocalTypesInline "schema.gql" [raw|
2023-04-10 11:37:43 +03:00
mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email, $phoneNumber: PhoneNumber) {
update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber) {
2023-01-20 09:20:06 +02:00
id
}
}
|]
declareLocalTypesInline "schema.gql" [raw|
mutation UpdatePassword($user: UserID, $password: String!) {
update(user: $user, password: $password) {
id
}
}
|]
passwordForm :: Form Text
passwordForm = renderDivs $ areq verifiedPasswordField "Uusi salasana" Nothing
profileForm :: (Maybe UserID) -> (Maybe ProfilePageUser) -> Form UpdateProfileArgs
profileForm userID user extraHtml = do
2023-04-10 11:37:43 +03:00
(nameRes, nameView) <- mopt textField "Nimi"
2023-04-10 11:44:51 +03:00
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in name) user)
2023-04-10 11:37:43 +03:00
(homeRes, homeView) <- mopt textField "Kotipaikka"
2023-04-10 11:44:51 +03:00
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in homeplace) user)
2023-04-10 11:37:43 +03:00
(nicknameRes, nicknameView) <- mopt textField "Kutsumanimi"
2023-04-10 11:44:51 +03:00
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in nickname) user)
2023-04-10 11:37:43 +03:00
(emailRes, emailView) <- mopt emailField "Sähköposti"
2023-04-10 11:44:51 +03:00
(maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in email) user)
2023-04-10 11:37:43 +03:00
(phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero"
2023-04-10 11:44:51 +03:00
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in phoneNumber) user)
2023-04-10 11:37:43 +03:00
let profileUpdateRes = UpdateProfileArgs userID <$>
nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes
2023-04-10 11:44:51 +03:00
maybePendingEmail = user >>= \x -> let ProfilePageUser {..} = x in pendingEmail
2023-01-20 09:20:06 +02:00
inputField FieldView {..} = [whamlet|
<label for="#{fvId}">
^{fvLabel}
^{fvInput}
|]
widget = [whamlet|
#{extraHtml}
^{inputField nameView}
^{inputField homeView}
^{inputField nicknameView}
2023-04-10 11:37:43 +03:00
^{inputField phoneNumberView}
2023-01-20 09:20:06 +02:00
^{inputField emailView}
$maybe pendingEmail <- maybePendingEmail
<p>Päivitys osoitteeseen #
<a href="mailto:#{renderEmail pendingEmail}">#{renderEmail pendingEmail}
odottaa vahvistusta. #
<a href="@{VerifyEmailR}">Siirry vahvistamaan
|]
return (profileUpdateRes, widget)
profile :: UserID -> (Widget, Enctype) -> (Widget, Enctype) -> Widget
profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) = do
setTitle "Muokkaa profiilia"
passwordRoute <- handlerToWidget $ maybeAuthorized (UpdatePasswordR user) True
[whamlet|
<h1>
Omat tiedot
<form action="@{ProfileR user}" method="post" enctype="#{profileEnctype}">
^{profileWidget}
<input type="submit" value="Päivitä tiedot">
$maybe route <- passwordRoute
<form action="@{route}" method="post" enctype="#{passwordEnctype}">
^{passwordWidget}
<input type="submit" value="Vaihda salasana">
|]
getProfile :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => (Maybe UserID) -> Handler Html
getProfile userID = do
ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
passwordForm <- liftHandler $ generateFormPost passwordForm
profileForm <- liftHandler $ generateFormPost $
2023-04-10 11:44:51 +03:00
profileForm ((\x -> let ProfilePageUser {..} = x in id) <$> user) user
defaultLayout $ profile ((\x -> let ProfilePageUser {..} = x in id) $ fromJust user)
profileForm passwordForm
2023-01-20 09:20:06 +02:00
where fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user"
getOwnProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
getOwnProfileR = getProfile Nothing
getProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
getProfileR = getProfile . Just
postProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
postProfileR userID = do
((result, widget), enctype) <- runFormPost $ profileForm (Just userID) Nothing
case result of
FormSuccess update -> apiRequest @UpdateProfile True update >> redirect (ProfileR userID)
_ -> do
passwordForm <- liftHandler $ generateFormPost passwordForm
defaultLayout $ profile userID (widget, enctype) passwordForm
postUpdatePasswordR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
postUpdatePasswordR userID = do
((result, widget), enctype) <- runFormPost passwordForm
case result of
FormSuccess new ->
apiRequest @UpdatePassword True (UpdatePasswordArgs {password = new, user = Just userID}) >> redirect (ProfileR userID)
_ -> do
profileForm <- liftHandler $ generateFormPost $ profileForm (Just userID) Nothing
defaultLayout $ profile userID profileForm (widget, enctype)