datarekisteri/Client/Handlers/Apply.hs

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

{-# LANGUAGE NoImplicitPrelude #-}

module Client.Handlers.Apply where

import Relude hiding (id)

import Client.ApiRequests
import Client.Types
import Data.Morpheus.Client
import Server.Types
import Yesod hiding (emailField)
import Yesod.Auth
import Client.FormFields
import Data.Time (Day)

declareLocalTypesInline "schema.gql" [raw|
mutation Apply($name: String!, $nickname: String, $homeplace: String!,
    $birthdate: Date!, $email: Email!, $phoneNumber: PhoneNumber!, $password: String!, $application: String!) {
  apply(email: $email, password: $password, name: $name, nickname: $nickname,
      birthdate: $birthdate, homeplace: $homeplace, application: $application, phoneNumber: $phoneNumber) {
    id
  }
}
|]

applyForm :: Html -> MForm Handler (FormResult ApplyArgs, Widget)
applyForm = renderDivs $ ApplyArgs
    <$> areq textField nameSettings Nothing
    <*> aopt textField nicknameSettings Nothing
    <*> areq textField homeplaceSettings Nothing
    <*> areq dayField' birthdateSettings Nothing
    <*> areq emailField emailSettings Nothing
    <*> areq telephoneField phoneSettings Nothing
    <*> areq verifiedPasswordField "Salasana" Nothing
    <*> areq textareaField' applicationSettings Nothing
        where dayField' :: Field Handler Date
              dayField' = checkMMap (pure . Right . Date :: Day -> Handler (Either Text Date))
                  (\(Date x) -> x) dayField
              textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
                  Textarea textareaField
              nameSettings = "Nimi" {fsAttrs = [("placeholder","Erkki Juhani Esimerkki")]}
              nicknameSettings = "Kutsumanimi" {fsAttrs = [("placeholder","Juhani")]}
              homeplaceSettings = "Kotipaikka" {fsAttrs = [("placeholder","Espoo")]}
              birthdateSettings = "Syntymäaika" {fsAttrs = [("placeholder","2000-01-01")]}
              emailSettings = "Sähköposti" {fsAttrs = [("placeholder","erkki.juhani@esimerkki.fi")]}
              phoneSettings = "Puhelinnumero" {fsAttrs = [("placeholder","+358 12 34567890")]}
              applicationSettings = "Hakemus (eli miksi olet data)"
                  {fsAttrs = [("placeholder","Aloitin opiskelun Otaniemen datalla vuonna 2020.")]}

applyW :: (Widget, Enctype) -> Widget
applyW (applyWidget, applyEnctype) = do
    setTitle "Jäsenhakemus"
    [whamlet|
<h1>
    Jäsenhakemus
<form action="@{ApplyR}" method="post" enctype="#{applyEnctype}">
    ^{applyWidget}
    <p>
        Lähettämällä jäsenhakemuksen vakuutat antamiesi tietojen oikeellisuuden ja puuttettomuuden
        sekä sitoudut pitämään ne ajan tasalla.
    <input type="submit" value="Hae jäseneksi">
|]

getApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
getApplyR = do
    applyForm <- liftHandler $ generateFormPost applyForm
    defaultLayout $ applyW applyForm

postApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
postApplyR = do
    ((result, widget), enctype) <- runFormPost applyForm
    case result of
      FormSuccess application -> apiRequest @Apply False application >>= \x ->
          redirect $ ProfileR $ let ApplyApply {..} = apply x in id
      _ -> do
          defaultLayout $ applyW (widget, enctype)