Modularise the UI with widgets

2024-01-05 13:01:31 +02:00 · 2024-01-05 13:01:31 +02:00 · 7ebc6b0eda
parent 3e274d94f8
commit 7ebc6b0eda
9 changed files with 327 additions and 223 deletions
--- a/frontend/datarekisteri-frontend.cabal
+++ b/frontend/datarekisteri-frontend.cabal
@ -49,6 +49,7 @@ executable datarekisteri-frontend
    Datarekisteri.Frontend.Handlers.Profile,
    Datarekisteri.Frontend.Handlers.VerifyEmail,
    Datarekisteri.Frontend.Handlers.Members,
-    Datarekisteri.Frontend.Types
+    Datarekisteri.Frontend.Types,
+    Datarekisteri.Frontend.Widgets
  hs-source-dirs: src
  default-language: Haskell2010
--- a/frontend/src/Datarekisteri/Frontend/Auth.hs
+++ b/frontend/src/Datarekisteri/Frontend/Auth.hs
@ -21,6 +21,8 @@ import Yesod.Auth

 import qualified Yesod.Auth.Message as Msg

+import Datarekisteri.Frontend.Widgets
+
 pluginName = "externalBasic"

 loginR = PluginR pluginName ["login"]
@ -53,9 +55,7 @@ loginForm :: YesodAuth site => (Route Auth -> Route site) -> WidgetFor site ()
 loginForm toParent = do
    emailId <- newIdent
    passwordId <- newIdent
