diff --git a/config/settings.yml b/config/settings.yml index 1e3a2a7de..aa72c132d 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 55c75cc7e..b7fe3de9a 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -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. diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 3d722ac40..a6b788212 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -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. diff --git a/src/Application.hs b/src/Application.hs index 44f16add8..831ed128f 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 039fb4016..d8dc47961 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 4aaea7262..9285b2e02 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 279e9d66f..8a6d86e2f 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -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 diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs index 3eb7525cc..37772304c 100644 --- a/src/Handler/Utils/I18n.hs +++ b/src/Handler/Utils/I18n.hs @@ -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 diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 01d6ca5e8..84c19ba6b 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -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) diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs index cc87a73c4..66bb85829 100644 --- a/src/Handler/Utils/Workflow/Workflow.hs +++ b/src/Handler/Utils/Workflow/Workflow.hs @@ -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) diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index a5fbaea8d..26a31b2e6 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -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 diff --git a/src/Settings.hs b/src/Settings.hs index ec893b793..ae84b7c42 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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 diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 0ef6ca5a0..d41b7fb76 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -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 -- --------- diff --git a/src/Utils/I18n.hs b/src/Utils/I18n.hs index a2c811a06..08595630d 100644 --- a/src/Utils/I18n.hs +++ b/src/Utils/I18n.hs @@ -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 diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index 50f96b0ad..744e62256 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -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 diff --git a/templates/widgets/asidenav/asidenav.hamlet b/templates/widgets/asidenav/asidenav.hamlet index d678a75eb..da4b8a010 100644 --- a/templates/widgets/asidenav/asidenav.hamlet +++ b/templates/widgets/asidenav/asidenav.hamlet @@ -21,12 +21,12 @@ $newline never

_{favReason}