From df073ef7947eb80dc35fe955b92e635881eb50fa Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 8 Jun 2021 15:13:08 +0200 Subject: [PATCH] feat(terms): time based term activity --- .../uniworx/categories/term/de-de-formal.msg | 11 + messages/uniworx/categories/term/en-eu.msg | 11 + models/terms.model | 15 +- src/Handler/Allocation/Form.hs | 5 +- src/Handler/Course/Edit.hs | 15 +- src/Handler/Course/List.hs | 10 +- src/Handler/Term.hs | 199 ++++++++++++++---- src/Handler/Users.hs | 10 +- src/Handler/Utils/Form.hs | 35 ++- src/Handler/Utils/StudyFeatures.hs | 13 +- src/Handler/Utils/Term.hs | 37 ++++ src/Model/Migration/Definitions.hs | 19 ++ src/Utils/Form.hs | 22 ++ src/Utils/Term.hs | 18 ++ templates/term/active-mass-input/add.hamlet | 10 + templates/term/active-mass-input/cell.hamlet | 8 + .../term/active-mass-input/layout.hamlet | 20 ++ templates/term/holiday-mass-input/add.hamlet | 8 + templates/term/holiday-mass-input/cell.hamlet | 3 + .../term/holiday-mass-input/layout.hamlet | 18 ++ test/Database/Fill.hs | 62 +++--- 21 files changed, 436 insertions(+), 113 deletions(-) create mode 100644 src/Utils/Term.hs create mode 100644 templates/term/active-mass-input/add.hamlet create mode 100644 templates/term/active-mass-input/cell.hamlet create mode 100644 templates/term/active-mass-input/layout.hamlet create mode 100644 templates/term/holiday-mass-input/add.hamlet create mode 100644 templates/term/holiday-mass-input/cell.hamlet create mode 100644 templates/term/holiday-mass-input/layout.hamlet 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 + + + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! 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 +
+ _{MsgTermFormActiveFrom} + + _{MsgTermFormActiveTo} + + _{MsgTermFormActiveFor} + +
+ ^{fvWidget (delButtons ! coord)} +
+ #{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 + + + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! 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
+ _{MsgTermFormHolidaysFrom} + + _{MsgTermFormHolidaysTo} + +
+ ^{fvWidget (delButtons ! coord)} +