datarekisteri/Client/Types.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-# LANGUAGE NoImplicitPrelude #-}

module Client.Types where

import Relude hiding (id)
import Relude.Extra.Foldable1 (maximum1)

import Yesod
import Yesod.Core.Handler (getCurrentRoute)
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Auth
import Yesod.Static
import Server.Types (UserID(..), Scope(..), Permission(..))
import Data.Time (getCurrentTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Client.Auth
import Client.ApiRequests
import Data.Morpheus.Client
import Server (readPermission)
import Data.Map (findWithDefault)

data DataIdClient = DataIdClient { getStatic :: Static }

instance PathPiece UserID where
    toPathPiece (UserID id) = show id
    fromPathPiece s = UserID <$> readMaybe (toString s)

mkYesodData "DataIdClient" [parseRoutes|
/ HomeR GET

/profile OwnProfileR GET
/profile/#UserID ProfileR GET POST
/update-password/#UserID UpdatePasswordR POST
/verify-email VerifyEmailR GET POST

/applications ApplicationsR GET
/accept AcceptR POST
/reject RejectR POST

/apply ApplyR GET POST

/api ApiR POST
/auth AuthR Auth getAuth
/static StaticR Static getStatic
|]

declareLocalTypesInline "schema.gql" [raw|
query GetPermissions {
  permissions
  user {
    id
  }
}
|]

declareLocalTypesInline "schema.gql" [raw|
mutation GetWebUIToken {
  newToken(comment: "id.datat.fi webui") {
    tokenData
  }
}
|]

instance YesodAuth DataIdClient where
    type AuthId DataIdClient = Text
    maybeAuthId = lookupSession credsKey
    loginDest = const HomeR
    logoutDest = const HomeR
    authPlugins = const $
        [ authExternalBasic $
            fmap (fmap (tokenData . newToken) . rightToMaybe) .
                flip (apiRequestAuth @GetWebUIToken []) () . Just
        ]
    authenticate = pure . Authenticated . credsIdent

withAuthenticated :: (AuthId DataIdClient -> Handler AuthResult) -> Handler AuthResult
withAuthenticated m = maybeAuthId >>= maybe (pure AuthenticationRequired) m

hasPermission :: Scope -> Permission -> Handler Bool
hasPermission scope permission = do
    GetPermissions {..} <- apiRequest @GetPermissions False ()
    let permissionMap = fromMaybe mempty $ readPermission permissions
        findPermission scope = findWithDefault None scope permissionMap
        userID = (\x -> id (x :: GetPermissionsUser)) <$> user
        scopes = scope :| case scope of
            Tokens uid | Just uid == userID -> [OwnTokens]
            Profile uid | Just uid == userID -> [OwnProfile]
            _ -> []
            -- TODO add Members and Applications to Profile Scopes if profile owner is member/applicant
    pure $ (>= permission) $ maximum1 $ findPermission <$> scopes

requirePermission :: Scope -> Permission -> Handler AuthResult
requirePermission scope permission = ifM (hasPermission scope permission)
    (pure Authorized)
    (pure $ Unauthorized $ "Toiminto vaatii " <> renderPermission permission <> " " <> renderScope scope)
        where renderPermission ReadWrite = "kirjoitusoikeuden"
              renderPermission ReadOnly = "lukuoikeuden"
              renderPermission None = "nollaoikeuden"
              renderScope OwnProfile = "omaan profiliin"
              renderScope (Profile user) = "käyttäjän '" <> show user <> "' profiliin"
              renderScope OwnTokens = "omiin tokeneihin" -- TODO kunnon suomennos
              renderScope (Tokens user) = "käyttäjän '" <> show user <> "' tokeneihin" -- TODO kunnon suomennos
              renderScope Members = "kaikkiin jäseniin"
              renderScope Applications = "jäsenhakemuksiin"

authorizedHelper :: Scope -> Bool -> Handler AuthResult
authorizedHelper scope True = requirePermission scope ReadWrite
authorizedHelper scope False = requirePermission scope ReadOnly

instance Yesod DataIdClient where
    authRoute = const $ Just $ AuthR LoginR
    approot = ApprootStatic "http://localhost:3000"
    makeSessionBackend = const $ sslOnlySessions $ laxSameSiteSessions $
        Just <$> defaultClientSessionBackend (60*24*7) "client_session_key.aes"
    isAuthorized (AuthR _) _ = pure Authorized
    isAuthorized (StaticR _) _ = pure Authorized
    isAuthorized HomeR _ = pure Authorized
    isAuthorized ApiR _ = pure Authorized
    isAuthorized ApplyR _ = pure Authorized
    isAuthorized VerifyEmailR _ = pure Authorized
    isAuthorized OwnProfileR isWrite = withAuthenticated $ const $ authorizedHelper OwnProfile isWrite
    isAuthorized (ProfileR user) isWrite = withAuthenticated $ const $ authorizedHelper (Profile user) isWrite
    isAuthorized (UpdatePasswordR user) isWrite =
        withAuthenticated $ const $ authorizedHelper (Profile user) isWrite
    isAuthorized ApplicationsR isWrite = withAuthenticated $ const $ authorizedHelper Applications isWrite
    isAuthorized AcceptR isWrite = withAuthenticated $ const $ authorizedHelper Applications isWrite
    isAuthorized RejectR isWrite = withAuthenticated $ const $ authorizedHelper Applications isWrite
    errorHandler NotFound = fmap toTypedContent $ defaultLayout $ defaultMessageWidget "Sivua ei löytynyt" $
        [hamlet|<p>Pyytämästäsi osoitteesta ei löytynyt sivua|]
    errorHandler (InternalError e) = do
        $logErrorS "yesod-core" e
        selectRep $ do
            provideRep $ defaultLayout $ do
                currentTime <- liftIO getCurrentTime
                defaultMessageWidget "Palvelinvirhe" [hamlet|
<p>
    Pyynnön käsittelyssä tapahtui virhe. #
    Ole yhteydessä ylläpitäjiin ja kerro heille palvelimen kellonaika virheen tapahtuessa #
    #{iso8601Show currentTime}
|]
    errorHandler x = defaultErrorHandler x
    addStaticContent = addStaticContentExternal Right base64md5 "/tmp/data-id" (StaticR . flip StaticRoute [])
    defaultLayout widget = do
        msgs <- getMessages
        applicationsRoute <- maybeAuthorized ApplicationsR False
        profileRoute <- maybeAuthorized OwnProfileR False
        currentRoute <- getCurrentRoute
        loggedIn <- isJust <$> maybeAuthId
        p <- widgetToPageContent $ do
            [whamlet|
                <header>
                  <nav>
                    <ul>
                      $maybe route <- profileRoute
                        <li :Just route == currentRoute:class="active-nav">
                          <a href="@{route}">Profiili
                      $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
                    <aside class="messages">
                      <ul>
                        $forall (_, msg) <- msgs
                          <li class="message">#{msg}
                  ^{widget}
            |] :: Widget
            toWidget $ [lucius|
                :root {
                  --bg-colour: #ffffff;
                  --fg-colour: #181c22;
                }
                html {
                  font-family: "Fira Sans", sans-serif;
                  height: 100%;
                }
                th {
                  text-align: right;
                }
                body {
                  background-color: #e8eaef;
                  color: var(--fg-colour);
                  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: 20em;
                }
                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;
                }
                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;
                }
                main {
                  margin: 0 auto;
                  max-width: 50em;
                  padding: 5em 1em 3em 1em;
                  background-color: var(--bg-colour);
                  min-height: 100%;
                  box-sizing: border-box;
                }
                |]
        withUrlRenderer [hamlet|
            $doctype 5
            <html>
              <head>
                <title>#{pageTitle p}
                ^{pageHead p}
              <body>
                ^{pageBody p}
            |]

instance ApiRequest DataIdClient where
    getApiUrl = ($ ApiR) <$> getUrlRender
    authIdToAuthorization = flip const

instance RenderMessage DataIdClient FormMessage where
    renderMessage _ _ = defaultFormMessage

type Form a = Html -> MForm Handler (FormResult a, Widget)