feat(terms): time based term activity

messages/uniworx/categories/term/de-de-formal.msg

@@ -27,3 +27,14 @@ TermActive: Aktiv
 NumCourses num@Int64: #{num} #{pluralDE num "Kurs" "Kurse"}
 TermsHeading: Semesterübersicht
 TermEditHeading: Semester editieren/anlegen
+
+TermFormHolidaysAlreadyAdded: Alle neuen Feiertage sind bereits eingetragen
+TermFormHolidaysFrom: Von
+TermFormHolidaysTo: Bis
+TermExists: Semester existiert bereits
+
+TermFormActiveFrom: Von
+TermFormActiveTo: Bis
+TermFormActiveFor: Für
+TermFormActiveUserNotFound: E-Mail Adresse konnte keinem/keiner Benutzer:in zugeordnet werden
+TermFormActiveAlreadyAdded: Aktivitätszeitraum ist bereits eingetragen

messages/uniworx/categories/term/en-eu.msg

@@ -27,3 +27,14 @@ TermActive: Active
 NumCourses num: #{num} #{pluralEN num "course" "courses"}
 TermsHeading: Semesters
 TermEditHeading: Edit semester
+
+TermFormHolidaysAlreadyAdded: All new holidays were already entered
+TermFormHolidaysFrom: From
+TermFormHolidaysTo: Until
+TermExists: Term already exists
+
+TermFormActiveFrom: From
+TermFormActiveTo: Until
+TermFormActiveFor: For
+TermFormActiveUserNotFound: Email address could not be resolved to a user
+TermFormActiveAlreadyAdded: Activity period was already entered

models/terms.model

@@ -1,6 +1,6 @@
--- Describes each term time.
+-- | Describes each term time.
--- TermIdentifier is either W for Winterterm or S for Summerterm,
+-- 
--- followed by a two-digit year
+-- `TermIdentifier` is either `Winter` or `Summer` and a Year (`Integer`)
 Term json
     name          TermIdentifier -- unTermKey :: TermId -> TermIdentifier
     start         Day            -- TermKey   :: TermIdentifier -> TermId
@@ -8,6 +8,13 @@ Term json
     holidays      [Day]          -- LMU holidays, for display in timetables
     lectureStart  Day            -- lectures usually start/end  later/earlier than the actual term,
     lectureEnd    Day            -- used to generate warnings for lecturers creating unusual courses
-    active        Bool           -- may lecturers add courses to this term?
     Primary name       -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
     deriving Show Eq Generic -- type TermId = Key Term
+
+-- | May lecturers add courses to this term?
+TermActive
+    term          TermId
+    from          UTCTime
+    to            UTCTime Maybe
+    for           UserId Maybe
+    deriving Show Eq Generic

src/Handler/Allocation/Form.hs

@@ -33,12 +33,14 @@ allocationForm :: Maybe AllocationForm
                -> AForm (YesodDB UniWorX) AllocationForm
 allocationForm mTemplate = validateAForm validateAllocationForm . wFormToAForm $ do
   mayEditTerms <- lift . lift $ hasWriteAccessTo TermEditR
+  now <- liftIO getCurrentTime
+  muid <- maybeAuthId
   termOptions <-
     let termQuery :: E.SqlQuery (E.SqlExpr (E.Value TermId))
         termQuery = E.from $ \t -> do
           unless mayEditTerms $
             E.where_ $ E.just (t E.^. TermId) E.==. E.val (afTerm <$> mTemplate)
-                 E.||. t E.^. TermActive
+                 E.||. termIsActiveE (E.val now) (E.val muid) (t E.^. TermId)
           E.orderBy [E.desc $ t E.^. TermStart]
           return $ t E.^. TermId
      in lift . lift $ mkOptionsE
@@ -47,7 +49,6 @@ allocationForm mTemplate = validateAForm validateAllocationForm . wFormToAForm $
           (return . ShortTermIdentifier . unTermKey . E.unValue)
           (return . E.unValue)
 
-  muid <- maybeAuthId
   schoolOptions <-
     let schoolQuery :: E.SqlQuery (E.SqlExpr (Entity School))
         schoolQuery = E.from $ \s -> do

src/Handler/Course/Edit.hs

@@ -131,10 +131,10 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
           mayDelete   <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
           if
             | (mayEditTerm == Authorized) || (mayDelete == Authorized)
-              -> (termsAllowedField, ) <$> runDB (selectKeysList [TermActive ==. True] [])
+              -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms
             | otherwise
               -> return (termsSetField [cfTerm cform], [cfTerm cform])
-      _allOtherCases -> (termsAllowedField, ) <$> runDB (selectKeysList [TermActive ==. True] [])
+      _allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms
 
     let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
         miAdd _ _ nudge btn = Just $ \csrf -> do
