fraport/fradrive-old
Archived
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 TermSchoolCourseName term school name -- name must be unique within school and semester
deriving Generic deriving Generic
CourseEvent CourseEvent
type (CI Text) type (CI Text)
course CourseId OnDeleteCascade OnUpdateCascade course CourseId OnDeleteCascade OnUpdateCascade
room RoomReference Maybe room RoomReference Maybe
roomHidden Bool default=false roomHidden Bool default=false
time Occurrences time (JSONB Occurrences)
note StoredMarkup Maybe note StoredMarkup Maybe
lastChanged UTCTime default=now() lastChanged UTCTime default=now()
deriving Generic deriving Generic
CourseAppInstructionFile CourseAppInstructionFile

2
models/tutorials.model
View File

@ -9,7 +9,7 @@ Tutorial json
capacity Int Maybe -- limit for enrolment in this tutorial capacity Int Maybe -- limit for enrolment in this tutorial
room RoomReference Maybe room RoomReference Maybe
roomHidden Bool default=false roomHidden Bool default=false
time Occurrences time (JSONB Occurrences)
regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup
registerFrom UTCTime Maybe registerFrom UTCTime Maybe
registerTo 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.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId
E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError 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 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) querryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
qerryUsrAvs = $(E.sqlIJproj 2 1) querryUsrAvs = $(E.sqlIJproj 2 1)
qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User) querryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
qerryUser = $(E.sqlIJproj 2 2) querryUser = $(E.sqlIJproj 2 2)
reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs) reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
reserrUsrAvs = _dbrOutput . _1 reserrUsrAvs = _dbrOutput . _1
-- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User) -- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
-- reserrUser = _dbrOutput . _2 -- reserrUser = _dbrOutput . _2
dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) dbtRowKey = querryUsrAvs >>> (E.^. UserAvsId)
dbtProj = dbtProjId dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ colUserNameModalHdrAdmin MsgLmsUser AdminUserR [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR
@ -1022,14 +1022,14 @@ getProblemAvsErrorR = do
$ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError) $ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError)
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ (sortUserNameLink qerryUser) [ sortUserNameLink querryUser
, ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson)) , ("avs-nr" , SortColumn $ querryUsrAvs >>> (E.^. UserAvsNoPerson))
, ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch)) , ("avs-last-synch", SortColumnNullsInv $ querryUsrAvs >>> (E.^. UserAvsLastSynch))
, ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError)) , ("avs-last-error", SortColumn $ querryUsrAvs >>> (E.^. UserAvsLastSynchError))
] ]
dbtFilter = Map.fromList dbtFilter = Map.fromList
[ fltrUserNameEmail qerryUser [ fltrUserNameEmail querryUser
, ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError)) , ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to querryUsrAvs) (E.^. UserAvsLastSynchError))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev

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

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

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

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

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

