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

refactor(jsonb): change DB using JSONB, to improve stub #90

Browse Source
This commit is contained in:
Steffen Jost 2024-09-13 13:39:38 +02:00
parent 5307350b0b
commit d0eb3ddf92
20 changed files with 160 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
models/courses.model
View File

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

2
models/tutorials.model
View File

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

22
src/Handler/Admin/Avs.hs
View File

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

2
src/Handler/Course/Events/Edit.hs
View File

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

2
src/Handler/Course/Events/Form.hs
View File

@ -54,6 +54,6 @@ courseEventToForm CourseEvent{..} = CourseEventForm
{ cefType = courseEventType
, cefRoom = courseEventRoom
, cefRoomHidden = courseEventRoomHidden
, cefTime = courseEventTime
, cefTime = courseEventTime & unJSONB
, cefNote = courseEventNote
}

2
src/Handler/Course/Events/New.hs
View File

@ -26,7 +26,7 @@ postCEventsNewR tid ssh csh = do
, courseEventType = cefType
, courseEventRoom = cefRoom
, courseEventRoomHidden = cefRoomHidden
, courseEventTime = cefTime
, courseEventTime = cefTime & JSONB
, courseEventNote = cefNote
, courseEventLastChanged = now
}

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

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

15
src/Handler/School/DayTasks.hs
View File

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

8
src/Handler/Tutorial/Edit.hs
View File

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

4
src/Handler/Tutorial/List.hs
View File

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

4
src/Handler/Tutorial/New.hs
View File

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

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

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

2
src/Handler/Utils/Table/Cells.hs
View File

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

6
src/Handler/Utils/Table/Columns.hs
View File

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

1
src/Import/NoModel.hs
View File

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

7
src/Model.hs
View File

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

70
src/Model/Types/DateTime.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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

1
src/Utils.hs
View File

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

28
src/Utils/Print/CourseCertificate.hs
View File

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

23
test/Database/Fill.hs
View File

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