@@ -203,16 +203,17 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
     (newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of
         (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
         _allIOtherCases -> do
-            mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
+            mbLastTerm <- liftHandler . runDB . runMaybeT $ MaybeT . get =<< MaybeT getCurrentTerm
             return ( Just $ Just now
-                   , Just . toMidnight     . termStart . entityVal <$> mbLastTerm
+                   , Just . toMidnight     . termStart <$> mbLastTerm
-                   , Just . beforeMidnight . termEnd   . entityVal <$> mbLastTerm
+                   , Just . beforeMidnight . termEnd   <$> mbLastTerm
-                   , Just . beforeMidnight . termEnd   . entityVal <$> mbLastTerm
+                   , Just . beforeMidnight . termEnd   <$> mbLastTerm
                    )
 
     let
       allocationForm :: AForm Handler (Maybe AllocationCourseForm)
       allocationForm = wFormToAForm $ do
+        muid <- maybeAuthId
         availableAllocations' <- liftHandler . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
           E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId
 
@@ -221,7 +222,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
                   E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
                        E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
 
-          E.where_ $ term E.^. TermActive
+          E.where_ $ termIsActiveE (E.val now) (E.val muid) (term E.^. TermId)
                E.||. alreadyParticipates
                E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools
           return (allocation, alreadyParticipates)

src/Handler/Course/List.hs

@@ -220,13 +220,9 @@ getCourseListR = do
     $(widgetFile "courses")
 
 getTermCurrentR :: Handler Html
-getTermCurrentR = do
+getTermCurrentR = maybeT notFound $ do
-  termIds  <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName]
+  currentTerm <- MaybeT $ runDB getCurrentTerm
-  case fromNullable termIds of
+  redirect (CourseListR, [("courses-term", toPathPiece currentTerm)])
-    Nothing
-      -> notFound
-    Just (maximum -> tid)
-      -> redirect (CourseListR, [("courses-term", toPathPiece tid)])  -- redirect avoids problematic breadcrumbs, headings, etc.
 
 getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
 getTermSchoolCourseListR tid ssh = redirect (CourseListR, [("courses-term", toPathPiece tid), ("courses-schoolshort", toPathPiece ssh)])

src/Handler/Term.hs

@@ -10,7 +10,8 @@ import Utils.Course (mayViewCourse)
 
 import Handler.Utils
 
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
+import Data.Map.Strict ((!))
 
 import qualified Database.Esqueleto as E
 
@@ -54,14 +55,14 @@ guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureEnd
 
 
 validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
-             => FormValidator Term m ()
+             => FormValidator TermForm m ()
 validateTerm = do
-  Term{..} <- State.get
+  TermForm{..} <- State.get
-  guardValidation MsgTermStartMustMatchName $ termStart `withinTerm` termName
+  guardValidation MsgTermStartMustMatchName $ tfStart `withinTerm` tfName
-  guardValidation MsgTermEndMustBeAfterStart $ termStart < termEnd
+  guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
-  guardValidation MsgTermLectureEndMustBeAfterStart $ termLectureStart < termLectureEnd
+  guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
-  guardValidation MsgTermStartMustBeBeforeLectureStart $ termStart <= termLectureStart
+  guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart
-  guardValidation MsgTermEndMustBeAfterLectureEnd $ termEnd >= termLectureEnd
+  guardValidation MsgTermEndMustBeAfterLectureEnd $ tfEnd >= tfLectureEnd
 
 
 getTermShowR :: Handler Html
@@ -71,14 +72,15 @@ getTermShowR = do
   ata <- getSessionActiveAuthTags
   table <- runDB $
     let termDBTable = DBTable{..}
-          where dbtSQLQuery term = return (term, courseCount)
+          where dbtSQLQuery term = return (term, courseCount, isActive)
                   where courseCount = E.subSelectCount . E.from $ \course ->
                           E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
                             E.&&. mayViewCourse muid ata now course Nothing
+                        isActive = termIsActiveE (E.val now) (E.val muid) (term E.^. TermId)
                 dbtRowKey = (E.^. TermId)
                 dbtProj = dbrOutput <$> dbtProjId
                 dbtColonnade = widgetColonnade $ mconcat
-                  [ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _)
+                  [ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _, _)
                       -> cell $ do
                            mayEdit <- hasWriteAccessTo $ TermEditExistR tid
                            [whamlet|
@@ -90,19 +92,19 @@ getTermShowR = do
                                <a href=@{TermEditExistR tid}>
                                  #{iconMenuAdmin}
                            |]
-                  , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_)
+                  , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_,_)
                       -> cell $ formatTime SelFormatDate termLectureStart >>= toWidget
