diff --git a/models/courses.model b/models/courses.model index ded2013dd..5f9702b55 100644 --- a/models/courses.model +++ b/models/courses.model @@ -28,13 +28,13 @@ Course -- Information about a single course; contained info is always visible TermSchoolCourseName term school name -- name must be unique within school and semester deriving Generic CourseEvent - type (CI Text) - course CourseId OnDeleteCascade OnUpdateCascade - room RoomReference Maybe - roomHidden Bool default=false - time Occurrences - note StoredMarkup Maybe - lastChanged UTCTime default=now() + type (CI Text) + course CourseId OnDeleteCascade OnUpdateCascade + room RoomReference Maybe + roomHidden Bool default=false + time (JSONB Occurrences) + note StoredMarkup Maybe + lastChanged UTCTime default=now() deriving Generic CourseAppInstructionFile diff --git a/models/tutorials.model b/models/tutorials.model index be27d6a87..e7e21e8b2 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -9,7 +9,7 @@ Tutorial json capacity Int Maybe -- limit for enrolment in this tutorial room RoomReference Maybe roomHidden Bool default=false - time Occurrences + time (JSONB Occurrences) regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 2da4b2e76..853c3450c 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -1000,15 +1000,15 @@ getProblemAvsErrorR = do E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring - qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs) - qerryUsrAvs = $(E.sqlIJproj 2 1) - qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User) - qerryUser = $(E.sqlIJproj 2 2) + querryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs) + querryUsrAvs = $(E.sqlIJproj 2 1) + querryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User) + querryUser = $(E.sqlIJproj 2 2) reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs) reserrUsrAvs = _dbrOutput . _1 -- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User) -- reserrUser = _dbrOutput . _2 - dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) + dbtRowKey = querryUsrAvs >>> (E.^. UserAvsId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR @@ -1022,14 +1022,14 @@ getProblemAvsErrorR = do $ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError) ] dbtSorting = Map.fromList - [ (sortUserNameLink qerryUser) - , ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson)) - , ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch)) - , ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError)) + [ sortUserNameLink querryUser + , ("avs-nr" , SortColumn $ querryUsrAvs >>> (E.^. UserAvsNoPerson)) + , ("avs-last-synch", SortColumnNullsInv $ querryUsrAvs >>> (E.^. UserAvsLastSynch)) + , ("avs-last-error", SortColumn $ querryUsrAvs >>> (E.^. UserAvsLastSynchError)) ] dbtFilter = Map.fromList - [ fltrUserNameEmail qerryUser - , ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError)) + [ fltrUserNameEmail querryUser + , ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to querryUsrAvs) (E.^. UserAvsLastSynchError)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev diff --git a/src/Handler/Course/Events/Edit.hs b/src/Handler/Course/Events/Edit.hs index ceef29fe1..b1af6858e 100644 --- a/src/Handler/Course/Events/Edit.hs +++ b/src/Handler/Course/Events/Edit.hs @@ -28,7 +28,7 @@ postCEvEditR tid ssh csh cID = do , courseEventType = cefType , courseEventRoom = cefRoom , courseEventRoomHidden = cefRoomHidden - , courseEventTime = cefTime + , courseEventTime = cefTime & JSONB , courseEventNote = cefNote , courseEventLastChanged = now } diff --git a/src/Handler/Course/Events/Form.hs b/src/Handler/Course/Events/Form.hs index 29a968826..30eb8ec6c 100644 --- a/src/Handler/Course/Events/Form.hs +++ b/src/Handler/Course/Events/Form.hs @@ -54,6 +54,6 @@ courseEventToForm CourseEvent{..} = CourseEventForm { cefType = courseEventType , cefRoom = courseEventRoom , cefRoomHidden = courseEventRoomHidden - , cefTime = courseEventTime + , cefTime = courseEventTime & unJSONB , cefNote = courseEventNote } diff --git a/src/Handler/Course/Events/New.hs b/src/Handler/Course/Events/New.hs index b43656d98..5c09e2931 100644 --- a/src/Handler/Course/Events/New.hs +++ b/src/Handler/Course/Events/New.hs @@ -26,7 +26,7 @@ postCEventsNewR tid ssh csh = do , courseEventType = cefType , courseEventRoom = cefRoom , courseEventRoomHidden = cefRoomHidden - , courseEventTime = cefTime + , courseEventTime = cefTime & JSONB , courseEventNote = cefNote , courseEventLastChanged = now } diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 53eff795d..c000c9c2b 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -49,15 +49,15 @@ tutorialTemplateNames Nothing = ["Vorlage", "Template"] tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]] tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName -tutorialDefaultName Nothing = formatDayForTutName -tutorialDefaultName (Just ttyp) = +tutorialDefaultName Nothing = formatDayForTutName +tutorialDefaultName (Just ttyp) = let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user -- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this -formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow - where +formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow + where d2u '-' = '_' d2u c = c @@ -151,7 +151,7 @@ instance Monoid AddParticipantsResult where getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR -postCAddUserR tid ssh csh = do +postCAddUserR tid ssh csh = do today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime handleAddUserR tid ssh csh (Right today) Nothing -- postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users @@ -163,8 +163,8 @@ postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html -handleAddUserR tid ssh csh tdesc ttyp = do - (cid, tutTypes, tutNameSuggestions) <- runDB $ do +handleAddUserR tid ssh csh tdesc ttyp = do + (cid, tutTypes, tutNameSuggestions) <- runDB $ do let plainTemplates = tutorialTemplateNames Nothing cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh tutTypes <- E.select $ E.distinct $ do @@ -176,9 +176,9 @@ handleAddUserR tid ssh csh tdesc ttyp = do let typeSet = Set.fromList [ maybe t CI.mk $ Text.stripPrefix temp_sep $ CI.original t | temp <- plainTemplates , let temp_sep = CI.original (temp <> tutorialTypeSeparator) - , E.Value t <- tutTypes + , E.Value t <- tutTypes ] - tutNames <- E.select $ do + tutNames <- E.select $ do tutorial <- E.from $ E.table @Tutorial let tuName = tutorial E.^. TutorialName E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid @@ -192,23 +192,23 @@ handleAddUserR tid ssh csh tdesc ttyp = do currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute - (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm + (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm -- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult - prefillUsers <- case registerConfirmResult of + prefillUsers <- case registerConfirmResult of Nothing -> return mempty - (Just BtnCourseRegisterAbort) -> do + (Just BtnCourseRegisterAbort) -> do addMessageI Warning MsgAborted -- prefill confirmed users for convenience. Note that Browser-Back may also return to the filled form, but history.back() does not in Chrome confirmedActs :: [CourseRegisterActionData] <- exceptT (const $ return mempty) return . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction -- ignore any exception, since it is only used to prefill a form field for convenience return $ Just $ Set.fromList $ fmap crActIdent confirmedActs (Just BtnCourseRegisterConfirm) -> do - confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction + confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction -- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs let users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs - actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! + actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! registeredUsers <- registerUsers cid users whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do @@ -218,13 +218,13 @@ handleAddUserR tid ssh csh tdesc ttyp = do redirect $ CTutorialR tid ssh csh tName TUsersR redirect $ CourseR tid ssh csh CUsersR return mempty - + ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . identifyForm FIDCourseRegister . renderWForm FormStandard $ do let tutTypesMsg = [(SomeMessage tt,tt) | tt <- tutTypes] - tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing) + tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing) auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) prefillUsers auReqTutorial <- optionalActionW - ( (,,) + ( (,,) <$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ maybeLeft tdesc) @@ -349,12 +349,12 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do existingTut <- getBy $ UniqueTutorial cid newTutorialName templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType, Asc TutorialName] case (existingTut, newFirstDay, templateEnt) of - (Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day + (Just Entity{entityKey=tid},_,_) -> return tid -- no need to update, we ignore the anchor day (Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do Course{..} <- get404 cid term <- get404 courseTerm - let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) - newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime + let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term $ unJSONB tutorialTime) + newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) $ unJSONB tutorialTime dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay mvTime = fmap $ addLocalDays dayDiff newType0 = CI.map (snd . Text.breakOnEnd (CI.original tutorialTypeSeparator)) tutorialType @@ -367,13 +367,13 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do , tutorialCourse = cid , tutorialType = newType , tutorialFirstDay = newFirstDay - , tutorialTime = newTime + , tutorialTime = newTime & JSONB , tutorialRegisterFrom = mvTime tutorialRegisterFrom , tutorialRegisterTo = mvTime tutorialRegisterTo , tutorialDeregisterUntil = mvTime tutorialDeregisterUntil , tutorialLastChanged = now , .. - } [] -- update cannot happen due to previous case + } [] -- update cannot happen due to previous case audit $ TransactionTutorialEdit tutId return tutId _ -> do @@ -385,7 +385,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do , tutorialCapacity = Nothing , tutorialRoom = Nothing , tutorialRoomHidden = False - , tutorialTime = Occurrences mempty mempty + , tutorialTime = mempty , tutorialRegGroup = Nothing , tutorialRegisterFrom = Nothing , tutorialRegisterTo = Nothing @@ -393,7 +393,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do , tutorialLastChanged = now , tutorialTutorControlled = False , tutorialFirstDay = Nothing - } [] -- update cannot happen due to previous cases + } [] -- update cannot happen due to previous cases audit $ TransactionTutorialEdit tutId return tutId diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 2b99929d1..846e1b615 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -4,6 +4,8 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO during development only +{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only module Handler.School.DayTasks ( getSchoolDayR, postSchoolDayR @@ -13,13 +15,13 @@ import Import import Handler.Utils -import qualified Data.Set as Set +-- import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) -import Database.Esqueleto.Experimental ((:&)(..)) +-- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E @@ -79,8 +81,11 @@ mkDailyTable ssh nd = do dbtSQLQuery (course `E.InnerJoin` tut) = do EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse E.where_ $ course E.^. CourseSchool E.==. E.val ssh - E.&&. ((tut E.^. TutorialTime) @>. (E.jsonbVal $ occurrenceDayValue nd) - ) + E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue nd)) + E.&&. E.exists $ do + trm <- E.from $ E.table @Term + E.where_ $ E.between (E.val nd) (trm E.^. TermStart, trm E.^. TermEnd) + E.&&. trm E.^. TermId E.==. course E.^. CourseTerm return (course, tut) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId @@ -141,7 +146,7 @@ getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html getSchoolDayR = postSchoolDayR postSchoolDayR ssh nd = do dday <- formatTime SelFormatDate nd - tableDaily <- runDB $ mkDailyTable ssh nd + (_,tableDaily) <- runDB $ mkDailyTable ssh nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do setTitleI (MsgMenuSchoolDay ssh dday) [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index 65d616e0a..ee65bd4cc 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -25,21 +25,21 @@ getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName - getTEditR = postTEditR postTEditR tid ssh csh tutn = do (cid, tutid, template) <- runDB $ do - (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn + (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid return $ tutor E.^. TutorUser tutorInvites <- sourceInvitationsF @Tutor tutid - let + let template = TutorialForm { tfName = tutorialName , tfType = tutorialType , tfCapacity = tutorialCapacity , tfRoom = tutorialRoom , tfRoomHidden = tutorialRoomHidden - , tfTime = tutorialTime + , tfTime = tutorialTime & unJSONB , tfRegGroup = tutorialRegGroup , tfRegisterFrom = tutorialRegisterFrom , tfRegisterTo = tutorialRegisterTo @@ -64,7 +64,7 @@ postTEditR tid ssh csh tutn = do , tutorialCapacity = tfCapacity , tutorialRoom = tfRoom , tutorialRoomHidden = tfRoomHidden - , tutorialTime = tfTime + , tutorialTime = tfTime & JSONB , tutorialRegGroup = tfRegGroup , tutorialRegisterFrom = tfRegisterFrom , tutorialRegisterTo = tfRegisterTo diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index 3f0c6a48d..ce1cb7a89 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -32,7 +32,7 @@ getCTutorialListR tid ssh csh = do resultTutorial = _dbrOutput . _1 resultParticipants = _dbrOutput . _2 resultShowRoom = _dbrOutput . _3 - + dbtSQLQuery tutorial = do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid let participants :: E.SqlExpr (E.Value Int) @@ -64,7 +64,7 @@ getCTutorialListR tid ssh csh = do , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if | res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res | otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text) - , sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime + , sortable Nothing (i18nCell MsgTableTutorialTime) $ \(view $ resultTutorial . _entityVal . _tutorialTime -> ttime) -> occurrencesCell ttime , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . CI.original) tutorialRegGroup , sortable (Just "register-from") (i18nCell MsgRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index 4fa98b0d6..50508ae68 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -25,7 +25,7 @@ postCTutorialNewR tid ssh csh = do ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing formResult newTutResult $ \TutorialForm{..} -> do - insertRes <- runDBJobs $ do + insertRes <- runDBJobs $ do now <- liftIO getCurrentTime term <- get404 $ course ^. _courseTerm insertRes <- insertUnique Tutorial @@ -35,7 +35,7 @@ postCTutorialNewR tid ssh csh = do , tutorialCapacity = tfCapacity , tutorialRoom = tfRoom , tutorialRoomHidden = tfRoomHidden - , tutorialTime = tfTime + , tutorialTime = JSONB tfTime , tutorialRegGroup = tfRegGroup , tutorialRegisterFrom = tfRegisterFrom , tutorialRegisterTo = tfRegisterTo diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 984a4b7a2..93642d524 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -18,8 +18,8 @@ import Utils.Occurrences import Handler.Utils.DateTime -occurrencesWidget :: Occurrences -> Widget -occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do +occurrencesWidget :: JSONB Occurrences -> Widget +occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case ScheduleWeekly{..} -> do scheduleStart' <- formatTime SelFormatTime scheduleStart @@ -35,10 +35,10 @@ occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do $(widgetFile "widgets/occurrence/cell/except-no-occur") $(widgetFile "widgets/occurrence/cell") --- | Get bounds for an Occurrences +-- | Get bounds for an Occurrences occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) -occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) - where +occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) + where occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already scdDays = Set.foldr getOccDays mempty occurrencesScheduled @@ -58,7 +58,7 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc dayDiff = diffDays dayNew dayOld offDays = Set.fromList $ termHolidays <> weekends - weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] + weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule switchDayOfWeek os | 0 == dayDiff `mod` 7 = os @@ -74,6 +74,6 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc = advanceExceptions (succ offset, acc) ex | otherwise = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc) - where + where ed = dayOfOccurrenceException ex nd = addDays offset ed diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 02ccc8857..dd5474df8 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -509,7 +509,7 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc -occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a +occurrencesCell :: IsDBTable m a => JSONB Occurrences -> DBCell m a occurrencesCell = cell . occurrencesWidget roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index a8c342a1c..89ebeec61 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -195,9 +195,9 @@ colExamLabel resultLabel = Colonnade.singleton (fromSortable header) body sortExamLabel :: OpticSortColumn (Maybe ExamOfficeLabelName) sortExamLabel queryLabel = singletonMap "exam-label" . SortColumn $ view queryLabel ---------------------- --- Exam occurences -- ---------------------- +---------------------- +-- Exam occurrences -- +---------------------- colOccurrenceStart :: OpticColonnade UTCTime colOccurrenceStart resultStart = Colonnade.singleton (fromSortable header) body diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 90edef7a1..ac2fb34f5 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -190,6 +190,7 @@ import Network.Mail.Mime.Instances as Import import Yesod.Core.Instances as Import () import Data.Aeson.Types.Instances as Import () import Database.Esqueleto.Instances as Import () +import Database.Esqueleto.PostgreSQL.JSON as Import (JSONB(..), unJSONB) import Numeric.Natural.Instances as Import () import Text.Blaze.Instances as Import () import Jose.Jwt.Instances as Import () diff --git a/src/Model.hs b/src/Model.hs index cebdd4056..d5100d4a8 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -29,7 +29,6 @@ import Database.Persist.Sql (BackendKey(..)) import qualified Database.Esqueleto.Legacy as E - type SqlBackendKey = BackendKey SqlBackend @@ -56,7 +55,7 @@ deriving newtype instance FromJSONKey ExamOccurrenceId deriving newtype instance ToSample UserId deriving newtype instance ToSample ExternalApiId --- required Show instances for use of getByJust +-- required Show instances for use of getByJust deriving instance Show (Unique ExamPart) deriving instance Show (Unique QualificationUser) deriving instance Show (Unique LmsUser) @@ -146,7 +145,7 @@ instance IsFileReference PersonalisedSheetFile where fileReferenceTitleField = PersonalisedSheetFileTitle fileReferenceContentField = PersonalisedSheetFileContent fileReferenceModifiedField = PersonalisedSheetFileModified - + instance HasFileReference SubmissionFile where data FileReferenceResidual SubmissionFile = SubmissionFileResidual { submissionFileResidualSubmission :: SubmissionId @@ -247,5 +246,5 @@ instance IsFileReference MaterialFile where deriveJSON defaultOptions { tagSingleConstructors = False , fieldLabelModifier = camelToPathPiece' 2 - , omitNothingFields = True + , omitNothingFields = True } ''QualificationUserBlock diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index bc31638b4..b329ad68e 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -39,7 +39,7 @@ import Data.Aeson.Types as Aeson -- Terms and anything loosely related to time newtype TermIdentifier = TermIdentifier { year :: Integer } -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' - deriving (Show, Read, Eq, Ord, Generic, Enum) + deriving (Show, Read, Eq, Ord, Generic, Enum) deriving newtype (Binary) -- , ISO8601, PersistField, PersistFieldSql) -- , ToJSON, FromJSON) deriving anyclass (NFData) -- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Enum, Binary, NFData) @@ -86,23 +86,23 @@ termFromText t = Right TermIdentifier {..} ---- * | Just (review shortened -> year) <- readMaybe $ Text.unpack t ---- * = Right TermIdentifier {..} - | otherwise - = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number." - - + | otherwise + = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number." + + daysPerYear :: Rational daysPerYear = 365 + (97 % 400) -dayOffset :: Rational +dayOffset :: Rational dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear) - where + where dayzero = toEnum 0 yearzero = fst3 $ toGregorian dayzero - diffstart = diffDays dayzero $ fromGregorian yearzero 1 1 - + diffstart = diffDays dayzero $ fromGregorian yearzero 1 1 + -- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . getTermDay´´ holds -termToRational :: TermIdentifier -> Rational -termToRational = fromInteger . year +termToRational :: TermIdentifier -> Rational +termToRational = fromInteger . year termFromRational :: Rational -> TermIdentifier termFromRational = TermIdentifier . floor @@ -159,7 +159,7 @@ guessDay t TermDayEnd = pred $ guessDay (succ t) TermDayStart guessDay t TermDayLectureEnd = pred $ pred $ guessDay t TermDayEnd -- Friday of last calendar week, no lectures on Saturday/Sunday -withinTerm :: Day -> TermIdentifier -> Bool +withinTerm :: Day -> TermIdentifier -> Bool withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd data OccurrenceSchedule = ScheduleWeekly @@ -189,15 +189,15 @@ data OccurrenceException = ExceptOccur deriving anyclass (NFData) -- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically -instance Ord OccurrenceException where - compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be} +instance Ord OccurrenceException where + compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be} = compare (ad,as,ae) (bd,bs,be) compare ExceptOccur{exceptDay=d, exceptStart=s} ExceptNoOccur{exceptTime=e} = replaceEq LT $ compare (LocalTime d s) e - compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s} + compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s} = replaceEq GT $ compare e (LocalTime d s) compare ExceptNoOccur{exceptTime=ae } ExceptNoOccur{exceptTime=be } - = compare ae be + = compare ae be deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 @@ -225,24 +225,46 @@ deriveJSON defaultOptions } ''Occurrences derivePersistFieldJSON ''Occurrences +instance Semigroup Occurrences where + (<>) Occurrences{occurrencesScheduled = aSched , occurrencesExceptions = aExcept} + Occurrences{occurrencesScheduled = bSched, occurrencesExceptions = bExcept} + = Occurrences{occurrencesScheduled = aSched <> bSched, occurrencesExceptions = aExcept <> bExcept} + +instance Monoid Occurrences where + mempty = Occurrences mempty mempty + +-- TODO: move elsewhere +deriving newtype instance NFData a => NFData (JSONB a) +deriving newtype instance Semigroup a => Semigroup (JSONB a) +deriving newtype instance Monoid a => Monoid (JSONB a) + +jsonbOCCUR :: Maybe (JSONB Occurrences) -> Occurrences +jsonbOCCUR = foldMap unJSONB + +occurJSONB :: Occurrences -> Maybe (JSONB Occurrences) +occurJSONB = Just . JSONB + +_Occurrences :: Iso' (JSONB Occurrences) Occurrences +_Occurrences = iso unJSONB JSONB + + nullaryPathPiece ''DayOfWeek camelToPathPiece - -- test :: IO [OccurrenceException] --- test = do +-- test = do -- now <- getCurrentTime -- tz <- getCurrentTimeZone --- let lt1 = utcToLocalTime tz now --- tomorrow = addUTCTime nominalDay now +-- let lt1 = utcToLocalTime tz now +-- tomorrow = addUTCTime nominalDay now -- lt2 = utcToLocalTime tz tomorrow --- yesterday = addUTCTime (negate nominalDay) now +-- yesterday = addUTCTime (negate nominalDay) now -- lt3 = utcToLocalTime tz yesterday --- pure +-- pure -- [ ExceptOccur (utctDay tomorrow ) midday midnight -- , ExceptOccur (utctDay now ) midnight midnight -- , ExceptOccur (utctDay now ) midday midnight --- , ExceptOccur (utctDay yesterday) midday midnight +-- , ExceptOccur (utctDay yesterday) midday midnight -- , ExceptNoOccur lt3 -- , ExceptNoOccur lt1 -- , ExceptNoOccur lt2 diff --git a/src/Utils.hs b/src/Utils.hs index 201fd54de..087fe7f1d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -946,6 +946,7 @@ deepAlt altFst Nothing = altFst deepAlt (Just Nothing) altSnd = altSnd deepAlt altFst _ = altFst +-- | flipped `foldMap` with type restriction to Maybe, also see @maybeMonoid@ maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap diff --git a/src/Utils/Print/CourseCertificate.hs b/src/Utils/Print/CourseCertificate.hs index 039885b7e..3a61e258a 100644 --- a/src/Utils/Print/CourseCertificate.hs +++ b/src/Utils/Print/CourseCertificate.hs @@ -6,7 +6,7 @@ module Utils.Print.CourseCertificate where -import Import +import Import -- import Data.Char as Char import qualified Data.Text as Text @@ -21,10 +21,10 @@ import Handler.Utils.Occurrences data LetterCourseCertificate = LetterCourseCertificate { ccCourseId :: CourseId - , ccCourseName :: Text - , ccCourseShorthand :: Text + , ccCourseName :: Text + , ccCourseShorthand :: Text , ccCourseSchool :: Text - , ccTutorialName :: Text + , ccTutorialName :: Text , ccCourseContent :: Maybe [Text] , ccCourseBegin :: Maybe Day , ccCourseEnd :: Maybe Day @@ -38,7 +38,7 @@ data LetterCourseCertificate = LetterCourseCertificate deriving (Eq, Show) -instance MDLetter LetterCourseCertificate where +instance MDLetter LetterCourseCertificate where encryptPDFfor _ = NoPassword getLetterKind _ = Plain getLetterEnvelope _ = 'c' @@ -48,21 +48,21 @@ instance MDLetter LetterCourseCertificate where getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") getMailSubject l = SomeMessage . MsgCourseCertificate $ ccCourseName l - letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = + letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = mkMeta [ toMeta "participant" ccParticipant , toMeta "subject-meta" ccParticipant , mbMeta "fra-number" ccFraNumber - , mbMeta "fra-department" ccFraDepartment + , mbMeta "fra-department" ccFraDepartment , mbMeta "company" ccCompany , toMeta "course-name" ccCourseName , mbMeta "course-content" ccCourseContent , mbMeta "course-begin" (format SelFormatDate <$> ccCourseBegin) , mbMeta "course-end" (format SelFormatDate <$> ccCourseEnd) , toMeta "lang" (fromMaybe lang ccCourseLang) - ] + ] - getPJId LetterCourseCertificate{..} = + getPJId LetterCourseCertificate{..} = PrintJobIdentification { pjiName = "Certificate" , pjiApcAcknowledge = "cc-" <> ccCourseName @@ -79,7 +79,7 @@ instance MDLetter LetterCourseCertificate where makeCourseCertificates :: Traversable t => Tutorial -> Maybe Lang -> t UserId -> DB (t LetterCourseCertificate) makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName , tutorialCourse = ccCourseId - , tutorialTime = occurrences + , tutorialTime = unJSONB -> occurrences } ccCourseLang participants = do Course{ courseName = CI.original -> ccCourseName , courseShorthand = CI.original -> ccCourseShorthand @@ -91,13 +91,13 @@ makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds term occurrences forM participants $ \ccParticipantId -> do User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 ccParticipantId - (ccFraNumber, ccFraDepartment, ccCompany) <- + (ccFraNumber, ccFraDepartment, ccCompany) <- if isJust userCompanyDepartment && validFraportPersonalNumber userCompanyPersonalNumber - then + then return (userCompanyPersonalNumber, userCompanyDepartment, Nothing) - else do + else do usrComp <- selectFirst [UserCompanyUser ==. ccParticipantId] [Desc UserCompanyId] comp <- forM usrComp (get . userCompanyCompany . entityVal) let res = (comp ^? _Just . _Just . _companyName . _CI) <|> userCompanyDepartment -- if there is no company, use the department as fallback, if possible - return (Nothing, Nothing, res) + return (Nothing, Nothing, res) return LetterCourseCertificate{..} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 525d6b290..f1047d2ef 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -63,9 +63,10 @@ fillDb = do insert' = fmap (either entityKey id) . insertBy addBDays = addBusinessDays Fraport -- holiday area to use - n_day n = addBDays n $ utctDay now + nowaday = utctDay now + n_day n = addBDays n nowaday n_day' n = now { utctDay = n_day n } - (currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now + (currentYear, _currentMonth, _currentDay) = toGregorian nowaday currentTerm = TermIdentifier currentYear nextTerm n = toEnum . (+n) $ fromEnum currentTerm @@ -1075,7 +1076,23 @@ fillDb = do _ -> "B777" , tutorialRoomHidden = False , tutorialTime = Occurrences - { occurrencesScheduled = Set.empty + { occurrencesScheduled = Set.fromList + [ ScheduleWeekly + { scheduleDayOfWeek = Thursday + , scheduleStart = TimeOfDay 11 11 0 + , scheduleEnd = TimeOfDay 12 22 0 + } + , ScheduleWeekly + { scheduleDayOfWeek = Friday + , scheduleStart = TimeOfDay 13 33 0 + , scheduleEnd = TimeOfDay 14 44 0 + } + , ScheduleWeekly + { scheduleDayOfWeek = Sunday + , scheduleStart = TimeOfDay 15 55 0 + , scheduleEnd = TimeOfDay 16 06 0 + } + ] , occurrencesExceptions = Set.fromList [ ExceptOccur { exceptDay = nTimes 7 succ firstDay