-- SPDX-FileCopyrightText: 2022-2025 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE TypeApplications, BlockArguments #-}


module Handler.Tutorial.Users
  ( getTUsersR, postTUsersR
  , getTExamR, postTExamR
  ) where

import Import
import Control.Monad.Zip (munzip)

import Utils.Form
import Utils.Print
import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Course.Cache
import Handler.Utils.Tutorial
import Handler.Exam.Form (ExamOccurrenceForm(..), examOccurrenceMultiForm, upsertExamOccurrences, copyExamOccurrences)
import Database.Persist.Sql (deleteWhereCount)

import qualified Data.CaseInsensitive as CI

-- import qualified Data.Text as Text
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as LBS
-- import qualified Data.Time.Zones as TZ

import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils        as E

import Handler.Course.Users


data TutorialUserAction
  = TutorialUserAssignExam
  | TutorialUserPrintQualification
  | TutorialUserRenewQualification
  | TutorialUserGrantQualification
  | TutorialUserSendMail
  | TutorialUserDeregister
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

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

data TutorialUserActionData
  = TutorialUserPrintQualificationData
  | TutorialUserRenewQualificationData
    { tuQualification :: QualificationId }
  | TutorialUserGrantQualificationData
    { tuQualification :: QualificationId
    , tuValidUntil    :: Maybe Day
    }
  | TutorialUserSendMailData
  | TutorialUserDeregisterData
  | TutorialUserAssignExamData
    { tuOccurrenceId  :: ExamOccurrenceId
    , tuExaminerAgain :: Bool
    , tuReassign      :: Bool
    }
  deriving (Eq, Ord, Read, Show, Generic)

-- non-table form for general tutorial actions
data GenTutAction
  = GenTutActShowExam
  | GenTutActOccCopyWeek
  | GenTutActOccCopyLast
  | GenTutActOccEdit
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)

nullaryPathPiece ''GenTutAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''GenTutAction id

data GenTutActionData = GenTutActionData { gtaAct :: GenTutAction, gtaExam :: ExamId }
  deriving (Eq, Ord, Show, Generic)

-- mkGenTutForm :: [Filter Exam] -> Form GenTutActionData
-- mkGenTutForm fltr = renderAForm FormStandard maa
--   where
--     maa = multiActionA acts (fslI MsgCourseExam) Nothing

