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

import Import

import Utils.Lens
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 qualified Database.Esqueleto as E

import Jobs.Queue

import Handler.Course.LecturerInvite


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

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

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

    MsgRenderer mr <- getMsgRenderer

    uid <- liftHandlerT requireAuthId
    (lecSchools, admSchools) <- liftHandlerT . runDB $ (,)
      <$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
      <*> (map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. uid] [] )
    let userSchools = lecSchools ++ admSchools

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

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

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

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

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

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

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

        miIdent :: Text
        miIdent = "lecturers"


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

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

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

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


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

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

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

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

  let noTemplateAction = courseEditHandler' Nothing
  case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more!
    FormMissing      -> noTemplateAction
    FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
                        noTemplateAction
    FormSuccess (Nothing, Nothing, Nothing) -> noTemplateAction
    FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
      oldCourses <- runDB $
        E.select $ E.from $ \course -> do
          whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
          whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
          whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand  E.==. E.val csh
          let lecturersCourse =
                E.exists $ E.from $ \lecturer ->
                  E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
                      E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
          let lecturersSchool =
                E.exists $ E.from $ \user ->
                  E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
                      E.&&.  user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
          let courseCreated c =
                E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
                  E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
                  return $ E.min_ $ edit E.^. CourseEditTime
          E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
                    , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
                    , E.desc $ courseCreated course]                                     -- most recent created course
          E.limit 1
          return course
      template <- case listToMaybe oldCourses of
        (Just oldTemplate) ->
            let newTemplate = courseToForm oldTemplate [] [] in
            return $ Just $ newTemplate
                { cfCourseId   = Nothing
                , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
                , cfRegFrom    = Nothing
                , cfRegTo      = Nothing
                , cfDeRegUntil = Nothing
                }
        Nothing -> do
            (tidOk,sshOk,cshOk) <- runDB $ (,,)
                <$> ifMaybeM mbTid True existsKey
                <*> ifMaybeM mbSsh True existsKey
                <*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
            unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
            unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
            unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
            when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
            return Nothing
      courseEditHandler' template

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

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

pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
pgCEditR tid ssh csh = do
  courseData <- runDB $ do
      mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
      mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
      mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
      return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
  -- IMPORTANT: both GET and POST Handler must use the same template,
  --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData


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

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

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