From 2feb751afa5d9bd7fb68810e0d6b6b1d4941c3f7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 6 Jun 2019 13:35:42 +0200 Subject: [PATCH 1/6] Towards #298 --- messages/uniworx/de.msg | 6 +++--- src/Handler/Corrections.hs | 13 +++++++----- src/Handler/Sheet.hs | 17 ++++++++++++--- src/Handler/Utils.hs | 21 +++++++++++-------- src/Handler/Utils/Submission.hs | 2 +- src/Utils/Frontend/Modal.hs | 11 ++++++++++ src/Utils/Message.hs | 2 +- templates/messages/correctionsUploaded.hamlet | 4 ++-- 8 files changed, 52 insertions(+), 24 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 993bffa46..b02f3a475 100644 --- a/messages/uniworx/de.msg +++ b/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) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index eb053bce9..deadf8c19 100644 --- a/src/Handler/Corrections.hs +++ b/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") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index f315c7709..238224add 100644 --- a/src/Handler/Sheet.hs +++ b/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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 8877dc8de..867291c47 100644 --- a/src/Handler/Utils.hs +++ b/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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 84a747cf5..9bb44bf00 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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) diff --git a/src/Utils/Frontend/Modal.hs b/src/Utils/Frontend/Modal.hs index 94948aeba..49f1f827e 100644 --- a/src/Utils/Frontend/Modal.hs +++ b/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 + diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 7a9e492bc..04dc41dcf 100644 --- a/src/Utils/Message.hs +++ b/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)) diff --git a/templates/messages/correctionsUploaded.hamlet b/templates/messages/correctionsUploaded.hamlet index 2edd0288b..c016ac95a 100644 --- a/templates/messages/correctionsUploaded.hamlet +++ b/templates/messages/correctionsUploaded.hamlet @@ -1,6 +1,6 @@ _{MsgCorrectionsUploaded (genericLength subs')}