--     acts :: Map GenTutAction (AForm Handler GenTutActionData)
--     acts = Map.fromList
--             [ (GenTutActOccCopy, GenTutActOccCopyData <$> areq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing)
--             , (GenTutActOccEdit, GenTutActOccEditData <$> aopt (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing)
--             ]
mkGenTutForm :: [Filter Exam] -> Form GenTutActionData
mkGenTutForm fltr html = do
  (actRes, actView) <- mreq (selectFieldList ((\a->(a,a)) <$> universeF))              (fslI MsgCourseExam) Nothing
  (exmRes, exmView) <- mreq (examFieldFilter (Just $ SomeMessage MsgMenuExamNew) fltr) (fslI MsgCourseExam) Nothing
  let res :: FormResult GenTutAction -> FormResult ExamId -> FormResult GenTutActionData
      res (FormSuccess gta) (FormSuccess eid) = FormSuccess $ GenTutActionData{gtaAct=gta, gtaExam=eid}
      res (FormFailure e1) (FormFailure e2) = FormFailure $ e1 <> e2
      res (FormFailure e) _ = FormFailure e
      res _ (FormFailure e) = FormFailure e
      res _ _ = FormMissing
      viw = [whamlet|
              <p>
                #{html}^{fvInput actView} _{MsgFor} ^{fvInput exmView}
            |]
  return (res actRes exmRes, viw)


getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
getTUsersR = postTUsersR
postTUsersR tid ssh csh tutn = do
  let heading = prependCourseTitle tid ssh csh $ CI.original tutn
      croute  = CTutorialR tid ssh csh tutn TUsersR
  now <- liftIO getCurrentTime
  let nowaday = utctDay now
  isAdmin <- hasReadAccessTo AdminR
  (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, dbegin, hasExams, exmFltr, exOccs) <- runDB do
    trm <- get404 tid
    -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    -- tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
    (cid, tutEnt@(Entity tutid _)) <- fetchCourseIdTutorial tid ssh csh tutn
    qualifications <- getCourseQualifications cid
    let dayExpiry = case nubOrd (mapMaybe qualificationValidDuration qualifications) of 
                      [oneDuration] -> Just $ Just $ computeNewValidDate qvd nowaday      -- suggest end day only if it is unique for all course qualifications
                      _             -> Nothing                                            -- using the minimum here causes confusion, better leave blank!                  
        colChoices  = mconcat $
          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
          , colUserEmail
          , colUserMatriclenr isAdmin
          ] <>
          [ colUserQualificationBlocked isAdmin nowaday q | q <- qualifications] <>
          [ colUserExamOccurrencesCheck tid ssh csh
          , colUserExams tid ssh csh
          ]
        psValidator = def
          & defaultSortingByName
          & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
          & restrictFilter  (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
        isInTut q = E.exists do
          tutorialParticipant <- E.from $ E.table @TutorialParticipant
          E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
               E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
        csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
        qualOptions = qualificationsOptionList qualifications
        lessons  = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
        timespan = lessonTimesSpan lessons
        (dbegin, dend) = munzip timespan
        tbegin = toMidnight . succ <$> dbegin
        tend   = toMidnight        <$> dend
        exmFltr = ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing]) ++ [ExamCourse ==. cid, ExamStart <=. tend]
    -- $logInfoS "ExamOccurrenceForm" [st|Exams from #{tshow tbegin} until #{tshow tend}.|]
    exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid -- :: ExamOccurrenceMap
    hasExams <- if null exOccs then exists exmFltr else pure True
    let
      acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
      acts = Map.fromList $
        bcons (not $ null exOccs)
            ( TutorialUserAssignExam
            , TutorialUserAssignExamData
                <$> apopt (selectField $ pure $ mkExamOccurrenceOptions exOccs) (fslI MsgCourseUserExamOccurrences) Nothing
                <*> apopt checkBoxField (fslI MsgCourseUserExamOccurrenceAgainExaminer) (Just False)
                <*> apopt checkBoxField (fslI MsgCourseUserExamOccurrenceOverride)      (Just False)
            ) $
        (if null qualifications then mempty else
          [ ( TutorialUserRenewQualification
            , TutorialUserRenewQualificationData
              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
            )
          , ( TutorialUserGrantQualification
            , TutorialUserGrantQualificationData
              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
              <*> aopt dayField (fslI MsgLmsQualificationValidUntil & setTooltip MsgTutorialUserGrantQualificationDateTooltip) dayExpiry
            )
          ]
        ) ++
        [ ( TutorialUserSendMail          , pure TutorialUserSendMailData           )
        , ( TutorialUserDeregister        , pure TutorialUserDeregisterData         )
        , ( TutorialUserPrintQualification, pure TutorialUserPrintQualificationData )
        ]
    table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices)
    return (tutEnt, table, qualifications, dbegin, hasExams, exmFltr, exOccs)

  let courseQids = entities2map qualifications
  tcontent <- formResultMaybe participantRes $ \case
    (TutorialUserPrintQualificationData, selectedUsers) -> do
        rcvr <- requireAuth
        encRcvr <- encrypt $ entityKey rcvr
        letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
        let mbAletter = anyone letters
        case mbAletter of
          Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- cannot really happen
          Just aletter -> do
            apcIdent <- letterApcIdent aletter encRcvr now
            let fName = letterFileName aletter
            renderLetters rcvr letters apcIdent >>= \case
              Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
              Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now)
                -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
                -- let typePDF :: ContentType
                --     typePDF = "application/pdf"
                -- sendResponse (typePDF, toContent pdf)
    (TutorialUserGrantQualificationData{..}, selectedUsers)
      | Just grantQual  <- Map.lookup tuQualification courseQids -> 
        case tuValidUntil <|> (flip computeNewValidDate nowaday <$> qualificationValidDuration grantQual) of        
          Nothing -> do -- TODO: change QualificationUser to have an optionnal validUntil for idefinitely valid qualifications
            addMessageI Error $ MsgTutorialUserGrantQualificationDateError $ qualificationShorthand grantQual
          (Just expiryDay) -> do               
            let qsh     = qualificationShorthand grantQual
                reason  = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
                selUsrs = Set.toList selectedUsers            
            expiryDayText <- formatTime SelFormatDate expiryDay
            nterm <- runDB $ do
              forM_ selUsrs $ upsertQualificationUser tuQualification now expiryDay Nothing reason
              terminateLms (LmsOrphanReasonManualGrant [st|bis #{expiryDayText}, #{reason}|]) tuQualification selUsrs            
            addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification qsh expiryDayText $ Set.size selectedUsers
            when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
            reloadKeepGetParams croute
    (TutorialUserRenewQualificationData{..}, selectedUsers)
      | Just grantQual  <- Map.lookup tuQualification courseQids -> do
        let qsh     = qualificationShorthand grantQual
            selUsrs = Set.toList selectedUsers            
        mr <- getMessageRender
        (noks,nterm) <- runDB $ (,)
          <$> renewValidQualificationUsers tuQualification Nothing Nothing selUsrs
          <*> terminateLms (LmsOrphanReasonManualGrant $ mr heading) tuQualification selUsrs
        addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification qsh noks
        when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm
        reloadKeepGetParams croute
    (TutorialUserSendMailData, selectedUsers) -> do
        cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
        redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
    (TutorialUserDeregisterData, selectedUsers) -> do
        nrDel <- runDB $ deleteWhereCount
          [ TutorialParticipantTutorial ==. tutid
          , TutorialParticipantUser <-. Set.toList selectedUsers
          ]
        addMessageI Success $ MsgTutorialUsersDeregistered nrDel
        reloadKeepGetParams croute
    (TutorialUserAssignExamData{..}, setSelectedUsers)
      | (Just (ExamOccurrence{..}, _, (eid,_))) <- Map.lookup tuOccurrenceId exOccs -> do
        assignRes <- runDB $ do
          (Set.toList &&& Set.size -> (selectedUsers, nr_usrs)) <- if -- remove duplicate examiners, if desired
            | isJust examOccurrenceExaminer && not tuExaminerAgain -> do
              conflictingUsers <- E.select $ do
                reg :& occ <- E.from $  E.table @ExamRegistration
                          `E.innerJoin` E.table @ExamOccurrence
                          `E.on` (\(reg :& occ) -> occ E.^. ExamOccurrenceId E.=?. reg E.^. ExamRegistrationOccurrence)
                E.where_ $ occ E.^. ExamOccurrenceExaminer E.==. E.val examOccurrenceExaminer
                  E.&&.    occ E.^. ExamOccurrenceExam     E.!=. E.val examOccurrenceExam
                  E.&&.   (reg E.^. ExamRegistrationUser `E.in_` E.vals setSelectedUsers)
                E.orderBy [E.asc $ reg E.^. ExamRegistrationUser]
                E.distinct $ pure $ reg E.^. ExamRegistrationUser
              return $ setSelectedUsers `Set.difference` Set.fromAscList (E.unValue <$> conflictingUsers)
            | otherwise -> return setSelectedUsers
          runExceptT $ do
            whenIsJust examOccurrenceCapacity $ \(fromIntegral -> totalCap) -> do
              usedCap <- lift $ count [ExamRegistrationOccurrence ==. Just tuOccurrenceId, ExamRegistrationUser /<-. selectedUsers]
              let remCap = totalCap - usedCap
              when (nr_usrs > remCap) $ throwE $ MsgExamRoomCapacityInsufficient remCap
            let regTemplate uid = ExamRegistration eid uid (Just tuOccurrenceId) now
            lift $ if tuReassign
              then putMany [regTemplate uid | uid <- selectedUsers] >> pure nr_usrs
              else forM selectedUsers (insertUnique . regTemplate) <&> (length . catMaybes)
        case assignRes of
          Left errm   -> do
            addMessageI Error errm
            return Nothing
          Right nrOk  -> do
            let total = Set.size setSelectedUsers
                allok = bool Warning Success $ nrOk == total
            addMessageI allok $ MsgTutorialUserExamAssignedFor nrOk total $ ciOriginal examOccurrenceName
            reloadKeepGetParams croute
    _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing

  case tcontent of
    Just act -> act -- execute action and return produced content (i.e. pdf)
    Nothing -> do   -- no table action content to return, continue normally
      let mkExamCreateBtn = linkButton mempty (msg2widget MsgMenuExamNew)  [BCIsButton, BCPrimary] $ SomeRoute $ CourseR tid ssh csh  CExamNewR
      ((gtaRes, gtaWgt), gtaEnctype) <- runFormPost . identifyForm ("FIDGeneralTutorialAction"::Text) $ mkGenTutForm exmFltr
      let gtaAnchor  = "general-tutorial-action-form" :: Text
          gtaRoute   = croute :#: gtaAnchor
          gtaForm    = wrapForm' BtnPerform gtaWgt FormSettings
                            { formMethod = POST
                            , formAction = Just . SomeRoute $ gtaRoute
                            , formEncoding = gtaEnctype
                            , formAttrs = []
                            , formSubmit = FormSubmit
                            , formAnchor = Just gtaAnchor
                            }
          copyAction eId step = case dbegin of
            Nothing  -> addMessageI Error MsgExamOccurrenceCopyNoStartDate
            Just dto ->
              let cfailure   = addMessageI Error    MsgExamOccurrenceCopyFail
                  csuccess n = addMessageI Success (MsgExamOccurrencesCopied n) >> reloadKeepGetParams croute
                  copyFrom dfrom = copyExamOccurrences eId dfrom dto <&> (toMaybe =<< (> 0))
                  step_dto = addDays (negate step) dto
              in  maybeM cfailure csuccess $
                    runDB $ firstJustM $ map copyFrom $ take 69 $ drop 1 [dto, step_dto..] -- search for up to 2 months / 1 year backwards
      formResult gtaRes $ \GenTutActionData{..} -> case gtaAct of
        GenTutActOccCopyWeek -> copyAction gtaExam 7
        GenTutActOccCopyLast -> copyAction gtaExam 1
        GenTutActOccEdit -> do
          Exam{examName=ename} <- runDBRead $ get404 gtaExam
          redirect $ CTutorialR tid ssh csh tutn $ TExamR ename
        GenTutActShowExam -> do
          Exam{examName=ename} <- runDBRead $ get404 gtaExam
          redirect (CExamR tid ssh csh ename EUsersR, [("exam-users-tutorial", toPathPiece tutn)])

      tutors <- runDBRead $ E.select do
                  (tutor :& user) <- E.from $ E.table @Tutor `E.innerJoin` E.table @User
                    `E.on` (\(tutor :& user) -> tutor E.^. TutorUser E.==. user E.^. UserId)
                  E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
                  return user
      --   $(i18nWidgetFile "exam-missing")
      html <- siteLayoutMsg heading do
        setTitleI heading
        $(widgetFile "tutorial-participants")
      return $ toTypedContent html


getTExamR, postTExamR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> ExamName -> Handler Html
getTExamR = postTExamR
postTExamR tid ssh csh tutn exmName = do
  let baseroute  = CTutorialR tid ssh csh tutn
  (Entity{entityKey=eId,entityVal=exm},exOccs) <- runDB do
    trm <- get404 tid
    (cid, tutEnt) <- fetchCourseIdTutorial tid ssh csh tutn
    exm <- getBy404 $ UniqueExam cid exmName
    let lessons  = occurringLessons trm $ tutEnt ^. _entityVal . _tutorialTime . _Wrapped'
        timespan = lessonTimesSpan lessons
        -- (fmap (toMidnight . succ) -> tbegin, fmap toMidnight -> tend) = munzip timespan
    -- exms <- selectList ([ExamCourse ==. cid, ExamStart <=. tend] ++ ([ExamEnd >=. tbegin] ||. [ExamEnd ==. Nothing])) [Asc ExamName]
    exOccs <- flip foldMapM timespan $ getDayExamOccurrences False ssh $ Just cid
    return (exm,exOccs)
  cueId :: CryptoUUIDExam <- encrypt eId
  let eid2eos = convertExamOccurrenceMap exOccs
      (cuEoIds, eos) = munzip $ Map.lookup eId eid2eos
      exOcForm = (,,)
        <$> areq             hiddenField  "" (Just cueId)
        <*> areq (mkSetField hiddenField) "" cuEoIds
        <*> examOccurrenceMultiForm eos
  ((eofRes, eofWgt), eofEnctype) <- runFormPost $ identifyForm FIDTutorialExamOccurrences $ renderAForm FormStandard exOcForm
  let eofForm = wrapForm eofWgt def{formEncoding = eofEnctype}
  formResult eofRes $ \(edCEId, edCEOIds, edOccs) -> do
    let ceoidsDelete = edCEOIds `Set.difference` setMapMaybe eofId edOccs
    $logInfoS "ExamOccurrenceEdit" [st|Exam-Edit: #{length edCEOIds} old occurrences, #{length ceoidsDelete} to delete, #{length $ Set.filter (isNothing . eofId) edOccs} to insert, #{length $ Set.filter (isJust . eofId) edOccs} to edit|]
    reId <- decrypt edCEId
    eoIdsDelete <- mapM decrypt $ Set.toList ceoidsDelete
    when (reId == eId) $ do
      (fromIntegral -> nrDel, nrUps) <- runDB $ (,)
        <$> deleteWhereCount [ExamOccurrenceExam ==. reId, ExamOccurrenceId <-. eoIdsDelete]
        <*> upsertExamOccurrences eId (Set.toList edOccs)
      let nr = nrUps + nrDel
          mstat = if nr > 0 then Success else Warning
      addMessageI mstat $ MsgExamOccurrencesEdited nrUps nrDel
      reload $ baseroute $ TExamR exmName

  let csh_tutn = csh <> "-" <> tutn -- hack to reuse prependCourseTitle
      heading = prependCourseTitle tid ssh csh_tutn $ MsgMenuTutorialExam exmName
  siteLayoutMsg heading do
    -- setTitle $ citext2Html exmName
    setTitleI heading
    [whamlet|
      <section>
        <h2>#{CI.original exmName}
        <p>#{examDescription exm}
      <section>
        ^{eofForm}
    |]