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.Function ((&))

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

import Control.Monad.Trans.Writer (execWriterT)
import qualified Control.Monad.State.Class as State

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

import Jobs.Queue

import Handler.Course.LecturerInvite

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

import qualified Data.Conduit.List as C


data CourseForm = CourseForm
        { cfCourseId    :: Maybe CourseId
        , cfName        :: CourseName
        , cfShort       :: CourseShorthand
        , cfSchool      :: SchoolId
        , cfTerm        :: TermId
        , cfDesc        :: Maybe Html
        , cfLink        :: Maybe Text
        , cfMatFree     :: Bool
        , cfAllocation  :: Maybe AllocationCourseForm
        , cfAppRequired         :: Bool
        , cfAppInstructions     :: Maybe Html
        , cfAppInstructionFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
        , 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
  }

courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> Maybe (Entity AllocationCourse) -> CourseForm
courseToForm (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 <$> alloc
    , cfAppRequired         = courseApplicationsRequired
    , cfAppInstructions     = courseApplicationsInstructions
    , cfAppInstructionFiles
    , cfAppText             = courseApplicationsText
    , cfAppFiles            = courseApplicationsFiles
    , cfAppRatingsVisible   = courseApplicationsRatingsVisible
    , 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 (Left . E.unValue)
      where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do
              E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
              return $ courseAppInstructionFile E.^. CourseAppInstructionFileFile
      

allocationCourseToForm :: Entity AllocationCourse -> AllocationCourseForm
allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
  { acfAllocation = allocationCourseAllocation
  , acfMinCapacity = allocationCourseMinCapacity
  }

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

    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 = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools

    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 -> liftHandler $ 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 $ liftHandler . 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} <- 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 <- messageI Warning 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

        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 <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
            return ( (Just . toMidnight     . termStart . entityVal) <$> mbLastTerm
                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm
                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm )

    let
      allocationForm :: AForm Handler (Maybe AllocationCourseForm)
      allocationForm = wFormToAForm $ do
        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_ $ term E.^. TermActive
               E.||. alreadyParticipates
               E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools
          return (allocation, alreadyParticipates)

        now <- liftIO getCurrentTime
        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
              userAdmin = not $ null adminSchools
              mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable
              
              allocationForm' =
                let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
                    ainp
                      | mayChange
                      = apreq
                      | otherwise
                      = aforcedJust
                 in AllocationCourseForm
                    <$> ainp (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation)
                    <*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation)

            optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template)

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

    (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
      <$> pure (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)
      <*> areq (schoolFieldFor userSchools)   (fslI MsgCourseSchool)    (cfSchool     <$> template)
      <*> areq termsField                     (fslI MsgCourseSemester)  (cfTerm       <$> template)
      <*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder)
                         & setTooltip MsgCourseDescriptionTip)          (cfDesc       <$> template)
      <*> aopt (urlField & cfStrip) (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder))
                                                                        (cfLink       <$> template)
      <*> apopt checkBoxField  (fslI  MsgMaterialFree)                   (cfMatFree    <$> template)
      <*  aformSection MsgCourseFormSectionRegistration
      <*> allocationForm
      <*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template)
      <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template))
      <*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template)
      <*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template)
      <*> uploadModeForm (cfAppFiles <$> template)
      <*> 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 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)
      <*  aformSection MsgCourseFormSectionAdministration
      <*> lecturerForm
    return (result, widget)


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

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

  oldAllocatedCapacity <- fmap join . for cfCourseId $ \cid -> lift $ do
    prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
    prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse

    fmap join . for prevAllocation $ \Allocation{allocationStaffAllocationTo, allocationRegisterByCourse} -> if
      | userAdmin
        -> return Nothing
      | NTop allocationStaffAllocationTo <= NTop (Just now)
      , NTop allocationRegisterByCourse > NTop (Just now)
        -> Just . courseCapacity <$> getJust cid
      | otherwise
        -> return Nothing

  guardValidation MsgCourseRegistrationEndMustBeAfterStart
    $ NTop cfRegFrom <= NTop cfRegTo
  guardValidation MsgCourseDeregistrationEndMustBeAfterStart
    $ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil
  unless userAdmin $
    guardValidation MsgCourseUserMustBeLecturer
      $ anyOf (traverse . _Right . _1) (== uid) cfLecturers
  guardValidation MsgCourseAllocationRequiresCapacity
    $ is _Nothing cfAllocation || is _Just cfCapacity
  guardValidation MsgCourseAllocationTermMustMatch
    $ maybe True (== cfTerm) allocationTerm
  guardValidation MsgCourseAllocationCapacityMayNotBeChanged
    $ maybe True (== cfCapacity) oldAllocatedCapacity

  warnValidation MsgCourseShorthandTooLong
    $ length (CI.original cfShort) <= 10
  

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
                                , courseRegisterFrom               = cfRegFrom
                                , courseRegisterTo                 = cfRegTo
                                , courseDeregisterUntil            = cfDeRegUntil
                                }
            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
            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 <- 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
                                , courseRegisterFrom               = cfRegFrom
                                , courseRegisterTo                 = cfRegTo
                                , courseDeregisterUntil            = cfDeRegUntil
                                }
                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
                      finsert val = do
                        fId <- lift $ either return insert val
                        tell $ Set.singleton fId
                        lift $
                          void . insertUnique $ CourseAppInstructionFile cid fId
                    keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert
                    acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] []
                    mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs

                    upsertAllocationCourse cid $ cfAllocation res

                    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 :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
upsertAllocationCourse cid cfAllocation = do
  now <- liftIO getCurrentTime
  Course{..} <- getJust cid
  prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
  prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
  userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)

  doEdit <- if
    | userAdmin
      -> return True
    | Just Allocation{allocationStaffRegisterTo} <- prevAllocation
    , NTop allocationStaffRegisterTo <= NTop (Just now)
      -> let anyChanges
               | Just AllocationCourseForm{..} <- cfAllocation
               , Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse
               = or [ acfAllocation  /= allocationCourseAllocation
                    , acfMinCapacity /= allocationCourseMinCapacity
                    ]
               | otherwise
               = True
          in False <$ when anyChanges (addMessageI Error MsgAllocationStaffRegisterToExpired)
    | otherwise
      -> return True

  when doEdit $
    case cfAllocation of
      Just AllocationCourseForm{..} ->
        void $ upsert AllocationCourse
          { allocationCourseAllocation  =  acfAllocation
          , allocationCourseCourse      =  cid
          , allocationCourseMinCapacity =  acfMinCapacity
          }
          [ AllocationCourseAllocation  =. acfAllocation
          , AllocationCourseCourse      =. cid
          , AllocationCourseMinCapacity =. acfMinCapacity
          ]
      Nothing
        | Just (Entity prevId _) <- prevAllocationCourse
          -> delete prevId
      _other -> return ()
