Token revocation & Bugfixes

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

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)

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
+  jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt
-    [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
-    , MaybeT $ lookupGlobalPostParam PostToken
-    , MaybeT $ lookupGlobalGetParam GetToken
-    ]
   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) $
+  guardExceptT (is _Authorized authorityVal) authorityVal
-    throwError authorityVal
+
   whenIsJust tokenAddAuth $ \addDNF -> do
     additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) addDNF mAuthId route isWrite
-    unless (is _Authorized additionalVal) $
+    guardExceptT (is _Authorized additionalVal) additionalVal
-      throwError 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

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
+  ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ 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
 
-    (FormFailure msgs) -> forM_ msgs $ addMessage Warning . toHtml
+  formResult res $ \SettingsForm{..} -> do
-    _ -> return ()
+    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
+    let settingsForm = 
-      { formAction = Just $ SomeRoute ProfileR
+          wrapForm formWidget FormSettings
-      , formEncoding = formEnctype
+            { 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
+              <input type=hidden name=#{toPathPiece PostToken} value=#{toPathPiece jwt}>
+            ^{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

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
+  ]

templates/profile.hamlet

@@ -1,2 +0,0 @@
-<div .profile>
-  ^{settingsForm}

templates/profile/profile.hamlet

@@ -0,0 +1,13 @@
+$newline never
+<section>
+  ^{settingsForm}
+<section>
+  ^{tokenExplanation}
+  <p>
+    _{MsgTokensLastReset}:
+    $maybe tResetTime' <- tResetTime
+      \ #{tResetTime'}
+    $nothing
+      \ _{MsgNever}
+    <br />
+    ^{tokenForm}

templates/profile/tokenExplanation/de.hamlet

@@ -0,0 +1,13 @@
+<p>
+  Das System stellt gelegentlich Benutzer-bezogene <i>Authorisierungs-Tokens</i> aus.
+  Diese Tokens erlauben es jedem, der in Besitz dieses Tokens ist, bestimmte Ihrer Benutzer-Rechte anzunehmen.
+
+<p>
+  Dies ist insbesondere notwendig um verschickten Emails einen Link beifügen zu können, der das Deabonnieren von Benachrichtigungen erlaubt.
+
+<p>
+  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.
+
+<p>
+  Für die sichere Verwahrung Ihnen ausgehändigter Tokens sind immer Sie selbst verantwortlich.