From 1380d9d21ea457ad631998c64b63d6aa85b764ce Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 15 Jul 2020 09:31:36 +0200 Subject: [PATCH] feat(invitations): anonymous invitations --- config/settings.yml | 10 +++++----- load/Load.hs | 2 +- messages/uniworx/de-de-formal.msg | 1 + messages/uniworx/en-eu.msg | 6 ++++++ src/Foundation.hs | 5 ++--- src/Handler/Utils/Invitations.hs | 2 +- src/Import/NoModel.hs | 11 ++++++++++- src/Jobs/Handler/Invitation.hs | 9 +++++---- src/Jobs/Types.hs | 2 +- templates/mail/invitation.hamlet | 5 ++++- 10 files changed, 36 insertions(+), 17 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 2e24f25be..929188996 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -35,7 +35,7 @@ bearer-expiration: 604800 bearer-encoding: HS256 maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728" session-files-expire: 3600 -prune-unreferenced-files: 86400 +prune-unreferenced-files: 600 health-check-interval: matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600" http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600" @@ -156,7 +156,7 @@ upload-cache: auto-discover-region: "_env:UPLOAD_S3_AUTO_DISCOVER_REGION:true" disable-cert-validation: "_env:UPLOAD_S3_DISABLE_CERT_VALIDATION:false" upload-cache-bucket: "uni2work-uploads" -inject-files: 300 +inject-files: 60 server-sessions: idle-timeout: 28807 @@ -220,10 +220,10 @@ favourites-quick-actions-cache-ttl: 120 # s token-buckets: inject-files: - depth: 2097152 # 2MiB + depth: 62914560 # 60MiB inv-rate: 9.5e-7 # 1MiB/s initial-value: 0 prune-files: - depth: 10485760 # 10MiB - inv-rate: 1.9e-6 # 2MiB/s + depth: 1258291200 # 1200MiB + inv-rate: 1.9e-6 # 2MiB/s initial-value: 0 diff --git a/load/Load.hs b/load/Load.hs index 5302d3cef..c17a52bd2 100644 --- a/load/Load.hs +++ b/load/Load.hs @@ -297,6 +297,7 @@ runSimulation' LoadSheetSubmission = do name <- Scalpel.attr "name" fileSel return $ partFileRequestBody (decodeUtf8 $ toStrict name) "loadtest.bin" fileUploadPart + let subData = (:) fileData $ formData2 >>= \(name := (renderFormValue -> value)) -> do guard $ name /= encodeUtf8 (fileData ^. partName) return $ partBS (decodeUtf8 name) value @@ -307,7 +308,6 @@ runSimulation' LoadSheetSubmission = do resp3 <- liftIO $ Session.post session (uriToString id formURI mempty) subData void . evaluate $! resp3 - -- print $ resp3 ^. responseStatus -- runSimulation' other = terror $ "Not implemented: " <> tshow other diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index fe3cecba6..19afb89c5 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1008,6 +1008,7 @@ CommCourseSubject: Kursmitteilung MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zum Kursverwalter InvitationAcceptDecline: Einladung annehmen/ablehnen InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in Uni2work ausgelöst hat. +InvitationFromTipAnonymous: Sie erhalten diese Einladung, weil ein nicht eingeloggter Benutzer ihren Versand in Uni2work ausgelöst hat. InvitationUniWorXTip: Uni2work ist ein webbasiertes Lehrverwaltungssystem der LMU München. MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursteilnahme diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index c782ed753..584f680d2 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -332,6 +332,11 @@ SheetGeneratePseudonym: Generate SheetAnonymousCorrection: Anonymized correction SheetAnonymousCorrectionTip: If correction is anonymized, correctors cannot see which students are involved in submissions that are assigned to them (names, matriculation numbers, and registered submission groups are hidden) +SheetArchiveFileTypeDirectoryExercise: exercise +SheetArchiveFileTypeDirectoryHint: hint +SheetArchiveFileTypeDirectorySolution: solution +SheetArchiveFileTypeDirectoryMarking: marking + SheetFormType: Valuation & submission SheetFormTimes: Times SheetFormFiles: Files @@ -1004,6 +1009,7 @@ CommCourseSubject: Course message MailSubjectLecturerInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitation to be a course administrator InvitationAcceptDecline: Accept/Decline invitation InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within Uni2work. +InvitationFromTipAnonymous: You are receiving this invitiation because an user who didn't log in has caused it to be send from within Uni2work. InvitationUniWorXTip: Uni2work is a web based teaching management system at LMU Munich. MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitation to be a course participant diff --git a/src/Foundation.hs b/src/Foundation.hs index 35af34d6b..12ba55520 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -27,7 +27,6 @@ import qualified Network.Wai as W import qualified Network.HTTP.Types.Header as W import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth) -import Yesod.Core.Types (HandlerContents) import qualified Yesod.Core.Unsafe as Unsafe import qualified Data.CaseInsensitive as CI @@ -105,7 +104,7 @@ import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession import Web.Cookie -import Yesod.Core.Types (GHState(..), HandlerData(handlerState, handlerEnv), RunHandlerEnv(rheSite, rheChild)) +import Yesod.Core.Types (GHState(..), HandlerData(..), HandlerContents, RunHandlerEnv(rheSite, rheChild)) import Database.Persist.Sql (transactionUndo, SqlReadBackend(..)) -- | Convenient Type Synonyms: @@ -1733,7 +1732,7 @@ instance Yesod UniWorX where csrfMiddleware handler = do hasBearer <- is _Just <$> lookupBearerAuth - if | hasBearer -> handler + if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler | otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler where csrfSetCookieMiddleware' handler' = do diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 6697f94cb..7d424420d 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -212,7 +212,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' fEnt <- Entity fid <$> get404 fid - jInviter <- liftHandler requireAuthId + jInviter <- liftHandler maybeAuthId route <- mapReaderT liftHandler $ invitationRoute fEnt dat InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 4f20427f9..1fca376b5 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -2,6 +2,7 @@ module Import.NoModel ( module Import , MForm , WeekDay + , requireAuthId ) where import ClassyPrelude.Yesod as Import @@ -29,7 +30,7 @@ import Model.Types.TH.Wordlist as Import import Mail as Import -import Yesod.Auth as Import +import Yesod.Auth as Import hiding (requireAuthId) import Yesod.Core.Types as Import (loggerSet) import Yesod.Default.Config2 as Import import Yesod.Core.Types.Instances as Import @@ -185,6 +186,14 @@ import GHC.TypeLits as Import (KnownSymbol) import Control.Monad.Trans.RWS (RWST) +import qualified Yesod.Auth as Yesod +import GHC.Stack + type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m type WeekDay = DayOfWeek + +requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m), HasCallStack) => m (AuthId (HandlerSite m)) +requireAuthId = do + $logDebugS "requireAuthId" . pack $ prettyCallStack callStack + Yesod.requireAuthId diff --git a/src/Jobs/Handler/Invitation.hs b/src/Jobs/Handler/Invitation.hs index 56d7203c9..f7a1e2e4a 100644 --- a/src/Jobs/Handler/Invitation.hs +++ b/src/Jobs/Handler/Invitation.hs @@ -9,18 +9,19 @@ import qualified Data.CaseInsensitive as CI import Text.Hamlet -dispatchJobInvitation :: UserId +dispatchJobInvitation :: Maybe UserId -> UserEmail -> Text -> Text -> Html -> JobHandler UniWorX dispatchJobInvitation jInviter jInvitee jInvitationUrl jInvitationSubject jInvitationExplanation = JobHandlerException $ do - mInviter <- runDB $ get jInviter + mInviter <- join <$> traverse (runDB . get) jInviter - whenIsJust mInviter $ \jInviter' -> mailT def $ do + mailT def $ do _mailTo .= [Address Nothing $ CI.original jInvitee] - replaceMailHeader "Reply-To" . Just . renderAddress $ userAddressFrom jInviter' + whenIsJust mInviter $ \jInviter' -> + replaceMailHeader "Reply-To" . Just . renderAddress $ userAddressFrom jInviter' replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Subject" $ Just jInvitationSubject addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/invitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index b7fdba876..7b36c2801 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -58,7 +58,7 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica , jSubject :: Maybe Text , jMailContent :: Html } - | JobInvitation { jInviter :: UserId + | JobInvitation { jInviter :: Maybe UserId , jInvitee :: UserEmail , jInvitationUrl :: Text , jInvitationSubject :: Text diff --git a/templates/mail/invitation.hamlet b/templates/mail/invitation.hamlet index ffa11b5cf..38d4f1b38 100644 --- a/templates/mail/invitation.hamlet +++ b/templates/mail/invitation.hamlet @@ -10,6 +10,9 @@ $newline never _{MsgInvitationAcceptDecline}

- _{MsgInvitationFromTip (userDisplayName jInviter')} + $maybe inviter <- mInviter + _{MsgInvitationFromTip (userDisplayName inviter)} + $nothing + _{MsgInvitationFromTipAnonymous}

_{MsgInvitationUniWorXTip}