Towards #298

messages/uniworx/de.msg

@@ -519,9 +519,9 @@ CorrectorMissing: Abwesend
 CorrectorExcused: Entschuldigt
 CorrectorStateTip: Abwesende Korrektoren bekommen bei späteren Übungsblättern mehr Korrekturen zum Ausgleich zugewiesen. Entschuldigte Korrektoren müssen nicht nacharbeiten.
 
-DayIsAHoliday     tid@TermId date@Text: #{date} ist ein Feiertag
-DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszeit des #{display tid}
-DayIsOutOfTerm    tid@TermId date@Text: #{date} liegt nicht im #{display tid}
+DayIsAHoliday     tid@TermId name@Text date@Text: Datum für "#{name}" ist ein Feiertag: #{date}
+DayIsOutOfLecture tid@TermId name@Text date@Text: Datum für "#{name}" ist außerhalb der Vorlesungszeit des #{display tid}: #{date}
+DayIsOutOfTerm    tid@TermId name@Text date@Text: Datum für "#{name}" liegt nicht im Semester #{display tid}: #{date}
 
 UploadModeNone: Kein Upload
 UploadModeAny: Upload, beliebige Datei(en)

src/Handler/Corrections.hs

@@ -802,9 +802,10 @@ postCorrectionsUploadR = do
         (Just subs)
           | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
           | otherwise -> do
-              subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
-              mr <- (toHtml .) <$> getMessageRender
-              addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
+              subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) $ Set.toList subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
+              let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
+                  content = Right $(widgetFile "messages/correctionsUploaded")
+              addMessageModal Success trigger content
 
   let uploadForm = wrapForm upload def
         { formAction = Just $ SomeRoute CorrectionsUploadR
@@ -1008,8 +1009,10 @@ postCorrectionsGradeR = do
                                           , SubmissionRatingTime =. now <$ guard rated
                                           ]
           | otherwise -> return Nothing
-      subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission]
-      unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet")
+      subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)]
+      let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|]
+          content = Right $(widgetFile "messages/correctionsUploaded")
+      unless (null subs') $ addMessageModal Success trigger content
 
   defaultLayout $
     $(widgetFile "corrections-grade")

src/Handler/Sheet.hs

@@ -580,14 +580,25 @@ handleSheetEdit tid ssh csh msId template dbAction = do
             insert_ $ SheetEdit aid actTime sid
             addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
             -- Sanity checks generating warnings only, but not errors!
-            warnTermDays tid [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom]
+            warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
+                [ (sfVisibleFrom,     MsgSheetVisibleFrom)
+                , (Just sfActiveFrom, MsgSheetActiveFrom)
+                , (Just sfActiveTo,   MsgSheetActiveTo)
+                , (sfHintFrom,        MsgSheetSolutionFromTip)
+                , (sfSolutionFrom,    MsgSheetSolutionFrom)
+                ] ]
             return True
       when saveOkay $ redirect $ case msId of
         Just _  -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
         Nothing -> CSheetR tid ssh csh sfName SCorrR
     (FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
-    _ -> runDB $ warnTermDays tid $ (join . (flip fmap template))
-          <$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom]
+    _ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
+            [(sfVisibleFrom  =<< template, MsgSheetVisibleFrom)
+            ,(sfActiveFrom   <$> template, MsgSheetActiveFrom)
+            ,(sfActiveTo     <$> template, MsgSheetActiveTo)
+            ,(sfHintFrom     =<< template, MsgSheetSolutionFromTip)
+            ,(sfSolutionFrom =<< template, MsgSheetSolutionFrom)
+            ] ]
 
   let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
                         (MsgSheetTitle    tid ssh csh) mbshn

src/Handler/Utils.hs

@@ -8,7 +8,8 @@ import Utils.Lens
 
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
--- import qualified Data.Set (Set)
+import Data.Map ((!))
+import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.CaseInsensitive (original)
 -- import qualified Data.CaseInsensitive as CI
