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

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 (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,7 +367,7 @@ 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
@ -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

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

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

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

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

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

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

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

4
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

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

1
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

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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -225,10 +225,32 @@ 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

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

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

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