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

fix(tutorial): template moving works now

Browse Source
This commit is contained in:
Steffen Jost 2023-06-02 11:50:50 +00:00
parent 79b45be5b6
commit b982e59b63
3 changed files with 16 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Handler/Course/ParticipantInvite.hs
View File

@ -32,6 +32,7 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E
import Utils.Occurrences
type UserSearchKey = Text
@ -316,7 +317,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
Course{..} <- get404 cid
term <- get404 courseTerm
let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime)
newTime = occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime
newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime
dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay
mvTime = fmap $ addLocalDays dayDiff
newType0 = CI.mk . snd . Text.breakOnEnd tutorialTypeSeparator $ CI.original tutorialType

14
src/Handler/Utils/Occurrences.hs
View File

@ -51,8 +51,8 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM
getOccDays :: OccurrenceSchedule -> Set Day -> Set Day
getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday
occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> (Occurrences,_)
occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = (Occurrences newSchedule newExceptions,(dayDiff, offDays,loff,dgb))
occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences
occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions
where
newSchedule = Set.map switchDayOfWeek occurrencesScheduled
dayDiff = diffDays dayNew dayOld
@ -64,16 +64,16 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = (Occurren
switchDayOfWeek os | 0 == dayDiff `mod` 7 = os
switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)}
(loff,newExceptions,dgb) = Set.foldl (flip advanceExceptions) (dayDiff,mempty,mempty) occurrencesExceptions
newExceptions = snd $ Set.foldl' advanceExceptions (dayDiff,mempty) occurrencesExceptions
-- we assume that instance Ord OccurrenceException is ordered chronologically
advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException,_) -> (Integer, Set OccurrenceException,_)
advanceExceptions ex (offset, acc, dbg)
advanceExceptions :: (Integer, Set OccurrenceException) -> OccurrenceException -> (Integer, Set OccurrenceException)
advanceExceptions (offset, acc) ex
| ed `Set.notMember` offDays -- skip term-holidays and weekends, unless the original day was a holiday or weekend
, nd `Set.member` offDays
= advanceExceptions ex (succ offset, acc, ("skip"<>show offset) :dbg)
= advanceExceptions (succ offset, acc) ex
| otherwise
= (offset, Set.insert (setDayOfOccurrenceException nd ex) acc, show ex : dbg)
= (offset, Set.insert (setDayOfOccurrenceException nd ex) acc)
where
ed = dayOfOccurrenceException ex
nd = addDays offset ed

9
test/Database/Fill.hs
View File

@ -1027,7 +1027,7 @@ fillDb = do
insert_ Tutorial
{ tutorialName = mkName "Vorlage"
, tutorialCourse = c
, tutorialType = "Vorlage___Schulung"
, tutorialType = "Vorlage"
, tutorialCapacity = capacity
, tutorialRoom = Just $ case weekDay of
Monday -> "A380"
@ -1045,10 +1045,15 @@ fillDb = do
, exceptEnd = TimeOfDay 16 0 0
}
, ExceptOccur
{ exceptDay = secondDay
{ exceptDay = succ firstDay
, exceptStart = TimeOfDay 9 0 0
, exceptEnd = TimeOfDay 16 0 0
}
, ExceptOccur
{ exceptDay = secondDay
, exceptStart = TimeOfDay 10 12 0
, exceptEnd = TimeOfDay 12 13 0
}
]
}
, tutorialRegGroup = Just "schulung"