fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(terms): time based term activity

Browse Source
This commit is contained in:
Gregor Kleen 2021-06-08 15:13:08 +02:00
parent 669ed3c6ef
commit df073ef794
21 changed files with 436 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
messages/uniworx/categories/term/de-de-formal.msg
View File

@ -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

11
messages/uniworx/categories/term/en-eu.msg
View File

@ -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

15
models/terms.model
View File

@ -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

5
src/Handler/Allocation/Form.hs
View File

@ -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

15
src/Handler/Course/Edit.hs
View File

@ -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)

10
src/Handler/Course/List.hs
View File

@ -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)])

199
src/Handler/Term.hs
View File

@ -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
<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{..},_)
-> 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

10
src/Handler/Users.hs
View File

@ -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

35
src/Handler/Utils/Form.hs
View File

@ -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

13
src/Handler/Utils/StudyFeatures.hs
View File

@ -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 -> [] )

37
src/Handler/Utils/Term.hs
View File

@ -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

19
src/Model/Migration/Definitions.hs
View File

@ -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

22
src/Utils/Form.hs
View File

@ -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

18
src/Utils/Term.hs Normal file
View File

@ -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)

10
templates/term/active-mass-input/add.hamlet Normal file
View File

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

8
templates/term/active-mass-input/cell.hamlet Normal file
View File

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

20
templates/term/active-mass-input/layout.hamlet Normal file
View File

@ -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)}

8
templates/term/holiday-mass-input/add.hamlet Normal file
View File

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

3
templates/term/holiday-mass-input/cell.hamlet Normal file
View File

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

18
templates/term/holiday-mass-input/layout.hamlet Normal file
View File

@ -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)}

62
test/Database/Fill.hs
View File

@ -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