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

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

@ -353,8 +353,8 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
(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,7 +367,7 @@ 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
@ -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

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

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

@ -39,7 +39,7 @@ postTEditR tid ssh csh tutn = do
, 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

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

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

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

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

4
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

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

1
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

26
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
@ -225,10 +225,32 @@ 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
-- now <- getCurrentTime

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

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

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

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