module Handler.Course.Edit
  ( getCourseNewR, postCourseNewR
  , getCEditR, postCEditR
  ) where

import Import

import Utils.Form
import Handler.Utils
import Handler.Utils.Invitations

import qualified Data.CaseInsensitive as CI

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

import qualified Control.Monad.State.Class as State

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E

import Jobs.Queue

import Handler.Course.LecturerInvite

import qualified Data.Conduit.List as C


data CourseForm = CourseForm
        { cfCourseId    :: Maybe CourseId
        , cfName        :: CourseName
        , cfShort       :: CourseShorthand
        , cfSchool      :: SchoolId
        , cfTerm        :: TermId
        , cfDesc        :: Maybe StoredMarkup
        , cfLink        :: Maybe URI
        , cfVisFrom     :: Maybe UTCTime
        , cfVisTo       :: Maybe UTCTime
        , cfMatFree     :: Bool
        , cfAllocation  :: Maybe AllocationCourseForm
        , cfAppRequired         :: Bool
        , cfAppInstructions     :: Maybe StoredMarkup
        , cfAppInstructionFiles :: Maybe FileUploads
        , cfAppText             :: Bool
        , cfAppFiles            :: UploadMode
        , cfAppRatingsVisible   :: Bool
        , cfCapacity    :: Maybe Int
        , cfSecret      :: Maybe Text
        , cfRegFrom     :: Maybe UTCTime
        , cfRegTo       :: Maybe UTCTime
        , cfDeRegUntil  :: Maybe UTCTime
        , cfLecturers   :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
        }

data AllocationCourseForm = AllocationCourseForm
  { acfAllocation                :: AllocationId
  , acfMinCapacity               :: Int
  , acfAcceptSubstitutes         :: Maybe UTCTime
  , acfDeregisterNoShow          :: Bool
  }

makeLenses_ ''CourseForm
makeLenses_ ''AllocationCourseForm

courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> Maybe (Entity AllocationCourse) -> CourseForm
courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm
    { cfCourseId            = Just cid
    , cfName                = courseName
    , cfDesc                = courseDescription
    , cfLink                = courseLinkExternal
    , cfShort               = courseShorthand
    , cfTerm                = courseTerm
    , cfSchool              = courseSchool
    , cfCapacity            = courseCapacity
    , cfSecret              = courseRegisterSecret
    , cfMatFree             = courseMaterialFree
    , cfAllocation          = allocationCourseToForm cEnt <$> alloc
    , cfAppRequired         = courseApplicationsRequired
    , cfAppInstructions     = courseApplicationsInstructions
    , cfAppInstructionFiles
    , cfAppText             = courseApplicationsText
    , cfAppFiles            = courseApplicationsFiles
    , cfAppRatingsVisible   = courseApplicationsRatingsVisible
    , cfVisFrom             = courseVisibleFrom
    , cfVisTo               = courseVisibleTo
    , cfRegFrom             = courseRegisterFrom
    , cfRegTo               = courseRegisterTo
    , cfDeRegUntil          = courseDeregisterUntil
    , cfLecturers           = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
                           ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ]
    }
  where
    cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (view $ _entityVal . _FileReference . _1)
      where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do
              E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
              return courseAppInstructionFile


allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm
allocationCourseToForm (Entity _ Course{..}) (Entity _ AllocationCourse{..}) = AllocationCourseForm
  { acfAllocation = allocationCourseAllocation
  , acfMinCapacity = allocationCourseMinCapacity
  , acfAcceptSubstitutes = allocationCourseAcceptSubstitutes
  , acfDeregisterNoShow = courseDeregisterNoShow
  }

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

    now <- liftIO getCurrentTime
    MsgRenderer mr <- getMsgRenderer

    uid <- liftHandler requireAuthId
    (lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
      lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
      protoAdminSchools  <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
      adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
      oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
      return (lecturerSchools, adminSchools, oldSchool)
    let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools

    (termsField, userTerms) <- liftHandler $ case template of
      -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
      (Just cform)  | (Just cid) <- cfCourseId cform -> do -- edit existing course
          _courseOld@Course{..} <- runDB $ get404 cid
          mayEditTerm <- isAuthorized TermEditR True
          mayDelete   <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
          if
            | (mayEditTerm == Authorized) || (mayDelete == Authorized)
              -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms
            | otherwise
              -> return (termsSetField [cfTerm cform], [cfTerm cform])
      _allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms

    let miAdd :: ListPosition -> Natural -> ListLength -> (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 (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
          let addRes'' = addRes <&> \newDat oldDat -> if
                | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
                , not $ Set.null existing
                  -> FormFailure [mr MsgCourseLecturerAlreadyAdded]
                | otherwise
                  -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
              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) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType)
          User{userEmail, userDisplayName, userSurname} <- liftHandler . 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
          invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
          let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
          return (lrwRes,lrwView')

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

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

    (newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of
        (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
        _allIOtherCases -> do
            mbLastTerm <- liftHandler . runDB . runMaybeT $ MaybeT . get =<< MaybeT getCurrentTerm
            return ( Just $ Just now
                   , Just . toMidnight     . termStart <$> mbLastTerm
                   , Just . beforeMidnight . termEnd   <$> mbLastTerm
                   , Just . beforeMidnight . termEnd   <$> mbLastTerm
                   )

    let
      allocationForm :: AForm Handler (Maybe AllocationCourseForm)
      allocationForm = wFormToAForm $ do
        muid <- maybeAuthId
        availableAllocations' <- liftHandler . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
          E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId

          let alreadyParticipates = flip (maybe E.false) (template >>= cfCourseId) $ \cid ->
                E.exists . E.from $ \allocationCourse ->
                  E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
                       E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId

          E.where_ $ termIsActiveE (E.val now) (E.val muid) (term E.^. TermId)
               E.||. alreadyParticipates
               E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools
          return (allocation, alreadyParticipates)

        let
          allocationEnabled :: Entity Allocation -> Bool
          allocationEnabled (Entity _ Allocation{..})
            = (   NTop allocationStaffRegisterFrom <= NTop (Just now)
               && NTop (Just now) <= NTop allocationStaffRegisterTo
              ) || allocationSchool `elem` adminSchools
          availableAllocations = availableAllocations' ^.. folded . filtered (allocationEnabled . view _1) . _1
          activeAllocations = availableAllocations' ^.. folded . filtered ((&&) <$> (not <$> allocationEnabled . view _1) <*> view (_2 . _Value)) . _1

          mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId)
          mkAllocationOption (Entity aId Allocation{..}) = liftHandler $ do
            cID <- encrypt aId :: Handler CryptoUUIDAllocation
            return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID

          currentAllocationAvailable = (\alloc -> any ((== alloc) . entityKey) availableAllocations) . acfAllocation <$> (template >>= cfAllocation)

        case (currentAllocationAvailable, availableAllocations) of
          (Nothing, []) -> wforced (convertField (const Nothing) (const False) checkBoxField) (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseNoAllocationsAvailable) Nothing
          _  -> do
            allocationOptions <- mkOptionList <$> mapM mkAllocationOption (availableAllocations ++ activeAllocations)

            let
              explainedAllocationOptions = return allocationOptions `explainOptionList` \allocId -> hoistMaybe . listToMaybe $ do
                (Entity allocId' Allocation{..}, _) <- availableAllocations'
                guard $ allocId' == allocId
                toWidget <$> hoistMaybe allocationStaffDescription

              doExplain = has (folded . _entityVal . _allocationStaffDescription . _Just) $ availableAllocations ++ activeAllocations
              allocField | doExplain = explainedSelectionField Nothing explainedAllocationOptions
                         | otherwise = selectField' Nothing $ return allocationOptions
              
              userAdmin = not $ null adminSchools
              mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable

              allocationForm' =
                let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
                    ainp
                      | mayChange
                      = apreq
                      | otherwise
                      = aforcedJust
                 in AllocationCourseForm
                    <$> ainp allocField (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation)
                    <*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation)
                    <*> aopt utcTimeField (fslI MsgCourseAcceptSubstitutesUntil & setTooltip MsgCourseAcceptSubstitutesUntilTip) (fmap acfAcceptSubstitutes $ template >>= cfAllocation)
                    <*> apopt checkBoxField (fslI MsgCourseDeregisterNoShow & setTooltip MsgCourseDeregisterNoShowTip) ((<|> Just True) . fmap acfDeregisterNoShow $ template >>= cfAllocation)

            let
              addTip :: (MonadHandler m, HandlerSite m ~ UniWorX)
                     => FieldView UniWorX -> m (FieldView UniWorX)
              addTip = addFieldViewTooltipWidget $(i18nWidgetFile "allocation-participate-tip")

            hoist (censorM $ traverseOf _head addTip) $ optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate) (is _Just . cfAllocation <$> template)

    -- let autoUnzipInfo = [|Entpackt hochgeladene Zip-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis der Abgabe hinzu. TODO|]

    multipleSchoolsMsg <- messageI Warning MsgCourseSchoolMultipleTip
    multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip

    (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
          (cfCourseId =<< template)
      <$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName)                             (cfName       <$> template)
      <*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
            -- & addAttr "disabled" "disabled"
            & setTooltip MsgCourseShorthandUnique)                      (cfShort      <$> template)
      <*  bool (pure ()) (aformMessage multipleSchoolsMsg) (length userSchools > 1)
      <*> areq (schoolFieldFor userSchools)   (fslI MsgCourseSchool)    (cfSchool     <$> template)
      <*  bool (pure ()) (aformMessage multipleTermsMsg) (length userTerms > 1)
      <*> areq termsField                     (fslI MsgCourseSemester)  (cfTerm       <$> template)
      <*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder))
                                                                        (cfDesc       <$> template)
      <*> aopt urlField (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder))
                                                                        (cfLink       <$> template)
      <*> aopt utcTimeField   (fslpI MsgCourseVisibleFrom  (mr MsgCourseDate)
            & setTooltip MsgCourseVisibleFromTip)                       (deepAlt (cfVisFrom    <$> template) newVisFrom)
      <*> aopt utcTimeField   (fslpI MsgCourseVisibleTo    (mr MsgCourseDate)
            & setTooltip MsgCourseVisibleToTip)                         (cfVisTo      <$> template)
      <*> apopt checkBoxField  (fslI  MsgCourseMaterialFree)                  (cfMatFree    <$> template)
      <*  aformSection MsgCourseFormSectionRegistration
      <*> allocationForm
      <*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template)
      <*> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template)
      <*> aopt (multiFileField' . maybeVoid $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template)
      <*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template)
      <*> uploadModeForm (fslI MsgCourseApplicationsFiles & setTooltip MsgCourseApplicationsFilesTip) (fmap cfAppFiles template <|> pure NoUpload)
      <*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template)
      <*> aopt (natFieldI MsgCourseCapacity)  (fslI MsgCourseCapacity
            & setTooltip MsgCourseCapacityTip)                          (cfCapacity   <$> template)
      <*> aopt (textField & cfStrip) (fslpI MsgCourseSecret (mr MsgCourseSecretFormat)
            & setTooltip MsgCourseSecretTip)                            (cfSecret     <$> template)
      <*> aopt utcTimeField   (fslpI MsgCourseRegisterFrom (mr MsgCourseDate)
            & setTooltip MsgCourseRegisterFromTip)                      (deepAlt (cfRegFrom    <$> template) newRegFrom)
      <*> aopt utcTimeField   (fslpI MsgCourseRegisterTo   (mr MsgCourseDate)
            & setTooltip MsgCourseRegisterToTip)                        (deepAlt (cfRegTo      <$> template) newRegTo)
      <*> aopt utcTimeField   (fslpI MsgDeRegUntil   (mr MsgCourseDate)
            & setTooltip MsgCourseDeregisterUntilTip)                   (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
      <*  aformSection MsgCourseFormSectionAdministration
      <*> lecturerForm
    return (result, widget)


validateCourse :: FormValidator CourseForm (YesodDB UniWorX) ()
validateCourse = do
  CourseForm{..} <- State.get

  now <- liftIO getCurrentTime
  uid <- liftHandler requireAuthId
  userAdmin <- lift . hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
  newAllocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust

  prevAllocationCourse <- join <$> traverse (lift . getBy . UniqueAllocationCourse) cfCourseId
  prevAllocation <- fmap join . traverse (lift . getEntity) $ allocationCourseAllocation . entityVal <$> prevAllocationCourse

  oldAllocatedCapacity <- if
    | Just (Entity _ Allocation{..}) <- prevAllocation
    , Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse
    , NTop allocationStaffAllocationTo <= NTop (Just now)
    , NTop allocationRegisterByCourse > NTop (Just now)
      -> lift $ Just . courseCapacity <$> getJust allocationCourseCourse
    | otherwise
      -> return Nothing
  let oldAllocation = do
        Entity allocId Allocation{..} <- prevAllocation
        guard $ NTop (Just now) > NTop allocationStaffRegisterTo
        pure $ Just allocId
      oldAllocatedMinCapacity = do
        Entity _ Allocation{..} <- prevAllocation
        Entity _ AllocationCourse{..} <- prevAllocationCourse
        guard $ NTop (Just now) > NTop allocationStaffRegisterTo
        pure $ Just allocationCourseMinCapacity

  guardValidation MsgCourseVisibilityEndMustBeAfterStart
    $ NTop cfVisFrom <= NTop cfVisTo
  guardValidation MsgCourseRegistrationEndMustBeAfterStart
    $ NTop cfRegFrom <= NTop cfRegTo
  guardValidation MsgCourseDeregistrationEndMustBeAfterStart
    $ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
  guardValidation MsgCourseAllocationRequiresCapacity
    $ is _Nothing cfAllocation || is _Just cfCapacity
  guardValidation MsgCourseAllocationTermMustMatch
    $ maybe True (== cfTerm) newAllocationTerm
  unless userAdmin $ do
    guardValidation MsgCourseUserMustBeLecturer
      $ anyOf (traverse . _Right . _1) (== uid) cfLecturers
    guardValidation MsgCourseAllocationCapacityMayNotBeChanged
      $ maybe True (== cfCapacity) oldAllocatedCapacity
    guardValidation MsgAllocationStaffRegisterToExpiredAllocation
      $ maybe True (== fmap acfAllocation cfAllocation) oldAllocation
    guardValidation MsgAllocationStaffRegisterToExpiredMinCapacity
      $ maybe True (== fmap acfMinCapacity cfAllocation) oldAllocatedMinCapacity

  warnValidation MsgCourseShorthandTooLong
    $ length (CI.original cfShort) <= 10
  warnValidation MsgCourseNotAlwaysVisibleDuringRegistration
    $ NTop cfVisFrom <= NTop cfRegFrom && NTop cfRegTo <= NTop cfVisTo

  warnValidation MsgCourseApplicationInstructionsRecommended
    $  (is _Just cfAppInstructions || is _Just cfAppInstructionFiles)
    || not (cfAppText || isn't _NoUpload cfAppFiles)
  

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.^. UserFunctionUser     E.==. E.val uid
                      E.&&.  user E.^. UserFunctionSchool   E.==. course E.^. CourseSchool
                      E.&&.  user E.^. UserFunctionFunction E.==. E.val SchoolLecturer
          let courseCreated c =
                E.subSelectMaybe . 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 mempty mempty Nothing 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 $ sourceInvitationsF . entityKey
      mbAllocation <- for mbCourse $ \course -> getBy . UniqueAllocationCourse $ entityKey course
      return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbAllocation
  -- 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 4) courseToForm <$> courseData


-- | 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 <- let CourseForm{..} = res
                           in insertUnique Course
                                { courseName                       = cfName
                                , courseDescription                = cfDesc
                                , courseLinkExternal               = cfLink
                                , courseShorthand                  = cfShort
                                , courseTerm                       = cfTerm
                                , courseSchool                     = cfSchool
                                , courseCapacity                   = cfCapacity
                                , courseRegisterSecret             = cfSecret
                                , courseMaterialFree               = cfMatFree
                                , courseApplicationsRequired       = cfAppRequired
                                , courseApplicationsInstructions   = cfAppInstructions
                                , courseApplicationsText           = cfAppText
                                , courseApplicationsFiles          = cfAppFiles
                                , courseApplicationsRatingsVisible = cfAppRatingsVisible
                                , courseVisibleFrom                = cfVisFrom
                                , courseVisibleTo                  = cfVisTo
                                , courseRegisterFrom               = cfRegFrom
                                , courseRegisterTo                 = cfRegTo
                                , courseDeregisterUntil            = cfDeRegUntil
                                , courseDeregisterNoShow           = maybe False acfDeregisterNoShow cfAllocation
                                }
            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
              upsertAllocationCourse cid $ cfAllocation res
              memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
            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 MsgCourseInvalidInput $> False
              (Just _) -> do
                updOkay <- let CourseForm{..} = res
                           in myReplaceUnique cid Course
                                { courseName                       = cfName
                                , courseDescription                = cfDesc
                                , courseLinkExternal               = cfLink
                                , courseShorthand                  = cfShort
                                , courseTerm                       = cfTerm -- dangerous
                                , courseSchool                     = cfSchool
                                , courseCapacity                   = cfCapacity
                                , courseRegisterSecret             = cfSecret
                                , courseMaterialFree               = cfMatFree
                                , courseApplicationsRequired       = cfAppRequired
                                , courseApplicationsInstructions   = cfAppInstructions
                                , courseApplicationsText           = cfAppText
                                , courseApplicationsFiles          = cfAppFiles
                                , courseApplicationsRatingsVisible = cfAppRatingsVisible
                                , courseVisibleFrom                = cfVisFrom
                                , courseVisibleTo                  = cfVisTo
                                , courseRegisterFrom               = cfRegFrom
                                , courseRegisterTo                 = cfRegTo
                                , courseDeregisterUntil            = cfDeRegUntil
                                , courseDeregisterNoShow           = maybe False acfDeregisterNoShow cfAllocation
                                }
                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

                    let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ]
                     in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res

                    upsertAllocationCourse cid $ cfAllocation res
  
                    memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)

                    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
        }

upsertAllocationCourse :: CourseId -> Maybe AllocationCourseForm -> YesodJobDB UniWorX ()
upsertAllocationCourse cid = \case
  Just AllocationCourseForm{..} -> do
    prevAllocationCourse <- getBy $ UniqueAllocationCourse cid

    void $ upsert AllocationCourse
      { allocationCourseAllocation          =  acfAllocation
      , allocationCourseCourse              =  cid
      , allocationCourseMinCapacity         =  acfMinCapacity
      , allocationCourseAcceptSubstitutes   =  acfAcceptSubstitutes
      , allocationCourseOverrideSumCapacity = Nothing
      }
      [ AllocationCourseAllocation        =. acfAllocation
      , AllocationCourseCourse            =. cid
      , AllocationCourseMinCapacity       =. acfMinCapacity
      , AllocationCourseAcceptSubstitutes =. acfAcceptSubstitutes
      ]

    when (Just acfAllocation /= fmap (allocationCourseAllocation . entityVal) prevAllocationCourse) $
      queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid
  Nothing ->
    deleteWhere [ AllocationCourseCourse ==. cid ]
