diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 09a7067c1..afbffb76e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -5,6 +5,7 @@ BtnRegister: Anmelden BtnDeregister: Abmelden BtnHijack: Sitzung übernehmen +Aborted: Abgebrochen Registered: Angemeldet RegisterFrom: Anmeldungen von RegisterTo: Anmeldungen bis diff --git a/models b/models index c4dca6cac..cb599b025 100644 --- a/models +++ b/models @@ -152,7 +152,7 @@ SubmissionFile isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector UniqueSubmissionFile file submission isUpdate deriving Show -SubmissionUser +SubmissionUser -- Actual submission participant user UserId submission SubmissionId UniqueSubmissionUser user submission @@ -163,7 +163,7 @@ SubmissionGroupEdit user UserId time UTCTime submissionGroup SubmissionGroupId -SubmissionGroupUser +SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser submissionGroup SubmissionGroupId user UserId UniqueSubmissionGroupUser submissionGroup user diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5e09e2b7e..044f9b391 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -15,7 +15,7 @@ module Handler.Course where -import Import +import Import hiding (catMaybes) import Control.Lens import Utils.Lens @@ -33,6 +33,9 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.CaseInsensitive as CI + + import Colonnade hiding (fromMaybe,bool) -- import Yesod.Colonnade @@ -317,6 +320,14 @@ postCRegisterR tid ssh csh = do (_other) -> return () -- TODO check this! redirect $ CourseR tid ssh csh CShowR + +getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html +getCourseNewTemplateR mbTid mbSsh mbCsh = + redirect (CourseNewR, catMaybes [ ("tid",).termToText.unTermKey <$> mbTid + , ("ssh",).CI.original.unSchoolKey <$> mbSsh + , ("csh",).CI.original <$> mbCsh + ]) + getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do uid <- requireAuthId @@ -325,59 +336,55 @@ getCourseNewR = do <*> iopt ciField "ssh" <*> iopt ciField "csh" let noTemplateAction = courseEditHandler True Nothing - case params of + case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more! FormMissing -> noTemplateAction - FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) - >> noTemplateAction - FormSuccess (mbTid,mbSsh,mbCsh) -> - getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh - -getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html -getCourseNewTemplateR mbTid mbSsh mbCsh = do - uid <- requireAuthId - oldCourses <- runDB $ do - E.select $ E.from $ \course -> do - whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid - whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh - whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh - let lecturersCourse = - E.exists $ E.from $ \lecturer -> do - E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid - E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - let lecturersSchool = - E.exists $ E.from $ \user -> do - E.where_ $ user E.^. UserLecturerUser E.==. E.val uid - E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool - let courseCreated c = - E.sub_select . E.from $ \edit -> do -- oldest edit must be creation - E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId - return $ E.min_ $ edit E.^. CourseEditTime - E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer - , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer - , E.desc $ courseCreated course] -- most recent created course - E.limit 1 - return course - template <- case listToMaybe oldCourses of - (Just oldTemplate) -> - let newTemplate = (courseToForm oldTemplate) in - return $ Just $ newTemplate - { cfCourseId = Nothing - , cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness - , cfRegFrom = Nothing - , cfRegTo = Nothing - , cfDeRegUntil = Nothing - } - Nothing -> do - (tidOk,sshOk,cshOk) <- runDB $ (,,) - <$> ifMaybeM mbTid True existsKey - <*> ifMaybeM mbSsh True existsKey - <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) - unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise - unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise - unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh - when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse - return Nothing - courseEditHandler True template + FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >> + noTemplateAction + FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do + uid <- requireAuthId + oldCourses <- runDB $ do + E.select $ E.from $ \course -> do + whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid + whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh + whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh + let lecturersCourse = + E.exists $ E.from $ \lecturer -> do + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId + let lecturersSchool = + E.exists $ E.from $ \user -> do + E.where_ $ user E.^. UserLecturerUser E.==. E.val uid + E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool + let courseCreated c = + E.sub_select . E.from $ \edit -> do -- oldest edit must be creation + E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId + return $ E.min_ $ edit E.^. CourseEditTime + E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer + , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer + , E.desc $ courseCreated course] -- most recent created course + E.limit 1 + return course + template <- case listToMaybe oldCourses of + (Just oldTemplate) -> + let newTemplate = (courseToForm oldTemplate) in + return $ Just $ newTemplate + { cfCourseId = Nothing + , cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness + , cfRegFrom = Nothing + , cfRegTo = Nothing + , cfDeRegUntil = Nothing + } + Nothing -> do + (tidOk,sshOk,cshOk) <- runDB $ (,,) + <$> ifMaybeM mbTid True existsKey + <*> ifMaybeM mbSsh True existsKey + <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) + unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise + unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise + unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh + when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse + return Nothing + courseEditHandler True template postCourseNewR :: Handler Html postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course. @@ -532,12 +539,17 @@ newCourseForm template = identForm FIDcourse $ \html -> do [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] [] , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] [] ] - let termsField = case template of - --TODO: if Admin, then all - -- if allowed to delete course then allow current and all active term - -- otherwise only keep current term - (Just cform) | (Just _) <- cfCourseId cform -> termsSetField [cfTerm cform] - _allOtherCases -> termsActiveField + + termsField <- liftHandlerT $ case template of + -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin + (Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course + _courseOld@Course{..} <- runDB $ get404 cid + mayEditTerm <- isAuthorized TermEditR True + mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True + return $ if + | (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField + | otherwise -> termsSetField [cfTerm cform] + _allOtherCases -> return termsAllowedField (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm <$> pure (cfCourseId =<< template) <*> areq ciField (fslI MsgCourseName) (cfName <$> template) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 3761df6af..55092ff11 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -159,15 +159,24 @@ postProfileR = do postProfileDataR :: Handler Html postProfileDataR = do - (uid, User{..}) <- requireAuthPair ((btnResult,_), _) <- runFormPost $ buttonForm case btnResult of - (FormSuccess BtnDelete) -> addMessage Warning "Delete-Knopf gedrückt" - (FormSuccess BtnAbort ) -> addMessage Warning "Knopf Abort erkannt" - _other -> addMessage Warning "KEIN Knopf erkannt" - addMessage Error "Löschen der Daten wurde noch nicht implementiert." + (FormSuccess BtnDelete) -> do + (uid, User{..}) <- requireAuthPair + addMessage Warning "Delete-Knopf gedrückt" + addMessage Error "Löschen der Daten wurde noch nicht implementiert." + -- first determine all submission that solely depend on this user: + -- SubmissionGroup / SubmissionGroupUser + -- Submission / SubmissionUser + -- runDB $ deleteCascade uid + (FormSuccess BtnAbort ) -> do + addMessageI Info MsgAborted + redirect ProfileDataR + _other -> return () getProfileDataR + + getProfileDataR :: Handler Html getProfileDataR = do (uid, User{..}) <- requireAuthPair @@ -193,15 +202,32 @@ getProfileDataR = do -- TODO: move this into a Message and/or Widget-File let delWdgt = [whamlet|
-

Sind Sie sich absolut sicher, alle gespeicherten Daten zu löschen? +

+ Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
- Abgegebene Hausaufgaben werden dadurch rückwirkend gelöscht, - wodurch eventuell ein Klausurbonus nicht mehr anerkannt wird. + Während der Testphase von Uni2work können Sie hiermit + Ihren Account bei Uni2work vollständig löschen. + Mit Ihrem Campus-Account können Sie sich aber danach + jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
- Gilt nicht in der Testphase von Uni2work: - Klausurnoten können Sie hiermit nicht löschen. - Da diese 5 Jahre bis nach Ihrer Exmatrikulation aufbewahrt werden müssen. -
^{btnWdgt} + Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht, + wenn die Dateien ausschließlich Ihnen zugeordnet sind. + Dateien aus Gruppenabgaben werden also erst dann gelöscht, + wenn alle Gruppenmitglieder Ihren Account gelöscht haben. +
+ Achtung: + Auch abgegebene Hausübungen werden gelöscht! + Falls ein Veranstalter Informationen darüber nicht anderweitig gespeichert hat, + kann dadurch ein etwaiger Hausaufgabenbonus verloren gehen. + (Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen + Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann + auch nicht mehr rekonstruiert/berücksichtigt werden.) +
+ Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas + eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation + aufbewahrt werden müssen. +
+ ^{btnWdgt} |] defaultLayout $ do $(widgetFile "profileData") diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 7eab2aefc..1061f4256 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} @@ -124,40 +125,9 @@ linkButton lbl cls url = [whamlet| - {- -combinedButtonField :: Button a => [a] -> Form m -> Form (a,m) -combinedButtonField btns inner csrf = do - buttonIdent <- newFormIdent - let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing - (results, btnViews) <- unzip <$> mapM button [minBound..maxBound] - (innerRes,innerWdgt) <- inner - let widget = do - [whamlet| - #{csrf} - ^{innerWdgt} -
- $forall bView <- btnViews - ^{fvInput bView} - |] - let result = case (accResult result, innerRes) of - (FormSuccess b, FormSuccess i) -> FormSuccess (b,i) - _ -> FormFailure ["Something went wrong"] -- TODO - return (result,widget) - where - accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a - accResult = Foldable.foldr accResult' FormMissing - - accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a - accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"] - accResult' (FormSuccess (Just x)) _ = FormSuccess x - accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success? - accResult' (FormSuccess Nothing) x = x - accResult' FormMissing _ = FormMissing - accResult' (FormFailure errs) _ = FormFailure errs - -} -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ())) -buttonForm :: (Button UniWorX a) => Form a +buttonForm :: (Button UniWorX a, Show a) => Form a buttonForm csrf = do buttonIdent <- newFormIdent let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing @@ -174,9 +144,10 @@ buttonForm csrf = do accResult = Foldable.foldr accResult' FormMissing accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a + -- Find the single FormSuccess Just _; Expected behaviour: all buttons deliver FormFailure, except for one. accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"] accResult' (FormSuccess (Just x)) _ = FormSuccess x - accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success? + accResult' _ x@(FormSuccess _) = x --Safe: most buttons deliver FormFailure, one delivers FormSuccess accResult' (FormSuccess Nothing) x = x accResult' FormMissing _ = FormMissing accResult' (FormFailure errs) _ = FormFailure errs @@ -221,6 +192,13 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} termsActiveField :: Field Handler TermId termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName +termsAllowedField :: Field Handler TermId +termsAllowedField = selectField $ do + mayEditTerm <- isAuthorized TermEditR True + let termFilter | Authorized <- mayEditTerm = [] + | otherwise = [TermActive ==. True] + optionsPersistKey termFilter [Desc TermStart] termName + termsSetField :: [TermId] -> Field Handler TermId termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName -- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]