144 lines
5.6 KiB
Haskell
144 lines
5.6 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
|
|
phoneNumber
|
|
}
|
|
permissions
|
|
}
|
|
|]
|
|
|
|
declareLocalTypesInline "schema.gql" [raw|
|
|
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) {
|
|
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)
|
|
(phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero"
|
|
(Just $ maybe Nothing (\x -> Just $ phoneNumber (x :: ProfilePageUser)) user)
|
|
let profileUpdateRes = UpdateProfileArgs userID <$>
|
|
nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes
|
|
maybePendingEmail = user >>= \x -> pendingEmail (x :: ProfilePageUser)
|
|
inputField FieldView {..} = [whamlet|
|
|
<label for="#{fvId}">
|
|
^{fvLabel}
|
|
^{fvInput}
|
|
|]
|
|
widget = [whamlet|
|
|
#{extraHtml}
|
|
^{inputField nameView}
|
|
^{inputField homeView}
|
|
^{inputField nicknameView}
|
|
^{inputField phoneNumberView}
|
|
^{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)
|