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

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

import Import

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

import Handler.Course.Users


data TutorialUserAction
   = 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
   = 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)) <- runDB $ do
    tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
    qualifications <- selectList [QualificationSchool ==. ssh] []
    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   colUserName
          , guardOn showSex colUserSex'
          , pure  colUserEmail
          , pure  colUserMatriclenr
          , pure  colUserQualifications
          ]
        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 . E.from $ \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"]

    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    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
        [ ( 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)

  formResult participantRes $ \case
    (TutorialUserGrantQualificationData{..}, selectedUsers) -> do
      -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
      today <- utctDay <$> liftIO getCurrentTime
      runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
      addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
      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
  
  tutors <- runDB $
    E.select $ E.from $ \(tutor `E.InnerJoin` user) -> do
      E.on $ 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")