@@ -199,15 +200,17 @@ prependCourseTitle tid ssh csh msg = UniWorXMessages
     colonText :: Text
     colonText = ":"
 
-warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
-warnTermDays tid times = do
+warnTermDays :: (RenderMessage UniWorX msg) => TermId -> Map UTCTime msg -> DB ()
+warnTermDays tid timeNames = do
   Term{..} <- get404 tid
-  let alldays       = Set.map utctDay $ Set.fromList $ catMaybes times
-      warnholidays  = Set.intersection alldays $ Set.fromList termHolidays
-      outoftermdays = Set.filter (\d -> d < termStart        || d > termEnd       ) alldays
-      outoflecture  = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays
+  MsgRenderer mr <- getMsgRenderer
+  let alldays       = Map.keysSet timeNames
+      warnholidays  = let hdays = Set.fromList termHolidays in
+                      Set.filter (\(utctDay -> d) -> Set.member d hdays)                         alldays
+      outoftermdays = Set.filter (\(utctDay -> d) -> d < termStart        || d > termEnd       ) alldays
+      outoflecture  = Set.filter (\(utctDay -> d) -> d < termLectureStart || d > termLectureEnd) alldays
                         `Set.difference` outoftermdays -- out of term implies out of lecture-time
-      warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid dt
+      warnI msg d   = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid (mr (timeNames ! d)) dt
   forM_ warnholidays  $ warnI MsgDayIsAHoliday
   forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
   forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
@@ -250,7 +253,7 @@ guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
 guardAuthorizedFor link val =
   val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)
 
-  
+
 runAppLoggingT :: UniWorX -> LoggingT m a -> m a
 runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
   where

src/Handler/Utils/Submission.hs

@@ -344,7 +344,7 @@ extractRatingsMsg = do
           (Right $(widgetFile "messages/submissionFilesIgnored"))
     addMessageWidget Warning ignoredModal
 
--- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
+-- | Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
 msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
 msgSubmissionErrors = flip catches
     [ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: RatingException)

src/Utils/Frontend/Modal.hs

@@ -2,12 +2,14 @@ module Utils.Frontend.Modal
   ( Modal(..)
   , customModal
   , modal, msgModal
+  , addMessageModal
   ) where
 
 import ClassyPrelude.Yesod
 
 import Control.Lens
 import Utils.Route
+import Utils.Message
 
 import Settings (widgetFile)
 
@@ -61,3 +63,12 @@ msgModal modalTrigger' modalContent = do
   customModal Modal{..}
   where
     modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger")
+
+-- | add message alert with a short trigger widget, whose larger content is displayed in a modal
+addMessageModal ::  forall m site.
+                    ( MonadHandler m
+                    , HandlerSite m ~ site
+                    , Yesod site
+                    ) => MessageStatus -> WidgetT site IO () -> Either (SomeRoute site) (WidgetT site IO ()) -> m ()
+addMessageModal ms trigger content =  addMessageWidget ms $ msgModal trigger content
+

src/Utils/Message.hs

@@ -7,7 +7,6 @@ module Utils.Message
   , messageI, messageIHamlet, messageFile, messageWidget
   ) where
 
-
 import Data.Universe
 import Utils.PathPiece
 import Data.Aeson
@@ -110,6 +109,7 @@ addMessageWidget :: forall m site.
                     , Yesod site
                     ) => MessageStatus -> WidgetT site IO () -> m ()
 -- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
+-- also see  Utils.Frontend.Modal.addMessageModal for large alerts with modal links
 addMessageWidget mc wgt = do
   PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
   addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))

templates/messages/correctionsUploaded.hamlet

@@ -1,6 +1,6 @@
 _{MsgCorrectionsUploaded (genericLength subs')}
 
 <ul>
-  $forall cID <- subs'
+  $forall (cID,uuid) <- subs'
     <li>
-      #{toPathPiece cID}
+      ^{simpleLink (toWidget (toPathPiece cID)) (CryptoUUIDDispatchR (ciphertext uuid))}