feat(avs): add page-action and form handler for registering avs participants

messages/uniworx/categories/courses/courses/de-de-formal.msg

@@ -286,3 +286,9 @@ CourseExamRegistrationTime: Angemeldet seit
 CourseParticipantStateIsActiveFilter: Ansicht
 CourseApply: Zum Kurs bewerben
 CourseAdministrator: Kursadministrator:in
+
+CourseAvsRegisterTitle: Teilnehmer:innen anmelden
+CourseAvsRegisterParticipants: Teilnehmer:innen
+CourseAvsRegisterParticipantsTip: Mehrere Teilnehmer:innen mit Komma separieren
+CourseAvsRegisterCreateTutorial: Teilnehmer:innen in Tagesgruppe eintragen
+CourseAvsRegisterTutorialDay: Tag

messages/uniworx/categories/courses/courses/en-eu.msg

@@ -285,3 +285,9 @@ CourseExamRegistrationTime: Registered since
 CourseParticipantStateIsActiveFilter: View
 CourseApply: Apply for course
 CourseAdministrator: Course administrator
+
+CourseAvsRegisterTitle: Register participants
+CourseAvsRegisterParticipants: Participants
+CourseAvsRegisterParticipantsTip: Separate multiple participants with comma
+CourseAvsRegisterCreateTutorial: Add participants to day group
+CourseAvsRegisterTutorialDay: Day

messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg

@@ -137,6 +137,7 @@ BreadcrumbCourseEventEdit: Kurstermin bearbeiten
 BreadcrumbExamList: Prüfungen
 BreadcrumbExamNew: Neue Prüfung anlegen
 BreadcrumbCourseApplications: Bewerbungen
+BreadcrumbCourseAvsRegister: AVS-Teilnehmer:innen anmelden
 BreadcrumbExamEdit: Prüfung bearbeiten
 BreadcrumbExamUsers: Teilnehmer:innen
 BreadcrumbExamGrades: Prüfungsleistungen

messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg

@@ -131,6 +131,7 @@ BreadcrumbCourseNewsNew: Add course news
 BreadcrumbCourseNewsEdit: Edit course news
 BreadcrumbCourseEventNew: New course occurrence
 BreadcrumbCourseEventEdit: Edit course occurrence
+BreadcrumbCourseAvsRegister: Register AVS participants
 BreadcrumbExamList: Exams
 BreadcrumbExamNew: Create new exam
 BreadcrumbCourseApplications: Applications

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -147,5 +147,7 @@ MenuApc: Druckerei
 MenuPrintSend: Manueller Briefversand
 MenuPrintDownload: Brief herunterladen
 
+MenuCourseAvsRegister: AVS-Teilnehmer:innen anmelden
+
 MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -148,5 +148,7 @@ MenuApc: Printing
 MenuPrintSend: Send Letter
 MenuPrintDownload: Download Letter
 
+MenuCourseAvsRegister: Register AVS participants
+
 MenuApiDocs: API documentation
 MenuSwagger: OpenAPI 2.0 (Swagger)

routes

@@ -176,6 +176,8 @@
   !/users/new                 CAddUserR        GET POST        !lecturerANDallocation-time
   !/users/invite              CInviteR         GET POST
   /users/#CryptoUUIDUser      CUserR           GET POST        !lecturerANDparticipant !lecturerANDapplicant
+  /avs                        CAvsR:
+    /register                 CAvsRegisterR    GET POST        !lecturer
   /correctors                 CHiWisR          GET
   /communication              CCommR           GET POST
   /notes                      CNotesR          GET POST        !corrector -- THIS route is used to check for overall course corrector access!

src/Foundation/Navigation.hs

@@ -250,6 +250,7 @@ breadcrumb (CourseR tid ssh csh CEditR)     = i18nCrumb MsgMenuCourseEdit . Just
 breadcrumb (CourseR tid ssh csh CUsersR)    = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR
 breadcrumb (CourseR tid ssh csh CAddUserR)  = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR
 breadcrumb (CourseR tid ssh csh CInviteR)   = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR
+breadcrumb (CourseR tid ssh csh (CAvsR CAvsRegisterR)) = i18nCrumb MsgBreadcrumbCourseAvsRegister . Just $ CourseR tid ssh csh CUsersR
 breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR
 breadcrumb (CourseR tid ssh csh (CUserR cID)) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do
   guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID
