fradrive/src/Handler/Tutorial/Users.hs

-- SPDX-FileCopyrightText: 2022-23 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 #-}

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
  | 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
  isAdmin <- hasReadAccessTo AdminR
  (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 nowaday = utctDay now
        minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications  -- no instance Ord CalendarDiffDays
        dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur
        colChoices  = mconcat $ catMaybes
          [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
          , pure   colUserEmail
          , pure $ colUserMatriclenr isAdmin
          , pure $ colUserQualifications nowaday
          , pure $ colUserQualificationBlocked isAdmin nowaday
          ]
        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
    let
      acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
      acts = Map.fromList $
        (if null qualifications then mempty else
          [ ( TutorialUserRenewQualification
            , TutorialUserRenewQualificationData
              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
            )
          , ( TutorialUserGrantQualification
            , TutorialUserGrantQualificationData
              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
              <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
            )
          ]
        ) ++
        [ ( TutorialUserSendMail          , pure TutorialUserSendMailData           )
        , ( TutorialUserDeregister        , pure TutorialUserDeregisterData         )
        , ( TutorialUserPrintQualification, pure TutorialUserPrintQualificationData )
        ]
    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) -> 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 <- liftIO getCurrentTime
        let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
        runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
        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 Nothing Nothing $ 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