diff --git a/frontend/src/app.sass b/frontend/src/app.sass index b2563cf73..0b3dcfd32 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -593,7 +593,7 @@ section & + section, & + .two-column-sections margin-top: 20px - &:last-child + &:last-of-type border-bottom: none padding-bottom: 0px @@ -604,7 +604,7 @@ section & + section, & + .two-column-sections margin-top: 20px - &:last-child + &:last-of-type border-bottom: none padding-bottom: 0px diff --git a/messages/uniworx/categories/courses/allocation/de-de-formal.msg b/messages/uniworx/categories/courses/allocation/de-de-formal.msg index 216095d3f..e72a79a8f 100644 --- a/messages/uniworx/categories/courses/allocation/de-de-formal.msg +++ b/messages/uniworx/categories/courses/allocation/de-de-formal.msg @@ -248,4 +248,12 @@ AllocationUserDeleteQuestion: Wollen Sie den/die unten aufgeführten Benutzer:in AllocationUserDeleted: Benutzer:in erfolgreich entfernt AllocationApplicationsCount n@Word64: #{n} #{pluralDE n "Bewerbung" "Bewerbungen"} AllocationAllocationsCount n@Word64: #{n} #{pluralDE n "Zuweisung" "Zuweisungen"} -AllocationCourseHasRatings ratings@Word64 vetos@Word64: Dieser Kurs hat bereits #{ratings} #{pluralDE ratings "Bewertung" "Bewertungen"} (#{vetos} #{pluralDE vetos "Veto" "Vetos"}) \ No newline at end of file +AllocationCourseHasRatings ratings@Word64 vetos@Word64: Dieser Kurs hat bereits #{ratings} #{pluralDE ratings "Bewertung" "Bewertungen"} (#{vetos} #{pluralDE vetos "Veto" "Vetos"}) + +AllocationCourseParticipantFormCourse: Kurs +AllocationCourseParticipantFormIsRegistered: Registriert? +AllocationCourseParticipantFormIsSelfInflicted: Selbstverschuldet abgemeldet (Grund)? +AllocationCourseParticipantFormDefaultReason: Kein Grund + +AllocationUserCourseParticipantFormTitle: Anmeldungen +AllocationUserAllocationUserFormTitle: Teilnahme an der Zentralanmeldung \ No newline at end of file diff --git a/messages/uniworx/categories/courses/allocation/en-eu.msg b/messages/uniworx/categories/courses/allocation/en-eu.msg index 99456e554..14d9809bb 100644 --- a/messages/uniworx/categories/courses/allocation/en-eu.msg +++ b/messages/uniworx/categories/courses/allocation/en-eu.msg @@ -248,3 +248,11 @@ AllocationUserDeleted: Participant successfully removed AllocationApplicationsCount n: #{n} #{pluralENs n "application"} AllocationAllocationsCount n: #{n} #{pluralENs n "allocation"} AllocationCourseHasRatings ratings vetos: This course already has #{ratings} #{pluralENs ratings "rating"} (#{vetos} #{pluralENs vetos "veto"}) + +AllocationCourseParticipantFormCourse: Course +AllocationCourseParticipantFormIsRegistered: Registered? +AllocationCourseParticipantFormIsSelfInflicted: Deregistration “self inflicted” (reason)? +AllocationCourseParticipantFormDefaultReason: No Reason + +AllocationUserCourseParticipantFormTitle: Course registrations +AllocationUserAllocationUserFormTitle: Participation in allocation diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 65924822d..b720355c6 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -513,7 +513,7 @@ unRenderMessage' cmp foundation inp = nub $ do unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] unRenderMessage = unRenderMessage' (==) -unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] +unRenderMessageLenient :: forall a master. (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] unRenderMessageLenient = unRenderMessage' cmp where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode) diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index bbd7da7db..8084da1be 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -110,8 +110,9 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions (prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of - (True , True , True , Nothing) - -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio) + (True , True , True , _) + | is _Nothing mApp || is _Nothing mcsrf + -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio) (True , True , True , Just _ ) -> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio (True , True , False, _ ) @@ -263,6 +264,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do if | BtnAllocationApply <- afAction , allowAction afAction + , is _Nothing maId || is _Just afPriority -> runDB . setSerializable $ do haveOld <- exists [ CourseApplicationCourse ==. cid , CourseApplicationUser ==. uid @@ -293,6 +295,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction , allowAction afAction , Just appId <- mAppId + , is _Nothing maId || is _Just afPriority -> runDB . setSerializable $ do now <- liftIO getCurrentTime diff --git a/src/Handler/Allocation/EditUser.hs b/src/Handler/Allocation/EditUser.hs index d6ee01a6e..a11230c14 100644 --- a/src/Handler/Allocation/EditUser.hs +++ b/src/Handler/Allocation/EditUser.hs @@ -17,36 +17,128 @@ import qualified Data.Conduit.Combinators as C import Handler.Utils.Delete import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import Handler.Course.Register (deregisterParticipant) + +import Jobs.Queue + + +data AllocationCourseParticipantFormDefaultReason = AllocationCourseParticipantFormDefaultReason + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +embedRenderMessage ''UniWorX ''AllocationCourseParticipantFormDefaultReason id getAEditUserR, postAEditUserR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDUser -> Handler Html getAEditUserR = postAEditUserR postAEditUserR tid ssh ash cID = do - (Entity _ Allocation{..}, User{..}, (editUserAct, editUserForm, editUserEnctype)) <- runDB $ do + (Entity _ Allocation{..}, User{..}, editUserAct, editUserForm, regFormForm, formEnctype) <- runDBJobs $ do uid <- decrypt cID user <- get404 uid alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash - Entity auId AllocationUser{..} <- getBy404 $ UniqueAllocationUser aId uid + Entity auId oldAllocationUser@AllocationUser{..} <- getBy404 $ UniqueAllocationUser aId uid - ((editUserRes, editUserForm), editUserEnctype) <- runFormPost . renderAForm FormStandard $ - allocationUserForm aId $ Just AllocationUserForm - { aauUser = uid - , aauTotalCourses = allocationUserTotalCourses - , aauPriority = allocationUserPriority - , aauApplications = Map.empty -- form collects existing applications itself - } + regState <- do + courses <- E.select . E.from $ \((course `E.InnerJoin` allocationCourse) `E.LeftOuterJoin` courseParticipant `E.LeftOuterJoin` allocationDeregister) -> do + E.on $ allocationDeregister E.?. AllocationDeregisterUser E.==. E.justVal uid + E.&&. E.joinV (allocationDeregister E.?. AllocationDeregisterCourse) E.==. E.just (allocationCourse E.^. AllocationCourseCourse) + E.on $ courseParticipant E.?. CourseParticipantUser E.==. E.justVal uid + E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (allocationCourse E.^. AllocationCourseCourse) + E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId + return ( course E.^. CourseId + , ( ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseShorthand + ) + , course E.^. CourseName + , ( ( E.joinV (courseParticipant E.?. CourseParticipantAllocated) E.==. E.justVal aId + E.||. E.isNothing (courseParticipant E.?. CourseParticipantId) + , courseParticipant E.?. CourseParticipantState + ) + , ( E.isJust $ allocationDeregister E.?. AllocationDeregisterId + , E.joinV $ allocationDeregister E.?. AllocationDeregisterReason + ) + ) + ) + ) + MsgRenderer mr <- getMsgRenderer + return $ + let toRegState (E.Value cId, (ident, E.Value cname, regState')) + = (cId, ((tid', ssh', csh), cname, courseRegState)) + where (E.Value tid', E.Value ssh', E.Value csh) = ident + ((E.Value isAlloc, E.Value mParState), (E.Value isDeregister, E.Value regReason)) = regState' + courseRegState + | not isAlloc = CourseParticipantFormNotAllocated + | isDeregister = CourseParticipantFormDeregistered + { cpfDeregisterReason = Just $ fromMaybe defReason regReason + , cpfEverRegistered = True + } + | mParState == Just CourseParticipantActive = CourseParticipantFormRegistered + | otherwise = CourseParticipantFormDeregistered + { cpfDeregisterReason = Nothing + , cpfEverRegistered = is _Just mParState + } + defReason = [st|<#{mr AllocationCourseParticipantFormDefaultReason}>|] + in Map.fromList $ map toRegState courses - editUserAct <- formResultMaybe editUserRes $ \AllocationUserForm{..} -> Just <$> do + ((formRes, (regFormForm, editUserForm)), formEnctype) <- runFormPost $ \csrf + -> let allocForm = renderAForm FormStandard $ + allocationUserForm aId $ Just AllocationUserForm + { aauUser = uid + , aauTotalCourses = allocationUserTotalCourses + , aauPriority = allocationUserPriority + , aauApplications = Map.empty -- form collects existing applications itself + } + in (\(regRes, regForm) (editUserRes, editUserForm) -> ((,) <$> regRes <*> editUserRes, (regForm, editUserForm))) <$> courseParticipantForm regState csrf <*> allocForm mempty + + editUserAct <- formResultMaybe formRes $ \(regState', AllocationUserForm{..}) -> Just <$> do now <- liftIO getCurrentTime - - replace auId AllocationUser - { allocationUserAllocation = aId - , allocationUserUser = aauUser - , allocationUserTotalCourses = aauTotalCourses - , allocationUserPriority = aauPriority - } - audit $ TransactionAllocationUserEdited aauUser aId + iforM_ (Map.intersectionWith (,) regState' regState) $ \cId (cpf, (_, _, oldCPF)) -> when (cpf /= oldCPF) $ case cpf of + CourseParticipantFormNotAllocated -> return () + CourseParticipantFormDeregistered mReason _ -> do + hoist liftHandler $ deregisterParticipant uid =<< getJustEntity cId + + app <- getYesod + let mReason' = mReason <&> \str -> maybe (Just str) (const Nothing) (listToMaybe $ unRenderMessageLenient @AllocationCourseParticipantFormDefaultReason app str) + deleteWhere [AllocationDeregisterUser ==. uid, AllocationDeregisterCourse ==. Just cId] + for_ mReason' $ \allocationDeregisterReason -> + insert AllocationDeregister + { allocationDeregisterCourse = Just cId + , allocationDeregisterTime = now + , allocationDeregisterUser = uid + , allocationDeregisterReason + } + CourseParticipantFormRegistered -> do + void $ upsert CourseParticipant + { courseParticipantCourse = cId + , courseParticipantUser = uid + , courseParticipantAllocated = Just aId + , courseParticipantState = CourseParticipantActive + , courseParticipantRegistration = now + } + [ CourseParticipantRegistration =. now + , CourseParticipantAllocated =. Just aId + , CourseParticipantState =. CourseParticipantActive + ] + audit $ TransactionCourseParticipantEdit cId uid + queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cId + + let newAllocationUser = AllocationUser + { allocationUserAllocation = aId + , allocationUserUser = aauUser + , allocationUserTotalCourses = aauTotalCourses + , allocationUserPriority = aauPriority + } + when (newAllocationUser /= oldAllocationUser) $ do + replace auId newAllocationUser + audit $ TransactionAllocationUserEdited aauUser aId + + -- Applications are complicated and it isn't easy to detect if something changed + -- Therefore we just always replace... oldApps <- selectList [CourseApplicationUser ==. aauUser, CourseApplicationAllocation ==. Just aId] [] forM_ oldApps $ \(Entity appId CourseApplication{..}) -> do deleteWhere [ CourseApplicationFileApplication ==. appId ] @@ -74,9 +166,9 @@ postAEditUserR tid ssh ash cID = do return $ do addMessageI Success MsgAllocationEditUserUserEdited - redirect $ AllocationR tid ssh ash AUsersR + redirect . AllocationR tid ssh ash $ AEditUserR cID - return (alloc, user, (editUserAct, editUserForm, editUserEnctype)) + return (alloc, user, editUserAct, editUserForm, regFormForm, formEnctype) sequence_ editUserAct @@ -86,10 +178,10 @@ postAEditUserR tid ssh ash cID = do siteLayoutMsg title $ do setTitleI shortTitle - wrapForm editUserForm FormSettings + wrapForm $(widgetFile "allocation/edit-user") FormSettings { formMethod = POST , formAction = Just . SomeRoute . AllocationR tid ssh ash $ AEditUserR cID - , formEncoding = editUserEnctype + , formEncoding = formEnctype , formAttrs = [] , formSubmit = FormSubmit , formAnchor = Nothing :: Maybe Text diff --git a/src/Handler/Allocation/UserForm.hs b/src/Handler/Allocation/UserForm.hs index 3e051e65a..8618f3458 100644 --- a/src/Handler/Allocation/UserForm.hs +++ b/src/Handler/Allocation/UserForm.hs @@ -1,6 +1,10 @@ module Handler.Allocation.UserForm ( AllocationUserForm(..) , allocationUserForm + , CourseParticipantForm(..) + , _CourseParticipantFormNotAllocated, _CourseParticipantFormDeregistered, _CourseParticipantFormRegistered, _cpfDeregisterReason, _cpfEverRegistered + , CourseParticipantForm' + , courseParticipantForm ) where import Import @@ -161,3 +165,63 @@ allocationApplicationsForm aId muid courses FieldSettings{..} fvRequired = form fvId <- maybe newIdent return fsId return (appsRes, pure FieldView{..}) + + +data CourseParticipantForm + = CourseParticipantFormNotAllocated -- ^ User is registered but not through allocation; no control + | CourseParticipantFormDeregistered -- ^ User is not currently registered + { cpfDeregisterReason :: Maybe Text -- ^ `Just` if user was deregistered "self-inflicted", reason is required + , cpfEverRegistered :: Bool + } + | CourseParticipantFormRegistered -- ^ User is currently registered + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +type CourseParticipantForm' = Map CourseId CourseParticipantForm + +makePrisms ''CourseParticipantForm +makeLenses_ ''CourseParticipantForm + +courseParticipantForm :: forall m. + ( MonadHandler m, HandlerSite m ~ UniWorX ) + => Map CourseId ((TermId, SchoolId, CourseShorthand), CourseName, CourseParticipantForm) + -> (Html -> MForm m (FormResult CourseParticipantForm', Widget)) +courseParticipantForm courses csrf = do + lines' <- iforM courses $ \_cId ((tid, ssh, csh), cname, prevSt) + -> let toLine fCell = $(widgetFile "allocation/user-course-participant-form/line") + in over _2 toLine <$> case prevSt of + CourseParticipantFormNotAllocated -> do + (_, isRegView) <- mforced checkBoxField def True + return ( FormSuccess CourseParticipantFormNotAllocated + , $(widgetFile "allocation/user-course-participant-form/not-allocated") + ) + _other -> do + let deregReason = prevSt ^? _cpfDeregisterReason . _Just + isRegPrev = is _CourseParticipantFormRegistered prevSt + everRegistered = fromMaybe True $ prevSt ^? _cpfEverRegistered + (isRegRes, isRegView) <- mpopt checkBoxField def $ Just isRegPrev + let selfInflictedFS = def + & addAttr "uw-interactive-fieldset" "" + & addAttr "data-conditional-input" (fvId isRegView) + & addAttr "data-conditional-negated" "" + (isSelfInflictedRes, isSelfInflictedView) <- if + | everRegistered -> over _2 Just <$> mopt (textField & cfStrip) selfInflictedFS (Just deregReason) + | otherwise -> return (FormSuccess Nothing, Nothing) + return ( case isRegRes of + FormMissing -> FormMissing + FormFailure es1 -> FormFailure $ es1 <> view _FormFailure isSelfInflictedRes + FormSuccess True + | FormFailure es2 <- isSelfInflictedRes + -> FormFailure es2 + | otherwise + -> FormSuccess CourseParticipantFormRegistered + FormSuccess False + -> CourseParticipantFormDeregistered <$> isSelfInflictedRes <*> pure everRegistered + , $(widgetFile "allocation/user-course-participant-form/cell") + ) + let linesWidget = Map.intersectionWith (,) courses lines' + & Map.elems + & sortBy (comparing . view $ _1 . _1) + & view (folded . _2 . _2) + return ( forM lines' $ view _1 + , $(widgetFile "allocation/user-course-participant-form/layout") + ) diff --git a/src/Handler/Course/Application/Edit.hs b/src/Handler/Course/Application/Edit.hs index b9b51cb1d..b2129ce37 100644 --- a/src/Handler/Course/Application/Edit.hs +++ b/src/Handler/Course/Application/Edit.hs @@ -22,9 +22,9 @@ postCAEditR tid ssh csh cID = do isAdmin <- case mAlloc of Just (Entity _ Allocation{..}) - -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR + -> hasWriteAccessTo $ AllocationR allocationTerm allocationSchool allocationShorthand AEditR Nothing - -> hasWriteAccessTo $ SchoolR courseSchool SchoolEditR + -> hasWriteAccessTo $ SchoolR courseSchool SchoolEditR let afmApplicant = uid == courseApplicationUser || isAdmin afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR mayEdit <- hasWriteAccessTo $ CApplicationR tid ssh csh cID CAEditR diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 951855d26..2bd19bc28 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -188,6 +188,7 @@ import Data.Bool.Instances as Import () import Data.Encoding.Instances as Import () import Prometheus.Instances as Import () import Yesod.Form.Fields.Instances as Import () +import Yesod.Form.Types.Instances as Import () import Data.MonoTraversable.Instances as Import () import Web.Cookie.Instances as Import () import Network.HTTP.Types.Method.Instances as Import () diff --git a/src/Yesod/Form/Types/Instances.hs b/src/Yesod/Form/Types/Instances.hs new file mode 100644 index 000000000..3a84d56c8 --- /dev/null +++ b/src/Yesod/Form/Types/Instances.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Yesod.Form.Types.Instances + () where + +import Yesod.Form.Types + +import Data.Default + + +instance Default (FieldSettings site) where + def = "" diff --git a/templates/allocation/edit-user.hamlet b/templates/allocation/edit-user.hamlet new file mode 100644 index 000000000..748abe67c --- /dev/null +++ b/templates/allocation/edit-user.hamlet @@ -0,0 +1,9 @@ +$newline never +
+

