Modularise the UI with widgets

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

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,14 +55,16 @@ loginForm :: YesodAuth site => (Route Auth -> Route site) -> WidgetFor site ()
 loginForm toParent = do
     emailId <- newIdent
     passwordId <- newIdent
+    let formContent = [whamlet|
+            <label for="#{emailId}">
+                Sähköposti
+            <input id="#{emailId}" name="email" type="text" autofocus>
+            <label for="#{passwordId}">
+                Salasana
+            <input id="#{passwordId}" name="password" type="password">
+            <input type="submit" value="Kirjaudu">
+            |]
     [whamlet|
 <h1>Kirjaudu
-<form action=@{toParent loginR} method=post>
+^{form (toParent loginR) UrlEncoded formContent}
-    <label for="#{emailId}">
-        Sähköposti
-    <input id="#{emailId}" name="email" type="text" autofocus>
-    <label for="#{passwordId}">
-        Salasana
-    <input id="#{passwordId}" name="password" type="password">
-    <input type="submit" value="Kirjaudu">
 |]

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,41 +66,54 @@ 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>
+                <summary>
-        <h2>#{name}
+                    <h2>#{name}
-    <article>
+                <article>
-        <h3>Hakemus
+                    <h3>Hakemus
-        <p>#{Textarea application}
+                    <p>#{Textarea application}
-        <table>
+                    ^{keyValueTable keysAndValues}
-            <tr>
+                $maybe route <- acceptRoute
-                <th scope="row">Nimi
+                    ^{form route enctype acceptFormContent}
-                <td>#{name}
+                $maybe route <- rejectRoute
-            <tr>
+                    ^{form route enctype rejectFormContent}
-                <th scope="row">Kutsumanimi
+        |]
-                <td>#{nickname}
+        toWidget [lucius|
-            <tr>
+            .#{detailsClass} {
-                <th scope="row">Kotipaikka
+                padding: 1.3em;
-                <td>#{homeplace}
+                margin: 0.6em;
-            <tr>
+                border-color: #00838a;
-                <th scope="row">Syntymäaika
+                border-width: 0 0 0 0.6em;
-                <td>#{renderDate $ birthdate}
+                border-style: solid;
-            <tr>
+                border-radius: 0.4em;
-                <th scope="row">Sähköposti
+                background-color: #f6f8f8;
-                <td>#{renderEmail $ fromJust $ email}
+                > summary > h2 {
-            <tr>
+                    display: inline-block;
-                <th scope="row">Puhelinnumero
+                    margin-top: 0;
-                <td>#{renderPhoneNumber $ phoneNumber}
+                    margin-bottom: 0;
-    $maybe route <- acceptRoute
+                }
-        <form action="@{route}" method="post" enctype="#{enctype}">
+                > article { margin-bottom: 1.5em }
-            ^{widget}
+            }
-            <input type="submit" value="Hyväksy">
+            .#{detailsClass}[open] { border-color: #339ca1; }
-    $maybe route <- rejectRoute
+        |]
-        <form action="@{route}" method="post" enctype="#{enctype}">
-            ^{widget}
-            <input type="submit" value="Hylkää" class="reject-button">
-|]
 
 getApplicationsR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
 getApplicationsR = do

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,17 +61,19 @@ applyForm = renderDivs $ ApplyArgs
 applyW :: (Widget, Enctype) -> Widget
 applyW (applyWidget, applyEnctype) = do
     setTitle "Jäsenhakemus"
+    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.
+            ^{submitButton "Hae Jäseneksi"}
+            |]
     [whamlet|
-<h1>
+        <h1>
-    Jäsenhakemus
+            Jäsenhakemus
-<form action="@{ApplyR}" method="post" enctype="#{applyEnctype}">
+        ^{form ApplyR applyEnctype formContent}
-    ^{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">
-|]
 
 getApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
 getApplyR = do

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 ()

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,20 +101,24 @@ profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) =
     setTitle "Muokkaa profiilia"
     let userID = let ProfilePageUser {..} = user in id
     passwordRoute <- handlerToWidget $ maybeAuthorized (UpdatePasswordR userID) True
-    [whamlet|
+    let profileFormContent = [whamlet|
-    <h1>
+            ^{profileWidget}
-        $if isMember user
+            ^{submitButton "Päivitä tiedot"}
-            Jäsentiedot
+            |]
-        $else
+        passwordFormContent = [whamlet|
-            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">
+            ^{submitButton "Vaihda salasana"}
-|]
+            |]
+    [whamlet|
+        <h1>
+            $if isMember user
+                Jäsentiedot
+            $else
+                Jäsenhakemuksen tiedot
+        ^{form (ProfileR userID) profileEnctype profileFormContent}
+        $maybe route <- passwordRoute
+            ^{form route passwordEnctype passwordFormContent}
+    |]
 
 getProfile :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => (Maybe UserID) -> Handler Html
 getProfile userID = do

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}">
+^{form VerifyEmailR codeEnctype formContent}
-    ^{codeWidget}
-    <input type="submit" value="Vahvista">
 |]
 
 verifyForm = renderDivs $ VerifyEmailArgs <$> areq textField "Vahvistuskoodi" Nothing

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
-        msgs <- getMessages
+        let messages :: Widget
-        applicationsRoute <- maybeAuthorized ApplicationsR False
+            messages = do
-        profileRoute <- maybeAuthorized OwnProfileR False
+                msgs <- getMessages
-        membersRoute <- maybeAuthorized MembersR False
+                messagesClass <- newIdent
-        currentRoute <- getCurrentRoute
+                messageClass <- newIdent
-        loggedIn <- isJust <$> maybeAuthId
+                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>
+                  ^{navigationBar}
-                    <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
                 <main>
-                  $if not $ null msgs
+                  ^{messages}
-                    <aside class="messages">
-                      <ul>
-                        $forall (_, msg) <- msgs
-                          <li class="message">#{msg}
                   ^{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

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]