Breadcrumbs shortened; Term warning added to sheet edit page.

messages/uniworx/de.msg

@@ -285,3 +285,7 @@ DummyLoginTitle: Development-Login
 CorrectorNormal: Normal
 CorrectorMissing: Abwesend
 CorrectorExcused: Entschuldigt
+
+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}

src/Foundation.hs

@@ -677,7 +677,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb TermCurrentR           = return ("Aktuell"   , Just TermShowR)
   breadcrumb TermEditR              = return ("Neu"       , Just TermCurrentR)
   breadcrumb (TermEditExistR tid)   = return ("Editieren" , Just $ TermCourseListR tid)
-  breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
+  breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Nothing)
 
   breadcrumb (TermSchoolCourseListR tid ssh)  = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
 

src/Handler/Sheet.hs

@@ -106,11 +106,11 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
     mr <- getMsgRenderer
     ctime <- liftIO $ getCurrentTime
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
-      <$> areq (ciField textField) (fslI MsgSheetName) (sfName <$> template)
+      <$> areq (ciField textField) (fslI MsgSheetName)    (sfName        <$> template)
       <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
-      <*> sheetTypeAFormReq   (fslI MsgSheetType)                (sfType <$> template)
+      <*> sheetTypeAFormReq   (fslI MsgSheetType)         (sfType        <$> template)
-      <*> sheetGroupAFormReq  (fslI MsgSheetGroup) (sfGrouping <$> template)
+      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
-      <*> aopt htmlField      (fslI MsgSheetMarking) (sfMarkingText <$> template)
+      <*> aopt htmlField      (fslI MsgSheetMarking)      (sfMarkingText <$> template)
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
             & setTooltip MsgSheetVisibleFromTip)
                                                               ((sfVisibleFrom  <$> template) <|> pure (Just ctime))
@@ -120,8 +120,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
       <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
-            & setTooltip MsgSheetHintFromTip)
+            & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)
-                                                              (sfHintFrom     <$> template)
       <*> aopt (multiFileField $ oldFileIds SheetHint)     (fslI MsgSheetHint)      (sfHintF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetSolutionFrom  "Datum, sonst nur für Korrektoren"
             & setTooltip MsgSheetSolutionFromTip)
@@ -442,7 +441,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               }
         mbsid <- dbAction newSheet
         case mbsid of
-          Nothing    -> False <$ addMessageI "danger" (MsgSheetNameDup tid ssh csh sfName)
+          Nothing    -> False <$ addMessageI "error" (MsgSheetNameDup tid ssh csh sfName)
           (Just sid) ->  do -- save files in DB:
             whenIsJust sfSheetF    $ insertSheetFile' sid SheetExercise
             whenIsJust sfHintF     $ insertSheetFile' sid SheetHint
@@ -450,12 +449,16 @@ handleSheetEdit tid ssh csh msId template dbAction = do
             whenIsJust sfMarkingF  $ insertSheetFile' sid SheetMarking
             insert_ $ SheetEdit aid actTime sid
             addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName
+            -- Sanity checks generating warnings only, but not errors!
+            warnTermDays tid [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom]
             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 "warning") . toHtml
+    (FormFailure msgs) -> forM_ msgs $ (addMessage "error") . toHtml
-    _ -> return ()
+    _ -> runDB $ warnTermDays tid $ (join . (flip fmap template))
+          <$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom]
+
   let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
                         (MsgSheetTitle    tid ssh csh) mbshn
 --   let formTitle = pageTitle -- no longer used in template

src/Handler/Utils.hs

@@ -12,6 +12,8 @@ module Handler.Utils
 import Import
 
 import qualified Data.Text as T
+import qualified Data.Set (Set)
+import qualified Data.Set as Set
 
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
@@ -52,3 +54,17 @@ nameWidget displayName surname
             |]
       [] -> error "Data.Text.splitOn returned empty list in violation of specification."
 
+
+warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
+warnTermDays tid times = 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
+                      `Set.difference` outoftermdays
+      warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI "warning" $ msg tid dt
+  forM_ warnholidays  $ warnI MsgDayIsAHoliday
+  forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
+  forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
+

templates/profile.hamlet

@@ -3,8 +3,9 @@
   <dl .deflist.profile-dl>
       <dt .deflist__dt> _{MsgName}
       <dd .deflist__dd> ^{nameWidget userDisplayName userSurname}
-      <dt .deflist__dt> _{MsgMatrikelNr}
+      $maybe matnr <- userMatrikelnummer
-      <dd .deflist__dd> #{display userMatrikelnummer}
+        <dt .deflist__dt> _{MsgMatrikelNr}
+        <dd .deflist__dd> #{matnr}
       <dt .deflist__dt> _{MsgEMail}
       <dd .deflist__dd> #{display userEmail}
       <dt .deflist__dt> _{MsgIdent}