diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index fa44ab8cc..cf6e1b500 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -89,6 +89,7 @@ CourseParticipantsRegisterTutorialField: Übungsgruppe CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Übungsgruppe mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Übungsgruppe mit diesem Namen vorhanden, werden die Kursteilnehmenden dieser hinzugefügt. CourseParticipantsRegisterNoneGiven: Es wurden keine anzumeldenden Personen angegeben! CourseParticipantsRegisterNotFoundInAvs n@Int: Zu #{n} #{pluralDE n "Angabe konnte keine übereinstimmende Person" "Angaben konnten keine übereinstimmenden Personen"} im AVS gefunden werden +CourseParticipantsRegisterTutorialFirstDayTip: Wenn ein neus Tutorium gemäß eine Vorlage erstellt wird, werden die Zeiten gemäß dem Starttag angepasst CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits zum Kurs angemeldet diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index ae25a7187..abfbba6cc 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -89,6 +89,7 @@ CourseParticipantsRegisterTutorialField: Tutorial CourseParticipantsRegisterTutorialFieldTip: If there is no tutorial with this name, a new one will be created. If there is a tutorial with this name, the course participants will be registered for it. CourseParticipantsRegisterNoneGiven: No persons given to register! CourseParticipantsRegisterNotFoundInAvs n: For #{n} #{pluralEN n "entry no corresponding person" "entries no corresponding persons"} could be found in AVS +CourseParticipantsRegisterTutorialFirstDayTip: If a new tutorial is created and a template exists, its dates are adjusted according to the start date CourseParticipantsRegisterUnnecessary: All requested registrations have already been saved. No actions have been performed. CourseParticipantsInvited n: #{n} #{pluralEN n "invitation" "invitations"} sent via email diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index c3247ecf5..bee0fc158 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -54,6 +54,7 @@ TableTutorialRoomIsUnset !ident-ok: — TableTutorialRoomIsHidden: Raum wird nur Teilnehmern angezeigt TableTutorialTime: Zeit TableTutorialDeregisterUntil: Abmeldungen bis +TableTutorialFirstDay: Starttag TableActionsHead: Aktionen TableNoFilter: Keine Einschränkung TableUserMatriculation: ASV Nummer diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 5ff701e6a..af505c942 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -53,6 +53,7 @@ TableTutorialRoomHidden: Room only for participants TableTutorialRoomIsUnset: — TableTutorialRoomIsHidden: Room is only displayed to participants TableTutorialDeregisterUntil: Deregister until +TableTutorialFirstDay: Start date TableActionsHead: Actions TableTutorialTime: Time TableNoFilter: No restriction diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 7064697e4..144eb99a6 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -10,6 +10,7 @@ module Database.Esqueleto.Utils , vals, justVal, justValList, toValues , isJust, alt , isInfixOf, hasInfix + , isPrefixOf_, hasPrefix_ , strConcat, substring , (=?.), (?=.) , (=~.), (~=.) @@ -142,9 +143,9 @@ alt :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value -- alt a b = E.case_ [(isJust a, a), (isJust b, b)] b alt a b = E.coalesce [a,b] -infix 4 `isInfixOf`, `hasInfix` +infix 4 `isInfixOf`, `hasInfix`, `isPrefixOf_`, `hasPrefix_` --- | Check if the first string is contained in the text derived from the second argument +-- | Check if the first string is contained in the text derived from the second argument (case-insensitive) isInfixOf :: ( E.SqlString s1 , E.SqlString s2 ) @@ -157,6 +158,20 @@ hasInfix :: ( E.SqlString s1 => E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool) hasInfix = flip isInfixOf +-- | Check if the first string is a prefix of the text derived from the second argument (case-insensitive) +isPrefixOf_ :: ( E.SqlString s1 + , E.SqlString s2 + ) + => E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool) +isPrefixOf_ needle strExpr = E.castString strExpr `E.ilike` needle E.++. (E.%) + +hasPrefix_ :: ( E.SqlString s1 + , E.SqlString s2 + ) + => E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool) +hasPrefix_ = flip isPrefixOf_ + + infixl 6 `strConcat` strConcat :: E.SqlString s diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 05757ee86..1cf631b3d 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} + module Handler.Course.ParticipantInvite ( getCAddUserR, postCAddUserR , getTAddUserR, postTAddUserR @@ -20,14 +22,27 @@ import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Time.Zones as TZ import qualified Data.Set as Set +-- import qualified Data.Text as Text import Control.Monad.Except (MonadError(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) +-- import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Utils as E + + type UserSearchKey = Text -type TutorialIdent = CI Text +type TutorialType = CI Text + +defaultTutorialType :: TutorialType +defaultTutorialType = "Schulung" + +tutorialTemplateNames :: Maybe TutorialType -> [TutorialType] +tutorialTemplateNames Nothing = ["Vorlage", "Template"] +tutorialTemplateNames (Just name) = [prefixes <> "_" <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, name]] data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort @@ -63,7 +78,7 @@ data CourseRegisterActionData | CourseRegisterActionAddTutorialMemberData { crActIdent :: UserSearchKey , crActUser :: (UserId, User) - , crActTutorial :: TutorialIdent + , crActTutorial :: TutorialName } -- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display -- { crActUnknownPersonIdent :: Text @@ -97,7 +112,7 @@ courseRegisterRenderAction act = [whamlet|^{userWidget (view _2 (crActUser act)) data AddUserRequest = AddUserRequest { auReqUsers :: Set UserSearchKey - , auReqTutorial :: Maybe TutorialIdent + , auReqTutorial :: Maybe (Maybe TutorialName, Maybe TutorialType, Maybe Day) } deriving (Eq, Ord, Read, Show, Generic) @@ -123,11 +138,26 @@ 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 +--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 - cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + now <- liftIO getCurrentTime + let nowaday = utctDay now + (cid,tutTypes,tutorial) <- 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 + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + E.&&. E.not_ (E.any (E.hasPrefix_ ttyp . 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) + currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction @@ -136,10 +166,10 @@ postTAddUserR tid ssh csh tut = do let users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList 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 forM_ actTutorial $ \tutName -> do - tutId <- upsertNewTutorial cid tutName + tutId <- upsertNewTutorial cid tutName --TODO registerTutorialMembers tutId registeredUsers if @@ -148,11 +178,17 @@ postTAddUserR tid ssh csh tut = do -> 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] auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auReqTutorial <- optionalActionW - ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just tut) ) + ( (,,) + <$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ Just tut) + <*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType) (Just ((tutorial ^? _entityVal . _tutorialType) <|> listToMaybe tutTypes)) + <*> aopt dayField (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip) + (Just ((tutorial ^? _entityVal . _tutorialFirstDay) <|> Just nowaday)) + ) ( fslI MsgCourseParticipantsRegisterTutorialOption ) ( Just True ) return $ AddUserRequest <$> auReqUsers <*> auReqTutorial @@ -261,91 +297,57 @@ registerUser cid (_avsIdent, Just uid) = exceptT return return $ do return $ mempty { aurRegisterSuccess = Set.singleton uid } -upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId -upsertNewTutorial cid tutorialName = do +upsertNewTutorial :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId +upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do now <- liftIO getCurrentTime - runDB $ do - Entity tutId _ <- upsert - Tutorial - { tutorialCourse = cid - , tutorialType = CI.mk "Schulung" - , tutorialCapacity = Nothing - , tutorialRoom = Nothing - , tutorialRoomHidden = False - , tutorialTime = Occurrences mempty mempty - , tutorialRegGroup = Nothing -- TODO: remove - , tutorialRegisterFrom = Nothing - , tutorialRegisterTo = Nothing - , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now - , tutorialTutorControlled = False - , tutorialFirstDay = Nothing - , .. - } - [ TutorialName =. tutorialName - , TutorialType =. CI.mk "Schulung" - , TutorialLastChanged =. now - ] - audit $ TransactionTutorialEdit tutId - return tutId - -tutorialTemplateNames :: Maybe (CI Text) -> [CI Text] -tutorialTemplateNames Nothing = ["Vorlage", "Template"] -tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- ["", Text.cons '_' name]] - -upsertNewTutorialTemplate :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId -upsertNewTutorialTemplate cid newTutorialName newTutorialType anchorDay = runDB $ do - now <- liftIO getCurrentTime - existingTut <- getBy $ UniqueTutorial cid tutorialName + existingTut <- getBy $ UniqueTutorial cid newTutorialName templateEnt <- selectFirst [TutorialType <-. tutorialTemplateNames newTutorialType] [Desc TutorialType] case (existingTut, anchorDay, 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 Course{..} <- get404 cid term <- get404 courseTerm - let newTime = occurrencesAddBusinessDays term (tutorialFirstDay, newFirstDay) + let oldFirstDay = fromMaybe newFirstDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) + newTime = occurrencesAddBusinessDays term (oldFirstDay, newFirstDay) tutorialTime + dayDiff = maybe 0 (diffDays newFirstDay) tutorialFirstDay + mvTime = fmap $ addLocalDays dayDiff Entity tutId _ <- upsert Tutorial - { tutorialCourse = cid - , tutorialType = fromMaybe (CI.mk "Schulung") newTutorialType - , tutorialTime = newTime - , tutorialFirstDay = newFirstDay - , tutorialName = newTutorialName - -- TODO - , tutorialRegisterFrom = Nothing - , tutorialRegisterTo = Nothing - , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now - + { tutorialName = newTutorialName + , tutorialCourse = cid + , tutorialType = fromMaybe defaultTutorialType newTutorialType + , tutorialFirstDay = anchorDay + , tutorialTime = newTime + , tutorialRegisterFrom = mvTime tutorialRegisterFrom + , tutorialRegisterTo = mvTime tutorialRegisterTo + , tutorialDeregisterUntil = mvTime tutorialDeregisterUntil + , tutorialLastChanged = now , .. - } [] - -- error "TODO" -- CONTINUE HERE + } [] -- update cannot happen due to previous case audit $ TransactionTutorialEdit tutId return tutId _ -> do Entity tutId _ <- upsert Tutorial - { tutorialCourse = cid - , tutorialType = CI.mk "Schulung" - , tutorialCapacity = Nothing - , tutorialRoom = Nothing - , tutorialRoomHidden = False - , tutorialTime = Occurrences mempty mempty - , tutorialRegGroup = Nothing -- TODO: remove - , tutorialRegisterFrom = Nothing - , tutorialRegisterTo = Nothing + { tutorialName = newTutorialName + , tutorialCourse = cid + , tutorialType = fromMaybe defaultTutorialType newTutorialType + , tutorialCapacity = Nothing + , tutorialRoom = Nothing + , tutorialRoomHidden = False + , tutorialTime = Occurrences mempty mempty + , tutorialRegGroup = Nothing + , tutorialRegisterFrom = Nothing + , tutorialRegisterTo = Nothing , tutorialDeregisterUntil = Nothing - , tutorialLastChanged = now + , tutorialLastChanged = now , tutorialTutorControlled = False - , tutorialFirstDay = anchorDay - , .. + , tutorialFirstDay = anchorDay } - [ ] -- should alwyas be an insert + [ ] -- update cannot happen due to previous cases audit $ TransactionTutorialEdit tutId return tutId --} - registerTutorialMembers :: TutorialId -> Set UserId -> Handler () registerTutorialMembers tutId (Set.toList -> users) = runDB $ do prevParticipants <- Set.fromList . fmap entityKey <$> selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] [] diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index 53a11c3c0..4fa98b0d6 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -27,7 +27,7 @@ postCTutorialNewR tid ssh csh = do formResult newTutResult $ \TutorialForm{..} -> do insertRes <- runDBJobs $ do now <- liftIO getCurrentTime - term <- get404 $ course ^. CourseTerm + term <- get404 $ course ^. _courseTerm insertRes <- insertUnique Tutorial { tutorialName = tfName , tutorialCourse = cid diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 550f4edd6..6afc21150 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 7e8dd5fee..f3412e29b 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -61,8 +61,8 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc weekends = [d | d <- [(min termLectureStart termStart)..(max termEnd termLectureEnd)], isWeekend d] switchDayOfWeek :: OccurrenceSchedule -> OccurrenceSchedule - switchDayOfWeek _ | 0 == dayDiff `mod` 7 = id - switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)} + switchDayOfWeek os | 0 == dayDiff `mod` 7 = os + switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)} newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 0771ce901..bc31638b4 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -211,7 +211,7 @@ dayOfOccurrenceException ExceptNoOccur{exceptTime=LocalTime{localDay=d}} = d setDayOfOccurrenceException :: Day -> OccurrenceException -> OccurrenceException setDayOfOccurrenceException d ex@ExceptOccur{} = ex{exceptDay=d} -setDayOfOccurrenceException d ExceptNoOccur{exceptTime=lt} = ExceptNoOccur{exceptTime = lt{localDay=d}} +setDayOfOccurrenceException d ExceptNoOccur{exceptTime=t} = ExceptNoOccur{exceptTime = t{localDay=d}} data Occurrences = Occurrences { occurrencesScheduled :: Set OccurrenceSchedule