diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2e3b06abe..1c07086f8 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -10,6 +10,7 @@ BtnSave: Speichern BtnCandidatesInfer: Studienfachzuordnung automatisch lernen BtnCandidatesDeleteConflicts: Konflikte löschen BtnCandidatesDeleteAll: Alle Beobachtungen löschen +BtnResetTokens: Authorisierungs-Tokens invalidieren Aborted: Abgebrochen Remarks: Hinweise @@ -279,6 +280,8 @@ DataProtHeading: Datenschutzerklärung SystemMessageHeading: Uni2work Statusmeldung SystemMessageListHeading: Uni2work Statusmeldungen NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName} +TokensLastReset: Tokens zuletzt invalidiert +TokensResetSuccess: Authorisierungs-Tokens invalidiert HomeOpenCourses: Kurse mit offener Registrierung HomeUpcomingSheets: Anstehende Übungsblätter diff --git a/models/users b/models/users index 80e5ff43c..cd08164d1 100644 --- a/models/users +++ b/models/users @@ -11,6 +11,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create ident (CI Text) -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date + tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer Text Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) email (CI Text) -- Case-insensitive eMail address displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) diff --git a/src/Foundation.hs b/src/Foundation.hs index 533804953..4e2ea8695 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -474,26 +474,26 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ do - jwt <- maybeTMExceptT (unauthorizedI MsgUnauthorizedNoToken) $ asum - [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece - , MaybeT $ lookupGlobalPostParam PostToken - , MaybeT $ lookupGlobalGetParam GetToken - ] + jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt BearerToken{..} <- catch (decodeToken jwt) $ \case BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted other -> do $logWarnS "AuthToken" $ tshow other throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid - unless (maybe True (HashSet.member route) tokenRoutes) $ - throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidRoute + + guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute) + + User{userTokensIssuedAfter} <- lift $ get404 tokenAuthority + guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired) + authorityVal <- evalAccessFor (Just tokenAuthority) route isWrite - unless (is _Authorized authorityVal) $ - throwError authorityVal + guardExceptT (is _Authorized authorityVal) authorityVal + whenIsJust tokenAddAuth $ \addDNF -> do additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) addDNF mAuthId route isWrite - unless (is _Authorized additionalVal) $ - throwError additionalVal + guardExceptT (is _Authorized additionalVal) additionalVal + return Authorized tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of AdminHijackUserR cID -> exceptT return return $ do @@ -2206,6 +2206,7 @@ instance YesodAuth UniWorX where , userDownloadFiles = userDefaultDownloadFiles , userNotificationSettings = def , userMailLanguages = def + , userTokensIssuedAfter = Nothing , .. } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 326beb0d6..f01f34281 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -79,7 +79,26 @@ notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSett notificationForm template = NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True where nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template) - + + +data ButtonResetTokens = BtnResetTokens + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonResetTokens +instance Finite ButtonResetTokens + +nullaryPathPiece ''ButtonResetTokens $ camelToPathPiece' 1 + +embedRenderMessage ''UniWorX ''ButtonResetTokens id +instance Button UniWorX ButtonResetTokens where + btnClasses BtnResetTokens = [BCIsButton, BCDanger] + +data ProfileAnchor = ProfileSettings | ProfileResetTokens + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +instance Universe ProfileAnchor +instance Finite ProfileAnchor + +nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1 + getProfileR, postProfileR :: Handler Html getProfileR = postProfileR @@ -94,37 +113,60 @@ postProfileR = do , stgDownloadFiles = userDownloadFiles , stgNotificationSettings = userNotificationSettings } - ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate - case res of - (FormSuccess SettingsForm{..}) -> do - runDB $ do - update uid [ UserMaxFavourites =. stgMaxFavourties - , UserTheme =. stgTheme - , UserDateTimeFormat =. stgDateTime - , UserDateFormat =. stgDate - , UserTimeFormat =. stgTime - , UserDownloadFiles =. stgDownloadFiles - , UserNotificationSettings =. stgNotificationSettings - ] - when (stgMaxFavourties < userMaxFavourites) $ do - -- prune Favourites to user-defined size - oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid] - [ Desc CourseFavouriteTime - , OffsetBy stgMaxFavourties - ] - mapM_ delete oldFavs - addMessageI Info MsgSettingsUpdate - redirect ProfileR -- TODO: them change does not happen without redirect + ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate - (FormFailure msgs) -> forM_ msgs $ addMessage Warning . toHtml - _ -> return () + formResult res $ \SettingsForm{..} -> do + runDB $ do + update uid [ UserMaxFavourites =. stgMaxFavourties + , UserTheme =. stgTheme + , UserDateTimeFormat =. stgDateTime + , UserDateFormat =. stgDate + , UserTimeFormat =. stgTime + , UserDownloadFiles =. stgDownloadFiles + , UserNotificationSettings =. stgNotificationSettings + ] + when (stgMaxFavourties < userMaxFavourites) $ do + -- prune Favourites to user-defined size + oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid] + [ Desc CourseFavouriteTime + , OffsetBy stgMaxFavourties + ] + mapM_ delete oldFavs + addMessageI Info MsgSettingsUpdate + redirect $ ProfileR :#: ProfileSettings + + ((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm + + formResult tokenRes $ \BtnResetTokens -> do + now <- liftIO getCurrentTime + runDB $ update uid [ UserTokensIssuedAfter =. Just now ] + addMessageI Info MsgTokensResetSuccess + redirect $ ProfileR :#: ProfileResetTokens + + tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do setTitle . toHtml $ "Profil " <> userIdent - wrapForm formWidget def - { formAction = Just $ SomeRoute ProfileR - , formEncoding = formEnctype - } + let settingsForm = + wrapForm formWidget FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings + , formEncoding = formEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just ProfileSettings + } + tokenForm = + wrapForm tokenFormWidget FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ ProfileR :#: ProfileResetTokens + , formEncoding = tokenEnctype + , formAttrs = [] + , formSubmit = FormNoSubmit + , formAnchor = Just ProfileResetTokens + } + tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation") + $(widgetFile "profile/profile") getProfileDataR :: Handler Html @@ -544,18 +586,27 @@ getUserNotificationR = postUserNotificationR postUserNotificationR cID = do uid <- decrypt cID User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid - + ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings + mJwt <- askJwt isModal <- hasCustomHeader HeaderIsModal - let formWidget = wrapForm nsInnerWdgt def + let formWidget = wrapForm nsInnerWdgt' def { formAction = Just . SomeRoute $ UserNotificationR cID , formEncoding = nsEnc , formAttrs = [ ("data-ajax-submit", "") | isModal ] } + nsInnerWdgt' + = [whamlet| + $newline never + $maybe jwt <- mJwt + + ^{nsInnerWdgt} + |] - formResultModal nsRes (UserNotificationR cID) $ \ns -> do + formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetToken, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do lift . runDB $ update uid [ UserNotificationSettings =. ns ] tell . pure =<< messageI Success MsgNotificationSettingsUpdate - siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ + siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do + setTitleI $ MsgNotificationSettingsHeading userDisplayName formWidget diff --git a/src/Model/Token.hs b/src/Model/Token.hs index d9c3afe94..a4d108714 100644 --- a/src/Model/Token.hs +++ b/src/Model/Token.hs @@ -5,13 +5,15 @@ module Model.Token , bearerToken , encodeToken, BearerTokenException(..), decodeToken , tokenToJSON, tokenParseJSON, tokenParseJSON' + , askJwt ) where import ClassyPrelude.Yesod import Model import Settings -import Utils (NTop(..)) +import Utils (NTop(..), hoistMaybe) import Utils.Lens hiding ((.=)) +import Utils.Parameters import Yesod.Auth (AuthId) @@ -40,6 +42,7 @@ import Data.Time.Clock import Data.Time.Clock.POSIX import Control.Monad.Random (MonadRandom(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) data BearerToken site = BearerToken @@ -203,3 +206,15 @@ decodeToken (Jwt bs) = do unless (tokenStartsAt <= Just now) $ throwM BearerTokenNotStarted return token + + +askJwt :: forall m. + ( MonadHandler m + ) + => m (Maybe Jwt) +-- | Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter +askJwt = runMaybeT $ asum + [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece + , MaybeT $ lookupGlobalPostParam PostToken + , MaybeT $ lookupGlobalGetParam GetToken + ] diff --git a/templates/profile.hamlet b/templates/profile.hamlet deleted file mode 100644 index fc6a9bef7..000000000 --- a/templates/profile.hamlet +++ /dev/null @@ -1,2 +0,0 @@ -
- ^{settingsForm} diff --git a/templates/profile/profile.hamlet b/templates/profile/profile.hamlet new file mode 100644 index 000000000..e2b1e4365 --- /dev/null +++ b/templates/profile/profile.hamlet @@ -0,0 +1,13 @@ +$newline never +
+ ^{settingsForm} +
+ ^{tokenExplanation} +

+ _{MsgTokensLastReset}: + $maybe tResetTime' <- tResetTime + \ #{tResetTime'} + $nothing + \ _{MsgNever} +
+ ^{tokenForm} diff --git a/templates/profile/tokenExplanation/de.hamlet b/templates/profile/tokenExplanation/de.hamlet new file mode 100644 index 000000000..2237bddee --- /dev/null +++ b/templates/profile/tokenExplanation/de.hamlet @@ -0,0 +1,13 @@ +

+ Das System stellt gelegentlich Benutzer-bezogene Authorisierungs-Tokens aus. + Diese Tokens erlauben es jedem, der in Besitz dieses Tokens ist, bestimmte Ihrer Benutzer-Rechte anzunehmen. + +

+ Dies ist insbesondere notwendig um verschickten Emails einen Link beifügen zu können, der das Deabonnieren von Benachrichtigungen erlaubt. + +

+ Mit dem untigen Knopf können Sie alle Authorisierungs-Tokens, die bisher für Sie ausgestellt wurden, als ungültig markieren. + Dies ist zum Beispiel dann notwendig, wenn Sie Grund haben zu vermuten, dass Dritte Zugriff auf eines Ihrer Tokens gehabt haben könnten. + +

+ Für die sichere Verwahrung Ihnen ausgehändigter Tokens sind immer Sie selbst verantwortlich.