331 lines
12 KiB
Haskell
331 lines
12 KiB
Haskell
{-# 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 }
|
|
|
|
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
|
|
}
|
|
}
|
|
|]
|
|
|
|
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}
|
|
|]
|
|
|
|
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
|
|
|
|
instance ApiRequest DataIdClient where
|
|
getApiUrl = ($ ApiR) <$> getUrlRender
|
|
authIdToAuthorization = flip const
|
|
|
|
instance RenderMessage DataIdClient FormMessage where
|
|
renderMessage _ _ = defaultFormMessage
|
|
|
|
instance PathPiece UserID where
|
|
toPathPiece (UserID id) = show id
|
|
fromPathPiece s = UserID <$> readMaybe (toString s)
|
|
|
|
type Form a = Html -> MForm Handler (FormResult a, Widget)
|