diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 88e2f2e97..41b5a11dc 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -47,6 +47,10 @@ tutorialTemplateNames :: Maybe TutorialType -> [TutorialType] tutorialTemplateNames Nothing = ["Vorlage", "Template"] 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 deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -139,27 +143,28 @@ getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler getCAddUserR = postCAddUserR postCAddUserR tid ssh csh = do 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 -postTAddUserR tid ssh csh tut = do - now <- liftIO getCurrentTime - let nowaday = utctDay now - (cid,tutTypes,tutorial) <- runDB $ do +postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing + + +handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html +handleAddUserR tid ssh csh tdesc ttyp = do + (cid, tutTypes) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh tutTypes <- E.select $ E.distinct $ do 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.&&. 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)) - E.orderBy [E.asc ttyp] - return ttyp - tutorial <- getBy $ UniqueTutorial cid tut - return (cid, E.unValue <$> tutTypes, tutorial) + E.orderBy [E.asc tuTyp] + return tuTyp + return (cid, E.unValue <$> tutTypes) 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 actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! registeredUsers <- registerUsers cid users - forM_ actTutorial $ \(tutName,tutType,tutDay) -> do - tutId <- upsertNewTutorial cid (fromMaybe "TODO" tutName) tutType tutDay - registerTutorialMembers tutId registeredUsers - - if - | Just tutName <- actTutorial -- CONTINUE HERE - , Set.size tutActs == Set.size confirmedActs - -> redirect $ CTutorialR tid ssh csh tutName TUsersR - | otherwise - -> redirect $ CourseR tid ssh csh CUsersR + whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do + whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do + tutId <- upsertNewTutorial cid tName tutType tutDay + registerTutorialMembers tutId registeredUsers + -- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point + redirect $ CTutorialR tid ssh csh tName TUsersR + redirect $ CourseR tid ssh csh CUsersR ((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 auReqTutorial <- optionalActionW ( (,,) - <$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ Just tut) - <*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType) (Just ((tutorial ^? _entityVal . _tutorialType) <|> listToMaybe tutTypes)) + <$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) + (Just $ maybeLeft tdesc) + <*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType) + (Just tutDefType) <*> aopt dayField (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip) - (Just ((tutorial ^? _entityVal . _tutorialFirstDay) <|> Just nowaday)) + (Just $ maybeRight tdesc) ) ( fslI MsgCourseParticipantsRegisterTutorialOption ) ( Just True ) @@ -300,19 +305,19 @@ registerUser cid (_avsIdent, Just uid) = exceptT return return $ do return $ mempty { aurRegisterSuccess = Set.singleton uid } -upsertNewTutorial :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId -upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do +upsertNewTutorial :: CourseId -> TutorialName -> Maybe TutorialType -> Maybe Day -> Handler TutorialId +upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do now <- liftIO getCurrentTime existingTut <- getBy $ UniqueTutorial cid newTutorialName 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 - (Nothing, Just newFirstDay, Just Entity{entityVal=Tutorial{..}}) -> do + (Nothing, Just moveDay, Just Entity{entityVal=Tutorial{..}}) -> do Course{..} <- get404 cid term <- get404 courseTerm - let oldFirstDay = fromMaybe newFirstDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) - newTime = occurrencesAddBusinessDays term (oldFirstDay, newFirstDay) tutorialTime - dayDiff = maybe 0 (diffDays newFirstDay) tutorialFirstDay + let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) + newTime = occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime + dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay mvTime = fmap $ addLocalDays dayDiff newType0 = CI.mk . snd . Text.breakOnEnd tutorialTypeSeparator $ CI.original tutorialType newType = if newType0 `elem` tutorialTemplateNames Nothing @@ -323,7 +328,7 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do { tutorialName = newTutorialName , tutorialCourse = cid , tutorialType = newType - , tutorialFirstDay = anchorDay + , tutorialFirstDay = newFirstDay , tutorialTime = newTime , tutorialRegisterFrom = mvTime tutorialRegisterFrom , tutorialRegisterTo = mvTime tutorialRegisterTo @@ -349,7 +354,7 @@ upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do , tutorialDeregisterUntil = Nothing , tutorialLastChanged = now , tutorialTutorControlled = False - , tutorialFirstDay = anchorDay + , tutorialFirstDay = Nothing } [] -- update cannot happen due to previous cases audit $ TransactionTutorialEdit tutId return tutId diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index fa24a5966..24f2e87ee 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -44,9 +44,10 @@ getCTutorialListR tid ssh csh = do dbtRowKey = (E.^. TutorialId) dbtProj = over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue <$> dbtProjId dbtColonnade = dbColonnade $ mconcat - [ 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 "tutors") (i18nCell MsgTableTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do + [ sortable (Just "type") (i18nCell MsgTableTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType + , sortable (Just "first-day") (i18nCell MsgTableTutorialFirstDay) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> cellMaybe dayCell tutorialFirstDay + , 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 E.on $ tutor E.^. TutorUser E.==. user E.^. UserId 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 ] dbtSorting = Map.fromList - [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType ) - , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName ) + [ ("type" , SortColumn $ \tutorial -> tutorial E.^. TutorialType ) + , ("name" , SortColumn $ \tutorial -> tutorial E.^. TutorialName ) + , ("first-day", SortColumn $ \tutorial -> tutorial E.^. TutorialFirstDay ) , ( "tutors" , SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId @@ -104,7 +106,7 @@ getCTutorialListR tid ssh csh = do dbtExtraReps = [] tutorialDBTableValidator = def - & defaultSorting [SortAscBy "type", SortAscBy "name"] + & defaultSorting [SortAscBy "type", SortDescBy "first-day", SortAscBy "name"] ((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do diff --git a/src/Utils.hs b/src/Utils.hs index 4ab7b9a57..78e47edc9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -870,7 +870,7 @@ deepAlt altFst _ = altFst maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap --- | also referred to as whenJust +-- | also referred to as whenJust and forM_ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index d393e22cd..3fa808102 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -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 = do AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod $ view appSettings @@ -993,6 +1000,42 @@ fillDb = do Thursday -> "A380" _ -> "B777" , 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 { occurrencesScheduled = Set.empty , occurrencesExceptions = Set.fromList @@ -1016,7 +1059,6 @@ fillDb = do , tutorialTutorControlled = True , tutorialFirstDay = Just firstDay } - insert_ $ Tutor tut1 jost void . insert' $ Exam { examCourse = c , examName = mkName "Theorieprüfung"