@@ -985,6 +986,17 @@ pageActions (CourseR tid ssh csh CShowR) = do
 
   return $
     [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuCourseAvsRegister
+        , navRoute       = CourseR tid ssh csh $ CAvsR CAvsRegisterR
+        , navAccess'     = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR
+        , navType        = NavTypeLink { navModal = True }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = mempty
+      }
+    , NavPageActionPrimary
       { navLink = NavLink
         { navLabel       = MsgMenuMaterialList
         , navRoute       = CourseR tid ssh csh MaterialListR
@@ -1717,6 +1729,17 @@ pageActions (CourseR tid ssh csh SheetListR) = do
     ]
 pageActions (CourseR tid ssh csh CUsersR) = return
   [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCourseAvsRegister
+      , navRoute       = CourseR tid ssh csh $ CAvsR CAvsRegisterR
+      , navAccess'     = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = mempty
+    }
+  , NavPageActionPrimary
     { navLink = NavLink
       { navLabel       = MsgMenuCourseAddMembers
       , navRoute       = CourseR tid ssh csh CAddUserR
@@ -1791,6 +1814,17 @@ pageActions (CMaterialR tid ssh csh mnm MShowR) = return
   ]
 pageActions (CourseR tid ssh csh CTutorialListR) = return
   [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCourseAvsRegister
+      , navRoute       = CourseR tid ssh csh $ CAvsR CAvsRegisterR
+      , navAccess'     = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = mempty
+    }
+  , NavPageActionPrimary
     { navLink = NavLink
       { navLabel       = MsgMenuTutorialNew
       , navRoute       = CourseR tid ssh csh CTutorialNewR
@@ -1837,6 +1871,17 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = return
       }
     , navChildren = []
     }
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuCourseAvsRegister
+      , navRoute       = CourseR tid ssh csh $ CAvsR CAvsRegisterR
+      , navAccess'     = NavAccessDB . hasWriteAccessTo . CourseR tid ssh csh $ CAvsR CAvsRegisterR
+      , navType        = NavTypeLink { navModal = True }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = mempty
+    }
   , NavPageActionSecondary
     { navLink = NavLink
       { navLabel       = MsgMenuTutorialDelete

src/Foundation/Routes.hs

@@ -34,6 +34,7 @@ import ServantApi.ExternalApis.Type
 mkYesodData "UniWorX" uniworxRoutes
 
 deriving instance Generic CourseR
+deriving instance Generic CAvsR
 deriving instance Generic SheetR
 deriving instance Generic SubmissionR
 deriving instance Generic MaterialR
@@ -51,6 +52,7 @@ deriving instance Generic (Route UniWorX)
 
 
 instance Hashable CourseR
+instance Hashable CAvsR
 instance Hashable SheetR
 instance Hashable SubmissionR
 instance Hashable MaterialR
@@ -76,6 +78,7 @@ instance Ord (Route EmbeddedStatic) where
   compare = compare `on` renderRoute
 
 deriving instance Ord CourseR
+deriving instance Ord CAvsR
 deriving instance Ord SheetR
 deriving instance Ord SubmissionR
 deriving instance Ord MaterialR

src/Handler/Course.hs

@@ -11,6 +11,7 @@ import Import
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Persist as P
 
+import Handler.Course.Avs as Handler.Course
 import Handler.Course.Communication as Handler.Course
 import Handler.Course.Delete as Handler.Course
 import Handler.Course.Edit as Handler.Course

src/Handler/Course/Avs.hs

@@ -0,0 +1,53 @@
+-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Handler.Course.Avs
+  ( getCAvsRegisterR, postCAvsRegisterR
+  ) where
+
+import Import
+
+import Handler.Utils
+
+import qualified Data.Set as Set
+import qualified Data.Text as Text
+import qualified Data.Time.Zones as TZ
+
+
+data CourseAvsRegisterForm = CourseAvsRegisterForm
+  { cavsregParticipants :: Set Text -- TODO: NonEmpty
+  , cavsregTutorial     :: Maybe Day
+  }
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+
+makeLenses_ ''CourseAvsRegisterForm
+
+courseAvsRegisterForm :: Maybe CourseAvsRegisterForm -> AForm Handler CourseAvsRegisterForm
+courseAvsRegisterForm template = wFormToAForm $ do
+  today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
+
+  let
+    cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text)
+    cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList)
+
+  aFormToWForm $ CourseAvsRegisterForm
+    <$> areq (textField & cfCommaSeparatedSet) (fslI MsgCourseAvsRegisterParticipants & setTooltip MsgCourseAvsRegisterParticipantsTip) (cavsregParticipants <$> template)
+    <*> optionalActionA
+        ( areq dayField (fslI MsgCourseAvsRegisterTutorialDay) (Just . fromMaybe today . join $ cavsregTutorial <$> template)
+        )
+        (fslI MsgCourseAvsRegisterCreateTutorial) (is _Just . cavsregTutorial <$> template)
+
+
+getCAvsRegisterR, postCAvsRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCAvsRegisterR = postCAvsRegisterR
+postCAvsRegisterR _tid _ssh _csh = do
+  ((_result, formView), formEnctype) <- runFormPost . renderAForm FormStandard $ courseAvsRegisterForm Nothing
+
+  -- TODO: process result
+
+  defaultLayout $ do
+    setTitleI MsgCourseAvsRegisterTitle
+    wrapForm formView def
+      { formEncoding = formEnctype
+      }