chore(tutorial): WIP towards tutorial templates

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

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

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

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

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

src/Handler/Course/ParticipantInvite.hs

@@ -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 :: CourseId -> TutorialName -> Maybe (CI Text) -> Maybe Day -> Handler TutorialId
-upsertNewTutorial cid tutorialName = do
+upsertNewTutorial cid newTutorialName newTutorialType anchorDay = runDB $ do
   now <- liftIO getCurrentTime
-  runDB $ do
+  existingTut <- getBy $ UniqueTutorial cid newTutorialName
-    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  
   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
+          { tutorialName            = newTutorialName
-          , tutorialType        = fromMaybe (CI.mk "Schulung") newTutorialType
+          , tutorialCourse          = cid
-          , tutorialTime        = newTime
+          , tutorialType            = fromMaybe defaultTutorialType newTutorialType
-          , tutorialFirstDay    = newFirstDay
+          , tutorialFirstDay        = anchorDay
-          , tutorialName        = newTutorialName
+          , tutorialTime            = newTime
-          -- TODO
+          , tutorialRegisterFrom    = mvTime tutorialRegisterFrom
-          , tutorialRegisterFrom = Nothing
+          , tutorialRegisterTo      = mvTime tutorialRegisterTo
-          , tutorialRegisterTo = Nothing
+          , tutorialDeregisterUntil = mvTime tutorialDeregisterUntil
-          , tutorialDeregisterUntil = Nothing
+          , tutorialLastChanged     = now
-          , tutorialLastChanged = now
-
           , ..
-          }  []
+          }  [] -- update cannot happen due to previous case      
-      -- error "TODO" -- CONTINUE HERE
       audit $ TransactionTutorialEdit tutId
       return tutId
     _ -> do
       Entity tutId _ <- upsert
         Tutorial
-          { tutorialCourse = cid
+          { tutorialName            = newTutorialName
-          , tutorialType = CI.mk "Schulung"
+          , tutorialCourse          = cid
-          , tutorialCapacity = Nothing
+          , tutorialType            = fromMaybe defaultTutorialType newTutorialType
-          , tutorialRoom = Nothing
+          , tutorialCapacity        = Nothing
-          , tutorialRoomHidden = False
+          , tutorialRoom            = Nothing
-          , tutorialTime = Occurrences mempty mempty
+          , tutorialRoomHidden      = False
-          , tutorialRegGroup = Nothing -- TODO: remove
+          , tutorialTime            = Occurrences mempty mempty
-          , tutorialRegisterFrom = Nothing
+          , tutorialRegGroup        = Nothing
-          , tutorialRegisterTo = 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] []

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

src/Handler/Utils/Avs.hs

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

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 | 0 == dayDiff `mod` 7 = os
-    switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday}  = os{scheduleDayOfWeek= toEnum (dayDiff + fromEnum wday)}
+    switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)}
 
     newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions
 

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