datarekisteri/Client/Types.hs

331 lines
12 KiB
Haskell
Raw Normal View History

2023-01-20 09:20:06 +02:00
{-# 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 }
2023-04-10 11:44:51 +03:00
instance PathPiece UserID where
toPathPiece (UserID id) = show id
fromPathPiece s = UserID <$> readMaybe (toString s)
2023-01-20 09:20:06 +02:00
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
}
}
|]
2023-04-10 11:44:51 +03:00
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
2023-01-20 09:20:06 +02:00
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)