diff --git a/messages/uniworx/categories/term/de-de-formal.msg b/messages/uniworx/categories/term/de-de-formal.msg
index 445f3c9cf..bb892f022 100644
--- a/messages/uniworx/categories/term/de-de-formal.msg
+++ b/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
\ No newline at end of file
diff --git a/messages/uniworx/categories/term/en-eu.msg b/messages/uniworx/categories/term/en-eu.msg
index c3f048056..30b2f9122 100644
--- a/messages/uniworx/categories/term/en-eu.msg
+++ b/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
diff --git a/models/terms.model b/models/terms.model
index 1ca1daae7..d1ed32dbb 100644
--- a/models/terms.model
+++ b/models/terms.model
@@ -1,6 +1,6 @@
--- Describes each term time.
--- TermIdentifier is either W for Winterterm or S for Summerterm,
--- followed by a two-digit year
+-- | Describes each term time.
+--
+-- `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
\ No newline at end of file
diff --git a/src/Handler/Allocation/Form.hs b/src/Handler/Allocation/Form.hs
index 99c701832..249a1efb3 100644
--- a/src/Handler/Allocation/Form.hs
+++ b/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
diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs
index 2358551d7..d2e687586 100644
--- a/src/Handler/Course/Edit.hs
+++ b/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 . beforeMidnight . termEnd . entityVal <$> mbLastTerm
- , Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm
+ , Just . toMidnight . termStart <$> mbLastTerm
+ , Just . beforeMidnight . termEnd <$> 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)
diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs
index 80cc22c37..cccd6401e 100644
--- a/src/Handler/Course/List.hs
+++ b/src/Handler/Course/List.hs
@@ -220,13 +220,9 @@ getCourseListR = do
$(widgetFile "courses")
getTermCurrentR :: Handler Html
-getTermCurrentR = do
- termIds <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName]
- case fromNullable termIds of
- Nothing
- -> notFound
- Just (maximum -> tid)
- -> redirect (CourseListR, [("courses-term", toPathPiece tid)]) -- redirect avoids problematic breadcrumbs, headings, etc.
+getTermCurrentR = maybeT notFound $ do
+ currentTerm <- MaybeT $ runDB getCurrentTerm
+ redirect (CourseListR, [("courses-term", toPathPiece currentTerm)])
getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
getTermSchoolCourseListR tid ssh = redirect (CourseListR, [("courses-term", toPathPiece tid), ("courses-schoolshort", toPathPiece ssh)])
diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs
index d616420f3..c815162be 100644
--- a/src/Handler/Term.hs
+++ b/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
- guardValidation MsgTermStartMustMatchName $ termStart `withinTerm` termName
- guardValidation MsgTermEndMustBeAfterStart $ termStart < termEnd
- guardValidation MsgTermLectureEndMustBeAfterStart $ termLectureStart < termLectureEnd
- guardValidation MsgTermStartMustBeBeforeLectureStart $ termStart <= termLectureStart
- guardValidation MsgTermEndMustBeAfterLectureEnd $ termEnd >= termLectureEnd
+ TermForm{..} <- State.get
+ guardValidation MsgTermStartMustMatchName $ tfStart `withinTerm` tfName
+ guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
+ guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
+ guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart
+ 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
#{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{..},_)
- -> tickmarkCell termActive
- , sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses)
+ , sortable Nothing (i18nCell MsgTermActive) $ \(_, _, E.Value isActive)
+ -> tickmarkCell isActive
+ , 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
- termEditHandler (Just tid) $ termToTemplate term
+ (term, active) <- runDB $ do
+ 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
- let tid = fromMaybe (TermKey $ termName res) mtid
- runDB $ do
- repsert tid res
- audit $ TransactionTermEdit tid
+ (FormSuccess TermForm{..}) -> exceptT (addMessageI Error) return $ do
+ let tid = TermKey tfName
+ hoist runDB $ do
+ let term = Term
+ { 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 Nothing = mempty
-termToTemplate (Just Term{..}) = TermFormTemplate
+termToTemplate :: Maybe Term -> [TermActiveForm] -> TermFormTemplate
+termToTemplate Nothing active = mempty { tftActive = Just active }
+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
- dayField
- (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))
- MsgTermHolidayMissing
- (const Nothing)
- ("holidays" :: Text)
- (fslI MsgTermHolidays)
- True
- (tftHolidays template)
- flip (renderAForm FormStandard) html $ Term
+ holidayForm = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired
+ where
+ miAdd mkUnique submitView csrf = do
+ (fromRes, fromView) <- mpreq dayField ("" & addName (mkUnique "from") & addPlaceholder (mr MsgTermHolidayPlaceholder)) Nothing
+ (toRes, toView) <- mopt dayField ("" & addName (mkUnique "to") & addPlaceholder (mr MsgTermHolidayPlaceholder)) Nothing
+ let
+ holidaysRes = case (fromRes, toRes) of
+ (FormSuccess f, FormSuccess (Just t)) -> FormSuccess $ Right (f, t)
+ (FormSuccess f, FormSuccess Nothing) -> FormSuccess $ Left f
+ (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
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index 780e6268d..7d9e97e19 100644
--- a/src/Handler/Users.hs
+++ b/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
- E.where_ $ term E.^. TermActive
- E.orderBy [E.desc $ term E.^. TermName]
- E.limit 1
- return $ term E.^. TermId
+ currentTerm <- getCurrentTerm
return . SomeRoute $ case currentTerm of
- [E.Value tid] -> TermSchoolCourseListR tid ssh
- _other -> CourseListR
+ Just tid -> TermSchoolCourseListR tid ssh
+ _other -> CourseListR
getAdminNewFunctionaryInviteR, postAdminNewFunctionaryInviteR :: Handler Html
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 9fc79c27c..a111d58de 100644
--- a/src/Handler/Utils/Form.hs
+++ b/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
- mayEditTerm <- isAuthorized TermEditR True
- let termFilter | Authorized <- mayEditTerm = []
- | otherwise = [TermActive ==. True]
- optionsPersistKey termFilter [Desc TermStart] termName
+termsAllowedField = selectField . fmap (fmap entityKey) $ do
+ mayEditTerm <- hasWriteAccessTo TermEditR
+ now <- liftIO getCurrentTime
+ muid <- maybeAuthId
+ 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
- where terms = map unTermKey tids
+termsActiveOrSetField tids = 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.||. 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
diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs
index 213657cdd..fc87cbaae 100644
--- a/src/Handler/Utils/StudyFeatures.hs
+++ b/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 -> [] )
diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs
index 1fa223378..2aac261c8 100644
--- a/src/Handler/Utils/Term.hs
+++ b/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
diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs
index c0fb48b78..537127fb5 100644
--- a/src/Model/Migration/Definitions.hs
+++ b/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
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 2b5bdd4c6..c331528d5 100644
--- a/src/Utils/Form.hs
+++ b/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
diff --git a/src/Utils/Term.hs b/src/Utils/Term.hs
new file mode 100644
index 000000000..f78127c9e
--- /dev/null
+++ b/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)
diff --git a/templates/term/active-mass-input/add.hamlet b/templates/term/active-mass-input/add.hamlet
new file mode 100644
index 000000000..8618e0366
--- /dev/null
+++ b/templates/term/active-mass-input/add.hamlet
@@ -0,0 +1,10 @@
+$newline never
+
+ #{csrf}
+ ^{fvWidget fromView}
+ |
+ ^{fvWidget toView}
+ |
+ ^{fvWidget forView}
+ |
+ ^{fvWidget submitView}
diff --git a/templates/term/active-mass-input/cell.hamlet b/templates/term/active-mass-input/cell.hamlet
new file mode 100644
index 000000000..c13f2d860
--- /dev/null
+++ b/templates/term/active-mass-input/cell.hamlet
@@ -0,0 +1,8 @@
+$newline never
+ |
+ ^{formatTimeRangeW SelFormatDateTime tafFrom tafTo}
+ |
+ $maybe User{userSurname, userDisplayName} <- user
+ ^{nameWidget userDisplayName userSurname}
+ $nothing
+ —
diff --git a/templates/term/active-mass-input/layout.hamlet b/templates/term/active-mass-input/layout.hamlet
new file mode 100644
index 000000000..b4d978168
--- /dev/null
+++ b/templates/term/active-mass-input/layout.hamlet
@@ -0,0 +1,20 @@
+$newline never
+
+
+
+ |
+ _{MsgTermFormActiveFrom}
+ |
+ _{MsgTermFormActiveTo}
+ |
+ _{MsgTermFormActiveFor}
+ |
+ |
+ $forall coord <- review liveCoords lLength
+
+ ^{cellWdgts ! coord}
+ |
+ ^{fvWidget (delButtons ! coord)}
+ |
+
+ ^{addWdgts ! (0, 0)}
diff --git a/templates/term/holiday-mass-input/add.hamlet b/templates/term/holiday-mass-input/add.hamlet
new file mode 100644
index 000000000..0d6df6dba
--- /dev/null
+++ b/templates/term/holiday-mass-input/add.hamlet
@@ -0,0 +1,8 @@
+$newline never
+|
+ #{csrf}
+ ^{fvWidget fromView}
+ |
+ ^{fvWidget toView}
+ |
+ ^{fvWidget submitView}
diff --git a/templates/term/holiday-mass-input/cell.hamlet b/templates/term/holiday-mass-input/cell.hamlet
new file mode 100644
index 000000000..77d8880d2
--- /dev/null
+++ b/templates/term/holiday-mass-input/cell.hamlet
@@ -0,0 +1,3 @@
+$newline never
+ |
+ ^{formatTimeRangeW SelFormatDate f t}
diff --git a/templates/term/holiday-mass-input/layout.hamlet b/templates/term/holiday-mass-input/layout.hamlet
new file mode 100644
index 000000000..f75c11991
--- /dev/null
+++ b/templates/term/holiday-mass-input/layout.hamlet
@@ -0,0 +1,18 @@
+$newline never
+
+
+
+ |
+ _{MsgTermFormHolidaysFrom}
+ |
+ _{MsgTermFormHolidaysTo}
+ |
+ |
+ $forall coord <- review liveCoords lLength
+
+ ^{cellWdgts ! coord}
+ |
+ ^{fvWidget (delButtons ! coord)}
+ |
+
+ ^{addWdgts ! (0, 0)}
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index fa933ab47..2392d829e 100644
--- a/test/Database/Fill.hs
+++ b/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
- termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
- termLectureEnd = fromWeekDate wYearStart (wWeekStart + 16) 5
- in void . repsert (TermKey term) $ Term
- { termName = term
- , termStart = fromGregorian year 04 01
- , termEnd = fromGregorian year 09 30
- , termHolidays = []
- , termLectureStart
- , termLectureEnd
- , termActive = term >= currentTerm
- }
- Winter -> let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 10 01
- termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
- (fromIntegral -> wYearOffset, wWeekEnd) = (wWeekStart + 18) `divMod` bool 53 54 longYear
- termLectureEnd = fromWeekDate (wYearStart + wYearOffset) (bool id succ (wYearOffset /= 0) wWeekEnd) 5
- longYear = case toWeekDate $ fromOrdinalDate wYearStart 365 of
- (_, 53, _) -> True
- _other -> False
- in void . repsert (TermKey term) $ Term
- { termName = term
- , termStart = fromGregorian year 10 01
- , termEnd = fromGregorian (succ year) 03 31
- , termHolidays = []
- , termLectureStart
- , termLectureEnd
- , termActive = term >= currentTerm
- }
+ Summer -> do
+ let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 04 01
+ termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
+ termLectureEnd = fromWeekDate wYearStart (wWeekStart + 16) 5
+ termStart = fromGregorian year 04 01
+ termEnd = fromGregorian year 09 30
+ void . repsert (TermKey term) $ Term
+ { termName = term
+ , termStart
+ , termEnd
+ , termHolidays = []
+ , termLectureStart
+ , termLectureEnd
+ }
+ void . insert_ $ TermActive (TermKey term) (toMidnight $ addDays (-60) termStart) (Just . beforeMidnight $ addDays 60 termEnd) Nothing
+ Winter -> do
+ let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 10 01
+ termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
+ (fromIntegral -> wYearOffset, wWeekEnd) = (wWeekStart + 18) `divMod` bool 53 54 longYear
+ termLectureEnd = fromWeekDate (wYearStart + wYearOffset) (bool id succ (wYearOffset /= 0) wWeekEnd) 5
+ longYear = case toWeekDate $ fromOrdinalDate wYearStart 365 of
+ (_, 53, _) -> True
+ _other -> False
+ termStart = fromGregorian year 10 01
+ termEnd = fromGregorian (succ year) 03 31
+ void . repsert (TermKey term) $ Term
+ { 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
| |