fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix: hopefully improve workflow auth performance

Browse Source
This commit is contained in:
Gregor Kleen 2020-12-11 19:56:05 +01:00
parent 29c61c5243
commit 1d3fd8c8a7
16 changed files with 396 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
config/settings.yml
View File

@ -87,6 +87,7 @@ auth-pw-hash:
# reload-templates: false
# mutable-static: false
# skip-combining: false
# clear-cache: false
database:
user: "_env:PGUSER:uniworx"
@ -259,3 +260,5 @@ token-buckets:
fallback-personalised-sheet-files-keys-expire: 2419200
download-token-expire: 604801
memcache-auth: true

1
messages/uniworx/de-de-formal.msg
View File

@ -457,6 +457,7 @@ Unauthorized: Sie haben hierfür keine explizite Berechtigung.
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
UnauthorizedNot r@Text: #{r}
UnauthorizedI18nMismatch: Es wurden unterschiedliche Authorisierungs-Ergebnisse für verschiedene Sprachen berechnet
UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt.
UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.

1
messages/uniworx/en-eu.msg
View File

@ -454,6 +454,7 @@ Unauthorized: You do not have explicit authorisation.
UnauthorizedAnd l r: (#{l} AND #{r})
UnauthorizedOr l r: (#{l} OR #{r})
UnauthorizedNot r: (NOT #{r})
UnauthorizedI18nMismatch: Different authentication results were calculated for different languages
UnauthorizedNoToken: No authorisation-token was provided with your request.
UnauthorizedTokenExpired: Your authorisation-token is expired.
UnauthorizedTokenNotStarted: Your authorisation-token is not yet valid.

3
src/Application.hs
View File

@ -257,6 +257,9 @@ makeFoundation appSettings''@AppSettings{..} = do
$logDebugS "setup" "Memcached"
memcachedKey <- clusterSetting (Proxy :: Proxy 'ClusterMemcachedKey) `runSqlPool` sqlPool
memcached <- createMemcached memcachedConf
when appClearCache $ do
$logWarnS "setup" "Clearing memcached"
liftIO $ Memcached.flushAll memcached
return (memcachedKey, memcached)
appSessionStore <- mkSessionStore appSettings'' sqlPool `runSqlPool` sqlPool

193
src/Foundation/Authorization.hs
View File

@ -18,6 +18,7 @@ module Foundation.Authorization
, hasWorkflowRole
, mayViewWorkflowAction, mayViewWorkflowAction'
, authoritiveApproot
, AuthorizationCacheKey(..)
) where
import Import.NoFoundation hiding (Last(..))
@ -31,6 +32,8 @@ import Foundation.DB
import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam
import Handler.Utils.Workflow.CanonicalRoute
import Handler.Utils.Memcached
import Handler.Utils.I18n
import Utils.Course (courseIsVisible)
import Utils.Workflow
@ -53,6 +56,8 @@ import Data.Aeson.Lens hiding (_Value, key)
import qualified Data.Conduit.Combinators as C
import qualified Data.Binary as Binary
type BearerAuthSite site
= ( MonadCrypto (HandlerFor site)
@ -87,22 +92,22 @@ type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool
data AccessPredicate
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
| APDB ((forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
| APDB (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
evalAccessPred :: AccessPredicate -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessPred :: AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
evalAccessPred aPred cont aid r w = liftHandler $ case aPred of
evalAccessPred aPred contCtx cont aid r w = liftHandler $ case aPred of
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> p aid r w
(APDB p) -> runDBRead $ p cont aid r w
(APDB p) -> runDBRead $ p contCtx cont aid r w
instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where
evalAccessPred aPred cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
(APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> lift $ p aid r w
(APDB p) -> p cont aid r w
(APDB p) -> p contCtx cont aid r w
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
@ -118,6 +123,21 @@ andAR _ _ reason@(Unauthorized _) = reason
andAR _ Authorized other = other
andAR _ AuthenticationRequired _ = AuthenticationRequired
_orARI18n, _andARI18n :: MsgRenderer -> I18nAuthResult -> I18nAuthResult -> I18nAuthResult
_orARI18n _ AuthorizedI18n _ = AuthorizedI18n
_orARI18n _ _ AuthorizedI18n = AuthorizedI18n
_orARI18n _ AuthenticationRequiredI18n _ = AuthenticationRequiredI18n
_orARI18n _ _ AuthenticationRequiredI18n = AuthenticationRequiredI18n
_orARI18n mr (UnauthorizedI18n x) (UnauthorizedI18n y) = fmap (Unauthorized . render mr) . MsgUnauthorizedOr <$> x <*> y
_orARI18n mr _ _ = UnauthorizedI18n . opoint $ render mr MsgUnauthorizedI18nMismatch
-- and
_andARI18n mr (UnauthorizedI18n x) (UnauthorizedI18n y) = fmap (Unauthorized . render mr) . MsgUnauthorizedAnd <$> x <*> y
_andARI18n _ reason@(UnauthorizedI18n _) _ = reason
_andARI18n _ _ reason@(UnauthorizedI18n _) = reason
_andARI18n _ AuthorizedI18n other = other
_andARI18n _ AuthenticationRequiredI18n _ = AuthenticationRequiredI18n
_andARI18n mr _ _ = UnauthorizedI18n . opoint $ render mr MsgUnauthorizedI18nMismatch
notAR :: RenderMessage UniWorX msg => MsgRenderer -> msg -> AuthResult -> AuthResult
notAR _ _ (Unauthorized _) = Authorized
notAR _ _ AuthenticationRequired = AuthenticationRequired
@ -315,10 +335,16 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
route <- MaybeT getCurrentRoute
hoistMaybe $ bearer ^? _bearerRestrictionIx route
data AuthorizationCacheKey
= AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow
| AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (Binary)
tagAccessPredicate :: BearerAuthSite UniWorX
=> AuthTag -> AccessPredicate
tagAccessPredicate AuthFree = trueAP
tagAccessPredicate AuthAdmin = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthAdmin = APDB $ \_ _ mAuthId route _ -> case route of
-- Courses: access only to school admins
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@ -355,17 +381,17 @@ tagAccessPredicate AuthAdmin = APDB $ \_ mAuthId route _ -> case route of
adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
return Authorized
tagAccessPredicate AuthSystemExamOffice = APDB $ \_ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
tagAccessPredicate AuthSystemExamOffice = APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
return Authorized
tagAccessPredicate AuthStudent = APDB $ \_ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
tagAccessPredicate AuthStudent = APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemStudent, UserSystemFunctionIsOptOut ==. False]
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedStudent
return Authorized
tagAccessPredicate AuthExamOffice = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthExamOffice = APDB $ \_ _ mAuthId route _ -> case route of
CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
@ -408,7 +434,7 @@ tagAccessPredicate AuthExamOffice = APDB $ \_ mAuthId route _ -> case route of
isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice)
return Authorized
tagAccessPredicate AuthEvaluation = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthEvaluation = APDB $ \_ _ mAuthId route _ -> case route of
ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
@ -424,7 +450,7 @@ tagAccessPredicate AuthEvaluation = APDB $ \_ mAuthId route _ -> case route of
isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
return Authorized
tagAccessPredicate AuthAllocationAdmin = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthAllocationAdmin = APDB $ \_ _ mAuthId route _ -> case route of
AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
@ -440,9 +466,9 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \_ mAuthId route _ -> case route
isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation]
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
return Authorized
tagAccessPredicate AuthToken = APDB $ \_ mAuthId route isWrite -> exceptT return return $
tagAccessPredicate AuthToken = APDB $ \_ _ mAuthId route isWrite -> exceptT return return $
lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe
tagAccessPredicate AuthNoEscalation = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthNoEscalation = APDB $ \_ _ mAuthId route _ -> case route of
AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
uid <- decrypt cID
@ -463,7 +489,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
#else
return $ Unauthorized "Route under development"
#endif
tagAccessPredicate AuthLecturer = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthLecturer = APDB $ \_ _ mAuthId route _ -> case route of
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do
@ -502,7 +528,7 @@ tagAccessPredicate AuthLecturer = APDB $ \_ mAuthId route _ -> case route of
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
return Authorized
tagAccessPredicate AuthCorrector = APDB $ \_ mAuthId route _ -> exceptT return return $ do
tagAccessPredicate AuthCorrector = APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
@ -530,7 +556,7 @@ tagAccessPredicate AuthCorrector = APDB $ \_ mAuthId route _ -> exceptT return r
_ -> do
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
return Authorized
tagAccessPredicate AuthExamCorrector = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthExamCorrector = APDB $ \_ _ mAuthId route _ -> case route of
CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
@ -555,7 +581,7 @@ tagAccessPredicate AuthExamCorrector = APDB $ \_ mAuthId route _ -> case route o
guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
return Authorized
r -> $unsupportedAuthPredicate AuthExamCorrector r
tagAccessPredicate AuthTutor = APDB $ \_ mAuthId route _ -> exceptT return return $ do
tagAccessPredicate AuthTutor = APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
@ -578,14 +604,14 @@ tagAccessPredicate AuthTutor = APDB $ \_ mAuthId route _ -> exceptT return retur
_ -> do
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
return Authorized
tagAccessPredicate AuthTutorControl = APDB $ \_ _ route _ -> case route of
tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
guard tutorialTutorControlled
return Authorized
r -> $unsupportedAuthPredicate AuthTutorControl r
tagAccessPredicate AuthSubmissionGroup = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthSubmissionGroup = APDB $ \_ _ mAuthId route _ -> case route of
CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn
@ -610,7 +636,7 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \_ mAuthId route _ -> case route
return Authorized
r -> $unsupportedAuthPredicate AuthSubmissionGroup r
tagAccessPredicate AuthTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> case route of
tagAccessPredicate AuthTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
@ -790,7 +816,7 @@ tagAccessPredicate AuthTime = APDB $ \(runTACont -> cont) mAuthId route isWrite
return Authorized
r -> $unsupportedAuthPredicate AuthTime r
tagAccessPredicate AuthStaffTime = APDB $ \_ _ route isWrite -> case route of
tagAccessPredicate AuthStaffTime = APDB $ \_ _ _ route isWrite -> case route of
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
@ -815,7 +841,7 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ _ route isWrite -> case route of
return Authorized
r -> $unsupportedAuthPredicate AuthStaffTime r
tagAccessPredicate AuthAllocationTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> case route of
tagAccessPredicate AuthAllocationTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of
CourseR tid ssh csh CRegisterR -> do
now <- liftIO getCurrentTime
mba <- mbAllocation tid ssh csh
@ -859,7 +885,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \(runTACont -> cont) mAuthId rout
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
(cid,) <$> MaybeT (get allocationCourseAllocation)
tagAccessPredicate AuthCourseTime = APDB $ \_ _mAuthId route _ -> case route of
tagAccessPredicate AuthCourseTime = APDB $ \_ _ _mAuthId route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do
now <- liftIO getCurrentTime
courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do
@ -870,7 +896,7 @@ tagAccessPredicate AuthCourseTime = APDB $ \_ _mAuthId route _ -> case route of
guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime)
return Authorized
r -> $unsupportedAuthPredicate AuthCourseTime r
tagAccessPredicate AuthCourseRegistered = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthCourseRegistered = APDB $ \_ _ mAuthId route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
@ -883,7 +909,7 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \_ mAuthId route _ -> case rout
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
return Authorized
r -> $unsupportedAuthPredicate AuthCourseRegistered r
tagAccessPredicate AuthTutorialRegistered = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthTutorialRegistered = APDB $ \_ _ mAuthId route _ -> case route of
CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
@ -908,7 +934,7 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \_ mAuthId route _ -> case ro
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
return Authorized
r -> $unsupportedAuthPredicate AuthTutorialRegistered r
tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ _ route _ -> case route of
tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ _ _ route _ -> case route of
CExamR tid ssh csh examn _ -> exceptT return return $ do
isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
@ -920,7 +946,7 @@ tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ _ route _ -> case
guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration)
return Authorized
r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r
tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \_ _ mAuthId route _ -> case route of
CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do
@ -961,7 +987,7 @@ tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \_ mAuthId route _ -> c
guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
return Authorized
r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r
tagAccessPredicate AuthExamRegistered = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthExamRegistered = APDB $ \_ _ mAuthId route _ -> case route of
CExamR tid ssh csh examn _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
@ -1002,7 +1028,7 @@ tagAccessPredicate AuthExamRegistered = APDB $ \_ mAuthId route _ -> case route
guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam
return Authorized
r -> $unsupportedAuthPredicate AuthExamRegistered r
tagAccessPredicate AuthExamResult = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthExamResult = APDB $ \_ _ mAuthId route _ -> case route of
CExamR tid ssh csh examn _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
@ -1055,14 +1081,14 @@ tagAccessPredicate AuthExamResult = APDB $ \_ mAuthId route _ -> case route of
guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
return Authorized
r -> $unsupportedAuthPredicate AuthExamRegistered r
tagAccessPredicate AuthAllocationRegistered = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthAllocationRegistered = APDB $ \_ _ mAuthId route _ -> case route of
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do
uid <- hoistMaybe mAuthId
aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash
void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
return Authorized
r -> $unsupportedAuthPredicate AuthAllocationRegistered r
tagAccessPredicate AuthParticipant = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthParticipant = APDB $ \_ _ mAuthId route _ -> case route of
CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId
@ -1170,7 +1196,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ mAuthId route _ -> case route of
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
tagAccessPredicate AuthApplicant = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthApplicant = APDB $ \_ _ mAuthId route _ -> case route of
CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do
uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
isApplicant <- isCourseApplicant tid ssh csh uid
@ -1191,7 +1217,7 @@ tagAccessPredicate AuthApplicant = APDB $ \_ mAuthId route _ -> case route of
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
tagAccessPredicate AuthCapacity = APDB $ \_ _ route _ -> case route of
tagAccessPredicate AuthCapacity = APDB $ \_ _ _ route _ -> case route of
CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn
@ -1211,7 +1237,7 @@ tagAccessPredicate AuthCapacity = APDB $ \_ _ route _ -> case route of
guard $ NTop courseCapacity > NTop (Just registered)
return Authorized
r -> $unsupportedAuthPredicate AuthCapacity r
tagAccessPredicate AuthRegisterGroup = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthRegisterGroup = APDB $ \_ _ mAuthId route _ -> case route of
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
@ -1227,8 +1253,8 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \_ mAuthId route _ -> case route o
guard $ not hasOther
return Authorized
r -> $unsupportedAuthPredicate AuthRegisterGroup r
tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _
-> let workflowInstanceWorkflowsEmpty rScope win = maybeT (unauthorizedI MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
tagAccessPredicate AuthEmpty = APDB $ \_ _ mAuthId route _
-> let workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $memcacheAuthHere' (Right diffDay) (mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
scope <- fromRouteWorkflowScope rScope
let dbScope = scope ^. _DBWorkflowScope
getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do
@ -1244,7 +1270,7 @@ tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _
guardM . fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
return True
guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or
return Authorized
return AuthorizedI18n
in case route of
r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute
-> workflowInstanceWorkflowsEmpty rScope win
@ -1268,20 +1294,20 @@ tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return Authorized
r -> $unsupportedAuthPredicate AuthEmpty r
tagAccessPredicate AuthMaterials = APDB $ \_ _ route _ -> case route of
tagAccessPredicate AuthMaterials = APDB $ \_ _ _ route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
guard courseMaterialFree
return Authorized
r -> $unsupportedAuthPredicate AuthMaterials r
tagAccessPredicate AuthOwner = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthOwner = APDB $ \_ _ mAuthId route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
return Authorized
r -> $unsupportedAuthPredicate AuthOwner r
tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \_ _ mAuthId route _ -> case route of
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do
Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
@ -1296,28 +1322,28 @@ tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \_ mAuthId route _ -> cas
E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count
return Authorized
r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r
tagAccessPredicate AuthRated = APDB $ \_ _ route _ -> case route of
tagAccessPredicate AuthRated = APDB $ \_ _ _ route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
sub <- MaybeT $ get sid
guard $ submissionRatingDone sub
return Authorized
r -> $unsupportedAuthPredicate AuthRated r
tagAccessPredicate AuthUserSubmissions = APDB $ \_ _ route _ -> case route of
tagAccessPredicate AuthUserSubmissions = APDB $ \_ _ _ route _ -> case route of
CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
guard $ is _Just submissionModeUser
return Authorized
r -> $unsupportedAuthPredicate AuthUserSubmissions r
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ _ route _ -> case route of
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ _ _ route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
guard submissionModeCorrector
return Authorized
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
tagAccessPredicate AuthSelf = APDB $ \_ mAuthId route _ -> exceptT return return $ do
tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
referencedUser' <- case route of
AdminUserR cID -> return $ Left cID
AdminUserDeleteR cID -> return $ Left cID
@ -1338,7 +1364,7 @@ tagAccessPredicate AuthSelf = APDB $ \_ mAuthId route _ -> exceptT return return
| uid == referencedUser -> return Authorized
Nothing -> return AuthenticationRequired
_other -> unauthorizedI MsgUnauthorizedSelf
tagAccessPredicate AuthIsLDAP = APDB $ \_ _ route _ -> exceptT return return $ do
tagAccessPredicate AuthIsLDAP = APDB $ \_ _ _ route _ -> exceptT return return $ do
referencedUser <- case route of
AdminUserR cID -> return cID
AdminUserDeleteR cID -> return cID
@ -1352,7 +1378,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ _ route _ -> exceptT return return $ d
User{..} <- MaybeT $ get referencedUser'
guard $ userAuthentication == AuthLDAP
return Authorized
tagAccessPredicate AuthIsPWHash = APDB $ \_ _ route _ -> exceptT return return $ do
tagAccessPredicate AuthIsPWHash = APDB $ \_ _ _ route _ -> exceptT return return $ do
referencedUser <- case route of
AdminUserR cID -> return cID
AdminUserDeleteR cID -> return cID
@ -1366,7 +1392,7 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ _ route _ -> exceptT return return $
User{..} <- MaybeT $ get referencedUser'
guard $ is _AuthPWHash userAuthentication
return Authorized
tagAccessPredicate AuthAuthentication = APDB $ \_ mAuthId route _ -> case route of
tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
@ -1380,13 +1406,14 @@ tagAccessPredicate AuthAuthentication = APDB $ \_ mAuthId route _ -> case route
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized
r -> $unsupportedAuthPredicate AuthAuthentication r
tagAccessPredicate AuthWorkflow = APDB $ \eval' mAuthId route isWrite -> do
tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> do
mr <- getMsgRenderer
let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
orAR' = shortCircuitM (is _Authorized) (orAR mr)
_andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
wInitiate win rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInitiate) $ do
wInitiate win rScope = selectLanguageI18n <=< $memcacheAuthHere' (Right diffDay) (evalCtx, route, mAuthId) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowInitiate) $ do -- @isWrite@ not included since it should make no difference regarding initiation (in the end that will always be a write)
scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope
Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
let
@ -1400,52 +1427,57 @@ tagAccessPredicate AuthWorkflow = APDB $ \eval' mAuthId route isWrite -> do
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId Nothing role route isWrite
checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors)
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
return Authorized
return AuthorizedI18n
wWorkflow isWrite' cID
| isWrite' = maybeT (unauthorizedI MsgUnauthorizedWorkflowWrite) $ do
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
(wwId, edges) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowEdgeActors cID) $ do
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
let
wwGraph :: IdWorkflowGraph
wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
let
wwGraph :: IdWorkflowGraph
wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
wwNode = wpTo $ last workflowWorkflowState
wwNode = wpTo $ last workflowWorkflowState
edges = do
return . (wwId, ) . (Set.fromList :: _ -> Set (WorkflowRole UserId)) . foldMap toNullable $ do
WGN{..} <- wwGraph ^.. _wgNodes . folded
WorkflowGraphEdgeManual{..} <- wgnEdges ^.. folded
guard $ wgeSource == wwNode
hoistMaybe . fromNullable $ wgeActors ^.. folded
let
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors)
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList edges)
return Authorized
| otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
(wwId, roles) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
let
wwGraph :: IdWorkflowGraph
wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
let
wwGraph :: IdWorkflowGraph
wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
nodeViewers = do
WorkflowAction{..} <- otoList workflowWorkflowState
(node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
guard $ node == wpTo
WorkflowNodeView{..} <- hoistMaybe wgnViewers
return $ toNullable wnvViewers
payloadViewers = do
(prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState
prevAct <- hoistMaybe $ prevActs ^? _last
payload <- Map.keys $ wpPayload act
guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act)
fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph)
nodeViewers = do
WorkflowAction{..} <- otoList workflowWorkflowState
(node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
guard $ node == wpTo
WorkflowNodeView{..} <- hoistMaybe wgnViewers
return $ toNullable wnvViewers
payloadViewers = do
(prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState
prevAct <- hoistMaybe $ prevActs ^? _last
payload <- Map.keys $ wpPayload act
guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act)
fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph)
return (wwId, fold nodeViewers <> fold payloadViewers :: (Set (WorkflowRole UserId)))
let
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable . otoList $ fold nodeViewers <> fold payloadViewers)
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles)
return Authorized
wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt wwCID
@ -1510,10 +1542,11 @@ routeAuthTags = fmap predDNFEntail . ofoldM parse defaultAuthDNF . routeAttrs
evalAuthTags :: forall ctx m. (Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m
-- ^ `tell`s disabled predicates, identified as pivots
evalAuthTags ctx AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
= do
mr <- getMsgRenderer
let
contCtx = toStrict $ Binary.encode (ctx, authActive)
authVarSpecificity = authTagSpecificity `on` plVar
authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF'
@ -1524,7 +1557,7 @@ evalAuthTags ctx AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toL
where
evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
evalAccessPred (tagAccessPredicate authTag') cont mAuthId' route' isWrite'
evalAccessPred (tagAccessPredicate authTag') contCtx cont mAuthId' route' isWrite'
evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
evalAuthLiteral PLVariable{..} = evalAuthTag plVar

4
src/Foundation/Navigation.hs
View File

@ -523,6 +523,7 @@ navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M`
defaultLinks :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadThrow m
, BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
) => m [Nav]
@ -708,7 +709,8 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
}
}
, do
(haveInstances, haveWorkflows) <- liftHandler . runDB $ (,)
authCtx <- getAuthContext
(haveInstances, haveWorkflows) <- $memcachedByHere (Just $ Right diffDay) authCtx . liftHandler . runDB $ (,) -- We don't expect haveTopWorkflowWorkflows to be relevant and haveTopWorkflowInstances shouldn't change often
<$> haveTopWorkflowInstances
<*> haveTopWorkflowWorkflows

35
src/Foundation/SiteLayout.hs
View File

@ -38,7 +38,7 @@ import Data.FileEmbed (embedFile)
data MemcachedKeyFavourites
= MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang)
= MemcachedKeyFavouriteQuickActions (TermId, SchoolId, CourseShorthand) AuthContext (NonEmpty Lang)
deriving (Generic, Typeable)
deriving instance Eq AuthContext => Eq MemcachedKeyFavourites
@ -157,12 +157,19 @@ siteLayout' overrideHeading widget = do
E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent
return (course, reason, courseVisible)
return ( ( course E.^. CourseName
, course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
, reason
, courseVisible
)
favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do
mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR
mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
return (course, reason, courseVisible, mayView, mayEdit)
favCourses' <- forM favCourses'' $ \((E.Value cName, E.Value tid, E.Value ssh, E.Value csh), reason, E.Value courseVisible) -> do
mayView <- hasReadAccessTo $ CourseR tid ssh csh CShowR
mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR
return ((cName, tid, ssh, csh), reason, courseVisible, mayView, mayEdit)
let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView)
@ -172,16 +179,16 @@ siteLayout' overrideHeading widget = do
)
let favouriteTerms :: [TermIdentifier]
favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites'
favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\((_, tid, _, _), _, _, _, _) -> Set.singleton $ unTermKey tid) favourites'
favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, courseVisible, mayView, mayEdit)
-> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
favourites <- fmap catMaybes . forM favourites' $ \(c@(_, tid, ssh, csh), E.Value mFavourite, courseVisible, mayView, mayEdit)
-> let courseRoute = CourseR tid ssh csh CShowR
favouriteReason = fromMaybe FavouriteCurrent mFavourite
in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
in runMaybeT . guardOnM (unTermKey tid `elem` favouriteTerms) . lift $ do
ctx <- getAuthContext
MsgRenderer mr <- getMsgRenderer
langs <- selectLanguages appLanguages <$> languages
let cK = MemcachedKeyFavouriteQuickActions cId ctx langs
let cK = MemcachedKeyFavouriteQuickActions (tid, ssh, csh) ctx langs
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
items <- memcachedLimitedKeyTimeoutBy
MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
@ -228,10 +235,10 @@ siteLayout' overrideHeading widget = do
navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to navBaseRoute) nav
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
highlightNav = (||) <$> navForceActive <*> (highlight . navBaseRoute)
favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
favouriteTermReason :: TermIdentifier -> FavouriteReason -> [((CourseName, TermId, SchoolId, CourseShorthand), Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
favouriteTermReason tid favReason' = favourites
& filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason')
& sortOn (\(Course{..}, _, _, _, _, _, _) -> courseName)
& filter (\((_, tid', _, _), _, _, favReason, _, _, _) -> unTermKey tid' == tid && favReason == favReason')
& sortOn (\((cName, _, _, _), _, _, _, _, _, _) -> cName)
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and

35
src/Handler/Utils/I18n.hs
View File

@ -2,6 +2,9 @@ module Handler.Utils.I18n
( i18nWidgetFile
, i18nWidgetFiles
, i18nMessage
, authorizedI18n, authenticationRequiredI18n, unauthorizedI18n
, _AuthorizedI18n, _AuthenticationRequiredI18n, _UnauthorizedI18n
, pattern UnauthorizedI18n, pattern AuthorizedI18n, pattern AuthenticationRequiredI18n
, module Utils.I18n
) where
@ -70,3 +73,35 @@ i18nMessage :: ( MonadHandler m
)
=> msg -> m I18nText
i18nMessage = i18nMessageFor $ toList appLanguages
unauthorizedI18n :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, RenderMessage UniWorX msg
)
=> msg -> m I18nAuthResult
unauthorizedI18n = fmap (fmap Unauthorized) . i18nMessage
_UnauthorizedI18n :: Prism' I18nAuthResult I18nText
_UnauthorizedI18n = prism' (fmap Unauthorized) . traverse $ preview _Unauthorized
_AuthorizedI18n :: Prism' I18nAuthResult ()
_AuthorizedI18n = prism' (\() -> authorizedI18n) . traverse_ $ preview _Authorized
_AuthenticationRequiredI18n :: Prism' I18nAuthResult ()
_AuthenticationRequiredI18n = prism' (\() -> authenticationRequiredI18n) . traverse_ $ preview _AuthenticationRequired
authorizedI18n, authenticationRequiredI18n :: I18nAuthResult
authorizedI18n = opoint Authorized
authenticationRequiredI18n = opoint Authorized
pattern UnauthorizedI18n :: I18nText -> I18nAuthResult
pattern UnauthorizedI18n x <- (preview _UnauthorizedI18n -> Just x) where
UnauthorizedI18n = review _UnauthorizedI18n
pattern AuthorizedI18n :: I18nAuthResult
pattern AuthorizedI18n <- (preview _AuthorizedI18n -> Just ()) where
AuthorizedI18n = authorizedI18n
pattern AuthenticationRequiredI18n :: I18nAuthResult
pattern AuthenticationRequiredI18n <- (preview _AuthenticationRequiredI18n -> Just ()) where
AuthenticationRequiredI18n = authenticationRequiredI18n

172
src/Handler/Utils/Memcached.hs
View File

@ -11,6 +11,9 @@ module Handler.Utils.Memcached
, memcachedLimitedHere, memcachedLimitedKeyHere, memcachedLimitedByHere, memcachedLimitedKeyByHere
, memcachedLimitedTimeout, memcachedLimitedKeyTimeout, memcachedLimitedTimeoutBy, memcachedLimitedKeyTimeoutBy
, memcachedLimitedTimeoutHere, memcachedLimitedKeyTimeoutHere, memcachedLimitedTimeoutByHere, memcachedLimitedKeyTimeoutByHere
, memcacheAuth, memcacheAuthHere
, memcacheAuth', memcacheAuthHere'
, memcacheAuthMax, memcacheAuthHereMax
, Expiry
, MemcachedException(..), AsyncTimeoutException(..)
) where
@ -22,9 +25,11 @@ import Foundation.Type
import qualified Database.Memcached.Binary.IO as Memcached
import Data.Bits (Bits(zeroBits), toIntegralSized)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime, getPOSIXTime, POSIXTime)
import qualified Data.Binary as Binary
import qualified Data.Binary.Put as Binary
import qualified Data.Binary.Get as Binary
import Crypto.Hash.Algorithms (SHAKE256)
@ -74,6 +79,55 @@ _MemcachedExpiry = prism' fromExpiry toExpiry
| otherwise
= Left . posixSecondsToUTCTime $ fromIntegral n
data MemcachedValue = MemcachedValue
{ mNonce :: AEAD.Nonce
, mExpiry :: Maybe POSIXTime
, mCiphertext :: ByteString
} deriving (Generic, Typeable)
putExpiry :: Maybe POSIXTime -> Binary.Put
putExpiry mExp = Binary.put $ fromMaybe 0 expEnc
where
expEnc :: Maybe Word64
expEnc = mExp <&> \exp ->
let expEnc' :: Integer
expEnc' = ceiling exp
in if | 0 < expEnc', expEnc' < fromIntegral (maxBound :: Word64)
-> fromIntegral expEnc'
| otherwise
-> error "Expiry cannot be represented in 64 unsigned bits"
getExpiry :: Binary.Get (Maybe POSIXTime)
getExpiry = Binary.label "expiry" $ do
mExpiry' <- Binary.get :: Binary.Get Word64
return $ if
| mExpiry' == 0 -> Nothing
| otherwise -> Just $ fromIntegral mExpiry'
putMemcachedValue :: MemcachedValue -> Binary.Put
putMemcachedValue MemcachedValue{..} = do
Binary.putByteString $ Saltine.encode mNonce
putExpiry mExpiry
Binary.putByteString mCiphertext
getMemcachedValue :: Binary.Get MemcachedValue
getMemcachedValue = do
Binary.lookAhead . Binary.label "length check" $ do
void . Binary.getByteString $ Saltine.secretBoxNonce + 4 + Saltine.secretBoxMac
mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretBoxNonce >>= hoistMaybe . Saltine.decode
mExpiry <- getExpiry
mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString
return MemcachedValue{..}
getMemcachedValueNoExpiry :: Binary.Get MemcachedValue
getMemcachedValueNoExpiry = do
Binary.lookAhead . Binary.label "length check" $ do
void . Binary.getByteString $ Saltine.secretBoxNonce + 4 + Saltine.secretBoxMac
mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretBoxNonce >>= hoistMaybe . Saltine.decode
let mExpiry = Nothing
mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString
return MemcachedValue{..}
memcachedAvailable :: ( MonadHandler m, HandlerSite m ~ UniWorX
)
@ -95,6 +149,11 @@ memcachedKey (Saltine.encode -> kmacKey) p k = Binary.encode k
& kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey
& BA.convert
memcachedAAD :: ByteString -> Maybe POSIXTime -> ByteString
memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do
Binary.putByteString cKey
putExpiry mExpiry
memcachedByGet :: forall a k m.
( MonadHandler m, HandlerSite m ~ UniWorX
, Typeable a, Binary a
@ -109,19 +168,27 @@ memcachedByGet k = runMaybeT $ do
$logDebugS "memcached" "Cache hit"
guard $ length encVal >= Saltine.secretBoxNonce + Saltine.secretBoxMac
let (nonceBS, encrypted) = splitAt Saltine.secretBoxNonce encVal
nonce <- hoistMaybe $ Saltine.decode nonceBS
decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey nonce encrypted cKey
let withExp doExp = do
MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp
$logDebugS "memcached" "Decode valid"
for_ mExpiry $ \expiry -> do
now <- liftIO getPOSIXTime
guard $ expiry > now + clockLeniency
$logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
let aad = memcachedAAD cKey mExpiry
decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey mNonce mCiphertext aad
$logDebugS "memcached" "Decryption valid"
$logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration"
case Binary.decodeOrFail $ fromStrict decrypted of
Right (unconsumed, _, v)
| null unconsumed -> do
$logDebugS "memcached" "Deserialization valid"
return v
_other -> mzero
hoistMaybe $ runGetMaybe Binary.get decrypted
withExp True <|> withExp False
where
runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of
Right (bs', _, x) | null bs' -> Just x
_other -> Nothing
clockLeniency :: NominalDiffTime
clockLeniency = 2
memcachedBySet :: forall a k m.
( MonadHandler m, HandlerSite m ~ UniWorX
@ -134,11 +201,15 @@ memcachedBySet mExp k v = do
mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry
mConn <- getsYesod appMemcached
for_ mConn $ \(aeadKey, conn) -> do
nonce <- liftIO AEAD.newNonce
mNonce <- liftIO AEAD.newNonce
mExpiry <- for mExp $ \case
Left uTime -> return $ utcTimeToPOSIXSeconds uTime
Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime
let cKey = memcachedKey aeadKey (Proxy @a) k
encVal = Saltine.encode nonce <> AEAD.aead aeadKey nonce (toStrict $ Binary.encode v) cKey
liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (fromStrict encVal) conn
$logDebugS "memcached" "Cache store"
aad = memcachedAAD cKey mExpiry
mCiphertext = AEAD.aead aeadKey mNonce (toStrict $ Binary.encode v) aad
liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) conn
$logDebugS "memcached" $ "Cache store: " <> tshow mExpiry
memcachedByInvalidate :: forall a k m p.
( MonadHandler m, HandlerSite m ~ UniWorX
@ -178,20 +249,19 @@ memcachedInvalidate _ = memcachedByInvalidate () $ Proxy @(MemcachedUnkeyed a)
memcachedWith :: Monad m
=> (m (Maybe a), a -> m ()) -> m a -> m a
=> (m (Maybe b), a -> m b) -> m a -> m b
memcachedWith (doGet, doSet) act = do
pRes <- doGet
maybe id (const . return) pRes $ do
res <- act
doSet res
return res
memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m
, Typeable a, Binary a
)
=> Maybe Expiry -> m a -> m a
memcached mExp = memcachedWith (memcachedGet, memcachedSet mExp)
memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x)
memcachedBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m
@ -199,7 +269,7 @@ memcachedBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
, Binary k
)
=> Maybe Expiry -> k -> m a -> m a
memcachedBy mExp k = memcachedWith (memcachedByGet k, memcachedBySet mExp k)
memcachedBy mExp k = memcachedWith (memcachedByGet k, \x -> x <$ memcachedBySet mExp k x)
newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a }
@ -354,6 +424,68 @@ memcachedLimitedKeyByHere = do
[e| \lK burst rate tokens mExp k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedKeyBy lK burst rate tokens mExp (loc, k) . fmap MemcachedKeyedLoc |]
memcacheAuth :: forall m k a.
( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m
, Typeable a, Binary a
, Binary k
)
=> k
-> WriterT (Maybe (Min Expiry)) m a
-> m a
memcacheAuth k mx = cachedByBinary k $ do
mayCache <- getsYesod $ view _appMemcacheAuth
if | mayCache
-> memcachedWith
( memcachedByGet k
, \(x, mExp) -> x <$ case mExp of
Nothing -> return ()
Just (Min exp) -> memcachedBySet (Just exp) k x
) $ runWriterT mx
| otherwise
-> evalWriterT mx
memcacheAuth' :: forall m k a.
( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m
, Typeable a, Binary a
, Binary k
)
=> Expiry
-> k
-> m a
-> m a
memcacheAuth' exp k = memcacheAuth k . (<* tell (Just $ Min exp)) . lift
memcacheAuthMax :: forall m k a.
( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m
, Typeable a, Binary a
, Binary k
)
=> Expiry
-> k
-> WriterT (Maybe (Min Expiry)) m a
-> m a
memcacheAuthMax exp k = memcacheAuth k . (tell (Just $ Min exp) *>)
memcacheAuthHere :: Q Exp
memcacheAuthHere = do
loc <- location
[e| \k -> fmap unMemcachedKeyedLoc . memcacheAuth (loc, k) . fmap MemcachedKeyedLoc |]
memcacheAuthHere' :: Q Exp
memcacheAuthHere' = do
loc <- location
[e| \exp k -> fmap unMemcachedKeyedLoc . memcacheAuth' exp (loc, k) . fmap MemcachedKeyedLoc |]
memcacheAuthHereMax :: Q Exp
memcacheAuthHereMax = do
loc <- location
[e| \exp k -> fmap unMemcachedKeyedLoc . memcacheAuthMax exp (loc, k) . fmap MemcachedKeyedLoc |]
data AsyncTimeoutException = AsyncTimeoutReturnTypeDoesNotMatchComputationKey
deriving (Show, Typeable)
deriving anyclass (Exception)

1
src/Handler/Utils/Workflow/Workflow.hs
View File

@ -31,6 +31,7 @@ followEdge :: ( MonadHandler m
, MonadThrow m
)
=> IdWorkflowGraph -> WorkflowEdgeForm -> Maybe IdWorkflowState -> m IdWorkflowState
-- | Remember to invalidate auth cache
followEdge graph edgeRes cState = do
act <- workflowEdgeFormToAction edgeRes
followAutomaticEdges graph $ maybe id (<>) cState (act `ncons` mempty)

3
src/Handler/Workflow/Workflow/Workflow.hs
View File

@ -91,6 +91,9 @@ workflowR rScope cID = do
edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
nState <- followEdge wGraph edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState
memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ]
return . Just $ do

6
src/Settings.hs
View File

@ -171,6 +171,7 @@ data AppSettings = AppSettings
, appAllowDeprecated :: Bool
-- ^ Indicate if deprecated routes are accessible for everyone
, appEncryptErrors :: Bool
, appClearCache :: Bool
, appUserDefaults :: UserDefaultConf
, appAuthPWHash :: PWHashConf
@ -201,6 +202,8 @@ data AppSettings = AppSettings
, appInitialInstanceID :: Maybe (Either FilePath UUID)
, appRibbon :: Maybe Text
, appMemcacheAuth :: Bool
} deriving Show
data ApprootScope = ApprootUserGenerated | ApprootDefault
@ -534,6 +537,7 @@ instance FromJSON AppSettings where
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
appEncryptErrors <- o .:? "encrypt-errors" .!= not defaultDev
appServerSessionAcidFallback <- o .:? "server-session-acid-fallback" .!= defaultDev
appClearCache <- o .:? "clear-cache" .!= defaultDev
appInitialLogSettings <- o .: "log-settings"
@ -580,6 +584,8 @@ instance FromJSON AppSettings where
appDownloadTokenExpire <- o .: "download-token-expire"
appMemcacheAuth <- o .:? "memcache-auth" .!= False
return AppSettings{..}
makeClassy_ ''AppSettings

12
src/Utils/DateTime.hs
View File

@ -11,6 +11,7 @@ module Utils.DateTime
, mkDateTimeFormatter
, nominalHour, nominalMinute
, minNominalYear, avgNominalYear
, diffMinute, diffHour, diffDay
, module Zones
, day
) where
@ -18,7 +19,7 @@ module Utils.DateTime
import ClassyPrelude.Yesod hiding (lift)
import System.Locale.Read
import Data.Time (NominalDiffTime, nominalDay, LocalTime(..), TimeOfDay, midnight, ZonedTime(..))
import Data.Time (NominalDiffTime, nominalDay, LocalTime(..), TimeOfDay, midnight, ZonedTime(..), DiffTime)
import Data.Time.Zones as Zones (TZ)
import Data.Time.Zones.TH as Zones (includeSystemTZ)
import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime)
@ -148,6 +149,15 @@ minNominalYear, avgNominalYear :: NominalDiffTime
minNominalYear = 365 * nominalDay
avgNominalYear = fromRational $ 365.2425 * toRational nominalDay
--------------
-- DiffTime --
--------------
diffMinute, diffHour, diffDay :: DiffTime
diffMinute = 60
diffHour = 3600
diffDay = 86400
---------
-- Day --
---------

54
src/Utils/I18n.hs
View File

@ -2,7 +2,7 @@
module Utils.I18n
( I18n(..)
, I18nText, I18nHtml
, I18nText, I18nHtml, I18nAuthResult
, renderMessageI18n
, i18nMessageFor
, LanguageSelectI18n(..), getLanguageSelectI18n
@ -46,6 +46,8 @@ import Control.Lens.Extras (is)
import Control.Monad.Fail (fail)
import Data.Binary (Binary)
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
@ -55,11 +57,12 @@ data I18n a = I18n
, i18nFallbackLang :: Maybe Lang
, i18nTranslations :: Map Lang a
} deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Generic, Typeable)
deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable)
deriving anyclass (MonoFunctor, MonoFoldable, MonoTraversable, Binary)
type instance Element (I18n a) = a
type I18nText = I18n Text
type I18nHtml = I18n Html
type I18nAuthResult = I18n AuthResult
instance MonoPointed (I18n a) where
@ -102,6 +105,36 @@ instance FromJSON a => FromJSON (I18n a) where
derivePersistFieldJSON ''I18n
unI18n :: [Lang] -> I18n a -> a
unI18n langs I18n{..} = case i18nFallbackLang of
Just fL -> let translations' = Map.insert fL i18nFallback i18nTranslations
avLangs = fL :| filter (/= fL) (Map.keys i18nTranslations)
in Map.findWithDefault i18nFallback (selectLanguage' avLangs langs) translations'
Nothing -> let fakeLang = go Nothing
where go Nothing | fake `Map.member` i18nTranslations = go $ Just 1
| otherwise = fake
where fake = "fake"
go (Just n) | fake `Map.member` i18nTranslations = go . Just $ succ n
| otherwise = fake
where fake = "fake-" <> tshow n
in Map.findWithDefault i18nFallback (selectLanguage' (fakeLang :| Map.keys i18nTranslations) langs) i18nTranslations
instance Applicative I18n where
pure = opoint
f <*> x = I18n
{ i18nFallback = i18nFallback f $ unI18n (maybeToList $ i18nFallbackLang f) x
, i18nFallbackLang = if
| i18nFallbackLang f == i18nFallbackLang x -> i18nFallbackLang f
| otherwise -> Nothing
, i18nTranslations = Map.fromList $ do
let fLangs = Map.keysSet $ i18nTranslations f
xLangs = Map.keysSet $ i18nTranslations x
lang <- Set.toList $ fLangs <> xLangs
return (lang, unI18n [lang] f $ unI18n [lang] x)
}
renderMessageI18n :: RenderMessage site msg
=> [Lang] -> site -> msg -> I18nText
renderMessageI18n ls app msg = I18n{..}
@ -123,22 +156,7 @@ data LanguageSelectI18n = LanguageSelectI18n { slI18n :: forall a. I18n a -> a }
getLanguageSelectI18n :: MonadHandler m
=> m LanguageSelectI18n
getLanguageSelectI18n = do
langs <- languages
return $ LanguageSelectI18n
( \I18n{..} -> case i18nFallbackLang of
Just fL -> let translations' = Map.insert fL i18nFallback i18nTranslations
avLangs = fL :| filter (/= fL) (Map.keys i18nTranslations)
in Map.findWithDefault i18nFallback (selectLanguage' avLangs langs) translations'
Nothing -> let fakeLang = go Nothing
where go Nothing | fake `Map.member` i18nTranslations = go $ Just 1
| otherwise = fake
where fake = "fake"
go (Just n) | fake `Map.member` i18nTranslations = go . Just $ succ n
| otherwise = fake
where fake = "fake-" <> tshow n
in Map.findWithDefault i18nFallback (selectLanguage' (fakeLang :| Map.keys i18nTranslations) langs) i18nTranslations
)
getLanguageSelectI18n = languages <&> \langs -> LanguageSelectI18n (unI18n langs)
selectLanguageI18n :: MonadHandler m
=> I18n a -> m a

4
src/Yesod/Core/Types/Instances.hs
View File

@ -77,3 +77,7 @@ runCachedMemoT = do
instance site ~ site' => ToWidget site (SomeMessage site') where
toWidget msg = toWidget =<< (getMessageRender <*> pure msg)
deriving instance Generic AuthResult
instance Binary AuthResult

6
templates/widgets/asidenav/asidenav.hamlet
View File

@ -21,12 +21,12 @@ $newline never
<h3 .asidenav__box-subtitle>
_{favReason}
<ul .asidenav__list.list--iconless>
$forall (Course{courseShorthand, courseName}, courseRoute, mPageActions, _, courseVisible, _, mayEdit) <- favouriteTermReason tid favReason
$forall ((cName, _, _, csh), courseRoute, mPageActions, _, courseVisible, _, mayEdit) <- favouriteTermReason tid favReason
<li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
<a .asidenav__link-wrapper href=@{courseRoute}>
<div .asidenav__link-shorthand>#{courseShorthand}
<div .asidenav__link-shorthand>#{csh}
<div .asidenav__link-label>
#{courseName}
#{cName}
$if mayEdit && not courseVisible
\ #{iconInvisible}
<div .asidenav__nested-list-wrapper>