-- 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 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.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 Html
getTUsersR = postTUsersR
postTUsersR tid ssh csh tutn = do
  showSex <- getShowSex
  (Entity tutid Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    tut@(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
          , guardOn showSex colUserSex'
          , 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 (tut, table, qualifications)

  let courseQids = Set.fromList (entityKey <$> qualifications)
  formResult participantRes $ \case
    (TutorialUserPrintQualificationData{..}, _selectedUsers)
      | tuQualification `Set.member` courseQids -> do
        -- TODO Continue here
        addMessageI Error MsgErrorUnknownFormAction
    (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
  
  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
  siteLayoutMsg heading $ do
    setTitleI heading
    $(widgetFile "tutorial-participants")