From 31f635793dbf06d0d174c8dc5b505e2e3c32c86c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 25 Mar 2019 15:38:03 +0100 Subject: [PATCH] multiple lecturers for course, no verification --- .hlint.yaml | 1 + messages/uniworx/de.msg | 4 +- src/Foundation.hs | 1 + src/Handler/Course.hs | 114 +++++++++++++++++++++++++++++----------- 4 files changed, 88 insertions(+), 32 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index ecd17c599..6b2cec643 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -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 ++" } diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1b678fda3..8448ea1e2 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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. diff --git a/src/Foundation.hs b/src/Foundation.hs index 60fb249f1..2ddbc118b 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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" <>) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b309da93b..e707c8cd1 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -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