-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

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 Jobs.Queue

import Handler.Course.LecturerInvite


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
        , cfCapacity     :: Maybe Int
        , cfSecret       :: Maybe Text
        , cfRegFrom      :: Maybe UTCTime
        , cfRegTo        :: Maybe UTCTime
        , cfDeRegUntil   :: Maybe UTCTime
        , cfLecturers    :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
        }

makeLenses_ ''CourseForm

courseToForm :: Entity Course -> [Lecturer] -> Map 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
    , 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 ]
    }


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

    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
      <*> 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

  uid <- liftHandler requireAuthId
  userAdmin <- lift . hasWriteAccessTo $ SchoolR cfSchool SchoolEditR

  guardValidation MsgCourseVisibilityEndMustBeAfterStart
    $ NTop cfVisFrom <= NTop cfVisTo
  guardValidation MsgCourseRegistrationEndMustBeAfterStart
    $ NTop cfRegFrom <= NTop cfRegTo
  guardValidation MsgCourseDeregistrationEndMustBeAfterStart
    $ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
  unless userAdmin $ do
    guardValidation MsgCourseUserMustBeLecturer
      $ anyOf (traverse . _Right . _1) (== uid) cfLecturers

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


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 oldCourses of
        (oldTemplate:_) ->
            let newTemplate = courseToForm oldTemplate mempty mempty in
            return $ Just $ newTemplate
                { cfCourseId   = Nothing
                , cfTerm       = TermKey $ termFromRational 0 -- invalid, will be ignored; undefined won't work due to strictness
                , cfRegFrom    = Nothing
                , cfRegTo      = Nothing
                , cfDeRegUntil = 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
      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


-- | 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
    ((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
                                , courseVisibleFrom                = cfVisFrom
                                , courseVisibleTo                  = cfVisTo
                                , 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
              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
                                , courseVisibleFrom                = cfVisFrom
                                , courseVisibleTo                  = cfVisTo
                                , 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

                    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
        }
