From 4a00907bdad26208329080ad87fe52daa33775ff Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 28 Nov 2022 19:55:14 +0100 Subject: [PATCH] feat(course-users): fuse avs register form with CAddUserR --- .../navigation/breadcrumbs/de-de-formal.msg | 1 - .../utils/navigation/breadcrumbs/en-eu.msg | 1 - .../utils/navigation/menu/de-de-formal.msg | 2 - .../uniworx/utils/navigation/menu/en-eu.msg | 2 - routes | 2 - src/Foundation/Navigation.hs | 45 ---------------- src/Foundation/Routes.hs | 3 -- src/Handler/Course.hs | 1 - src/Handler/Course/Avs.hs | 53 ------------------- src/Handler/Course/ParticipantInvite.hs | 46 ++++++++++++---- 10 files changed, 35 insertions(+), 121 deletions(-) delete mode 100644 src/Handler/Course/Avs.hs diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 059524d1e..2552a6418 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -137,7 +137,6 @@ 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 diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index ce41cf679..2c8f601c5 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -131,7 +131,6 @@ 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 diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 091a28614..803e46860 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -147,7 +147,5 @@ MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen -MenuCourseAvsRegister: AVS-Teilnehmer:innen anmelden - MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 3f9ca4ee8..73f58d1f3 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -148,7 +148,5 @@ MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter -MenuCourseAvsRegister: Register AVS participants - MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/routes b/routes index cb840852e..435ca94d3 100644 --- a/routes +++ b/routes @@ -176,8 +176,6 @@ !/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 /correctors CHiWisR GET /communication CCommR GET POST /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 472547818..b17708671 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -250,7 +250,6 @@ 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 @@ -986,17 +985,6 @@ 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 @@ -1729,17 +1717,6 @@ 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 @@ -1814,17 +1791,6 @@ 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 @@ -1871,17 +1837,6 @@ 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 diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 6ece00b0b..a6ce7b7fd 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -34,7 +34,6 @@ 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 @@ -52,7 +51,6 @@ deriving instance Generic (Route UniWorX) instance Hashable CourseR -instance Hashable CAvsR instance Hashable SheetR instance Hashable SubmissionR instance Hashable MaterialR @@ -78,7 +76,6 @@ 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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 1efd5a085..5786e3566 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -11,7 +11,6 @@ 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 diff --git a/src/Handler/Course/Avs.hs b/src/Handler/Course/Avs.hs deleted file mode 100644 index dc4bfe53f..000000000 --- a/src/Handler/Course/Avs.hs +++ /dev/null @@ -1,53 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel --- --- 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) <|> Just True) - - -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 - } diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 6f1f83149..fc8d44312 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros +-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -16,25 +16,48 @@ module Handler.Course.ParticipantInvite import Import -import Utils.Form import Handler.Utils import Handler.Utils.Invitations import Handler.Utils.Course -import qualified Data.CaseInsensitive as CI - -import qualified Data.Set as Set -import qualified Data.Map as Map - import Jobs.Queue -import Data.Aeson hiding (Result(..)) - import Control.Monad.Except (MonadError(..)) +import Data.Aeson hiding (Result(..)) +import qualified Data.CaseInsensitive as CI +import qualified Data.HashSet as HashSet +import qualified Data.Map as Map +import qualified Data.Text as Text +import qualified Data.Time.Zones as TZ +import qualified Data.Set as Set + import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import qualified Data.HashSet as HashSet + +data CourseAvsRegisterForm = CourseAvsRegisterForm + { cavsregParticipants :: Set Text -- TODO: NonEmpty + , cavsregTutorial :: Maybe Day + } + deriving (Eq, Ord, Show, Read, Generic, Typeable) + +makeLenses_ ''CourseAvsRegisterForm + +-- TODO: merge to postCAddUserR +_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) <|> Just True) -- Invitations for ordinary participants of this course @@ -123,6 +146,7 @@ getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler getCAddUserR = postCAddUserR postCAddUserR tid ssh csh = do cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False) @@ -138,7 +162,6 @@ postCAddUserR tid ssh csh = do formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ hoist runDBJobs . registerUsers' cid - let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading siteLayoutMsg heading $ do @@ -148,6 +171,7 @@ postCAddUserR tid ssh csh = do , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR } + registerUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] (YesodJobDB UniWorX) () registerUsers cid = registerUsers' cid . Map.fromSet (const Nothing)