{-# 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|

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|

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|