@ -26,7 +26,7 @@ postCEventsNewR tid ssh csh = do
, courseEventType = cefType , courseEventType = cefType
, courseEventRoom = cefRoom , courseEventRoom = cefRoom
, courseEventRoomHidden = cefRoomHidden , courseEventRoomHidden = cefRoomHidden
, courseEventTime = cefTime , courseEventTime = cefTime & JSONB
, courseEventNote = cefNote , courseEventNote = cefNote
, courseEventLastChanged = now , 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]] tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]]
tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
tutorialDefaultName Nothing = formatDayForTutName tutorialDefaultName Nothing = formatDayForTutName
tutorialDefaultName (Just ttyp) = tutorialDefaultName (Just ttyp) =
let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp
in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing 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 :: 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 . formatTime' "%y_%m_%d" -- we don't want to go monadic for this
formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow
where where
d2u '-' = '_' d2u '-' = '_'
d2u c = c d2u c = c
@ -151,7 +151,7 @@ instance Monoid AddParticipantsResult where
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAddUserR = postCAddUserR getCAddUserR = postCAddUserR
postCAddUserR tid ssh csh = do postCAddUserR tid ssh csh = do
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
handleAddUserR tid ssh csh (Right today) Nothing 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 -- 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 :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html
handleAddUserR tid ssh csh tdesc ttyp = do handleAddUserR tid ssh csh tdesc ttyp = do
(cid, tutTypes, tutNameSuggestions) <- runDB $ do (cid, tutTypes, tutNameSuggestions) <- runDB $ do
let plainTemplates = tutorialTemplateNames Nothing let plainTemplates = tutorialTemplateNames Nothing
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
tutTypes <- E.select $ E.distinct $ do 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 let typeSet = Set.fromList [ maybe t CI.mk $ Text.stripPrefix temp_sep $ CI.original t
| temp <- plainTemplates | temp <- plainTemplates
, let temp_sep = CI.original (temp <> tutorialTypeSeparator) , 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 tutorial <- E.from $ E.table @Tutorial
let tuName = tutorial E.^. TutorialName let tuName = tutorial E.^. TutorialName
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid 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 currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
(_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm
-- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult -- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult
prefillUsers <- case registerConfirmResult of prefillUsers <- case registerConfirmResult of
Nothing -> return mempty Nothing -> return mempty
(Just BtnCourseRegisterAbort) -> do (Just BtnCourseRegisterAbort) -> do
addMessageI Warning MsgAborted 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 -- 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 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 return $ Just $ Set.fromList $ fmap crActIdent confirmedActs
(Just BtnCourseRegisterConfirm) -> do (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 -- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs
let let
users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) 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 registeredUsers <- registerUsers cid users
whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> 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 $ CTutorialR tid ssh csh tName TUsersR
redirect $ CourseR tid ssh csh CUsersR redirect $ CourseR tid ssh csh CUsersR
return mempty return mempty
((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . identifyForm FIDCourseRegister . renderWForm FormStandard $ do ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . identifyForm FIDCourseRegister . renderWForm FormStandard $ do
let tutTypesMsg = [(SomeMessage tt,tt) | tt <- tutTypes] 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 auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) prefillUsers
auReqTutorial <- optionalActionW auReqTutorial <- optionalActionW
( (,,) ( (,,)
<$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions) <$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions)
(fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip)
(Just $ maybeLeft tdesc) (Just $ maybeLeft tdesc)
@ -349,12 +349,12 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
existingTut <- getBy $ UniqueTutorial cid newTutorialName existingTut <- getBy $ UniqueTutorial cid newTutorialName
templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType, Asc TutorialName] templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType, Asc TutorialName]
case (existingTut, newFirstDay, templateEnt) of 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 (Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do
Course{..} <- get404 cid Course{..} <- get404 cid
term <- get404 courseTerm term <- get404 courseTerm
let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term $ unJSONB tutorialTime)
newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) $ unJSONB tutorialTime
dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay
mvTime = fmap $ addLocalDays dayDiff mvTime = fmap $ addLocalDays dayDiff
newType0 = CI.map (snd . Text.breakOnEnd (CI.original tutorialTypeSeparator)) tutorialType newType0 = CI.map (snd . Text.breakOnEnd (CI.original tutorialTypeSeparator)) tutorialType
@ -367,13 +367,13 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
, tutorialCourse = cid , tutorialCourse = cid
, tutorialType = newType , tutorialType = newType
, tutorialFirstDay = newFirstDay , tutorialFirstDay = newFirstDay
, tutorialTime = newTime , tutorialTime = newTime & JSONB
, tutorialRegisterFrom = mvTime tutorialRegisterFrom , tutorialRegisterFrom = mvTime tutorialRegisterFrom
, tutorialRegisterTo = mvTime tutorialRegisterTo , tutorialRegisterTo = mvTime tutorialRegisterTo
, tutorialDeregisterUntil = mvTime tutorialDeregisterUntil , tutorialDeregisterUntil = mvTime tutorialDeregisterUntil
, tutorialLastChanged = now , tutorialLastChanged = now
, .. , ..
} [] -- update cannot happen due to previous case } [] -- update cannot happen due to previous case
audit $ TransactionTutorialEdit tutId audit $ TransactionTutorialEdit tutId
return tutId return tutId
_ -> do _ -> do
@ -385,7 +385,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
, tutorialCapacity = Nothing , tutorialCapacity = Nothing
, tutorialRoom = Nothing , tutorialRoom = Nothing
, tutorialRoomHidden = False , tutorialRoomHidden = False
, tutorialTime = Occurrences mempty mempty , tutorialTime = mempty
, tutorialRegGroup = Nothing , tutorialRegGroup = Nothing
, tutorialRegisterFrom = Nothing , tutorialRegisterFrom = Nothing
, tutorialRegisterTo = Nothing , tutorialRegisterTo = Nothing
@ -393,7 +393,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
, tutorialLastChanged = now , tutorialLastChanged = now
, tutorialTutorControlled = False , tutorialTutorControlled = False
, tutorialFirstDay = Nothing , tutorialFirstDay = Nothing
} [] -- update cannot happen due to previous cases } [] -- update cannot happen due to previous cases
audit $ TransactionTutorialEdit tutId audit $ TransactionTutorialEdit tutId
return tutId return tutId

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

