Merge remote-tracking branch 'origin/master' into feat/jobs
This commit is contained in:
Gregor Kleen
commit
9a94e48d40
@ -5,6 +5,7 @@ BtnRegister: Anmelden
|
||||
BtnDeregister: Abmelden
|
||||
BtnHijack: Sitzung übernehmen
|
||||
|
||||
Aborted: Abgebrochen
|
||||
Registered: Angemeldet
|
||||
RegisterFrom: Anmeldungen von
|
||||
RegisterTo: Anmeldungen bis
|
||||
|
||||
4
models
4
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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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|
|
||||
<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,
|
||||
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.
|
||||
<div .container>
|
||||
<em>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.
|
||||
<div .container>^{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.
|
||||
<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")
|
||||
|
||||
@ -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 ]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user