{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Course where

import Import

import Utils.Lens
import Utils.Form
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Tutorial
import Handler.Utils.Communication
import Handler.Utils.Form.MassInput
import Handler.Utils.Delete
import Handler.Utils.Database
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Handler.Utils.Invitations
import Database.Persist.Sql (deleteWhereCount)
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH

-- import Data.Time
import qualified Data.CaseInsensitive as CI
import Data.Function ((&))
-- import Yesod.Form.Bootstrap3

import Data.Maybe (fromJust)
import qualified Data.Set as Set
import Data.Map ((!))
import qualified Data.Map as Map

import qualified Database.Esqueleto as E

import Text.Blaze.Html.Renderer.Text (renderHtml)

import Jobs.Queue

import Data.Aeson hiding (Result(..))

import Text.Hamlet (ihamlet)

import Control.Monad.Trans.Writer (WriterT, execWriterT)
import Control.Monad.Except (MonadError(..))

import Generics.Deriving.Monoid (memptydefault, mappenddefault)


-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)

colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
              [whamlet|#{display courseName}|]

-- colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
-- colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
--     course <- view $ _dbrOutput . _1 . _entityVal
--     return $ courseCell course

colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colDescription = sortable Nothing mempty
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            case courseDescription of
              Nothing      -> mempty
              (Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)

colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]

-- colCShortDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
-- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
--           $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend
--             ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
--             ( case courseDescription of
--                 Nothing      -> mempty
--                 (Just descr) -> cell
--                   [whamlet|
--                     $newline never
--                     <div>
--                       ^{modal "Beschreibung" (Right $ toWidget descr)}
--                   |]
--             )

colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]

colSchool :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]

colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]

colRegFrom :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            maybe mempty dateTimeCell courseRegisterFrom
            -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget

colRegTo :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
            maybe mempty dateTimeCell courseRegisterTo

colMembers :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colMembers = sortable (Just "members") (i18nCell MsgCourseMembers)
          $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
              Nothing -> MsgCourseMembersCount currentParticipants
              Just limit -> MsgCourseMembersCountLimited currentParticipants limit

colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
          $ \DBRow{ dbrOutput=(_, _, registered, _) } -> tickmarkCell registered

type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)

course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
    E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
    return (E.countRows :: E.SqlExpr (E.Value Int))

course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
    E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
      E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid

makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
makeCourseTable whereClause colChoices psValidator = do
  muid <- lift maybeAuthId
  let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
      dbtSQLQuery qin@(course `E.InnerJoin` school) = do
        E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
        let participants = course2Participants qin
        let registered   = course2Registered muid qin
        E.where_ $ whereClause (course, participants, registered)
        return (course, participants, registered, school)
      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
      dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
  snd <$> dbTable psValidator DBTable
    { dbtSQLQuery
    , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
    , dbtColonnade = colChoices
    , dbtProj
    , dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
        [ ( "course",        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName)
        , ( "cshort",        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand)
        , ( "term"  ,        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm)
        , ( "school",        SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName)
        , ( "schoolshort",   SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
        , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
        , ( "register-to",   SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
        , ( "members",       SortColumn   course2Participants   )
        , ( "registered",    SortColumn $ course2Registered muid)
        ]
    , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
        [ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if
                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise          -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
          )
        , ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise          -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
          )
        , ( "term"  , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise          -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
          )
--         , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
--                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
--                 | otherwise          -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
--           )
        , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) ->
              emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?!
          )
        , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise          -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
          )
        , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
              Just needle -> course2Registered muid tExpr E.==. E.val needle
          )
        , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of
              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
              Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
                       E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
                       E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
          )
        ]
    , dbtFilterUI = \mPrev -> mconcat $ catMaybes
      [ Just  $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgCourseFilterSearch)
      , muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered))
      ]
    , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
    , dbtParams = def
    , dbtIdent = "courses" :: Text
    }

getCourseListR :: Handler Html
getCourseListR = do
  muid <- maybeAuthId
  let colonnade = widgetColonnade $ mconcat
        [ colCourse -- colCourseDescr
        , colDescription
        , colSchoolShort
        , colTerm
        , colCShort
        , maybe mempty (const colRegistered) muid
        ]
      whereClause = const $ E.val True
      validator = def
        & defaultSorting [SortDescBy "term",SortAscBy "course"]
  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
  defaultLayout $ do
    setTitleI MsgCourseListTitle
    $(widgetFile "courses")

getTermCurrentR :: Handler Html
getTermCurrentR = do
  termIds  <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName]
  case fromNullable termIds of
    Nothing -> notFound
    (Just (maximum -> tid)) ->
        redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc.

getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
getTermSchoolCourseListR tid ssh = do
  void . runDB $ get404 tid -- Just ensure the term exists
  School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists
  muid <- maybeAuthId
  let colonnade = widgetColonnade $ mconcat
        [ dbRow
        , colCShort
        , colDescription
        , colRegFrom
        , colRegTo
        , colMembers
        , maybe mempty (const colRegistered) muid
        ]
      whereClause (course, _, _) =
              course E.^. CourseTerm   E.==. E.val tid
        E.&&. course E.^. CourseSchool E.==. E.val ssh
      validator = def
        & defaultSorting [SortAscBy "cshort"]
  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
  defaultLayout $ do
    setTitleI $ MsgTermSchoolCourseListTitle tid school
    $(widgetFile "courses")


