multiple lecturers for course, no verification
This commit is contained in:
Steffen Jost
parent
6a5437ce72
commit
31f635793d
@ -4,6 +4,7 @@
|
||||
|
||||
- ignore: { name: "Parse error" }
|
||||
- ignore: { name: "Reduce duplication" }
|
||||
- ignore: { name: "Redundant lambda" }
|
||||
- ignore: { name: "Use ||" }
|
||||
- ignore: { name: "Use &&" }
|
||||
- ignore: { name: "Use ++" }
|
||||
|
||||
@ -100,7 +100,9 @@ CourseUserNote: Notiz
|
||||
CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar
|
||||
CourseUserNoteSaved: Notizänderungen gespeichert
|
||||
CourseUserNoteDeleted: Teilnehmernotiz gelöscht
|
||||
|
||||
CourseLecturers: Kursverwalter
|
||||
CourseLecturer: Dozent
|
||||
CourseAssistant: Assistent
|
||||
|
||||
NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
|
||||
NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
|
||||
|
||||
@ -239,6 +239,7 @@ embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
|
||||
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
|
||||
embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
|
||||
embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
|
||||
embedRenderMessage ''UniWorX ''LecturerType id
|
||||
|
||||
newtype SheetTypeHeader = SheetTypeHeader SheetType
|
||||
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
|
||||
|
||||
@ -9,6 +9,7 @@ import Utils.Form
|
||||
-- import Utils.DB
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Course
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Database
|
||||
import Handler.Utils.Table.Cells
|
||||
@ -17,7 +18,7 @@ import Database.Esqueleto.Utils
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
-- import Data.Time
|
||||
-- import qualified Data.Text as T
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Function ((&))
|
||||
-- import Yesod.Form.Bootstrap3
|
||||
|
||||
@ -403,7 +404,7 @@ getCourseNewR = do
|
||||
return course
|
||||
template <- case listToMaybe oldCourses of
|
||||
(Just oldTemplate) ->
|
||||
let newTemplate = courseToForm oldTemplate in
|
||||
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
|
||||
@ -432,10 +433,13 @@ postCEditR = pgCEditR
|
||||
|
||||
pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
pgCEditR tid ssh csh = do
|
||||
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
|
||||
courseLecs <- runDB $ do
|
||||
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
|
||||
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
|
||||
return $ (,) <$> mbCourse <*> mbLecs
|
||||
-- IMPORTANT: both GET and POST Handler must use the same template,
|
||||
-- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
|
||||
courseEditHandler $ courseToForm <$> course
|
||||
courseEditHandler $ uncurry courseToForm <$> courseLecs
|
||||
|
||||
|
||||
getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
@ -463,25 +467,27 @@ courseEditHandler mbCourseForm = do
|
||||
, cfTerm = tid
|
||||
}) -> do -- create new course
|
||||
now <- liftIO getCurrentTime
|
||||
insertOkay <- runDB $ insertUnique Course
|
||||
{ courseName = cfName res
|
||||
, courseDescription = cfDesc res
|
||||
, courseLinkExternal = cfLink res
|
||||
, courseShorthand = cfShort res
|
||||
, courseTerm = cfTerm res
|
||||
, courseSchool = cfSchool res
|
||||
, courseCapacity = cfCapacity res
|
||||
, courseRegisterSecret = cfSecret res
|
||||
, courseMaterialFree = cfMatFree res
|
||||
, courseRegisterFrom = cfRegFrom res
|
||||
, courseRegisterTo = cfRegTo res
|
||||
, courseDeregisterUntil = cfDeRegUntil res
|
||||
}
|
||||
case insertOkay of
|
||||
(Just cid) -> do
|
||||
runDB $ do
|
||||
insertOkay <- runDB $ do
|
||||
insertOkay <- insertUnique Course
|
||||
{ courseName = cfName res
|
||||
, courseDescription = cfDesc res
|
||||
, courseLinkExternal = cfLink res
|
||||
, courseShorthand = cfShort res
|
||||
, courseTerm = cfTerm res
|
||||
, courseSchool = cfSchool res
|
||||
, courseCapacity = cfCapacity res
|
||||
, courseRegisterSecret = cfSecret res
|
||||
, courseMaterialFree = cfMatFree res
|
||||
, courseRegisterFrom = cfRegFrom res
|
||||
, courseRegisterTo = cfRegTo res
|
||||
, courseDeregisterUntil = cfDeRegUntil res
|
||||
}
|
||||
whenIsJust insertOkay $ \cid -> do
|
||||
forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty)
|
||||
insert_ $ CourseEdit aid now cid
|
||||
insert_ $ Lecturer aid cid CourseLecturer
|
||||
return insertOkay
|
||||
case insertOkay of
|
||||
Just _ -> do
|
||||
addMessageI Info $ MsgCourseNewOk tid ssh csh
|
||||
redirect $ TermCourseListR tid
|
||||
Nothing ->
|
||||
@ -517,6 +523,8 @@ courseEditHandler mbCourseForm = do
|
||||
case updOkay of
|
||||
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
|
||||
Nothing -> do
|
||||
deleteWhere [LecturerCourse ==. cid]
|
||||
forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty)
|
||||
insert_ $ CourseEdit aid now cid
|
||||
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
||||
return True
|
||||
@ -547,10 +555,11 @@ data CourseForm = CourseForm
|
||||
, cfRegFrom :: Maybe UTCTime
|
||||
, cfRegTo :: Maybe UTCTime
|
||||
, cfDeRegUntil :: Maybe UTCTime
|
||||
, cfLecturers :: [(UserId, LecturerType)]
|
||||
}
|
||||
|
||||
courseToForm :: Entity Course -> CourseForm
|
||||
courseToForm (Entity cid Course{..}) = CourseForm
|
||||
courseToForm :: Entity Course -> [Lecturer] -> CourseForm
|
||||
courseToForm (Entity cid Course{..}) lecs = CourseForm
|
||||
{ cfCourseId = Just cid
|
||||
, cfName = courseName
|
||||
, cfDesc = courseDescription
|
||||
@ -564,6 +573,7 @@ courseToForm (Entity cid Course{..}) = CourseForm
|
||||
, cfRegFrom = courseRegisterFrom
|
||||
, cfRegTo = courseRegisterTo
|
||||
, cfDeRegUntil = courseDeregisterUntil
|
||||
, cfLecturers = [(lecturerUser, lecturerType) | Lecturer{..} <- lecs]
|
||||
}
|
||||
|
||||
makeCourseForm :: Maybe CourseForm -> Form CourseForm
|
||||
@ -573,12 +583,11 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do
|
||||
|
||||
mr <- liftHandlerT getMessageRender -- needed for translation of placeholders
|
||||
|
||||
userSchools <- liftHandlerT . runDB $ do
|
||||
userId <- liftHandlerT requireAuthId
|
||||
(fmap concat . sequence)
|
||||
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
|
||||
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
|
||||
]
|
||||
uid <- liftHandlerT requireAuthId
|
||||
(lecSchools, admSchools) <- liftHandlerT . runDB $ (,)
|
||||
<$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
|
||||
<*> (map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] )
|
||||
let userSchools = lecSchools ++ admSchools
|
||||
|
||||
termsField <- case template of
|
||||
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
|
||||
@ -591,6 +600,49 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do
|
||||
| otherwise -> termsSetField [cfTerm cform]
|
||||
_allOtherCases -> return termsAllowedField
|
||||
|
||||
let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (ListLength -> (ListPosition, UserId)))
|
||||
miAdd _ _ nudge btn = Just $ \csrf -> do
|
||||
(addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
|
||||
addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
|
||||
addRes'' <- case (,) <$> addRes <*> addRes' of
|
||||
FormSuccess (email, Nothing) -> formFailure [ MsgEMailUnknown $ CI.mk email ]
|
||||
FormSuccess (_,Just lid) -> return $ FormSuccess lid
|
||||
FormFailure errs -> return $ FormFailure errs
|
||||
FormMissing -> return FormMissing
|
||||
let addRes''' = (\dat l -> (fromIntegral l, dat)) <$> addRes''
|
||||
addView' = toWidget csrf >> fvInput addView >> fvInput btn
|
||||
return (addRes''', addView')
|
||||
|
||||
miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType
|
||||
miCell _ lid defType nudge = \csrf -> do
|
||||
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
|
||||
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
|
||||
let lrwView' = [whamlet|$newline never
|
||||
#{csrf}
|
||||
^{nameEmailWidget userEmail userDisplayName userSurname} #
|
||||
^{fvInput lrwView}
|
||||
|]
|
||||
return (lrwRes,lrwView')
|
||||
|
||||
miDelete :: ListLength -- ^ Current shape
|
||||
-> ListPosition -- ^ Coordinate to delete
|
||||
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
|
||||
miDelete l pos
|
||||
| l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
|
||||
| otherwise = return Map.empty
|
||||
|
||||
miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
||||
miAllowAdd _ _ _ = True
|
||||
|
||||
|
||||
lecturerForm :: AForm Handler [(UserId,LecturerType)]
|
||||
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput
|
||||
MassInput{..}
|
||||
(fslI MsgCourseLecturers)
|
||||
True
|
||||
(Just . Map.fromList . zip [0..] $ maybe [(uid, CourseLecturer)] cfLecturers template)
|
||||
mempty
|
||||
|
||||
(newRegFrom,newRegTo,newDeRegUntil) <- case template of
|
||||
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
|
||||
_allIOtherCases -> do
|
||||
@ -622,7 +674,7 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do
|
||||
& setTooltip MsgCourseRegisterToTip) (deepAlt (cfRegTo <$> template) newRegTo)
|
||||
<*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate)
|
||||
& setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
|
||||
<* submitButton
|
||||
<*> lecturerForm
|
||||
return $ case result of
|
||||
FormSuccess courseResult
|
||||
| errorMsgs <- validateCourse courseResult
|
||||
|
||||
Loading…
Reference in New Issue
Block a user