datarekisteri/Client/Handlers/Profile.hs

{-# 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 $ let ProfilePageUser {..} = x in name) user)
    (homeRes, homeView) <- mopt textField "Kotipaikka"
        (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in homeplace) user)
    (nicknameRes, nicknameView) <- mopt textField "Kutsumanimi"
        (Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in nickname) user)
    (emailRes, emailView) <- mopt emailField "Sähköposti"
        (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)
    let profileUpdateRes = UpdateProfileArgs userID <$>
            nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes
        maybePendingEmail = user >>= \x -> let ProfilePageUser {..} = x in pendingEmail
        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 -> let ProfilePageUser {..} = x in id) <$> user) user
    defaultLayout $ profile ((\x -> let ProfilePageUser {..} = x in id) $ 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)