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

chore(tutorial): WIP towards tutorial templates

Browse Source
This commit is contained in:
Steffen Jost 2023-05-24 13:29:53 +00:00
parent c2521df20b
commit 5400c32477
10 changed files with 102 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/courses/courses/de-de-formal.msg
View File

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

1
messages/uniworx/categories/courses/courses/en-eu.msg
View File

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

1
messages/uniworx/utils/table_column/de-de-formal.msg
View File

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

1
messages/uniworx/utils/table_column/en-eu.msg
View File

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

19
src/Database/Esqueleto/Utils.hs
View File

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

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

@ -1,7 +1,9 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
--
-- 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] []

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

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

2
src/Handler/Utils/Avs.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

4
src/Handler/Utils/Occurrences.hs
View File

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

2
src/Model/Types/DateTime.hs
View File

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