getTermCourseListR :: TermId -> Handler Html
getTermCourseListR tid = do
  void . runDB $ get404 tid -- Just ensure the term exists
  muid <- maybeAuthId
  let colonnade = widgetColonnade $ mconcat
        [ dbRow
        , colCShort
        , colDescription
        , colSchoolShort
        , colRegFrom
        , colRegTo
        , colMembers
        , maybe mempty (const colRegistered) muid
        ]
      whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
      validator = def
        & defaultSorting [SortAscBy "cshort"]
  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
  defaultLayout $ do
    setTitleI . MsgTermCourseListTitle $ tid
    $(widgetFile "courses")

getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
  mbAid <- maybeAuthId
  (cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors) <- runDB . maybeT notFound $ do
    [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
       <- lift . E.select . E.from $
         \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
            E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
                E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser
            E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
            E.where_ $ course E.^. CourseTerm      E.==. E.val tid
                 E.&&. course E.^. CourseSchool    E.==. E.val ssh
                 E.&&. course E.^. CourseShorthand E.==. E.val csh
            E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
            let numParticipants = E.sub_select . E.from $ \part -> do
                  E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
                  return ( E.countRows :: E.SqlExpr (E.Value Int))
            return (course,school E.^. SchoolName, numParticipants, participant)
    defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion
    staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
      E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
      E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
      E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
      return ( lecturer E.^. LecturerType
             , user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
    let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text)
        partStaff (CourseLecturer  ,name,surn,mail) = Right (name,surn,mail)
        partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail)
        (assistants,lecturers) = partitionWith  partStaff $ map $(unValueN 4) staff
    correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
      E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
      E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
      E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
      return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
    tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
      E.on $ tutor E.^. TutorUser     E.==. user E.^. UserId
      E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
      E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
      E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
      return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
    return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors)

  mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom    course
  mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo      course
  mDereg   <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
  mRegAt   <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
  (regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration defSFid $ courseRegisterSecret course
  let regForm = wrapForm regWidget def
        { formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR
        , formEncoding = regEnctype
        , formSubmit = FormNoSubmit
        }
  registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True

  let
    tutorialDBTable = DBTable{..}
      where
        dbtSQLQuery tutorial = do
          E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
          return tutorial
        dbtRowKey = (E.^. TutorialId)
        dbtProj = return
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType
          , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
          , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do
              tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
                E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
                E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
                return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
              return [whamlet|
                       $newline never
                       <ul .list--iconless .list--inline .list--comma-separated>
                         $forall tutor <- tutTutors
                           <li>
                             ^{nameEmailWidget' tutor}
                     |]
          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom
          , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurencesCell tutorialTime
          , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom
          , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo
          , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil
          , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of
              Nothing -> mempty
              Just tutorialCapacity' -> sqlCell $ do
                [E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
                                                           E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
                                                           return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
                                                      in return $ E.val tutorialCapacity' E.-. numParticipants
                return . toWidget . tshow $ max 0 freeCapacity
          , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
              mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
              isRegistered <- case mbAid of
                Nothing  -> return False
                Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
              if
                | mayRegister -> do
                    (tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
                    return $ wrapForm tutRegisterForm def
                      { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
                      , formEncoding = tutRegisterEnctype
                      , formSubmit = FormNoSubmit
                      }
                | isRegistered -> return [whamlet|_{MsgTutorialRegistered}|]
                | otherwise -> return mempty
          ]
        dbtSorting = Map.fromList
          [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
          , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
          , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
          , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
          , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
          , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
          ]
        dbtFilter = Map.empty
        dbtFilterUI = const mempty
        dbtStyle = def
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "tutorials"

    tutorialDBTableValidator = def
      & defaultSorting [SortAscBy "type", SortAscBy "name"]
  (Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable

  siteLayout (toWgt $ courseName course) $ do
    setTitleI $ prependCourseTitle tid ssh csh (""::Text)
    $(widgetFile "course")

-- | Registration button with maybe a userid if logged in
-- , maybe existing features if already registered
-- , maybe some default study features
-- , maybe a course secret
registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
-- unfinished WIP: must take study features if registred and show as mforced field
registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do
    -- secret fields
    (msecretRes', msecretView) <- case msecret of
      (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
      _ -> return (Nothing,Nothing)
    -- study features
    (msfRes', msfView) <- case loggedin of
      Nothing -> return (Nothing,Nothing)
      Just _  -> bimap Just Just <$> case participant of
        Just CourseParticipant{courseParticipantField=Just sfid}
                -> mforced (studyFeaturesPrimaryFieldFor False [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
        _other  -> mreq    (studyFeaturesPrimaryFieldFor False [ ]    loggedin) (fslI MsgCourseStudyFeature
                                                                 & setTooltip  MsgCourseStudyFeatureTooltip) (Just defSFid)
    -- button de-/register
    (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing

    let widget = $(widgetFile "widgets/register-form/register-form")
    let msecretRes | Just res <- msecretRes' = Just <$> res
                   | otherwise               = FormSuccess Nothing
    let msfRes     | Just res <- msfRes'     = res
                   | otherwise               = FormSuccess Nothing
    -- checks that correct button was pressed, and ignores result of btnRes
    let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes)
    return (formRes, widget)
  where
    isRegistered = isJust participant


-- | Workaround for klicking register button without being logged in.
-- After log in, the user sees a "get request not supported" error.
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCRegisterR tid ssh csh = do
  muid <- maybeAuthId
  case muid of
    Nothing -> addMessageI Info MsgLoginNecessary
    (Just uid) -> runDB $ do
      cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
      registration <- getBy (UniqueParticipant uid cid)
      when (isNothing registration) $ addMessageI Warning MsgRegisterRetry
  redirect $ CourseR tid ssh csh CShowR

postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do
  aid <- requireAuthId
  (cid, course, registration) <- runDB $ do
      (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
      registration <- getBy (UniqueParticipant aid cid)
      return (cid, course, entityVal <$> registration)
  let isRegistered  = isJust registration
  ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration Nothing $ courseRegisterSecret course
  formResult regResult $ \(mbSfId,codeOk) -> if
      | isRegistered -> do
          runDB $ deleteBy $ UniqueParticipant aid cid
          addMessageI Info MsgCourseDeregisterOk
      | codeOk -> do
          actTime <- liftIO getCurrentTime
          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
          when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
      | otherwise -> addMessageI Warning MsgCourseSecretWrong
  -- addMessage Info $ toHtml $ show regResult -- For debugging only
  redirect $ CourseR tid ssh csh CShowR


getCourseNewR :: Handler Html -- call via toTextUrl
getCourseNewR = do
  uid <- requireAuthId
  params <- runInputGetResult $ (,,)    --TODO: change to AForm, which is used in Course-Copy-Button
            <$> iopt termNewField "tid"
            <*> iopt ciField      "ssh"
            <*> iopt ciField      "csh"

  let courseEditHandler' = courseEditHandler $ \p -> Just . SomeRoute $ (CourseNewR, getParams) :#: p
      getParams = concat
        [ [ ("tid", toPathPiece tid) | FormSuccess (Just tid, _, _) <- [params] ]
        , [ ("ssh", toPathPiece ssh) | FormSuccess (_, Just ssh, _) <- [params] ]
        , [ ("csh", toPathPiece csh) | FormSuccess (_, _, Just csh) <- [params] ]
        ]

  let noTemplateAction = courseEditHandler' Nothing
  case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more!
    FormMissing      -> noTemplateAction
    FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
                        noTemplateAction
    FormSuccess (Nothing, Nothing, Nothing) -> noTemplateAction
    FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
      oldCourses <- runDB $
        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 ->
                  E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
                      E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
          let lecturersSchool =
                E.exists $ E.from $ \user ->
                  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' template

postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler (\p -> Just . SomeRoute $ CourseNewR :#: p) Nothing -- Note: Nothing is safe here, since we will create a new course.

getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCEditR  = pgCEditR
postCEditR = pgCEditR

pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
pgCEditR tid ssh csh = do
  courseData <- runDB $ do
      mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
      mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
      mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
      return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
  -- 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 (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData


getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCDeleteR = postCDeleteR
postCDeleteR tid ssh csh = do
  Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
  deleteR $ (courseDeleteRoute $ Set.singleton cId)
    { drAbort = SomeRoute $ CourseR tid ssh csh CShowR
    , drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
    }


-- | Course Creation and Editing
-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
-- |            since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
courseEditHandler :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html
courseEditHandler miButtonAction mbCourseForm = do
    aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
    ((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm
    formResult result $ \case
      res@CourseForm
        { cfCourseId = Nothing
        , cfShort    = csh
        , cfSchool   = ssh
        , cfTerm     = tid
        } -> do -- create new course
          now <- liftIO getCurrentTime
          insertOkay <- runDBJobs $ 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
              let (invites, adds) = partitionEithers $ cfLecturers res
              insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
              sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
              insert_ $ CourseEdit aid now cid
            return insertOkay
          case insertOkay of
            Just _ -> do
              -- addMessageI Info $ MsgCourseNewOk tid ssh csh
              redirect $ CourseR tid ssh csh CShowR
            Nothing ->
              addMessageI Warning $ MsgCourseNewDupShort tid ssh csh

      res@CourseForm
        { cfCourseId = Just cid
        , cfShort    = csh
        , cfSchool   = ssh
        , cfTerm     = tid
        } -> do -- edit existing course
          now <- liftIO getCurrentTime
          -- addMessage "debug" [shamlet| #{show res}|]
          success <- runDBJobs $ do
            old <- get cid
            case old of
              Nothing -> addMessageI Error MsgInvalidInput $> False
              (Just _) -> do
                updOkay <- myReplaceUnique cid Course
                  { courseName            = cfName       res
                  , courseDescription     = cfDesc       res
                  , courseLinkExternal    = cfLink       res
                  , courseShorthand       = cfShort      res
                  , courseTerm            = cfTerm       res -- dangerous
                  , courseSchool          = cfSchool     res
                  , courseCapacity        = cfCapacity   res
                  , courseRegisterSecret  = cfSecret     res
                  , courseMaterialFree    = cfMatFree    res
                  , courseRegisterFrom    = cfRegFrom    res
                  , courseRegisterTo      = cfRegTo      res
                  , courseDeregisterUntil = cfDeRegUntil res
                  }
                case updOkay of
                  (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                  Nothing  -> do
                    deleteWhere [LecturerCourse ==. cid]
                    deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
                    let (invites, adds) = partitionEithers $ cfLecturers res
                    insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
                    sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites

                    insert_ $ CourseEdit aid now cid
                    addMessageI Success $ MsgCourseEditOk tid ssh csh
                    return True
          when success $ redirect $ CourseR tid ssh csh CShowR
    actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
    defaultLayout $ do
      setTitleI MsgCourseEditTitle
      wrapForm formWidget def
        { formAction = Just $ SomeRoute actionUrl
        , formEncoding = formEnctype
        }


instance IsInvitableJunction Lecturer where
  type InvitationFor Lecturer = Course
  data InvitableJunction Lecturer = JunctionLecturer
    { jLecturerType :: LecturerType
    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationDBData Lecturer = InvDBDataLecturer
    { invDBLecturerType :: Maybe LecturerType
    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationTokenData Lecturer = InvTokenDataLecturer
    deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _InvitableJunction = iso
    (\Lecturer{..} -> (lecturerUser, lecturerCourse, JunctionLecturer lecturerType))
    (\(lecturerUser, lecturerCourse, JunctionLecturer lecturerType) -> Lecturer{..})

instance ToJSON (InvitableJunction Lecturer) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction Lecturer) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }

instance ToJSON (InvitationDBData Lecturer) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationDBData Lecturer) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }

instance ToJSON (InvitationTokenData Lecturer) where
  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationTokenData Lecturer) where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }

lecturerInvitationConfig :: InvitationConfig Lecturer
lecturerInvitationConfig = InvitationConfig{..}
  where
    invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
    invitationResolveFor = do
      Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
    invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
    invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
    invitationTokenConfig _ _ = do
      itAuthority <- liftHandlerT requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of
      Nothing    -> areq    (selectField optionsFinite) lFs Nothing
      Just lType -> aforced (selectField optionsFinite) lFs lType
      where
        toJunction jLecturerType = JunctionLecturer{..}
        lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
    invitationSuccessMsg Course{..} (Entity _ Lecturer{..}) = do
      MsgRenderer mr <- getMsgRenderer
      return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
    invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR


data CourseForm = CourseForm
        { cfCourseId   :: Maybe CourseId
        , cfName       :: CourseName
        , cfDesc       :: Maybe Html
        , cfLink       :: Maybe Text
        , cfShort      :: CourseShorthand
        , cfTerm       :: TermId
        , cfSchool     :: SchoolId
        , cfCapacity   :: Maybe Int
        , cfSecret     :: Maybe Text
        , cfMatFree    :: Bool
        , cfRegFrom    :: Maybe UTCTime
        , cfRegTo      :: Maybe UTCTime
        , cfDeRegUntil :: Maybe UTCTime
        , cfLecturers  :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
        }

courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm
courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
    { cfCourseId   = Just cid
    , cfName       = courseName
    , cfDesc       = courseDescription
    , cfLink       = courseLinkExternal
    , cfShort      = courseShorthand
    , cfTerm       = courseTerm
    , cfSchool     = courseSchool
    , cfCapacity   = courseCapacity
    , cfSecret     = courseRegisterSecret
    , cfMatFree    = courseMaterialFree
    , cfRegFrom    = courseRegisterFrom
    , cfRegTo      = courseRegisterTo
    , cfDeRegUntil = courseDeregisterUntil
    , cfLecturers  = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
                  ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
    }

makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
    -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
    -- let editCid = cfCourseId =<< template -- possible start for refactoring

    MsgRenderer mr <- getMsgRenderer

    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
          (Just cform)  | (Just cid) <- cfCourseId cform -> liftHandlerT $ 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

    let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
        miAdd _ _ nudge btn = Just $ \csrf -> do
          (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
          addRes'  <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
          let addRes'' = case (,) <$> addRes <*> addRes' of
                FormSuccess (CI.mk -> email, mLid) ->
                  let new = maybe (Left email) Right mLid
                  in  FormSuccess $ \prev -> if
                        | new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course)
                        | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
                FormFailure errs -> FormFailure errs
                FormMissing -> FormMissing
              addView' = $(widgetFile "course/lecturerMassInput/add")
          return (addRes'', addView')

        miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
        miCell _ (Right lid) defType nudge = \csrf -> do
          (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
          User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
          let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
          return (Just <$> lrwRes,lrwView')
        miCell _ (Left lEmail) defType nudge = \csrf -> do
          (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
          let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
          return (lrwRes,lrwView')

        miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
                 -> ListPosition -- ^ Coordinate to delete
                 -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
        miDelete = miDeleteList

        miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
        miAllowAdd _ _ _ = True

        miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
        miAddEmpty _ _ _ = Set.empty

        miLayout :: ListLength
                 -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
                 -> Map ListPosition Widget -- ^ Cell widgets
                 -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
                 -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
                 -> Widget
        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")

        miIdent :: Text
        miIdent = "lecturers"


        lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
        lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
                MassInput{..}
                (fslI MsgCourseLecturers & setTooltip (UniWorXMessages [SomeMessage MsgCourseLecturerRightsIdentical, SomeMessage MsgMassInputTip]))
                True
                (Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template)
                mempty
          where
            liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)
            liftEither (Right lid  , Just lType) = Right (lid   , lType )
            liftEither (Left lEmail, mLType    ) = Left  (lEmail, mLType)
            liftEither _                         = error "liftEither: lecturerForm produced output it should not have been able to"

            unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType)
            unliftEither (Right (lid   , lType )) = (Right lid  , Just lType)
            unliftEither (Left  (lEmail, mLType)) = (Left lEmail, mLType    )

    (newRegFrom,newRegTo,newDeRegUntil) <- case template of
        (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
        _allIOtherCases -> do
            mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
            return ( (Just . toMidnight     . termStart . entityVal) <$> mbLastTerm
                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm
                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm )

    (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
      <$> pure (cfCourseId =<< template)
      <*> areq ciField (fslI MsgCourseName)                             (cfName       <$> template)
      <*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben"
                         & setTooltip MsgCourseDescriptionTip)          (cfDesc       <$> template)
      <*> aopt urlField  (fslpI MsgCourseHomepageExternal "Optionale externe URL")
                                                                        (cfLink       <$> template)
      <*> areq ciField (fslI MsgCourseShorthand
            -- & addAttr "disabled" "disabled"
            & setTooltip MsgCourseShorthandUnique)                      (cfShort      <$> template)
      <*> areq termsField                     (fslI MsgCourseSemester)  (cfTerm       <$> template)
      <*> areq (schoolFieldFor userSchools)   (fslI MsgCourseSchool)    (cfSchool     <$> template)
      <*> aopt (natFieldI MsgCourseCapacity)  (fslI MsgCourseCapacity
            & setTooltip MsgCourseCapacityTip)                          (cfCapacity   <$> template)
      <*> aopt textField      (fslpI MsgCourseSecret (mr MsgCourseSecretFormat)
            & setTooltip MsgCourseSecretTip)                            (cfSecret     <$> template)
      <*> areq checkBoxField  (fslI  MsgMaterialFree)                   (cfMatFree    <$> template)
      <*> aopt utcTimeField   (fslpI MsgRegisterFrom (mr MsgDate)
            & setTooltip MsgCourseRegisterFromTip)                      (deepAlt (cfRegFrom    <$> template) newRegFrom)
      <*> aopt utcTimeField   (fslpI MsgRegisterTo   (mr MsgDate)
            & setTooltip MsgCourseRegisterToTip)                        (deepAlt (cfRegTo      <$> template) newRegTo)
      <*> aopt utcTimeField   (fslpI MsgDeRegUntil   (mr MsgDate)
            & setTooltip MsgCourseDeregisterUntilTip)                   (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
      <*> lecturerForm
    errorMsgs' <- traverse validateCourse result
    return $ case errorMsgs' of
      FormSuccess errorMsgs
        | not $ null errorMsgs ->
          (FormFailure errorMsgs,
                [whamlet|
                  <div class="alert alert-danger">
                    <div class="alert__content">
                      <h4> Fehler:
                      <ul>
                        $forall errmsg <- errorMsgs
                          <li> #{errmsg}
                  ^{widget}
                |]
              )
      _ -> (result, widget)


validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
validateCourse CourseForm{..} = do
  uid <- liftHandlerT requireAuthId
  userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
  MsgRenderer mr <- getMsgRenderer

  return
    [ mr msg | (False, msg) <-
        [
          ( NTop cfRegFrom <= NTop cfRegTo
          , MsgCourseRegistrationEndMustBeAfterStart
          )
        ,
          ( NTop cfRegFrom <= NTop cfDeRegUntil
          , MsgCourseDeregistrationEndMustBeAfterStart
          )
        , ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
          , MsgCourseUserMustBeLecturer
          )
        ] ]



--------------------
-- CourseUserTable

type UserTableExpr   = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant))
        `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
        `E.LeftOuterJoin`
        (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))

-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
-- forceUserTableType = id

-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
-- This ought to ease refactoring the query
queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)

queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)

queryUserNote ::  UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
queryUserNote = $(sqlLOJproj 3 2)

queryFeaturesStudy ::  UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryFeaturesStudy  = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)

queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)

queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryFeaturesField  = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)


userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
                                                          , E.SqlExpr (E.Value UTCTime)
                                                          , E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
                                                          , StudyFeaturesDescription')
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
  -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
  features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
  E.on $  (note E.?. CourseUserNoteUser   E.==. E.just (participant E.^. CourseParticipantUser))
    E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
  E.on $     participant E.^. CourseParticipantUser   E.==. user E.^. UserId
  E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
  return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)


type UserTableData   = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms))

instance HasEntity UserTableData User where
  hasEntity = _dbrOutput . _1

instance HasUser UserTableData where
  -- hasUser = _entityVal
  hasUser = _dbrOutput . _1 . _entityVal

_userTableRegistration :: Lens' UserTableData UTCTime
_userTableRegistration = _dbrOutput . _2

_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
_userTableNote = _dbrOutput . _3

_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
_userTableFeatures = _dbrOutput . _4

_rowUserSemester :: Traversal' UserTableData Int
_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester


colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserComment tid ssh csh =
    sortable (Just "note") (i18nCell MsgCourseUserNote)
      $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } ->
        maybeEmpty mbNoteKey $ const $
          anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True)
  where
    courseLink = CourseR tid ssh csh . CUserR

colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
    foldMap numCell . preview _rowUserSemester

colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $
    foldMap i18nCell . view (_userTableFeatures . _3)

colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
    foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3)

colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
    foldMap i18nCell . preview (_userTableFeatures . _2 . _Just)

colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
    foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)


data CourseUserAction = CourseUserSendMail | CourseUserDeregister
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe CourseUserAction
instance Finite CourseUserAction
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''CourseUserAction id

data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe TutorialUserAction
instance Finite TutorialUserAction
nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''TutorialUserAction id

makeCourseUserTable :: forall h act.
                       ( Functor h, ToSortable h
                       , RenderMessage UniWorX act, Eq act, PathPiece act, Finite act)
                    => CourseId
                    -> (UserTableExpr -> E.SqlExpr (E.Value Bool))
                    -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData)))
                    -> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))
                    -> DB (FormResult (act, Set UserId), Widget)
makeCourseUserTable cid restrict colChoices psValidator = do
    Just currentRoute <- liftHandlerT getCurrentRoute
    -- -- psValidator has default sorting and filtering
    let dbtIdent     = "courseUsers" :: Text
        dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
        dbtRowKey    = queryUser >>> (E.^. UserId)
        dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
        dbtColonnade = colChoices
        dbtSorting   = Map.fromList
          [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
          , sortUserSurname     queryUser -- needed for initial sorting
          , sortUserDisplayName queryUser -- needed for initial sorting
          , sortUserEmail       queryUser
          , sortUserMatriclenr  queryUser
          , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
          , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
          , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
          , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
          , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
          , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
          , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
                E.sub_select . E.from $ \edit -> do
                  E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
                  return . E.max_ $ edit E.^. CourseUserNoteEditTime
            )
          ]
        dbtFilter    = Map.fromList
          [ fltrUserNameLink    queryUser
          , fltrUserEmail       queryUser
          , fltrUserMatriclenr  queryUser
          , fltrUserNameEmail   queryUser
          , ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
          , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
          , ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
          , ("field"       , FilterColumn $ E.anyFilter
                                 [ E.mkContainsFilter          $ queryFeaturesField >>> (E.?. StudyTermsName)
                                 , E.mkContainsFilter          $ queryFeaturesField >>> (E.?. StudyTermsShorthand)
                                 , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
                                 ] )
          , ("degree"      , FilterColumn $ E.anyFilter
                                 [ E.mkContainsFilter          $ queryFeaturesDegree >>> (E.?. StudyDegreeName)
                                 , E.mkContainsFilter          $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)
                                 , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
                                 ] )
          , ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
          , ("tutorial"    , FilterColumn $ E.mkExistsFilter   $ \row criterion ->
                E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
                  E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
                  E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
                       E.&&. E.hasInfix (tutorial E.^. TutorialName) criterion
                       E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
            )
          -- , ("course-registration", error "TODO") -- TODO
          -- , ("course-user-note", error "TODO") -- TODO
          ]
        dbtFilterUI mPrev = mconcat
          [ fltrUserNameEmailUI  mPrev
          , fltrUserMatriclenrUI mPrev
          , prismAForm (singletonFilter "degree")   mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
          , prismAForm (singletonFilter "field")    mPrev $ aopt textField (fslI MsgCourseStudyFeature)
          , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseTutorial)
          ]
        dbtParams    = DBParamsForm
          { dbParamsFormMethod = POST
          , dbParamsFormAction = Just $ SomeRoute currentRoute
          , dbParamsFormAttrs  = []
          , dbParamsFormSubmit = FormSubmit
          , dbParamsFormAdditional = \csrf -> do
              (res,vw) <- mreq (selectField optionsFinite) "" Nothing
              let formWgt = toWidget csrf <> fvInput vw
                  formRes = (, mempty) . First . Just <$> res
              return (formRes,formWgt)
          , dbParamsFormEvaluate = liftHandlerT . runFormPost
          , dbParamsFormResult   = id
          , dbParamsFormIdent    = def
          }
    over _1 postprocess <$> dbTable psValidator DBTable{..}
  where
    postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)
    postprocess inp = do
      (First (Just act), usrMap) <- inp
      let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
      return (act, usrSet)

getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR = postCUsersR
postCUsersR tid ssh csh = do
  (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
    let colChoices  = mconcat
          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , colUserNameLink (CourseR tid ssh csh . CUserR)
          , colUserEmail
          , colUserMatriclenr
          , colUserDegreeShort
          , colUserField
          , colUserSemester
          , sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
          , colUserComment tid ssh csh
          ]
        psValidator = def & defaultSortingByName
    ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
    numParticipants <- count [CourseParticipantCourse ==. cid]
    table <- makeCourseUserTable cid (const E.true) colChoices psValidator
    return (ent, numParticipants, table)
  formResult participantRes $ \case
    (CourseUserSendMail, selectedUsers) -> do
        cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
        redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
    (CourseUserDeregister,selectedUsers) -> do
        nrDel <- runDB $ deleteWhereCount
          [ CourseParticipantCourse ==. cid
          , CourseParticipantUser <-. Set.toList selectedUsers
          ]
        addMessageI Success $ MsgCourseUsersDeregistered nrDel
        redirect $ CourseR tid ssh csh CUsersR
  let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
      headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
  siteLayout headingLong $ do
    setTitleI headingShort
    $(widgetFile "course-participants")



getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTUsersR = postTUsersR
postTUsersR tid ssh csh tutn = do
  (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
    tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
    let colChoices  = mconcat
          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , colUserName
          , colUserEmail
          , colUserMatriclenr
          , colUserDegreeShort
          , colUserField
          , colUserSemester
          ]
        psValidator = def
          & defaultSortingByName
          & restrictSorting (\name _ -> none (== name) ["note"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
        isInTut q = E.exists . E.from $ \tutorialParticipant ->
          E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
               E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    table <- makeCourseUserTable cid isInTut colChoices psValidator
    return (tut, table)

  formResult participantRes $ \case
    (TutorialUserSendMail, selectedUsers) -> do
        cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
        redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
    (TutorialUserDeregister,selectedUsers) -> do
        nrDel <- runDB $ deleteWhereCount
          [ TutorialParticipantTutorial ==. tutid
          , TutorialParticipantUser <-. Set.toList selectedUsers
          ]
        addMessageI Success $ MsgTutorialUsersDeregistered nrDel
        redirect $ CTutorialR tid ssh csh tutn TUsersR

  let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
  siteLayoutMsg heading $ do
    setTitleI heading
    $(widgetFile "tutorial-participants")


getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR = postCUserR
postCUserR tid ssh csh uCId = do
  -- Has authorization checks (OR):
  --
  --   - User is current member of course
  --   - User has submitted in course
  --   - User is member of registered group for course
  --   - User is member of a tutorial for course
  --   - User is corrector for course
  --   - User is a tutor for course
  --   - User is a lecturer for course
  let currentRoute = CourseR tid ssh csh (CUserR uCId)
  dozentId <- requireAuthId
  uid <- decrypt uCId
  -- DB reads
  (cid, User{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do
    cid  <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    -- Abfrage Benutzerdaten
    user <- get404 uid
    registration <- getBy (UniqueParticipant uid cid)
    -- Abfrage Teilnehmernotiz
    let thisUniqueNote = UniqueCourseUserNote uid cid
    mbNoteEnt <- getBy thisUniqueNote
    (noteText,noteEdits) <- case mbNoteEnt of
      Nothing -> return (Nothing,[])
      (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
        noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
          E.on     $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
          E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
          E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
          E.limit 1 -- more will be shown, if changed here
          return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
        return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
    -- Abfrage Studiengänge
    studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
      E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
      E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
      E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
      return  (studyfeat, studydegree, studyterms)
    return (cid, user, registration, thisUniqueNote, noteText, noteEdits, studies)
  let editByWgt = [whamlet|
          $forall (etime,_eemail,ename,_esurname) <- noteEdits
            <br>
            _{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
        |] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}

  ((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
      aopt (annotateField editByWgt htmlField') (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
  let noteFrag :: Text
      noteFrag = "notes"
      noteWidget = wrapForm noteView FormSettings
        { formMethod = POST
        , formAction = Just . SomeRoute $ currentRoute :#: noteFrag
        , formEncoding = noteEnctype
        , formAttrs = []
        , formSubmit = FormSubmit
        , formAnchor = Just noteFrag
        }
  formResult noteRes $ \mbNote -> do
    now <- liftIO getCurrentTime
    runDB $ case mbNote of
      Nothing -> do
        -- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
        maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
        deleteBy thisUniqueNote
        addMessageI Info MsgCourseUserNoteDeleted
      _ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
      (Just note) -> do
        (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
        void . insert $ CourseUserNoteEdit dozentId now noteKey
        addMessageI Success MsgCourseUserNoteSaved
    redirect $ currentRoute :#: noteFrag -- reload page after post

  ((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
    let currentField :: Maybe (Maybe StudyFeaturesId)
        currentField = courseParticipantField . entityVal <$> mRegistration
     in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesPrimaryFieldFor True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField

  let registrationFieldFrag :: Text
      registrationFieldFrag = "registration-field"
      regFieldWidget = wrapForm regFieldView FormSettings
        { formMethod = POST
        , formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
        , formEncoding = regFieldEnctype
        , formAttrs = []
        , formSubmit = FormAutoSubmit
        , formAnchor = Just registrationFieldFrag
        }
  for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
    formResult regFieldRes $ \courseParticipantField' -> do
      runDB $ do
        update pId [ CourseParticipantField =. courseParticipantField' ]
        addMessageI Success MsgCourseStudyFeatureUpdated
      redirect $ currentRoute :#: registrationFieldFrag

  let regButton
        | Just _ <- mRegistration = BtnDeregister
        | otherwise = BtnRegister
  ((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton]

  let registrationButtonFrag :: Text
      registrationButtonFrag = "registration-button"
      regButtonWidget = wrapForm regButtonView FormSettings
        { formMethod = POST
        , formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
        , formEncoding = regButtonEnctype
        , formAttrs = []
        , formSubmit = FormNoSubmit
        , formAnchor = Just registrationButtonFrag
        }
  formResult regButtonRes $ \case
    BtnDeregister
      | Just (Entity pId _) <- mRegistration
        -> do
          runDB $ delete pId
          addMessageI Info MsgCourseDeregisterOk
          redirect $ CourseR tid ssh csh CUsersR
      | otherwise
        -> invalidArgs ["User not registered"]
    BtnRegister -> do
      now <- liftIO getCurrentTime
      let primaryField
            | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies
            = Just featId
            | otherwise
            = Nothing
      pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField
      case pId of
        Just _  -> do
          addMessageI Success MsgCourseRegisterOk
          redirect currentRoute
        Nothing -> invalidArgs ["User already registered"]

  mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime

  -- generate output
  let headingLong  = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{display tid}|]
      headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
  siteLayout headingLong $ do
    setTitleI headingShort
    $(widgetFile "course-user")


getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCHiWisR = error "CHiWisR: Not implemented"

getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-- NOTE: The route getNotesR is abused for correctorORlecturer access rights!
-- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared?
-- If they are shared, adjust MsgCourseUserNoteTooltip
getCNotesR = postCNotesR
postCNotesR _ _ _ = do
  defaultLayout $ [whamlet|You have corrector access to this course.|]


getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCCommR = postCCommR
postCCommR tid ssh csh = do
  jSender <- requireAuthId
  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh

  commR CommunicationRoute
    { crHeading    = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading
    , crUltDest    = SomeRoute $ CourseR tid ssh csh CCommR
    , crJobs       = \Communication{..} -> do
        let jSubject = cSubject
            jMailContent = cBody
            jCourse = cid
            allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
        jMailObjectUUID <- liftIO getRandom
        jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
          Left email -> return . Address Nothing $ CI.original email
          Right rid  -> userAddress <$> getJust rid
        forM_ allRecipients $ \jRecipientEmail ->
          yield JobSendCourseCommunication{..}
    , crRecipients = Map.fromList
      [ ( RGCourseParticipants
        , E.from $ \(user `E.InnerJoin` participant) -> do
            E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
            E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
            return user
        )
      , ( RGCourseLecturers
        , E.from $ \(user `E.InnerJoin` lecturer) -> do
            E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
            E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
            return user
        )
      , ( RGCourseCorrectors
        , E.from $ \user -> do
            E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
              E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
              E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
                   E.&&. user E.^. UserId E.==. corrector E.^. SheetCorrectorUser
            return user
        )
      , ( RGCourseTutors
        , E.from $ \user -> do
            E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
              E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
              E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
                   E.&&. user E.^. UserId E.==. tutor E.^. TutorUser
            return user
        )
      ]
    , crRecipientAuth = Just $ \uid -> do
        cID <- encrypt uid
        evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
    }


getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCLecInviteR = postCLecInviteR
postCLecInviteR = invitationR lecturerInvitationConfig



-- Invitations for ordinary participants of this course
instance IsInvitableJunction CourseParticipant where
  type InvitationFor CourseParticipant = Course
  data InvitableJunction CourseParticipant = JunctionParticipant
    { jParticipantRegistration :: UTCTime
    , jParticipantFild         :: Maybe StudyFeaturesId
    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationDBData CourseParticipant = InvDBDataParticipant
    -- no data needed in DB to manage participant invitation
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationTokenData CourseParticipant = InvTokenDataParticipant
    deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _InvitableJunction = iso
    (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField))
    (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..})

  ephemeralInvitation = Just (iso (const InvDBDataParticipant) (const ()))

instance ToJSON (InvitableJunction CourseParticipant) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction CourseParticipant) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }

instance ToJSON (InvitationDBData CourseParticipant) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationDBData CourseParticipant) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }

instance ToJSON (InvitationTokenData CourseParticipant) where
  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationTokenData CourseParticipant) where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }

participantInvitationConfig :: InvitationConfig CourseParticipant
participantInvitationConfig = InvitationConfig{..}
  where
    invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
    invitationResolveFor = do
      Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
    invitationSubject     Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
    invitationHeading     Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
    invitationExplanation _          _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
    -- Keine besonderen Einschränkungen beim Einlösen der Token
    -- ACHTUNG: Mit einem Token könnten sich deshalb mehrere Benutzer anmelden!
    invitationTokenConfig _ _ = do
      itAuthority <- liftHandlerT requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do
      now <- liftIO getCurrentTime
      studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
          (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
      return $ JunctionParticipant <$> pure now <*> studyFeatures
    invitationSuccessMsg Course{..} _ =
      return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
    invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR

data AddRecipientsResult = AddRecipientsResult
  { aurAlreadyRegistered
  , aurNoUniquePrimaryField
  , aurSuccess              :: [UserEmail]
  } deriving (Read, Show, Generic, Typeable)

instance Monoid AddRecipientsResult where
  mempty = memptydefault
  mappend = mappenddefault

getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAddUserR = postCAddUserR
postCAddUserR tid ssh csh = do
    cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
      enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
      wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
              (fslI MsgCourseParticipantInviteField) Nothing

    formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid

    let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading

    siteLayoutMsg heading $ do
      setTitleI heading
      wrapForm formWgt def
        { formEncoding
        , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
        }
  where
    processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
    processUsers cid users = do
      let (emails,uids) = partitionEithers $ Set.toList users
      AddRecipientsResult alreadyRegistered registeredNoField registeredOneField <- lift . runDBJobs $ do
        -- send Invitation eMails to unkown users
        sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
        -- register known users
        execWriterT $ mapM (registerUser cid) uids

      when (not $ null emails) $
        tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails

      when (not $ null alreadyRegistered) $ do
        let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}|]
            modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
        tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)

      when (not $ null registeredNoField) $ do
        let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}|]
            modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
        tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)

      when (not $ null registeredOneField) $
        tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length registeredOneField

    registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
    registerUser cid uid = exceptT tell tell $ do
      User{..} <- lift . lift $ getJust uid

      whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
        throwError $ mempty { aurAlreadyRegistered = pure userEmail }

      features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []

      let courseParticipantField
            | [f] <- features = Just f
            | otherwise       = Nothing

      courseParticipantRegistration <- liftIO getCurrentTime
      void . lift . lift . insert $ CourseParticipant
        { courseParticipantCourse = cid
        , courseParticipantUser = uid
        , ..
        }

      return $ case courseParticipantField of
        Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
        Just _  -> mempty { aurSuccess              = pure userEmail }


getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCInviteR = postCInviteR
postCInviteR = invitationR participantInvitationConfig