multiple lecturers for course, no verification

.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 ++" }

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.

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" <>)

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
+          insertOkay <- runDB $ do
-            { courseName            = cfName     res
+            insertOkay <- insertUnique Course
-            , courseDescription     = cfDesc     res
+              { courseName            = cfName     res
-            , courseLinkExternal    = cfLink     res
+              , courseDescription     = cfDesc     res
-            , courseShorthand       = cfShort    res
+              , courseLinkExternal    = cfLink     res
-            , courseTerm            = cfTerm     res
+              , courseShorthand       = cfShort    res
-            , courseSchool          = cfSchool   res
+              , courseTerm            = cfTerm     res
-            , courseCapacity        = cfCapacity res
+              , courseSchool          = cfSchool   res
-            , courseRegisterSecret  = cfSecret   res
+              , courseCapacity        = cfCapacity res
-            , courseMaterialFree    = cfMatFree  res
+              , courseRegisterSecret  = cfSecret   res
-            , courseRegisterFrom    = cfRegFrom  res
+              , courseMaterialFree    = cfMatFree  res
-            , courseRegisterTo      = cfRegTo    res
+              , courseRegisterFrom    = cfRegFrom  res
-            , courseDeregisterUntil = cfDeRegUntil res
+              , courseRegisterTo      = cfRegTo    res
-            }
+              , courseDeregisterUntil = cfDeRegUntil res
-          case insertOkay of
+              }
-            (Just cid) -> do
+            whenIsJust insertOkay $ \cid -> do
-              runDB $ 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 Course -> [Lecturer] -> CourseForm
-courseToForm (Entity cid Course{..}) = 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
+    uid <- liftHandlerT requireAuthId
-      userId <- liftHandlerT requireAuthId
+    (lecSchools, admSchools) <- liftHandlerT . runDB $ (,)
-      (fmap concat . sequence)
+      <$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
-        [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
+      <*> (map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. uid] [] )
-        , map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. userId] []
+    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