-                  , sortable (Just "lecture-end") (i18nCell MsgTermLectureEnd) $ \(Entity _ Term{..},_)
+                  , sortable (Just "lecture-end") (i18nCell MsgTermLectureEnd) $ \(Entity _ Term{..},_,_)
                       -> cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
-                  , sortable Nothing (i18nCell MsgTermActive) $ \(Entity _ Term{..},_)
+                  , sortable Nothing (i18nCell MsgTermActive) $ \(_, _, E.Value isActive)
-                      -> tickmarkCell termActive
+                      -> tickmarkCell isActive
-                  , sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses)
+                  , sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses, _)
                       -> cell [whamlet|_{MsgNumCourses numCourses}|]
-                  , sortable (Just "start") (i18nCell MsgTermStart) $ \(Entity _ Term{..},_)
+                  , sortable (Just "start") (i18nCell MsgTermStart) $ \(Entity _ Term{..},_, _)
                       -> cell $ formatTime SelFormatDate termStart >>= toWidget
-                  , sortable (Just "end") (i18nCell MsgTermEnd) $ \(Entity _ Term{..},_)
+                  , sortable (Just "end") (i18nCell MsgTermEnd) $ \(Entity _ Term{..},_, _)
                       -> cell $ formatTime SelFormatDate termEnd >>= toWidget
-                  , sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_)
+                  , sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_, _)
                       -> cell $ do
                            let termHolidays' = groupHolidays termHolidays
                            [whamlet|
@@ -138,7 +140,7 @@ getTermShowR = do
                   ]
                 dbtFilter = Map.fromList
                   [ ( "active"
-                    , FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool)
+                    , FilterColumn $ \term -> termIsActiveE (E.val now) (E.val muid) (term E.^. TermId) :: E.SqlExpr (E.Value Bool)
                     )
                   , ( "course"
                     , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
@@ -181,20 +183,46 @@ postTermEditR = do
 getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
 getTermEditExistR = postTermEditExistR
 postTermEditExistR tid = do
-  term <- runDB $ get tid
+  (term, active) <- runDB $ do
-  termEditHandler (Just tid) $ termToTemplate term
+    term <- get tid
+    active <- selectList [ TermActiveTerm ==. tid ] []
+    return (term, map entityVal active)
+  termEditHandler (Just tid) $ termToTemplate term (map termActiveToForm active)
 
 
 termEditHandler :: Maybe TermId -> TermFormTemplate -> Handler Html
-termEditHandler mtid term = do
+termEditHandler mtid template = do
     eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
-    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm mtid term
+    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm mtid template
     case result of
-      (FormSuccess res) -> do
+      (FormSuccess TermForm{..}) -> exceptT (addMessageI Error) return $ do
-          let tid = fromMaybe (TermKey $ termName res) mtid
+          let tid = TermKey tfName
-          runDB $ do
+          hoist runDB $ do
-            repsert tid res
+            let term = Term
-            audit $ TransactionTermEdit tid
+                  { termName = tfName
+                  , termStart = tfStart
+                  , termEnd = tfEnd
+                  , termHolidays = tfHolidays
+                  , termLectureStart = tfLectureStart
+                  , termLectureEnd = tfLectureEnd
+                  }
+            case mtid of
+              Just oTId | tid == oTId ->
+                lift $ replace tid term
+              _other -> do
+                whenM (lift $ existsKey tid) $
+                  throwE MsgTermExists
+                lift $ insertKey tid term
+
+            lift $ deleteWhere [TermActiveTerm ==. tid]
+            forM_ tfActive $ \TermActiveForm{..} ->
+              lift $ insert_ TermActive
+                { termActiveTerm = tid
+                , termActiveFrom = tafFrom
+                , termActiveTo = tafTo
+                , termActiveFor = tafFor
+                }
+            lift . audit $ TransactionTermEdit tid
           addMessageI Success $ MsgTermEdited tid
           redirect TermShowR
       FormMissing     -> return ()
@@ -213,7 +241,7 @@ data TermFormTemplate = TermFormTemplate
       , tftHolidays     :: Maybe [Day]
       , tftLectureStart :: Maybe Day
       , tftLectureEnd   :: Maybe Day
-      , tftActive       :: Maybe Bool
+      , tftActive       :: Maybe [TermActiveForm]
       }
 
 -- | TermFormTemplates form a pointwise-left biased Semigroup
@@ -240,20 +268,44 @@ instance Monoid TermFormTemplate where
     , tftActive       = Nothing
     }
 
