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

{-# LANGUAGE TypeApplications #-}

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

import Import

import Utils.Form
import Utils.Print
import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Tutorial
import Database.Persist.Sql (deleteWhereCount)

import qualified Data.CaseInsensitive as CI

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 Handler.Course.Users


data TutorialUserAction
  = 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
    { tuQualification :: QualificationId    
    }  
  | TutorialUserRenewQualificationData
    { tuQualification :: QualificationId }
  | TutorialUserGrantQualificationData
    { tuQualification :: QualificationId
    , tuValidUntil    :: Day
    }    
  | TutorialUserSendMailData
  | TutorialUserDeregisterData{}
  deriving (Eq, Ord, Read, Show, Generic)


getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler TypedContent
getTUsersR = postTUsersR
postTUsersR tid ssh csh tutn = do  
  (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn    
    qualifications <- getCourseQualifications cid
    now <- liftIO getCurrentTime
    let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications)  -- no instance Ord CalendarDiffDays        
        dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur
        colChoices  = mconcat $ catMaybes
          [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR          
          , pure  colUserEmail
          , pure  colUserMatriclenr
          , pure  colUserQualifications
          , pure  colUserQualificationBlocked
          ]
        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"]
    
    let      
      qualOpt :: Entity Qualification -> Handler (Option QualificationId)
      qualOpt (Entity qualId qual) = do
        cQualId :: CryptoUUIDQualification <- encrypt qualId
        return $ Option
          { optionDisplay       = CI.original $ qualificationName qual
          , optionInternalValue = qualId
          , optionExternalValue = tshow cQualId
          }
      acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
      acts = Map.fromList $
        (if null qualifications then mempty else
          [ ( TutorialUserPrintQualification
            , TutorialUserPrintQualificationData
              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing            
            )
          , ( TutorialUserRenewQualification
            , TutorialUserRenewQualificationData
              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing            
            )
          , ( TutorialUserGrantQualification
            , TutorialUserGrantQualificationData
              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
              <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
            )                     
          ] 
        ) ++
        [ ( TutorialUserSendMail, pure TutorialUserSendMailData )
        , ( TutorialUserDeregister, pure TutorialUserDeregisterData )
        ]
    table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices)
    return (tutEnt, table, qualifications)

  let courseQids = Set.fromList (entityKey <$> qualifications)
  tcontent <- formResultMaybe participantRes $ \case
    (TutorialUserPrintQualificationData{..}, selectedUsers)
      | tuQualification `Set.member` courseQids -> 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 -- TODO: better error message
          Just aletter -> do             
            now <- liftIO getCurrentTime
            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)
      | tuQualification `Set.member` courseQids -> do
        -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
        today <- utctDay <$> liftIO getCurrentTime
        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
        addMessageI  (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
        redirect $ CTutorialR tid ssh csh tutn TUsersR
    (TutorialUserRenewQualificationData{..}, selectedUsers)
      | tuQualification `Set.member` courseQids -> do
        noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers      
        addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
        redirect $ CTutorialR tid ssh csh tutn TUsersR
    (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
        redirect $ CTutorialR tid ssh csh tutn TUsersR
    _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
  
  case tcontent of 
    Just act -> act -- abort and return produced content
    Nothing -> do
      tutors <- runDB $ 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

      let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
      html <- siteLayoutMsg heading $ do
        setTitleI heading
        $(widgetFile "tutorial-participants")
      return $ toTypedContent html