feat(authorisation): cookie-active-auth-tags

config/settings.yml

@@ -196,6 +196,11 @@ cookies:
     same-site: lax
     http-only: false
     secure: "_env:COOKIES_SECURE:true"
+  ACTIVE-AUTH-TAGS:
+    expires: 12622780800
+    same-site: lax
+    http-only: true
+    secure: "_env:COOKIES_SECURE:true"
 
 user-defaults:
   max-favourites:      12

messages/uniworx/de-de-formal.msg

@@ -805,6 +805,8 @@ PersonalInfoExamAchievementsWip: Die Anzeige von Prüfungsergebnissen wird momen
 PersonalInfoOwnTutorialsWip: Die Anzeige von Tutorien, zu denen Sie als Tutor eingetragen sind wird momentan an dieser Stelle leider noch nicht unterstützt.
 PersonalInfoTutorialsWip: Die Anzeige von Tutorien, zu denen Sie angemeldet sind wird momentan an dieser Stelle leider noch nicht unterstützt.
 
+ActiveAuthTagsSaveCookie: In Cookie speichern?
+ActiveAuthTagsSaveCookieTip: Falls gesetzt werden die aktivierten Authorisierungsprädikate zusätzlich zur aktiven Session auch in einem persistenten Cookie gespeichert. Dies kann vor Allem in Kombination mit Tab-Containern nützlich sein.
 ActiveAuthTags: Aktivierte Authorisierungsprädikate
 
 InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet
@@ -1466,9 +1468,9 @@ ExternalExamUsers coursen@CourseName examn@ExamName: Teilnehmer: #{coursen}, #{e
 
 TitleMetrics: Metriken
 
-AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
+AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. 
 AuthPredsActive: Aktive Authorisierungsprädikate
-AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
+AuthPredsActiveChanged: Authorisierungseinstellungen gespeichert
 AuthTagFree: Seite ist universell zugänglich
 AuthTagAdmin: Nutzer ist Administrator
 AuthTagExamOffice: Nutzer ist mit Prüfungsverwaltung beauftragt

messages/uniworx/en-eu.msg

@@ -802,6 +802,9 @@ PersonalInfoExamAchievementsWip: The feature to display your exam achievements h
 PersonalInfoOwnTutorialsWip: The feature to display tutorials you have been assigned to as tutor has not yet been implemented.
 PersonalInfoTutorialsWip: The feature to display tutorials you have registered for has not yet been implemented.
 
+ActiveAuthTagsSaveCookie: Save in cookie?
+ActiveAuthTagsSaveCookieTip: Should the configuration of active authorisation predicates be additionally saved in a persistent cookie? This may be especially useful if using container tabs.
+
 ActiveAuthTags: Active authorisation predicates
 
 InvalidDateTimeFormat: Invalid date and time format. YYYY-MM-DDTHH:MM[:SS] expected
@@ -1466,9 +1469,9 @@ ExternalExamUsers coursen examn: Exam participants: #{coursen}, #{examn}
 
 TitleMetrics: Metrics
 
-AuthPredsInfo: To view their own courses like a participant would, administrators and correctors can deactivate the checking of their credentials temporarily. Disabled authorisation predicates always fail. This means that deactivated predicates are not checked to grant access where it would otherwise not be permitted. These settings are only temporary, until your session expires i.e. your browser-cookie does. By deactivating predicates you can lock yourself out temporarily, at most.
+AuthPredsInfo: To view their own courses like a participant would, administrators and correctors can deactivate the checking of their credentials temporarily. Disabled authorisation predicates always fail. This means that deactivated predicates are not checked to grant access where it would otherwise not be permitted. 
 AuthPredsActive: Active authorisation predicates
-AuthPredsActiveChanged: Authorisation settings saved for the current session
+AuthPredsActiveChanged: Successfully saved authorisation settings
 AuthTagFree: Page is freely accessable
 AuthTagAdmin: User is administrator
 AuthTagExamOffice: User is part of an exam office

src/Foundation/Instances.hs

@@ -160,6 +160,7 @@ instance YesodAuth UniWorX where
       app <- getYesod
       let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang
              | otherwise = renderMessage app []
+      
       addMessage Success . toHtml $ mr Auth.NowLoggedIn
 
     onErrorHtml dest msg = do

src/Foundation/Yesod/Middleware.hs

@@ -26,7 +26,7 @@ yesodMiddleware :: ( BearerAuthSite UniWorX
                    , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
                    )
                 => HandlerFor UniWorX res -> HandlerFor UniWorX res
-yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware
+yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware . setActiveAuthTagsMiddleware
   where
     dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
     dryRunMiddleware handler = do
@@ -98,6 +98,14 @@ yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . ob
         Nothing       -> return ()
 
       handler
