feat(invitations): anonymous invitations

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
+    depth: 1258291200 # 1200MiB
-    inv-rate: 1.9e-6 # 2MiB/s
+    inv-rate: 1.9e-6  # 2MiB/s
     initial-value: 0

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
 

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

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

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

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

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

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))

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

templates/mail/invitation.hamlet

@@ -10,6 +10,9 @@ $newline never
       <a href=#{jInvitationUrl}>
         _{MsgInvitationAcceptDecline}
     <p>
-      _{MsgInvitationFromTip (userDisplayName jInviter')}
+      $maybe inviter <- mInviter
+        _{MsgInvitationFromTip (userDisplayName inviter)}
+      $nothing
+        _{MsgInvitationFromTipAnonymous}
     <p>
       _{MsgInvitationUniWorXTip}