-termToTemplate ::Maybe Term -> TermFormTemplate
+termToTemplate :: Maybe Term -> [TermActiveForm] -> TermFormTemplate
-termToTemplate Nothing = mempty
+termToTemplate Nothing active = mempty { tftActive = Just active }
-termToTemplate (Just Term{..}) = TermFormTemplate
+termToTemplate (Just Term{..}) active = TermFormTemplate
     { tftName         = Just termName
     , tftStart        = Just termStart
     , tftEnd          = Just termEnd
     , tftHolidays     = Just termHolidays
     , tftLectureStart = Just termLectureStart
     , tftLectureEnd   = Just termLectureEnd
-    , tftActive       = Just termActive
+    , tftActive       = Just active
     }
 
-newTermForm :: Maybe TermId -> TermFormTemplate -> Form Term
+data TermActiveForm = TermActiveForm
+  { tafFrom :: UTCTime
+  , tafTo :: Maybe UTCTime
+  , tafFor :: Maybe UserId
+  } deriving (Eq)
+
+termActiveToForm :: TermActive -> TermActiveForm
+termActiveToForm TermActive{..} = TermActiveForm
+  { tafFrom = termActiveFrom
+  , tafTo = termActiveTo
+  , tafFor = termActiveFor
+  }
+
+data TermForm = TermForm
+  { tfName         :: TermIdentifier
+  , tfStart        :: Day
+  , tfEnd          :: Day
+  , tfHolidays     :: [Day]
+  , tfLectureStart :: Day
+  , tfLectureEnd   :: Day
+  , tfActive       :: [TermActiveForm]
+  }
+
+newTermForm :: Maybe TermId -> TermFormTemplate -> Form TermForm
 newTermForm mtid template = validateForm validateTerm $ \html -> do
+    cRoute <- fromMaybe (error "newTermForm called from 404-Handler") <$> getCurrentRoute
     mr <- getMessageRender
     let
       tidForm
@@ -261,20 +313,75 @@ newTermForm mtid template = validateForm validateTerm $ \html -> do
         = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
         | otherwise
         = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
