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

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE NoImplicitPrelude #-}

module Datarekisteri.Frontend.Handlers.Profile where

import Relude hiding (id)

import Data.Morpheus.Client (raw, declareLocalTypesInline)

import Yesod hiding (emailField)
import Yesod.Auth

import Datarekisteri.Core.Types
import Datarekisteri.Frontend.ApiRequests
import Datarekisteri.Frontend.Types
import Datarekisteri.Frontend.FormFields

declareLocalTypesInline "schema.gql" [raw|
query ProfilePage($id: UserID) {
  user(id: $id) {
    id
    name
    nickname
    email
    pendingEmail
    homeplace
    birthdate
    phoneNumber
    isMember
    application
  }
  permissions
}
|]

declareLocalTypesInline "schema.gql" [raw|
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, application: $application) {
    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 :: ProfilePageUser -> Form UpdateProfileArgs
profileForm ProfilePageUser {..} extraHtml = do
    (nameRes, nameView) <- mopt textField "Nimi" (Just $ Just name)
    (homeRes, homeView) <- mopt textField "Kotipaikka" (Just $ Just homeplace)
    (nicknameRes, nicknameView) <- mopt textField "Kutsumanimi" (Just $ Just nickname)
    (emailRes, emailView) <- mopt emailField "Sähköposti" (Just email)
    (phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero" (Just $ Just phoneNumber)
    (applicationRes, applicationView) <- mopt textareaField' "Jäsenhakemus" (Just $ Just application)
    let profileUpdateRes = UpdateProfileArgs (Just id) <$>
            nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes <*> applicationRes
        inputField FieldView {..} = [whamlet|
            <label for="#{fvId}">
                ^{fvLabel}
                ^{fvInput}
            |]
        widget = [whamlet|
            #{extraHtml}
            ^{inputField nameView}
            ^{inputField homeView}
            ^{inputField nicknameView}
            ^{inputField phoneNumberView}
            ^{inputField emailView}
            $maybe pending <- pendingEmail
                <p>Päivitys osoitteeseen #
                    <a href="mailto:#{renderEmail pending}">#{renderEmail pending}
                    odottaa vahvistusta. #
                    <a href="@{VerifyEmailR}">Siirry vahvistamaan
            $if not isMember
                ^{inputField applicationView}
            |]
    return (profileUpdateRes, widget)

profile :: ProfilePageUser -> (Widget, Enctype) -> (Widget, Enctype) -> Widget
profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) = do
    setTitle "Muokkaa profiilia"
    let userID = let ProfilePageUser {..} = user in id
    passwordRoute <- handlerToWidget $ maybeAuthorized (UpdatePasswordR userID) True
    [whamlet|
    <h1>
        $if isMember user
            Jäsentiedot
        $else
            Jäsenhakemuksen tiedot
    <form action="@{ProfileR userID}" 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 (fromJust user)
    defaultLayout $ profile (fromJust user)
        profileForm passwordForm

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
    ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
    ((result, widget), enctype) <- runFormPost $ profileForm (fromJust user)
    case result of
      FormSuccess update -> apiRequest @UpdateProfile True update >> redirect (ProfileR userID)
      _ -> do
          passwordForm <- liftHandler $ generateFormPost passwordForm
          defaultLayout $ profile (fromJust user) (widget, enctype) passwordForm
          --- XXX fromJust explodes if the user no longer exists

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
          ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
          profileForm <- liftHandler $ generateFormPost $ profileForm (fromJust user)
          defaultLayout $ profile (fromJust user) profileForm (widget, enctype)
          --- XXX fromJust explodes if the user no longer exists