+    setActiveAuthTagsMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    setActiveAuthTagsMiddleware handler = do
+      mtagActive <- lookupSessionJson SessionActiveAuthTags :: HandlerFor UniWorX (Maybe AuthTagActive)
+      when (is _Nothing mtagActive) $ do
+        mAuthTagActive <- lookupRegisteredCookieJson CookieActiveAuthTags
+        for_ mAuthTagActive $ setSessionJson SessionActiveAuthTags . review _ReducedActiveAuthTags
+
+      handler
 
 updateFavourites :: forall m backend.
                     ( MonadHandler m, HandlerSite m ~ UniWorX

src/Handler/Profile.hs

@@ -817,8 +817,9 @@ postAuthPredsR = do
       | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
       | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
 
-  ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
+  ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard $ (,)
-    $ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True
+    <$> apopt checkBoxField (fslI MsgActiveAuthTagsSaveCookie & setTooltip MsgActiveAuthTagsSaveCookieTip) (Just False)
+    <*> fmap AuthTagActive (funcForm taForm (fslI MsgActiveAuthTags) True)
 
   mReferer <- runMaybeT $ do
     param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer)
@@ -837,7 +838,10 @@ postAuthPredsR = do
             ^{authActiveWidget}
           |]
 
-  formResult authActiveRes $ \authTagActive -> do
+  formResult authActiveRes $ \(saveCookie, authTagActive) -> do
+    when saveCookie $ if
+      | authTagActive == def -> deleteRegisteredCookie  CookieActiveAuthTags
+      | otherwise            -> setRegisteredCookieJson CookieActiveAuthTags $ authTagActive ^. _ReducedActiveAuthTags
     setSessionJson SessionActiveAuthTags authTagActive
     modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive)
     addMessageI Success MsgAuthPredsActiveChanged

src/Model/Types/Security.hs

@@ -108,12 +108,15 @@ instance Default AuthTagActive where
     _ -> True
 
 instance ToJSON AuthTagActive where
-  toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF
+  toJSON v = toJSON . HashMap.fromList $ map (toPathPiece &&& authTagIsActive v) universeF
 
 instance FromJSON AuthTagActive where
   parseJSON = Aeson.withObject "AuthTagActive" $ \o -> do
-    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool)
+    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap Text Bool)
-    return . AuthTagActive $ \n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n o'
+    fmap toAuthTagActive . flip ifoldMapM o' $ \k v -> maybeT mempty $ do
+      k' <- hoistMaybe $ fromPathPiece k
+      return $ HashMap.singleton k' v
+    where toAuthTagActive o = AuthTagActive $ \n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n o
 
 instance Hashable AuthTagActive where
   hashWithSalt s = foldl' hashWithSalt s . authTagIsActive
@@ -127,6 +130,27 @@ derivePersistFieldJSON ''AuthTagActive
 getSessionActiveAuthTags :: MonadHandler m => m AuthTagActive
 getSessionActiveAuthTags = fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
 
+newtype ReducedActiveAuthTags = ReducedActiveAuthTags (HashMap AuthTag Bool)
+  deriving newtype (Monoid, Semigroup)
+
+instance ToJSON ReducedActiveAuthTags where
+  toJSON (ReducedActiveAuthTags a) = toJSON $ HashMap.fromList [ (toPathPiece k, v) | (k, v) <- HashMap.toList a ]
+  
+instance FromJSON ReducedActiveAuthTags where
+  parseJSON = Aeson.withObject "ReducedActiveAuthTags" $ \o -> do
+    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap Text Bool)
+    fmap ReducedActiveAuthTags . flip ifoldMap o' $ \k v -> maybeT mempty $ do
+      k' <- hoistMaybe $ fromPathPiece k
+      return $ HashMap.singleton k' v
+
+_ReducedActiveAuthTags :: Iso' AuthTagActive ReducedActiveAuthTags
+_ReducedActiveAuthTags = iso toReducedActiveAuthTags fromReducedActiveAuthTags
+  where
+    toReducedActiveAuthTags a = ReducedActiveAuthTags . flip foldMap universeF $ \n -> if
+      | authTagIsActive a n /= authTagIsActive def n -> HashMap.singleton n $ authTagIsActive a n
+      | otherwise -> mempty
+    fromReducedActiveAuthTags (ReducedActiveAuthTags hm) = AuthTagActive $ \n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n hm
+
 
 data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)

src/Utils/Cookies/Registered.hs

@@ -31,7 +31,7 @@ import Data.Char (isAscii)
 import Data.Monoid (Last(..))
 
 
-data RegisteredCookie = CookieSession | CookieXSRFToken | CookieLang | CookieSystemMessageState
+data RegisteredCookie = CookieSession | CookieXSRFToken | CookieLang | CookieSystemMessageState | CookieActiveAuthTags
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
   deriving anyclass (Universe, Finite, Hashable)
 

templates/i18n/changelog/cookie-active-auth-tags.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Aktive Authorisierungsprädikate können nun in einem persistenten Cookie gespeichert werden

templates/i18n/changelog/cookie-active-auth-tags.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Active authorisation predicates can now be saved as a persistent cookie