-      holidayForm = massInputListA
+      holidayForm = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired
-        dayField
+        where
-        (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))
+          miAdd mkUnique submitView csrf = do
-        MsgTermHolidayMissing
+            (fromRes, fromView) <- mpreq dayField ("" & addName (mkUnique "from") & addPlaceholder (mr MsgTermHolidayPlaceholder)) Nothing
-        (const Nothing)
+            (toRes, toView) <- mopt dayField ("" & addName (mkUnique "to") & addPlaceholder (mr MsgTermHolidayPlaceholder)) Nothing
-        ("holidays" :: Text)
+            let
-        (fslI MsgTermHolidays)
+              holidaysRes = case (fromRes, toRes) of
-        True
+                (FormSuccess f, FormSuccess (Just t)) -> FormSuccess $ Right (f, t)
-        (tftHolidays template)
+                (FormSuccess f, FormSuccess Nothing) -> FormSuccess $ Left f
-    flip (renderAForm FormStandard) html $ Term
+                (FormSuccess f, FormMissing) -> FormSuccess $ Left f
+                (f, tRes) -> fmap Left f <* tRes
+              holidaysRes' = holidaysRes <&> \newDat oldDat -> if
+                | let newUngrouped = Set.fromList . ungroupHolidays $ pure newDat
+                      oldUngrouped = Set.fromList $ ungroupHolidays oldDat
+                , newUngrouped `Set.isSubsetOf` oldUngrouped
+                  -> FormFailure [mr MsgTermFormHolidaysAlreadyAdded]
+                | otherwise
+                  -> FormSuccess $ pure newDat
+            return (holidaysRes', $(widgetFile "term/holiday-mass-input/add"))
+          miCell x = $(widgetFile "term/holiday-mass-input/cell")
+            where (f, t) = case x of
+                    Left d -> (d, Nothing)
+                    Right (f', t') -> (f', Just t')
+          miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+          miButtonAction = Just . SomeRoute . (cRoute :#:)
+          miLayout :: MassInputLayout ListLength (Either Day (Day, Day)) ()
+          miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "term/holiday-mass-input/layout")
+          miIdent :: Text
+          miIdent = "holidays"
+          fSettings = fslI MsgTermHolidays
+          fRequired = False
+      ungroupHolidays = foldMap $ \case
+        Left d -> pure d
+        Right (f, t) -> [f..t]
+      activeForm = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired
+        where
+          miAdd mkUnique submitView csrf = do
+            (fromRes, fromView) <- mpreq utcTimeField ("" & addName (mkUnique "from")) Nothing
+            (toRes, toView) <- mopt utcTimeField ("" & addName (mkUnique "to")) Nothing
+            (forRes, forView) <- mopt (checkMap (first $ const MsgTermFormActiveUserNotFound) Right $ userField False Nothing) ("" & addName (mkUnique "for")) Nothing
+            
+            let res = TermActiveForm <$> fromRes <*> toRes <*> forRes
+                res' = res <&> \newDat oldDat -> if
+                  | newDat `elem` oldDat
+                    -> FormFailure [mr MsgTermFormActiveAlreadyAdded]
+                  | otherwise
+                    -> FormSuccess $ pure newDat
+            return (res', $(widgetFile "term/active-mass-input/add"))
+          miCell TermActiveForm{..} = do
+            user <- for tafFor $ liftHandler . runDB . get404
+            $(widgetFile "term/active-mass-input/cell")
+          miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+          miButtonAction = Just . SomeRoute . (cRoute :#:)
+          miLayout :: MassInputLayout ListLength TermActiveForm ()
+          miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "term/active-mass-input/layout")
+          miIdent :: Text
+          miIdent = "active-periods"
+          fSettings = fslI MsgTermActive
+          fRequired = False
+    flip (renderAForm FormStandard) html $ TermForm
       <$> tidForm
       <*> areq dayField  (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
       <*> areq dayField  (fslI MsgTermEndDay   & setTooltip MsgTermEndDayTooltip)   (tftEnd   template)
-      <*> (Set.toList . Set.fromList <$> holidayForm)
+      <*> (ungroupHolidays <$> holidayForm (groupHolidays <$> tftHolidays template))
       <*> areq dayField  (fslI MsgTermLectureStart) (tftLectureStart template)
       <*> areq dayField  (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
-      <*> areq checkBoxField (fslI MsgTermActive) (tftActive template)
+      <*> activeForm (tftActive template)
+
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''TermActiveForm

src/Handler/Users.hs

@@ -650,14 +650,10 @@ functionInvitationConfig = InvitationConfig{..}
       MsgRenderer mr <- getMsgRenderer
       return . SomeMessage . MsgSchoolFunctionInvitationAccepted schoolName $ mr userFunctionFunction
     invitationUltDest (Entity ssh _) _ = do
-      currentTerm <- E.select . E.from $ \term -> do
+      currentTerm <- getCurrentTerm
-        E.where_ $ term E.^. TermActive
-        E.orderBy [E.desc $ term E.^. TermName]
-        E.limit 1
-        return $ term E.^. TermId
       return . SomeRoute $ case currentTerm of
-        [E.Value tid] -> TermSchoolCourseListR tid ssh
+        Just tid -> TermSchoolCourseListR tid ssh
-        _other        -> CourseListR
+        _other   -> CourseListR
 
 
 getAdminNewFunctionaryInviteR, postAdminNewFunctionaryInviteR :: Handler Html

src/Handler/Utils/Form.hs

@@ -21,6 +21,8 @@ import Handler.Utils.Files
 
 import Handler.Utils.Exam
 
+import Utils.Term
+
 import Import
 import Data.Char ( chr, ord, isDigit )
 import qualified Data.Char as Char
@@ -507,14 +509,24 @@ matriculationField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Fi
 matriculationField = textField -- no restrictions, since not everyone has a matriculation and pupils need special tags here
 
 termsActiveField :: Field Handler TermId
-termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
+termsActiveField = selectField . fmap (fmap entityKey) $ do
+  now <- liftIO getCurrentTime
+  muid <- maybeAuthId
+  flip optionsE termName . E.from $ \t -> do
+    E.where_ $ termIsActiveE (E.val now) (E.val muid) (t E.^. TermId)
+    E.orderBy [E.desc $ t E.^. TermStart]
+    return t
 
 termsAllowedField :: Field Handler TermId
-termsAllowedField = selectField $ do
+termsAllowedField = selectField . fmap (fmap entityKey) $ do
-  mayEditTerm <- isAuthorized TermEditR True
+  mayEditTerm <- hasWriteAccessTo TermEditR
-  let termFilter | Authorized <- mayEditTerm = []
+  now <- liftIO getCurrentTime
-                 | otherwise = [TermActive ==. True]
+  muid <- maybeAuthId
-  optionsPersistKey termFilter [Desc TermStart] termName
+  flip optionsE termName . E.from $ \t -> do
+    unless mayEditTerm $
+      E.where_ $ termIsActiveE (E.val now) (E.val muid) (t E.^. TermId)
+    E.orderBy [E.desc $ t E.^. TermStart]
+    return t
 
 termField :: Field Handler TermId
 termField = selectField $ optionsPersistKey [] [Desc TermStart] termName
@@ -524,8 +536,15 @@ termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$
 -- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
 
 termsActiveOrSetField :: [TermId] -> Field Handler TermId
-termsActiveOrSetField tids = selectField $ optionsPersistKey ([TermActive ==.True] ||. [TermName <-. terms]) [Desc TermStart] termName
+termsActiveOrSetField tids = selectField . fmap (fmap entityKey) $ do
-  where terms = map unTermKey tids
+  now <- liftIO getCurrentTime
+  muid <- maybeAuthId
+  flip optionsE termName . E.from $ \t -> do
+    E.where_ $ termIsActiveE (E.val now) (E.val muid) (t E.^. TermId)
+         E.||. t E.^. TermId `E.in_` E.valList tids
+    E.orderBy [E.desc $ t E.^. TermStart]
+    return t
+
 -- termActiveOld :: Field Handler TermIdentifier
 -- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
 

src/Handler/Utils/StudyFeatures.hs

@@ -16,6 +16,8 @@ import Import.NoFoundation
 import Foundation.Type
 import Foundation.I18n
 
+import Utils.Term
+
 import Handler.Utils.StudyFeatures.Parse
 
 import qualified Data.Csv as Csv
@@ -77,11 +79,12 @@ userTableStudyFeatureSort = mconcat
 
 
 isRelevantStudyFeature :: PersistEntity record
-                       => EntityField record TermId
+                       => E.SqlExpr (E.Value UTCTime)
+                       -> EntityField record TermId
                        -> E.SqlExpr (Entity record)
                        -> E.SqlExpr (Entity StudyFeatures)
                        -> E.SqlExpr (E.Value Bool)
-isRelevantStudyFeature termField record studyFeatures
+isRelevantStudyFeature now termField record studyFeatures
       = (       (       overlap studyFeatures E.>. E.val 0
                   E.||. (       E.just (studyFeatures E.^. StudyFeaturesLastObserved) E.==. studyFeatures E.^. StudyFeaturesFirstObserved
                           E.&&. termStart E.<=. E.day (studyFeatures E.^. StudyFeaturesLastObserved)
@@ -90,7 +93,7 @@ isRelevantStudyFeature termField record studyFeatures
                 )
           E.&&. E.not_ (E.exists betterOverlap)
         )
-  E.||. ( E.subSelectForeign record termField (E.^. TermActive)
+  E.||. ( termIsActiveE now E.nothing (record E.^. termField)
           E.&&. E.not_ (E.exists anyOverlap)
           E.&&. studyFeatures E.^. StudyFeaturesValid
         )
@@ -129,11 +132,13 @@ cacheStudyFeatureRelevance :: MonadResource m
                            => (E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool))
                            -> SqlPersistT m ()
 cacheStudyFeatureRelevance fFilter = do
+  now <- liftIO getCurrentTime
+
   E.insertSelectWithConflict UniqueRelevantStudyFeatures
     ( E.from $ \(studyFeatures `E.InnerJoin` term) -> do
         E.on E.true
         E.where_ $ fFilter studyFeatures
-        E.where_ $ isRelevantStudyFeature TermId term studyFeatures
+        E.where_ $ isRelevantStudyFeature (E.val now) TermId term studyFeatures
         return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId)
     )
     ( \_current _excluded -> [] )

src/Handler/Utils/Term.hs

@@ -1,5 +1,8 @@
 module Handler.Utils.Term
   ( groupHolidays
+  , getCurrentTerm
+  , getActiveTerms
+  , module Utils.Term
   ) where
 
 import Import
@@ -7,6 +10,14 @@ import Import
 import qualified Data.Set as Set
 import qualified Data.Sequence as Seq
 
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import Utils.Term
+
+import qualified Data.Conduit.Combinators as C
+
+
 groupHolidays :: ( MonoFoldable mono
                  , Enum (Element mono)
                  , Ord (Element mono)
@@ -20,3 +31,29 @@ groupHolidays = go Seq.empty . foldMap Set.singleton
         go  acc                          xs'
           | Just (x, xs) <- Set.minView xs' = go (acc Seq.:|> Left x) xs
           | otherwise                       = toList acc
+
+getCurrentTerm :: MonadIO m => SqlReadT m (Maybe TermId)
+-- ^ Current, generally active, term (i.e. `termIsActiveE` with `Nothing` as `maybeAuthId`)
+getCurrentTerm = do
+  now <- liftIO getCurrentTime
+  fmap (fmap E.unValue) . E.selectMaybe . E.from $ \term -> do
+    E.where_ . termIsActiveE (E.val now) E.nothing $ term E.^. TermId
+    E.orderBy [E.desc $ term E.^. TermName]
+    return $ term E.^. TermId
+
+getActiveTerms :: ( MonadHandler m, HandlerSite m ~ UniWorX
+                  , BackendCompatible SqlBackend backend
+                  , IsPersistBackend backend
+                  , PersistQueryRead backend, PersistUniqueRead backend
+                  )
+               => ReaderT backend m (Set TermId)
+getActiveTerms = do
+  now <- liftIO getCurrentTime
+  muid <- maybeAuthId
+
+  let activeTermsQuery = E.from $ \term -> E.distinctOnOrderBy [E.asc $ term E.^. TermId] $ do
+        E.where_ . termIsActiveE (E.val now) (E.val muid) $ term E.^. TermId
+        return $ term E.^. TermId
+
+  fmap Set.fromDistinctAscList . runConduit $
+    E.selectSource activeTermsQuery .| C.map E.unValue .| C.sinkList

src/Model/Migration/Definitions.hs

@@ -102,6 +102,7 @@ data ManualMigration
   | Migration20210201SharedWorkflowGraphs
   | Migration20210208StudyFeaturesRelevanceCachedUUIDs
   | Migration20210318CrontabSubmissionRatedNotification
+  | Migration20210608SeparateTermActive
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 
@@ -1047,6 +1048,24 @@ customMigrations = mapF $ \case
   -- Placeholder to inform crontab generation when switchover happened so old submissions don't get notified as corrected
   Migration20210318CrontabSubmissionRatedNotification -> return ()
 
+  Migration20210608SeparateTermActive -> do
+    now <- liftIO getCurrentTime
+
+    whenM (and2M (tableExists "term") (not <$> tableExists "term_active")) $ do
+      [executeQQ|
+        CREATe TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL)
+      |]
+
+      let getTerms = [queryQQ|SELECT "name", "active" FROM "term"|]
+          migrateTerms [ fromPersistValue -> Right (tid :: TermId), fromPersistValue -> Right (isActive :: Bool) ] = when isActive
+            [executeQQ|INSERT INTO term_active (term, "from") VALUES (#{tid}, #{now})|]
+          migrateTerms _ = return ()
+       in runConduit $ getTerms .| C.mapM_ migrateTerms
+
+      [executeQQ|
+        ALTER TABLE "term" DROP COLUMN "active";
+      |]
+
 
 tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableExists table = do

src/Utils/Form.hs

@@ -60,6 +60,8 @@ import Network.URI (URI, parseURI, uriToString)
 
 import Data.Either (fromRight)
 
+import qualified Database.Esqueleto as E
+
 
 --------------------
 -- Field Settings --
@@ -580,6 +582,26 @@ optionsFinite :: ( MonadHandler m
               => m (OptionList a)
 optionsFinite = optionsF universeF
 
+optionsE :: forall record site msg.
+            ( RenderMessage site msg
+            , PersistRecordBackend record SqlBackend
+            , YesodPersist site
+            , E.SqlBackendCanRead (YesodPersistBackend site)
+            , PathPiece (Key record)
+            )
+         => E.SqlQuery (E.SqlExpr (Entity record))
+         -> (record -> msg)
+         -> HandlerFor site (OptionList (Entity record))
+optionsE query toMsg = mkOptionList <$> do
+  mr <- getMessageRender
+  pairs <- runDB $ E.select query
+  return . flip map pairs $ \ent@Entity{..} -> Option
+    { optionDisplay = mr $ toMsg entityVal
+    , optionInternalValue = ent
+    , optionExternalValue = toPathPiece entityKey
+    }
+
+
 fractionalField :: forall m a.
                    ( RealFrac a
                    , Monad m

src/Utils/Term.hs

@@ -0,0 +1,18 @@
+module Utils.Term
+  ( termIsActiveE
+  ) where
+
+import Import.NoFoundation
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+
+termIsActiveE :: E.SqlExpr (E.Value UTCTime) -- ^ @now@
+              -> E.SqlExpr (E.Value (Maybe UserId)) -- ^ `maybeAuthId`
+              -> E.SqlExpr (E.Value TermId)
+              -> E.SqlExpr (E.Value Bool)
+termIsActiveE now muid tId = E.exists . E.from $ \termActive -> do
+  E.where_ $ termActive E.^. TermActiveTerm E.==. tId
+  E.where_ $ E.maybe E.true (\f -> E.just f E.==. muid) (termActive E.^. TermActiveFor)
+  E.where_ $ termActive E.^. TermActiveFrom E.<=. now
+       E.&&. E.maybe E.true (E.>=. now) (termActive E.^. TermActiveTo)

templates/term/active-mass-input/add.hamlet

@@ -0,0 +1,10 @@
+$newline never
+<td>
+  #{csrf}
+  ^{fvWidget fromView}
+<td>
+  ^{fvWidget toView}
+<td>
+  ^{fvWidget forView}
+<td>
+  ^{fvWidget submitView}

templates/term/active-mass-input/cell.hamlet

@@ -0,0 +1,8 @@
+$newline never
+<td colspan=2>
+  ^{formatTimeRangeW SelFormatDateTime tafFrom tafTo}
+<td>
+  $maybe User{userSurname, userDisplayName} <- user
+    ^{nameWidget userDisplayName userSurname}
+  $nothing
+    —

templates/term/active-mass-input/layout.hamlet

@@ -0,0 +1,20 @@
+$newline never
+<table>
+  <thead>
+    <tr>
+      <th>
+        _{MsgTermFormActiveFrom}
+      <th>
+        _{MsgTermFormActiveTo}
+      <th>
+        _{MsgTermFormActiveFor}
+      <td>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvWidget (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}

templates/term/holiday-mass-input/add.hamlet

@@ -0,0 +1,8 @@
+$newline never
+<td>
+  #{csrf}
+  ^{fvWidget fromView}
+<td>
+  ^{fvWidget toView}
+<td>
+  ^{fvWidget submitView}

templates/term/holiday-mass-input/cell.hamlet

@@ -0,0 +1,3 @@
+$newline never
+<td colspan=2>
+  ^{formatTimeRangeW SelFormatDate f t}

templates/term/holiday-mass-input/layout.hamlet

@@ -0,0 +1,18 @@
+$newline never
+<table>
+  <thead>
+    <tr>
+      <th>
+        _{MsgTermFormHolidaysFrom}
+      <th>
+        _{MsgTermFormHolidaysTo}
+      <td>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvWidget (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}

test/Database/Fill.hs

@@ -377,34 +377,40 @@ fillDb = do
   manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
   
   forM_ [prevPrevTerm, prevTerm, currentTerm, nextTerm] $ \term@TermIdentifier{..} -> case season of
-    Summer -> let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 04 01
+    Summer -> do
-                  termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
+      let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 04 01
-                  termLectureEnd = fromWeekDate wYearStart (wWeekStart + 16) 5
+          termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
-               in void . repsert (TermKey term) $ Term
+          termLectureEnd = fromWeekDate wYearStart (wWeekStart + 16) 5
-                  { termName     = term
+          termStart = fromGregorian year 04 01
-                  , termStart    = fromGregorian year 04 01
+          termEnd = fromGregorian year 09 30
-                  , termEnd      = fromGregorian year 09 30
+      void . repsert (TermKey term) $ Term
-                  , termHolidays = []
+        { termName     = term
-                  , termLectureStart
+        , termStart
-                  , termLectureEnd
+        , termEnd
-                  , termActive   = term >= currentTerm
+        , termHolidays = []
-                  }
+        , termLectureStart
-    Winter -> let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 10 01
+        , termLectureEnd
-                  termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
+        }
-                  (fromIntegral -> wYearOffset, wWeekEnd) = (wWeekStart + 18) `divMod` bool 53 54 longYear
+      void . insert_ $ TermActive (TermKey term) (toMidnight $ addDays (-60) termStart) (Just . beforeMidnight $ addDays 60 termEnd) Nothing
-                  termLectureEnd = fromWeekDate (wYearStart + wYearOffset) (bool id succ (wYearOffset /= 0) wWeekEnd) 5
+    Winter -> do
-                  longYear = case toWeekDate $ fromOrdinalDate wYearStart 365 of
+      let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 10 01
-                    (_, 53, _) -> True
+          termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
-                    _other     -> False
+          (fromIntegral -> wYearOffset, wWeekEnd) = (wWeekStart + 18) `divMod` bool 53 54 longYear
-               in void . repsert (TermKey term) $ Term
+          termLectureEnd = fromWeekDate (wYearStart + wYearOffset) (bool id succ (wYearOffset /= 0) wWeekEnd) 5
-                  { termName     = term
+          longYear = case toWeekDate $ fromOrdinalDate wYearStart 365 of
-                  , termStart    = fromGregorian year 10 01
+            (_, 53, _) -> True
-                  , termEnd      = fromGregorian (succ year) 03 31
+            _other     -> False
-                  , termHolidays = []
+          termStart    = fromGregorian year 10 01
-                  , termLectureStart
+          termEnd      = fromGregorian (succ year) 03 31
-                  , termLectureEnd
+      void . repsert (TermKey term) $ Term
-                  , termActive   = term >= currentTerm
+        { termName     = term
-                  }
+        , termStart
+        , termEnd
+        , termHolidays = []
+        , termLectureStart
+        , termLectureEnd
+        }
+      void . insert_ $ TermActive (TermKey term) (toMidnight $ addDays (-60) termStart) (Just . beforeMidnight $ addDays 60 termEnd) Nothing
   ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True)
   mi  <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False)
   void . insert' $ UserFunction gkleen ifi SchoolAdmin