datarekisteri/Client/Handlers/Profile.hs

135 lines
5.2 KiB
Haskell

{-# 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
}
permissions
}
|]
declareLocalTypesInline "schema.gql" [raw|
mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email) {
update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email) {
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
(nameRes, nameView) <- mopt textField "Nimi" (Just $ maybe Nothing (\x -> Just $ name (x ::ProfilePageUser)) user)
(homeRes, homeView) <- mopt textField "Kotipaikka" (Just $ maybe Nothing (\x -> Just $ homeplace (x :: ProfilePageUser)) user)
(nicknameRes, nicknameView) <- mopt textField "Kutsumanimi" (Just $ maybe Nothing (\x -> Just $ nickname (x :: ProfilePageUser)) user)
(emailRes, emailView) <- mopt emailField "Sähköposti" (maybe Nothing (\x -> Just $ email (x :: ProfilePageUser)) user)
let profileUpdateRes = UpdateProfileArgs userID <$> nameRes <*> homeRes <*> nicknameRes <*> emailRes
maybePendingEmail = user >>= \x -> pendingEmail (x :: ProfilePageUser)
inputField FieldView {..} = [whamlet|
<label for="#{fvId}">
^{fvLabel}
^{fvInput}
|]
widget = [whamlet|
#{extraHtml}
^{inputField nameView}
^{inputField homeView}
^{inputField nicknameView}
^{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 $
profileForm ((\x -> id (x :: ProfilePageUser)) <$> user) user
defaultLayout $ profile ((\x -> id (x :: ProfilePageUser)) $ fromJust user) profileForm passwordForm
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)