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

chore(tutorial): towards #37 by adding new tutorials from template

Browse Source
This commit is contained in:
Steffen Jost 2023-05-26 16:03:10 +00:00
parent 94b48f59cf
commit 930bcef9cd
4 changed files with 92 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -47,6 +47,10 @@ tutorialTemplateNames :: Maybe TutorialType -> [TutorialType]
tutorialTemplateNames Nothing = ["Vorlage", "Template"] tutorialTemplateNames Nothing = ["Vorlage", "Template"]
tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, CI.mk tutorialTypeSeparator <> name]] tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, CI.mk tutorialTypeSeparator <> name]]
tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
-- tutorialDefaultName Nothing = tutorialDefaultName $ Just defaultTutorialType
tutorialDefaultName _ = CI.mk . tshow -- Don't use user date display setting, so that tutorial default names conform to all users
data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@ -139,27 +143,28 @@ getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler
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
postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users 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
--TODO: Refactor above to send Day instead of TutorialName and refactor below to accept Either Day TutorialName or maybe even TutorialId?
getTAddUserR, postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html getTAddUserR, postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTAddUserR = postTAddUserR getTAddUserR = postTAddUserR
postTAddUserR tid ssh csh tut = do postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing
now <- liftIO getCurrentTime
let nowaday = utctDay now
(cid,tutTypes,tutorial) <- runDB $ do handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html
handleAddUserR tid ssh csh tdesc ttyp = do
(cid, tutTypes) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
tutTypes <- E.select $ E.distinct $ do tutTypes <- E.select $ E.distinct $ do
tutorial <- E.from $ E.table @Tutorial tutorial <- E.from $ E.table @Tutorial
let ttyp = tutorial E.^. TutorialType let tuTyp = tutorial E.^. TutorialType
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.&&. E.not_ (E.any (E.hasPrefix_ ttyp . E.val) (tutorialTemplateNames Nothing)) E.&&. E.not_ (E.any (E.hasPrefix_ tuTyp . E.val) (tutorialTemplateNames Nothing))
-- ((\pfx -> E.val pfx `E.isPrefixOf_` tutorial E.^. TutorialType) (tutorialTemplateNames Nothing)) -- ((\pfx -> E.val pfx `E.isPrefixOf_` tutorial E.^. TutorialType) (tutorialTemplateNames Nothing))
E.orderBy [E.asc ttyp] E.orderBy [E.asc tuTyp]
return ttyp return tuTyp
tutorial <- getBy $ UniqueTutorial cid tut return (cid, E.unValue <$> tutTypes)
return (cid, E.unValue <$> tutTypes, tutorial)
currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
@ -171,26 +176,26 @@ postTAddUserR tid ssh csh tut = do
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
forM_ actTutorial $ \(tutName,tutType,tutDay) -> do whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
tutId <- upsertNewTutorial cid (fromMaybe "TODO" tutName) tutType tutDay whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do
registerTutorialMembers tutId registeredUsers tutId <- upsertNewTutorial cid tName tutType tutDay
registerTutorialMembers tutId registeredUsers
if -- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point
| Just tutName <- actTutorial -- CONTINUE HERE redirect $ CTutorialR tid ssh csh tName TUsersR
, Set.size tutActs == Set.size confirmedActs redirect $ CourseR tid ssh csh CUsersR
-> redirect $ CTutorialR tid ssh csh tutName TUsersR
| otherwise
-> redirect $ CourseR tid ssh csh CUsersR
((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . 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)
auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
auReqTutorial <- optionalActionW auReqTutorial <- optionalActionW
( (,,) ( (,,)
<$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ Just tut) <$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip)
<*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType) (Just ((tutorial ^? _entityVal . _tutorialType) <|> listToMaybe tutTypes)) (Just $ maybeLeft tdesc)
<*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType)
(Just tutDefType)
<*> aopt dayField (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip) <*> aopt dayField (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip)
(Just ((tutorial ^? _entityVal . _tutorialFirstDay) <|> Just nowaday)) (Just $ maybeRight tdesc)
) )
( fslI MsgCourseParticipantsRegisterTutorialOption ) ( fslI MsgCourseParticipantsRegisterTutorialOption )
( Just True ) ( Just True )
@ -300,19 +305,19 @@ registerUser cid (_avsIdent, Just uid) = exceptT return return $ do
return $ mempty { aurRegisterSuccess = Set.singleton uid } return $ mempty { aurRegisterSuccess = Set.singleton uid }
upsertNewTutorial :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId upsertNewTutorial :: CourseId -> TutorialName -> Maybe TutorialType -> Maybe Day -> Handler TutorialId
upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
existingTut <- getBy $ UniqueTutorial cid newTutorialName existingTut <- getBy $ UniqueTutorial cid newTutorialName
templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType] templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType]
case (existingTut, anchorDay, 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 newFirstDay, 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 newFirstDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime)
newTime = occurrencesAddBusinessDays term (oldFirstDay, newFirstDay) tutorialTime newTime = occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime
dayDiff = maybe 0 (diffDays newFirstDay) tutorialFirstDay dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay
mvTime = fmap $ addLocalDays dayDiff mvTime = fmap $ addLocalDays dayDiff
newType0 = CI.mk . snd . Text.breakOnEnd tutorialTypeSeparator $ CI.original tutorialType newType0 = CI.mk . snd . Text.breakOnEnd tutorialTypeSeparator $ CI.original tutorialType
newType = if newType0 `elem` tutorialTemplateNames Nothing newType = if newType0 `elem` tutorialTemplateNames Nothing
@ -323,7 +328,7 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do
{ tutorialName = newTutorialName { tutorialName = newTutorialName
, tutorialCourse = cid , tutorialCourse = cid
, tutorialType = newType , tutorialType = newType
, tutorialFirstDay = anchorDay , tutorialFirstDay = newFirstDay
, tutorialTime = newTime , tutorialTime = newTime
, tutorialRegisterFrom = mvTime tutorialRegisterFrom , tutorialRegisterFrom = mvTime tutorialRegisterFrom
, tutorialRegisterTo = mvTime tutorialRegisterTo , tutorialRegisterTo = mvTime tutorialRegisterTo
@ -349,7 +354,7 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do
, tutorialDeregisterUntil = Nothing , tutorialDeregisterUntil = Nothing
, tutorialLastChanged = now , tutorialLastChanged = now
, tutorialTutorControlled = False , tutorialTutorControlled = False
, tutorialFirstDay = anchorDay , 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

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

@ -44,9 +44,10 @@ getCTutorialListR tid ssh csh = do
dbtRowKey = (E.^. TutorialId) dbtRowKey = (E.^. TutorialId)
dbtProj = over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue <$> dbtProjId dbtProj = over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue <$> dbtProjId
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType [ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
, sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] , sortable (Just "first-day") (i18nCell MsgTableTutorialFirstDay) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> cellMaybe dayCell tutorialFirstDay
, sortable (Just "tutors") (i18nCell MsgTableTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do , sortable (Just "name") (i18nCell MsgTableTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
, sortable (Just "tutors") (i18nCell MsgTableTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do
tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
@ -73,8 +74,9 @@ getCTutorialListR tid ssh csh = do
linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType ) [ ("type" , SortColumn $ \tutorial -> tutorial E.^. TutorialType )
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName ) , ("name" , SortColumn $ \tutorial -> tutorial E.^. TutorialName )
, ("first-day", SortColumn $ \tutorial -> tutorial E.^. TutorialFirstDay )
, ( "tutors" , ( "tutors"
, SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do , SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
@ -104,7 +106,7 @@ getCTutorialListR tid ssh csh = do
dbtExtraReps = [] dbtExtraReps = []
tutorialDBTableValidator = def tutorialDBTableValidator = def
& defaultSorting [SortAscBy "type", SortAscBy "name"] & defaultSorting [SortAscBy "type", SortDescBy "first-day", SortAscBy "name"]
((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable ((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do

2
src/Utils.hs
View File

@ -870,7 +870,7 @@ deepAlt altFst _ = altFst
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty = flip foldMap maybeEmpty = flip foldMap
-- | also referred to as whenJust -- | also referred to as whenJust and forM_
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x whenIsJust (Just x) f = f x
whenIsJust Nothing _ = return () whenIsJust Nothing _ = return ()

44
test/Database/Fill.hs
View File

@ -46,6 +46,13 @@ insertFile residual fileTitle = do
-} -}
-- | Apply a function @n@ times to a given value. From GHC.Utils.Misc
nTimes :: Int -> (a -> a) -> (a -> a)
nTimes 0 _ = id
nTimes 1 f = f
nTimes n f = f . nTimes (n-1) f
fillDb :: DB () fillDb :: DB ()
fillDb = do fillDb = do
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod $ view appSettings AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod $ view appSettings
@ -993,6 +1000,42 @@ fillDb = do
Thursday -> "A380" Thursday -> "A380"
_ -> "B777" _ -> "B777"
, tutorialRoomHidden = False , tutorialRoomHidden = False
, tutorialTime = Occurrences
{ occurrencesScheduled = Set.empty
, occurrencesExceptions = Set.fromList
[ ExceptOccur
{ exceptDay = nTimes 7 succ firstDay
, exceptStart = TimeOfDay 8 30 0
, exceptEnd = TimeOfDay 16 0 0
}
, ExceptOccur
{ exceptDay = nTimes 8 succ secondDay
, exceptStart = TimeOfDay 9 0 0
, exceptEnd = TimeOfDay 16 0 0
}
]
}
, tutorialRegGroup = Just "Schulung"
, tutorialRegisterFrom = jtt TermDayStart 0 Nothing toMidnight
, tutorialRegisterTo = jtt TermDayLectureStart (-1) Nothing toMidnight
, tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
, tutorialLastChanged = now
, tutorialTutorControlled = True
, tutorialFirstDay = Just firstDay
}
insert_ $ Tutor tut1 jost
insert_ Tutorial
{ tutorialName = mkName "Vorlage"
, tutorialCourse = c
, tutorialType = "Schulung"
, tutorialCapacity = capacity
, tutorialRoom = Just $ case weekDay of
Monday -> "A380"
Tuesday -> "B747"
Wednesday -> "MD11"
Thursday -> "A380"
_ -> "B777"
, tutorialRoomHidden = False
, tutorialTime = Occurrences , tutorialTime = Occurrences
{ occurrencesScheduled = Set.empty { occurrencesScheduled = Set.empty
, occurrencesExceptions = Set.fromList , occurrencesExceptions = Set.fromList
@ -1016,7 +1059,6 @@ fillDb = do
, tutorialTutorControlled = True , tutorialTutorControlled = True
, tutorialFirstDay = Just firstDay , tutorialFirstDay = Just firstDay
} }
insert_ $ Tutor tut1 jost
void . insert' $ Exam void . insert' $ Exam
{ examCourse = c { examCourse = c
, examName = mkName "Theorieprüfung" , examName = mkName "Theorieprüfung"