-    [whamlet|
-<h1>Kirjaudu
-<form action=@{toParent loginR} method=post>
+    let formContent = [whamlet|
            <label for="#{emailId}">
                Sähköposti
            <input id="#{emailId}" name="email" type="text" autofocus>
@ -64,3 +64,7 @@ loginForm toParent = do
            <input id="#{passwordId}" name="password" type="password">
            <input type="submit" value="Kirjaudu">
            |]
+    [whamlet|
+<h1>Kirjaudu
+^{form (toParent loginR) UrlEncoded formContent}
+|]
--- a/frontend/src/Datarekisteri/Frontend/Handlers/Applications.hs
+++ b/frontend/src/Datarekisteri/Frontend/Handlers/Applications.hs
@ -25,6 +25,7 @@ import Datarekisteri.Core.Types hiding (Applications)
 import Datarekisteri.Frontend.ApiRequests
 import Datarekisteri.Frontend.FormFields
 import Datarekisteri.Frontend.Types
+import Datarekisteri.Frontend.Widgets

 declareLocalTypesInline "schema.gql" [raw|
 query Applications {
@ -65,40 +66,53 @@ applicationsW applications = do
    acceptRoute <- handlerToWidget $ maybeAuthorized AcceptR True
    forM_ applications $ \ApplicationsApplications {..} -> do
        (widget, enctype) <- handlerToWidget $ generateFormPost $ resolveApplicationForm $ Just id
+        let keysAndValues =
+                [ ("Nimi" :: Text, name)
+                , ("Kutsumanimi", nickname)
+                , ("Kotipaikka", homeplace)
+                , ("Syntymäaika", renderDate birthdate)
+                , ("Sähköposti", renderEmail $ fromJust email)
+                , ("Puhelinnumero", renderPhoneNumber phoneNumber)
+                ]
+            acceptFormContent = [whamlet|
+                ^{widget}
+                ^{submitButton "Hyväksy"}
+                |]
+            rejectFormContent = [whamlet|
+                ^{widget}
+                ^{submitButtonBad "Hylkää"}
+                |]
+        detailsClass <- newIdent
        [whamlet|
-<details>
+            <details .#{detailsClass}>
                <summary>
                    <h2>#{name}
                <article>
                    <h3>Hakemus
                    <p>#{Textarea application}
-        <table>
-            <tr>
-                <th scope="row">Nimi
-                <td>#{name}
-            <tr>
-                <th scope="row">Kutsumanimi
-                <td>#{nickname}
-            <tr>
-                <th scope="row">Kotipaikka
-                <td>#{homeplace}
-            <tr>
-                <th scope="row">Syntymäaika
-                <td>#{renderDate $ birthdate}
-            <tr>
-                <th scope="row">Sähköposti
-                <td>#{renderEmail $ fromJust $ email}
-            <tr>
-                <th scope="row">Puhelinnumero
-                <td>#{renderPhoneNumber $ phoneNumber}
+                    ^{keyValueTable keysAndValues}
                $maybe route <- acceptRoute
-        <form action="@{route}" method="post" enctype="#{enctype}">
-            ^{widget}
-            <input type="submit" value="Hyväksy">
+                    ^{form route enctype acceptFormContent}
                $maybe route <- rejectRoute
-        <form action="@{route}" method="post" enctype="#{enctype}">
-            ^{widget}
-            <input type="submit" value="Hylkää" class="reject-button">
+                    ^{form route enctype rejectFormContent}
+        |]
+        toWidget [lucius|
+            .#{detailsClass} {
+                padding: 1.3em;
+                margin: 0.6em;
+                border-color: #00838a;
+                border-width: 0 0 0 0.6em;
+                border-style: solid;
+                border-radius: 0.4em;
+                background-color: #f6f8f8;
+                > summary > h2 {
+                    display: inline-block;
+                    margin-top: 0;
+                    margin-bottom: 0;
+                }
+                > article { margin-bottom: 1.5em }
+            }
+            .#{detailsClass}[open] { border-color: #339ca1; }
        |]

 getApplicationsR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
--- a/frontend/src/Datarekisteri/Frontend/Handlers/Apply.hs
+++ b/frontend/src/Datarekisteri/Frontend/Handlers/Apply.hs
@ -24,6 +24,7 @@ import Datarekisteri.Core.Types
 import Datarekisteri.Frontend.ApiRequests
 import Datarekisteri.Frontend.FormFields
 import Datarekisteri.Frontend.Types
+import Datarekisteri.Frontend.Widgets

 declareLocalTypesInline "schema.gql" [raw|
 mutation Apply($name: String!, $nickname: String, $homeplace: String!,
@ -60,16 +61,18 @@ applyForm = renderDivs $ ApplyArgs
 applyW :: (Widget, Enctype) -> Widget
 applyW (applyWidget, applyEnctype) = do
    setTitle "Jäsenhakemus"
-    [whamlet|
-<h1>
-    Jäsenhakemus
-<form action="@{ApplyR}" method="post" enctype="#{applyEnctype}">
+    let formContent = [whamlet|
            ^{applyWidget}
            <p>
                Lähettämällä jäsenhakemuksen vakuutat antamiesi tietojen oikeellisuuden ja puuttettomuuden
                sekä sitoudut pitämään ne ajan tasalla. Rekisteriin kirjattuja tietoja käsitellään
                <a href="https://datat.fi/rekisteriseloste">rekisteriselosteen</a> mukaisesti.
-    <input type="submit" value="Hae jäseneksi">
+            ^{submitButton "Hae Jäseneksi"}
+            |]
+    [whamlet|
+        <h1>
+            Jäsenhakemus
+        ^{form ApplyR applyEnctype formContent}
    |]

 getApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
--- a/frontend/src/Datarekisteri/Frontend/Handlers/Members.hs
+++ b/frontend/src/Datarekisteri/Frontend/Handlers/Members.hs
@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
@ -19,6 +20,7 @@ import Yesod.Auth

 import Datarekisteri.Frontend.Types
 import Datarekisteri.Frontend.ApiRequests
+import Datarekisteri.Frontend.Widgets
 import Datarekisteri.Core.Types

 declareLocalTypesInline "schema.gql" [raw|
@ -32,6 +34,10 @@ query MembersPage {
 }
 |]

+instance ToTableRow DataIdClient MembersPageUsers where
+    tableHeader _ = toWidget <$> ["Nimi" :: Text, "Kutsumanimi", "Kotipaikka"]
+    toCells MembersPageUsers {..} = toWidget <$> [name, nickname, homeplace]
+
 getMembersR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
 getMembersR = do
    MembersPage {..} <- apiRequest True ()
--- a/frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs
+++ b/frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs
@ -23,6 +23,7 @@ import Datarekisteri.Core.Types
 import Datarekisteri.Frontend.ApiRequests
 import Datarekisteri.Frontend.Types
 import Datarekisteri.Frontend.FormFields
+import Datarekisteri.Frontend.Widgets

 declareLocalTypesInline "schema.gql" [raw|
 query ProfilePage($id: UserID) {
@ -100,19 +101,23 @@ profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) =
    setTitle "Muokkaa profiilia"
    let userID = let ProfilePageUser {..} = user in id
    passwordRoute <- handlerToWidget $ maybeAuthorized (UpdatePasswordR userID) True
+    let profileFormContent = [whamlet|
+            ^{profileWidget}
+            ^{submitButton "Päivitä tiedot"}
+            |]
+        passwordFormContent = [whamlet|
+            ^{passwordWidget}
+            ^{submitButton "Vaihda salasana"}
+            |]
    [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">
+        ^{form (ProfileR userID) profileEnctype profileFormContent}
        $maybe route <- passwordRoute
-        <form action="@{route}" method="post" enctype="#{passwordEnctype}">
-            ^{passwordWidget}
-            <input type="submit" value="Vaihda salasana">
+            ^{form route passwordEnctype passwordFormContent}
    |]

 getProfile :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => (Maybe UserID) -> Handler Html
--- a/frontend/src/Datarekisteri/Frontend/Handlers/VerifyEmail.hs
+++ b/frontend/src/Datarekisteri/Frontend/Handlers/VerifyEmail.hs
@ -20,6 +20,7 @@ import Yesod.Auth

 import Datarekisteri.Frontend.ApiRequests
 import Datarekisteri.Frontend.Types
+import Datarekisteri.Frontend.Widgets
 import Datarekisteri.Core.Types

 declareLocalTypesInline "schema.gql" [raw|
@ -45,12 +46,14 @@ postVerifyEmailR = do

 verifyEmailW (codeWidget, codeEnctype) = do
    setTitle "Vahvista sähköpostiosoite"
+    let formContent = [whamlet|
+            ^{codeWidget}
+            ^{submitButton "Vahvista"}
+            |]
    [whamlet|
 <h1>
    Vahvista sähköpostiosoite
-<form action="@{VerifyEmailR}" method="post" enctype="#{codeEnctype}">
-    ^{codeWidget}
-    <input type="submit" value="Vahvista">
+^{form VerifyEmailR codeEnctype formContent}
 |]

 verifyForm = renderDivs $ VerifyEmailArgs <$> areq textField "Vahvistuskoodi" Nothing
--- a/frontend/src/Datarekisteri/Frontend/Types.hs
+++ b/frontend/src/Datarekisteri/Frontend/Types.hs
@ -163,47 +163,105 @@ instance Yesod DataIdClient where
    errorHandler x = defaultErrorHandler x
    addStaticContent = addStaticContentExternal Right base64md5 "/tmp/data-id" (StaticR . flip StaticRoute [])
    defaultLayout widget = do
+        let messages :: Widget
+            messages = do
                msgs <- getMessages
-        applicationsRoute <- maybeAuthorized ApplicationsR False
-        profileRoute <- maybeAuthorized OwnProfileR False
-        membersRoute <- maybeAuthorized MembersR False
+                messagesClass <- newIdent
+                messageClass <- newIdent
+                toWidget [hamlet|
+                    $if not $ null msgs
+                        <aside class="#{messagesClass}">
+                          <ul>
+                            $forall (_, msg) <- msgs
+                              <li class="#{messageClass}">#{msg}
+                |]
+                toWidget [lucius|
+                    aside.#{messagesClass} > ul {
+                      list-style: none;
+                      padding: 0;
+                      margin: 0;
+                      li.#{messageClass} {
+                        display: block;
+                        padding: 0.7em;
+                        background-color: #3b4553;
+                        color: white;
+                        border-radius: 0.3em;
+                      }
+                    }
+                |]
+            navigationBar :: Widget
+            navigationBar = do
+                applicationsRoute <- handlerToWidget $ maybeAuthorized ApplicationsR False
+                profileRoute <- handlerToWidget $ maybeAuthorized OwnProfileR False
+                membersRoute <- handlerToWidget $ maybeAuthorized MembersR False
                currentRoute <- getCurrentRoute
                loggedIn <- isJust <$> maybeAuthId
+                navClass <- newIdent
+                activeClass <- newIdent
+                rightClass <- newIdent
+                let navItem :: Bool -> Maybe (Route DataIdClient) -> Text -> HtmlUrl (Route DataIdClient)
+                    navItem alignRight maybeRoute name = [hamlet|
+                        $maybe route <- maybeRoute
+                            <li :Just route == currentRoute:class="#{activeClass}" :alignRight:class="#{rightClass}">
+                                <a href="@{route}">#{name}
+                        |]
+                    rightNavItem = navItem True
+                    leftNavItem = navItem False
+                toWidget [hamlet|
+                    <nav .#{navClass}>
+                      <ul>
+                        ^{leftNavItem profileRoute "Profiili"}
+                        ^{leftNavItem membersRoute "Jäsenet"}
+                        ^{leftNavItem applicationsRoute "Hakemukset"}
+                        $if loggedIn
+                          ^{rightNavItem (Just (AuthR LogoutR)) "Kirjaudu ulos"}
+                        $else
+                          ^{rightNavItem (Just (AuthR LoginR)) "Kirjaudu sisään"}
+                          ^{rightNavItem (Just ApplyR) "Hae jäseneksi"}
+                |]
+                toWidget [lucius|
+                    .#{navClass} {
+                      display: block;
+                      position: fixed;
+                      top: 0;
+                      width: 100%;
+                      padding: 0;
+                      background-color: #{fgColor};
+                      ul {
+                        list-style-type: none;
+                        margin: 0;
+                        padding: 0;
+                      }
+                      li {
+                        display: block;
+                        float: left;
+                        padding: 0;
+                        margin: 0;
+                        a {
+                          color: #{bgColor};
+                          text-decoration: none;
+                          display: inline-block;
+                          padding: 0.7em 1em;
+                        }
+                        a:hover {
+                          background-color: #00838a;
+                          color: #ffffff;
+                        }
+                      }
+                      .#{activeClass} { font-weight: 500; }
+                      .#{rightClass} { float: right; }
+                    }
+                |]
+
        p <- widgetToPageContent $ do
            [whamlet|
                <header>
-                  <nav>
-                    <ul>
-                      $maybe route <- profileRoute
-                        <li :Just route == currentRoute:class="active-nav">
-                          <a href="@{route}">Profiili
-                      $maybe route <- membersRoute
-                        <li :Just route == currentRoute:class="active-nav">
-                          <a href="@{route}">Jäsenet
-                      $maybe route <- applicationsRoute
-                        <li :Just route == currentRoute:class="active-nav">
-                          <a href="@{route}">Hakemukset
-                      $if loggedIn
-                        <li class="left-nav">
-                          <a href="@{AuthR LogoutR}">Kirjaudu ulos
-                      $else
-                        <li :Just (AuthR LoginR) == currentRoute:class="active-nav" class="left-nav">
-                          <a href="@{AuthR LoginR}">Kirjaudu sisään
-                        <li :Just ApplyR == currentRoute:class="active-nav" class="left-nav">
-                          <a href="@{ApplyR}">Hae jäseneksi
+                  ^{navigationBar}
                <main>
-                  $if not $ null msgs
-                    <aside class="messages">
-                      <ul>
-                        $forall (_, msg) <- msgs
-                          <li class="message">#{msg}
+                  ^{messages}
                  ^{widget}
            |] :: Widget
            toWidget $ [lucius|
-                :root {
-                  --bg-colour: #ffffff;
-                  --fg-colour: #181c22;
-                }
                * {
                  box-sizing: border-box;
                }
@ -211,135 +269,17 @@ instance Yesod DataIdClient where
                  font-family: "Fira Sans", sans-serif;
                  height: 100%;
                }
-                th[scope="row"] {
-                  text-align: right;
-                }
-                th[scope="col"] {
-                  text-align: center;
-                }
                body {
                  background-color: #e8eaef;
-                  color: var(--fg-colour);
+                  color: #{fgColor};
                  margin: 0;
                  height: 100%;
                }
-                label {
-                  display: block;
-                  padding-top: 0.3em;
-                  padding-bottom: 0.3em;
-                }
-                input {
-                  width: 100%;
-                  padding: 0.4em;
-                  margin-top: 0.3em;
-                  margin-bottom: 0.3em;
-                  border-radius: 0.25em;
-                }
-                textarea {
-                  width: 100%;
-                  padding: 0.4em;
-                  margin-top: 0.3em;
-                  margin-bottom: 0.3em;
-                }
-                form {
-                  max-width: min(30em,100%);
-                }
-                summary > h2 {
-                  display: inline-block;
-                  margin-top: 0;
-                  margin-bottom: 0;
-                }
-                details > table th {
-                  text-align: left;
-                  padding-left: 0;
-                }
-                details {
-                  padding: 1.3em;
-                  margin: 0.6em;
-                  border-color: #00838a;
-                  border-width: 0 0 0 0.6em;
-                  border-style: solid;
-                  border-radius: 0.4em;
-                  background-color: #f6f8f8;
-                }
-                details[open] {
-                  border-color: #339ca1;
-                }
-                details > article {
-                    margin-bottom: 1.5em
-                }
-                input[type="submit"] {
-                  background-color: #00838a;
-                  color: #ffffff;
-                  padding: 0.5em 1em;
-                  border: 0;
-                  cursor: pointer;
-                  font-weight: bold;
-                }
-                input[type="submit"]:hover {
-                  background-color: #339ca1;
-                }
-                input[type="submit"].reject-button {
-                  background-color: #8a003a;
-                }
-                input[type="submit"].reject-button:hover {
-                  background-color: #aa3968;
-                }
-                input:invalid {
-                  border-color: #8a003a;
-                }
-                nav {
-                  display: block;
-                  position: fixed;
-                  top: 0;
-                  width: 100%;
-                  padding: 0;
-                  background-color: var(--fg-colour);
-                }
-                nav ul {
-                  list-style-type: none;
-                  margin: 0;
-                  padding: 0;
-                }
-                nav li {
-                  display: block;
-                  float: left;
-                  padding: 0;
-                  margin: 0;
-                }
-                nav li a {
-                  color: var(--bg-colour);
-                  text-decoration: none;
-                  display: inline-block;
-                  padding: 0.7em 1em;
-                }
-                nav li a:hover {
-                  background-color: #00838a;
-                  color: #ffffff;
-                }
-                .active-nav {
-                  font-weight: 500;
-                }
-                .left-nav {
-                  float: right;
-                }
-                aside.messages > ul {
-                  list-style: none;
-                  padding: 0;
-                  margin: 0;
-                }
-                aside.messages li.message {
-                  display: block;
-                  padding: 0.7em;
-                  background-color: #3b4553;
-                  color: white;
-                  border-radius: 0.3em;
-                }
                main {
                  margin: 0 auto;
                  max-width: 50em;
                  padding: 5em 1em 3em 1em;
-                  background-color: var(--bg-colour);
+                  background-color: #{bgColor};
                  min-height: 100%;
                  box-sizing: border-box;
                }
@ -355,6 +295,10 @@ instance Yesod DataIdClient where
                ^{pageBody p}
            |]

+bgColor, fgColor :: Text
+bgColor = "#ffffff"
+fgColor = "#181c22"
+
 instance ApiRequest DataIdClient where
    getApiUrl = configServerUrl . getConfig <$> getYesod
    authIdToAuthorization = flip const
--- a/frontend/src/Datarekisteri/Frontend/Widgets.hs
+++ b/frontend/src/Datarekisteri/Frontend/Widgets.hs
@ -0,0 +1,124 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Datarekisteri.Frontend.Widgets where
+
+import Data.Text (Text)
+
+import Yesod
+
+type Widget' a = WidgetFor a ()
+
+submitButton :: Text -> Widget' a
+submitButton text = do
+    toWidget [hamlet|<input type="submit" value="#{text}">|]
+
+submitButtonBad :: Text -> Widget' a
+submitButtonBad text = do
+    buttonId <- newIdent
+    toWidget [hamlet|<input id="#{buttonId}" type="submit" value="#{text}">|]
+    toWidget [lucius|
+        input[type="submit"]##{buttonId} {
+            background-color: #8a003a;
+        }
+        input[type="submit"]##{buttonId}:hover {
+            background-color: #aa3968;
+        }
+    |]
+
+keyValueTable :: (ToWidget site a, ToWidget site b) => [(a, b)] -> Widget' site
+keyValueTable rows = do
+    tableClass <- newIdent
+    [whamlet|
+        <table .#{tableClass}>
+            $forall row <- rows
+                <tr>
+                    <th scope="row">^{fst row}
+                    <td>^{snd row}
+    |]
+    toWidget [lucius|
+        .#{tableClass} {
+            th { text-align: right; }
+            td { text-align: left; }
+        }
+    |]
+
+form :: Route a -> Enctype -> Widget' a -> Widget' a
+form route enctype content = do
+    formClass <- newIdent
+    [whamlet|
+        <form .#{formClass} action="@{route}" method="post" enctype="#{enctype}">
+            ^{content}
+    |]
+    toWidget [lucius|
+        form.#{formClass} {
+          max-width: min(30em,100%);
+          label {
+            display: block;
+            padding-top: 0.3em;
+            padding-bottom: 0.3em;
+          }
+          textarea {
+            width: 100%;
+            padding: 0.4em;
+            margin-top: 0.3em;
+            margin-bottom: 0.3em;
+          }
+          input {
+            width: 100%;
+            padding: 0.4em;
+            margin-top: 0.3em;
+            margin-bottom: 0.3em;
+            border-radius: 0.25em;
+          }
+          input:invalid {
+            border-color: #8a003a;
+          }
+          input[type="submit"] {
+            background-color: #00838a;
+            color: #ffffff;
+            padding: 0.5em 1em;
+            border: 0;
+            cursor: pointer;
+            font-weight: bold;
+          }
+          input[type="submit"]:hover {
+            background-color: #339ca1;
+          }
+        }
+    |]
+
+table' :: [Widget' a] -> [[Widget' a]] -> Widget' a
+table' header rows = do
+    tableClass <- newIdent
+    thClass <- newIdent
+    [whamlet|
+      <table .#{tableClass}>
+        <thead>
+          <tr>
+            $forall cell <- header
+              <th .#{thClass} scope="col">
+                ^{cell}
+      $forall row <- rows
+        <tr>
+          $forall cell <- row
+            <td>
+              ^{cell}
+    |]
+    toWidget [lucius|
+        table.#{tableClass} {
+          th[scope="col"].#{thClass} {
+            text-align: center;
+          }
+        }
+    |]
+
+table :: forall a site. ToTableRow site a => [a] -> Widget' site
+table rows = table' (tableHeader (undefined :: a)) (toCells <$> rows)
+
+class ToTableRow site a where
+    tableHeader :: a -> [Widget' site]
+    toCells :: a -> [Widget' site]