+ _{MsgAllocationUserCourseParticipantFormTitle} + ^{regFormForm} +
+

+ _{MsgAllocationUserAllocationUserFormTitle} + ^{editUserForm} diff --git a/templates/allocation/user-course-participant-form/cell.hamlet b/templates/allocation/user-course-participant-form/cell.hamlet new file mode 100644 index 000000000..e3b90825a --- /dev/null +++ b/templates/allocation/user-course-participant-form/cell.hamlet @@ -0,0 +1,8 @@ +$newline never + + ^{fvWidget isRegView} +$maybe siView <- isSelfInflictedView + + ^{fvWidget siView} +$nothing + diff --git a/templates/allocation/user-course-participant-form/layout.hamlet b/templates/allocation/user-course-participant-form/layout.hamlet new file mode 100644 index 000000000..e472546ff --- /dev/null +++ b/templates/allocation/user-course-participant-form/layout.hamlet @@ -0,0 +1,14 @@ +$newline never +#{csrf} +
+ + + + + ^{linesWidget} diff --git a/templates/allocation/user-course-participant-form/line.hamlet b/templates/allocation/user-course-participant-form/line.hamlet new file mode 100644 index 000000000..a8fce6fd6 --- /dev/null +++ b/templates/allocation/user-course-participant-form/line.hamlet @@ -0,0 +1,9 @@ +$newline never + +
+ _{MsgAllocationCourseParticipantFormCourse} + + _{MsgAllocationCourseParticipantFormIsRegistered} + + _{MsgAllocationCourseParticipantFormIsSelfInflicted} +
+ + #{toPathPiece tid}-#{ssh}-#{csh} + + + #{cname} + ^{fCell} diff --git a/templates/allocation/user-course-participant-form/not-allocated.hamlet b/templates/allocation/user-course-participant-form/not-allocated.hamlet new file mode 100644 index 000000000..48c750b82 --- /dev/null +++ b/templates/allocation/user-course-participant-form/not-allocated.hamlet @@ -0,0 +1,4 @@ +$newline never + + ^{fvWidget isRegView} +