Merge remote-tracking branch 'origin/master' into feat/jobs

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

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

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)
+    FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >>
-                        >> noTemplateAction
+                        noTemplateAction
-    FormSuccess (mbTid,mbSsh,mbCsh) ->
+    FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
-      getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh
+      uid <- requireAuthId
-
+      oldCourses <- runDB $ do
-getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
+        E.select $ E.from $ \course -> do
-getCourseNewTemplateR mbTid mbSsh mbCsh = do
+          whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
-  uid <- requireAuthId
+          whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
-  oldCourses <- runDB $ do
+          whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand  E.==. E.val csh
-    E.select $ E.from $ \course -> do
+          let lecturersCourse =
-      whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
+                E.exists $ E.from $ \lecturer -> do
-      whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
+                  E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
-      whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand  E.==. E.val csh
+                      E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-      let lecturersCourse =
+          let lecturersSchool =
-            E.exists $ E.from $ \lecturer -> do
+                E.exists $ E.from $ \user -> do
-              E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
+                  E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
-                  E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+                      E.&&.  user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
-      let lecturersSchool =
+          let courseCreated c =
-            E.exists $ E.from $ \user -> do
+                E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
-              E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
+                  E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
-                  E.&&.  user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
+                  return $ E.min_ $ edit E.^. CourseEditTime
-      let courseCreated c =
+          E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
-            E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
+                    , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
-              E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
+                    , E.desc $ courseCreated course]                                     -- most recent created course
-              return $ E.min_ $ edit E.^. CourseEditTime
+          E.limit 1
-      E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
+          return course
-                , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
+      template <- case listToMaybe oldCourses of
-                , E.desc $ courseCreated course]                                     -- most recent created course
+        (Just oldTemplate) ->
-      E.limit 1
+            let newTemplate = (courseToForm oldTemplate) in
-      return course
+            return $ Just $ newTemplate
-  template <- case listToMaybe oldCourses of
+                { cfCourseId   = Nothing
-    (Just oldTemplate) ->
+                , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
-        let newTemplate = (courseToForm oldTemplate) in
+                , cfRegFrom    = Nothing
-        return $ Just $ newTemplate
+                , cfRegTo      = Nothing
-            { cfCourseId   = Nothing
+                , cfDeRegUntil = Nothing
-            , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
+                }
-            , cfRegFrom    = Nothing
+        Nothing -> do
-            , cfRegTo      = Nothing
+            (tidOk,sshOk,cshOk) <- runDB $ (,,)
-            , cfDeRegUntil = Nothing
+                <$> ifMaybeM mbTid True existsKey
-            }
+                <*> ifMaybeM mbSsh True existsKey
-    Nothing -> do
+                <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
-        (tidOk,sshOk,cshOk) <- runDB $ (,,)
+            unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
-            <$> ifMaybeM mbTid True existsKey
+            unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
-            <*> ifMaybeM mbSsh True existsKey
+            unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
-            <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
+            when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
-        unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
+            return Nothing
-        unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
+      courseEditHandler True template
-        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
+    termsField <- liftHandlerT $ case template of
-          -- if allowed to delete course then allow current and all active term
+          -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
-          -- otherwise only keep current term
+          (Just cform)  | (Just cid) <- cfCourseId cform -> do -- edit existing course
-          (Just cform) | (Just _) <- cfCourseId cform -> termsSetField [cfTerm cform]
+              _courseOld@Course{..} <- runDB $ get404 cid
-          _allOtherCases -> termsActiveField
+              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)

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 BtnDelete) -> do
-    (FormSuccess BtnAbort ) -> addMessage Warning "Knopf Abort erkannt"
+      (uid, User{..}) <- requireAuthPair
-    _other -> addMessage Warning "KEIN Knopf erkannt"
+      addMessage Warning "Delete-Knopf gedrückt"
-  addMessage Error "Löschen der Daten wurde noch nicht implementiert."
+      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|
         <form .form-inline method=post action=@{ProfileDataR} enctype=#{btnEnctype}>
-          <h2>Sind Sie sich absolut sicher, alle gespeicherten Daten zu löschen?
+          <h2>
+            Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
           <div .container>
-              Abgegebene Hausaufgaben werden dadurch rückwirkend gelöscht,
+              Während der Testphase von Uni2work können Sie hiermit
-              wodurch eventuell ein Klausurbonus nicht mehr anerkannt wird.
+              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.
           <div .container>
-            <em>Gilt nicht in der Testphase von Uni2work:
+              Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht,
-            Klausurnoten können Sie hiermit nicht löschen.
+              wenn die Dateien ausschließlich Ihnen zugeordnet sind.
-            Da diese 5 Jahre bis nach Ihrer Exmatrikulation aufbewahrt werden müssen.
+              Dateien aus Gruppenabgaben werden also erst dann gelöscht,
-          <div .container>^{btnWdgt}
+              wenn alle Gruppenmitglieder Ihren Account gelöscht haben.
+          <div .container>
+              <em>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.)
+          <div .container>
+            <em>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.
+          <div .container>
+            ^{btnWdgt}
       |]
   defaultLayout $ do
     $(widgetFile "profileData")

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| <a href=@{url} .btn .#{bcc2txt cls} role=butt
 --   |]
   --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
 
-    {-
-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}
-            <div .btn-group>
-              $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 ]