@ -4,6 +4,8 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# 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 module Handler.School.DayTasks
( getSchoolDayR, postSchoolDayR ( getSchoolDayR, postSchoolDayR
@ -13,13 +15,13 @@ import Import
import Handler.Utils import Handler.Utils
import qualified Data.Set as Set -- import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
-- import qualified Data.Text as Text -- import qualified Data.Text as Text
-- import Database.Persist.Sql (updateWhereCount) -- 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.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.Experimental as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
@ -79,8 +81,11 @@ mkDailyTable ssh nd = do
dbtSQLQuery (course `E.InnerJoin` tut) = do dbtSQLQuery (course `E.InnerJoin` tut) = do
EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse
E.where_ $ course E.^. CourseSchool E.==. E.val ssh 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) return (course, tut)
dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtRowKey = queryTutorial >>> (E.^. TutorialId)
dbtProj = dbtProjId dbtProj = dbtProjId
@ -141,7 +146,7 @@ getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html
getSchoolDayR = postSchoolDayR getSchoolDayR = postSchoolDayR
postSchoolDayR ssh nd = do postSchoolDayR ssh nd = do
dday <- formatTime SelFormatDate nd dday <- formatTime SelFormatDate nd
tableDaily <- runDB $ mkDailyTable ssh nd (_,tableDaily) <- runDB $ mkDailyTable ssh nd
siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
setTitleI (MsgMenuSchoolDay ssh dday) setTitleI (MsgMenuSchoolDay ssh dday)
[whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} [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 getTEditR = postTEditR
postTEditR tid ssh csh tutn = do postTEditR tid ssh csh tutn = do
(cid, tutid, template) <- runDB $ 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 tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
return $ tutor E.^. TutorUser return $ tutor E.^. TutorUser
tutorInvites <- sourceInvitationsF @Tutor tutid tutorInvites <- sourceInvitationsF @Tutor tutid
let let
template = TutorialForm template = TutorialForm
{ tfName = tutorialName { tfName = tutorialName
, tfType = tutorialType , tfType = tutorialType
, tfCapacity = tutorialCapacity , tfCapacity = tutorialCapacity
, tfRoom = tutorialRoom , tfRoom = tutorialRoom
, tfRoomHidden = tutorialRoomHidden , tfRoomHidden = tutorialRoomHidden
, tfTime = tutorialTime , tfTime = tutorialTime & unJSONB
, tfRegGroup = tutorialRegGroup , tfRegGroup = tutorialRegGroup
, tfRegisterFrom = tutorialRegisterFrom , tfRegisterFrom = tutorialRegisterFrom
, tfRegisterTo = tutorialRegisterTo , tfRegisterTo = tutorialRegisterTo
@ -64,7 +64,7 @@ postTEditR tid ssh csh tutn = do
, tutorialCapacity = tfCapacity , tutorialCapacity = tfCapacity
, tutorialRoom = tfRoom , tutorialRoom = tfRoom
, tutorialRoomHidden = tfRoomHidden , tutorialRoomHidden = tfRoomHidden
, tutorialTime = tfTime , tutorialTime = tfTime & JSONB
, tutorialRegGroup = tfRegGroup , tutorialRegGroup = tfRegGroup
, tutorialRegisterFrom = tfRegisterFrom , tutorialRegisterFrom = tfRegisterFrom
, tutorialRegisterTo = tfRegisterTo , tutorialRegisterTo = tfRegisterTo

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

@ -32,7 +32,7 @@ getCTutorialListR tid ssh csh = do
resultTutorial = _dbrOutput . _1 resultTutorial = _dbrOutput . _1
resultParticipants = _dbrOutput . _2 resultParticipants = _dbrOutput . _2
resultShowRoom = _dbrOutput . _3 resultShowRoom = _dbrOutput . _3
dbtSQLQuery tutorial = do dbtSQLQuery tutorial = do
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
let participants :: E.SqlExpr (E.Value Int) let participants :: E.SqlExpr (E.Value Int)
@ -64,7 +64,7 @@ getCTutorialListR tid ssh csh = do
, sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if , sortable (Just "room") (i18nCell MsgTableTutorialRoom) $ \res -> if
| res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res | res ^. resultShowRoom -> maybe (i18nCell MsgTableTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res
| otherwise -> i18nCell MsgTableTutorialRoomIsHidden & addCellClass ("explanation" :: Text) | 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-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-from") (i18nCell MsgRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom
, sortable (Just "register-to") (i18nCell MsgRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo , 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 ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing
formResult newTutResult $ \TutorialForm{..} -> do formResult newTutResult $ \TutorialForm{..} -> do
insertRes <- runDBJobs $ do insertRes <- runDBJobs $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
term <- get404 $ course ^. _courseTerm term <- get404 $ course ^. _courseTerm
insertRes <- insertUnique Tutorial insertRes <- insertUnique Tutorial
@ -35,7 +35,7 @@ postCTutorialNewR tid ssh csh = do
, tutorialCapacity = tfCapacity , tutorialCapacity = tfCapacity
, tutorialRoom = tfRoom , tutorialRoom = tfRoom
, tutorialRoomHidden = tfRoomHidden , tutorialRoomHidden = tfRoomHidden
, tutorialTime = tfTime , tutorialTime = JSONB tfTime
, tutorialRegGroup = tfRegGroup , tutorialRegGroup = tfRegGroup
, tutorialRegisterFrom = tfRegisterFrom , tutorialRegisterFrom = tfRegisterFrom
, tutorialRegisterTo = tfRegisterTo , tutorialRegisterTo = tfRegisterTo

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

@ -18,8 +18,8 @@ import Utils.Occurrences
import Handler.Utils.DateTime import Handler.Utils.DateTime
occurrencesWidget :: Occurrences -> Widget occurrencesWidget :: JSONB Occurrences -> Widget
occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do occurrencesWidget (normalizeOccurrences . unJSONB -> Occurrences{..}) = do
let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case
ScheduleWeekly{..} -> do ScheduleWeekly{..} -> do
scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleStart' <- formatTime SelFormatTime scheduleStart
@ -35,10 +35,10 @@ occurrencesWidget (normalizeOccurrences -> Occurrences{..}) = do
$(widgetFile "widgets/occurrence/cell/except-no-occur") $(widgetFile "widgets/occurrence/cell/except-no-occur")
$(widgetFile "widgets/occurrence/cell") $(widgetFile "widgets/occurrence/cell")
-- | Get bounds for an Occurrences -- | Get bounds for an Occurrences
occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day) occurrencesBounds :: Term -> Occurrences -> (Maybe Day, Maybe Day)
occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays) occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupMax occDays)
where where
occDays = (scdDays <> plsDays) \\ excDays -- (excDays <> termHolidays term) -- TODO: should holidays be exluded here? Probably not, as they can be added as exceptions already 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 scdDays = Set.foldr getOccDays mempty occurrencesScheduled
@ -58,7 +58,7 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc
dayDiff = diffDays dayNew dayOld dayDiff = diffDays dayNew dayOld
offDays = Set.fromList $ termHolidays <> weekends 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 :: OccurrenceSchedule -> OccurrenceSchedule
switchDayOfWeek os | 0 == dayDiff `mod` 7 = os switchDayOfWeek os | 0 == dayDiff `mod` 7 = os
@ -74,6 +74,6 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc
= advanceExceptions (succ offset, acc) ex = advanceExceptions (succ offset, acc) ex
| otherwise | otherwise
= (offset, Set.insert (setDayOfOccurrenceException nd ex) acc) = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc)
where where
ed = dayOfOccurrenceException ex ed = dayOfOccurrenceException ex
nd = addDays offset ed 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 = correctorLoadCell sc =
i18nCell $ sheetCorrectorLoad sc i18nCell $ sheetCorrectorLoad sc
occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a occurrencesCell :: IsDBTable m a => JSONB Occurrences -> DBCell m a
occurrencesCell = cell . occurrencesWidget occurrencesCell = cell . occurrencesWidget
roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a 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 :: OpticSortColumn (Maybe ExamOfficeLabelName)
sortExamLabel queryLabel = singletonMap "exam-label" . SortColumn $ view queryLabel sortExamLabel queryLabel = singletonMap "exam-label" . SortColumn $ view queryLabel
--------------------- ----------------------
-- Exam occurences -- -- Exam occurrences --
--------------------- ----------------------
colOccurrenceStart :: OpticColonnade UTCTime colOccurrenceStart :: OpticColonnade UTCTime
colOccurrenceStart resultStart = Colonnade.singleton (fromSortable header) body 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 Yesod.Core.Instances as Import ()
import Data.Aeson.Types.Instances as Import () import Data.Aeson.Types.Instances as Import ()
import Database.Esqueleto.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 Numeric.Natural.Instances as Import ()
import Text.Blaze.Instances as Import () import Text.Blaze.Instances as Import ()
import Jose.Jwt.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 import qualified Database.Esqueleto.Legacy as E
type SqlBackendKey = BackendKey SqlBackend type SqlBackendKey = BackendKey SqlBackend
@ -56,7 +55,7 @@ deriving newtype instance FromJSONKey ExamOccurrenceId
deriving newtype instance ToSample UserId deriving newtype instance ToSample UserId
deriving newtype instance ToSample ExternalApiId 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 ExamPart)
deriving instance Show (Unique QualificationUser) deriving instance Show (Unique QualificationUser)
deriving instance Show (Unique LmsUser) deriving instance Show (Unique LmsUser)
@ -146,7 +145,7 @@ instance IsFileReference PersonalisedSheetFile where
fileReferenceTitleField = PersonalisedSheetFileTitle fileReferenceTitleField = PersonalisedSheetFileTitle
fileReferenceContentField = PersonalisedSheetFileContent fileReferenceContentField = PersonalisedSheetFileContent
fileReferenceModifiedField = PersonalisedSheetFileModified fileReferenceModifiedField = PersonalisedSheetFileModified
instance HasFileReference SubmissionFile where instance HasFileReference SubmissionFile where
data FileReferenceResidual SubmissionFile = SubmissionFileResidual data FileReferenceResidual SubmissionFile = SubmissionFileResidual
{ submissionFileResidualSubmission :: SubmissionId { submissionFileResidualSubmission :: SubmissionId
@ -247,5 +246,5 @@ instance IsFileReference MaterialFile where
deriveJSON defaultOptions deriveJSON defaultOptions
{ tagSingleConstructors = False { tagSingleConstructors = False
, fieldLabelModifier = camelToPathPiece' 2 , fieldLabelModifier = camelToPathPiece' 2
, omitNothingFields = True , omitNothingFields = True
} ''QualificationUserBlock } ''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 -- 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 -- Terms and anything loosely related to time
newtype TermIdentifier = TermIdentifier { year :: Integer } -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' 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 newtype (Binary) -- , ISO8601, PersistField, PersistFieldSql) -- , ToJSON, FromJSON)
deriving anyclass (NFData) deriving anyclass (NFData)
-- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Enum, Binary, NFData) -- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Enum, Binary, NFData)
@ -86,23 +86,23 @@ termFromText t
= Right TermIdentifier {..} = Right TermIdentifier {..}
---- * | Just (review shortened -> year) <- readMaybe $ Text.unpack t ---- * | Just (review shortened -> year) <- readMaybe $ Text.unpack t
---- * = Right TermIdentifier {..} ---- * = Right TermIdentifier {..}
| otherwise | otherwise
= Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number." = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number."
daysPerYear :: Rational daysPerYear :: Rational
daysPerYear = 365 + (97 % 400) daysPerYear = 365 + (97 % 400)
dayOffset :: Rational dayOffset :: Rational
dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear) dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear)
where where
dayzero = toEnum 0 dayzero = toEnum 0
yearzero = fst3 $ toGregorian dayzero 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 -- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . getTermDay´´ holds
termToRational :: TermIdentifier -> Rational termToRational :: TermIdentifier -> Rational
termToRational = fromInteger . year termToRational = fromInteger . year
termFromRational :: Rational -> TermIdentifier termFromRational :: Rational -> TermIdentifier
termFromRational = TermIdentifier . floor 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 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 withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd
data OccurrenceSchedule = ScheduleWeekly data OccurrenceSchedule = ScheduleWeekly
@ -189,15 +189,15 @@ data OccurrenceException = ExceptOccur
deriving anyclass (NFData) deriving anyclass (NFData)
-- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically -- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically
instance Ord OccurrenceException where instance Ord OccurrenceException where
compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be} compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be}
= compare (ad,as,ae) (bd,bs,be) = compare (ad,as,ae) (bd,bs,be)
compare ExceptOccur{exceptDay=d, exceptStart=s} ExceptNoOccur{exceptTime=e} compare ExceptOccur{exceptDay=d, exceptStart=s} ExceptNoOccur{exceptTime=e}
= replaceEq LT $ compare (LocalTime d s) 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) = replaceEq GT $ compare e (LocalTime d s)
compare ExceptNoOccur{exceptTime=ae } ExceptNoOccur{exceptTime=be } compare ExceptNoOccur{exceptTime=ae } ExceptNoOccur{exceptTime=be }
= compare ae be = compare ae be
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1
@ -225,24 +225,46 @@ deriveJSON defaultOptions
} ''Occurrences } ''Occurrences
derivePersistFieldJSON ''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 nullaryPathPiece ''DayOfWeek camelToPathPiece
-- test :: IO [OccurrenceException] -- test :: IO [OccurrenceException]
-- test = do -- test = do
-- now <- getCurrentTime -- now <- getCurrentTime
-- tz <- getCurrentTimeZone -- tz <- getCurrentTimeZone
-- let lt1 = utcToLocalTime tz now -- let lt1 = utcToLocalTime tz now
-- tomorrow = addUTCTime nominalDay now -- tomorrow = addUTCTime nominalDay now
-- lt2 = utcToLocalTime tz tomorrow -- lt2 = utcToLocalTime tz tomorrow
-- yesterday = addUTCTime (negate nominalDay) now -- yesterday = addUTCTime (negate nominalDay) now
-- lt3 = utcToLocalTime tz yesterday -- lt3 = utcToLocalTime tz yesterday
-- pure -- pure
-- [ ExceptOccur (utctDay tomorrow ) midday midnight -- [ ExceptOccur (utctDay tomorrow ) midday midnight
-- , ExceptOccur (utctDay now ) midnight midnight -- , ExceptOccur (utctDay now ) midnight midnight
-- , ExceptOccur (utctDay now ) midday midnight -- , ExceptOccur (utctDay now ) midday midnight
-- , ExceptOccur (utctDay yesterday) midday midnight -- , ExceptOccur (utctDay yesterday) midday midnight
-- , ExceptNoOccur lt3 -- , ExceptNoOccur lt3
-- , ExceptNoOccur lt1 -- , ExceptNoOccur lt1
-- , ExceptNoOccur lt2 -- , ExceptNoOccur lt2

1
src/Utils.hs
View File

@ -946,6 +946,7 @@ deepAlt altFst Nothing = altFst
deepAlt (Just Nothing) altSnd = altSnd deepAlt (Just Nothing) altSnd = altSnd
deepAlt altFst _ = altFst deepAlt altFst _ = altFst
-- | flipped `foldMap` with type restriction to Maybe, also see @maybeMonoid@
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty = flip foldMap maybeEmpty = flip foldMap

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

@ -6,7 +6,7 @@
module Utils.Print.CourseCertificate where module Utils.Print.CourseCertificate where
import Import import Import
-- import Data.Char as Char -- import Data.Char as Char
import qualified Data.Text as Text import qualified Data.Text as Text
@ -21,10 +21,10 @@ import Handler.Utils.Occurrences
data LetterCourseCertificate = LetterCourseCertificate data LetterCourseCertificate = LetterCourseCertificate
{ ccCourseId :: CourseId { ccCourseId :: CourseId
, ccCourseName :: Text , ccCourseName :: Text
, ccCourseShorthand :: Text , ccCourseShorthand :: Text
, ccCourseSchool :: Text , ccCourseSchool :: Text
, ccTutorialName :: Text , ccTutorialName :: Text
, ccCourseContent :: Maybe [Text] , ccCourseContent :: Maybe [Text]
, ccCourseBegin :: Maybe Day , ccCourseBegin :: Maybe Day
, ccCourseEnd :: Maybe Day , ccCourseEnd :: Maybe Day
@ -38,7 +38,7 @@ data LetterCourseCertificate = LetterCourseCertificate
deriving (Eq, Show) deriving (Eq, Show)
instance MDLetter LetterCourseCertificate where instance MDLetter LetterCourseCertificate where
encryptPDFfor _ = NoPassword encryptPDFfor _ = NoPassword
getLetterKind _ = Plain getLetterKind _ = Plain
getLetterEnvelope _ = 'c' getLetterEnvelope _ = 'c'
@ -48,21 +48,21 @@ instance MDLetter LetterCourseCertificate where
getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md") getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_qualification.md")
getMailSubject l = SomeMessage . MsgCourseCertificate $ ccCourseName l getMailSubject l = SomeMessage . MsgCourseCertificate $ ccCourseName l
letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt = letterMeta LetterCourseCertificate{..} DateTimeFormatter{ format } lang _rcvrEnt =
mkMeta mkMeta
[ toMeta "participant" ccParticipant [ toMeta "participant" ccParticipant
, toMeta "subject-meta" ccParticipant , toMeta "subject-meta" ccParticipant
, mbMeta "fra-number" ccFraNumber , mbMeta "fra-number" ccFraNumber
, mbMeta "fra-department" ccFraDepartment , mbMeta "fra-department" ccFraDepartment
, mbMeta "company" ccCompany , mbMeta "company" ccCompany
, toMeta "course-name" ccCourseName , toMeta "course-name" ccCourseName
, mbMeta "course-content" ccCourseContent , mbMeta "course-content" ccCourseContent
, mbMeta "course-begin" (format SelFormatDate <$> ccCourseBegin) , mbMeta "course-begin" (format SelFormatDate <$> ccCourseBegin)
, mbMeta "course-end" (format SelFormatDate <$> ccCourseEnd) , mbMeta "course-end" (format SelFormatDate <$> ccCourseEnd)
, toMeta "lang" (fromMaybe lang ccCourseLang) , toMeta "lang" (fromMaybe lang ccCourseLang)
] ]
getPJId LetterCourseCertificate{..} = getPJId LetterCourseCertificate{..} =
PrintJobIdentification PrintJobIdentification
{ pjiName = "Certificate" { pjiName = "Certificate"
, pjiApcAcknowledge = "cc-" <> ccCourseName , pjiApcAcknowledge = "cc-" <> ccCourseName
@ -79,7 +79,7 @@ instance MDLetter LetterCourseCertificate where
makeCourseCertificates :: Traversable t => Tutorial -> Maybe Lang -> t UserId -> DB (t LetterCourseCertificate) makeCourseCertificates :: Traversable t => Tutorial -> Maybe Lang -> t UserId -> DB (t LetterCourseCertificate)
makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName
, tutorialCourse = ccCourseId , tutorialCourse = ccCourseId
, tutorialTime = occurrences , tutorialTime = unJSONB -> occurrences
} ccCourseLang participants = do } ccCourseLang participants = do
Course{ courseName = CI.original -> ccCourseName Course{ courseName = CI.original -> ccCourseName
, courseShorthand = CI.original -> ccCourseShorthand , courseShorthand = CI.original -> ccCourseShorthand
@ -91,13 +91,13 @@ makeCourseCertificates Tutorial{ tutorialName = CI.original -> ccTutorialName
let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds term occurrences let (ccCourseBegin, ccCourseEnd) = eq2nothing $ occurrencesBounds term occurrences
forM participants $ \ccParticipantId -> do forM participants $ \ccParticipantId -> do
User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 ccParticipantId User{userDisplayName=ccParticipant, userCompanyDepartment, userCompanyPersonalNumber} <- get404 ccParticipantId
(ccFraNumber, ccFraDepartment, ccCompany) <- (ccFraNumber, ccFraDepartment, ccCompany) <-
if isJust userCompanyDepartment && validFraportPersonalNumber userCompanyPersonalNumber if isJust userCompanyDepartment && validFraportPersonalNumber userCompanyPersonalNumber
then then
return (userCompanyPersonalNumber, userCompanyDepartment, Nothing) return (userCompanyPersonalNumber, userCompanyDepartment, Nothing)
else do else do
usrComp <- selectFirst [UserCompanyUser ==. ccParticipantId] [Desc UserCompanyId] usrComp <- selectFirst [UserCompanyUser ==. ccParticipantId] [Desc UserCompanyId]
comp <- forM usrComp (get . userCompanyCompany . entityVal) 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 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{..} return LetterCourseCertificate{..}

23
test/Database/Fill.hs
View File

@ -63,9 +63,10 @@ fillDb = do
insert' = fmap (either entityKey id) . insertBy insert' = fmap (either entityKey id) . insertBy
addBDays = addBusinessDays Fraport -- holiday area to use 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 } n_day' n = now { utctDay = n_day n }
(currentYear, _currentMonth, _currentDay) = toGregorian $ utctDay now (currentYear, _currentMonth, _currentDay) = toGregorian nowaday
currentTerm = TermIdentifier currentYear currentTerm = TermIdentifier currentYear
nextTerm n = toEnum . (+n) $ fromEnum currentTerm nextTerm n = toEnum . (+n) $ fromEnum currentTerm
@ -1075,7 +1076,23 @@ fillDb = do
_ -> "B777" _ -> "B777"
, tutorialRoomHidden = False , tutorialRoomHidden = False
, tutorialTime = Occurrences , 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 , occurrencesExceptions = Set.fromList
[ ExceptOccur [ ExceptOccur
{ exceptDay = nTimes 7 succ firstDay { exceptDay = nTimes 7 succ firstDay