fradrive/src/Handler/Exam/Correct.hs

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

module Handler.Exam.Correct
  ( getECorrectR, postECorrectR
  ) where

import Import

import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import Database.Persist.Sql (transactionUndo)

import Handler.Utils
import Handler.Utils.Exam (fetchExam)

import Utils.Exam.Correct

{-# ANN module ("HLint: ignore Functor law" :: String) #-}

-- | Minimum length of a participant identifier. Identifiers that are shorter would result in too many query results and are therefor rejected.
minNeedleLength :: Int
minNeedleLength = 3

-- | Maximum number of participant matches to show. Also serves as an upper limit to the number of query results from participant lookups.
maxCountUserMatches :: Integral a => a
maxCountUserMatches = 10


getECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getECorrectR tid ssh csh examn = do
  MsgRenderer mr <- getMsgRenderer

  (Entity eId Exam{..}, examParts) <- runDB $ do
    exam@(Entity eId _) <- fetchExam tid ssh csh examn
    examParts <- sortOn (view $ _entityVal . _examPartNumber) <$> selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
    return (exam, entityVal <$> examParts)

  mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR

  let
    heading = prependCourseTitle tid ssh csh $ (mr . MsgExamCorrectHeading . CI.original) examName

    ptsInput :: ExamPartNumber -> Widget
    ptsInput n = do
      name <- newIdent
      fieldView (pointsField :: Field Handler Points) ("exam-correct__" <> toPathPiece n) name [("uw-exam-correct--part-input", toPathPiece n)] (Left "") False

    examGrades :: [ExamGrade]
    examGrades = universeF

  examCorrectIdent <- encrypt eId :: Handler CryptoUUIDExam

  siteLayoutMsg heading $ do
    setTitleI heading
    let examCorrectExplanation = $(i18nWidgetFile "exam-correct-explanation")
    $(widgetFile "exam-correct")


postECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Void
postECorrectR tid ssh csh examn = do
  MsgRenderer mr <- getMsgRenderer

  CorrectInterfaceRequest{..} <- requireCheckJsonBody

  mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR

  response <- runDB . exceptT (<$ transactionUndo) return $ do
    Entity eId Exam{} <- lift $ fetchExam tid ssh csh examn
    euid <- traverse decrypt ciqUser

    guardMExceptT (maybe True ((>= minNeedleLength) . length) $ euid ^? _Left) $
      CorrectInterfaceResponseFailure Nothing <$> (getMessageRender <*> pure MsgExamCorrectErrorNeedleTooShort)

    participantMatches <- lift . E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do
      E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
      E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId

      let
        uidMatch   = either (const $ E.val False) (\uid -> user E.^. UserId E.==. E.val uid) euid
        mUserIdent = euid ^? _Left
      E.where_ $ uidMatch
           E.||. (case mUserIdent of
            Just userIdent -> user E.^. UserSurname         E.==.         E.val  userIdent
                        E.||. user E.^. UserSurname         `E.hasInfix`  E.val  userIdent
                        E.||. user E.^. UserFirstName       E.==.         E.val  userIdent
                        E.||. user E.^. UserFirstName       `E.hasInfix`  E.val  userIdent
                        E.||. user E.^. UserDisplayName     E.==.         E.val  userIdent
                        E.||. user E.^. UserDisplayName     `E.hasInfix`  E.val  userIdent
                        E.||. user E.^. UserMatrikelnummer  E.==.         E.val mUserIdent
                        E.||. user E.^. UserMatrikelnummer  `E.hasInfix`  E.val mUserIdent
                        E.||. user E.^. UserEmail           E.==.         E.val (userIdent & CI.mk)
                        E.||. user E.^. UserDisplayEmail    E.==.         E.val (userIdent & CI.mk)
            Nothing -> E.val False)
      E.limit $ succ maxCountUserMatches
      return user

    if
      -- on no-op request, answer with 200 and a set of all participant matches
      | is _Nothing ciqResults, is _Nothing ciqGrade -> do
        users <- traverse userToResponse $ take maxCountUserMatches participantMatches
        return CorrectInterfaceResponseNoOp
          { cirnUsers   = Set.fromList users
          , cirnHasMore = length participantMatches > maxCountUserMatches
          }

      -- on match with exactly one exam participant, insert results and/or grade and answer with 200
      | [match@(Entity uid _)] <- participantMatches -> do
        now <- liftIO getCurrentTime
        newExamPartResults <- if
          | Just results <- ciqResults -> iforM (toNullable results) $ \partNumber mPartResult -> do
            (Entity examPartId ExamPart{..}) <- lift . getBy404 $ UniqueExamPartNumber eId partNumber
            mOldResult <- lift . getBy $ UniqueExamPartResult examPartId uid
            if
              | Just (Entity oldId _) <- mOldResult, is _Nothing mPartResult -> lift $ do
                delete oldId
                audit $ TransactionExamPartResultDeleted examPartId uid
                return Nothing
              | Just partResult <- mPartResult -> let
                  mOld = examPartResultResult . entityVal <$> mOldResult
                  mNew = ExamAttended <$> mPartResult
                  resultVal = _entityVal . _examPartResultResult
                in if
                  | mOld /= mNew -> do
                      let
                        partResultAcceptable = 0 <= partResult
                                            && maybe True (partResult <=) examPartMaxPoints
                      guardMExceptT partResultAcceptable $
                        let
                          msg | Just maxPoints <- examPartMaxPoints
                              = MsgExamCorrectErrorPartResultOutOfBoundsMax partNumber maxPoints
                              | otherwise
                              = MsgExamCorrectErrorPartResultOutOfBounds partNumber
                         in CorrectInterfaceResponseFailure
                              <$> (Just <$> userToResponse match)
                              <*> (getMessageRender <*> pure msg)

                      newExamPartResult <- lift $ upsert ExamPartResult
                        { examPartResultExamPart    = examPartId
                        , examPartResultUser        = uid
                        , examPartResultResult      = ExamAttended partResult
                        , examPartResultLastChanged = now
                        }
                        [ ExamPartResultResult      =. ExamAttended partResult
                        , ExamPartResultLastChanged =. now
                        ]
                      lift . audit $ TransactionExamPartResultEdit examPartId uid
                      return $ newExamPartResult ^? resultVal
                  | otherwise -> return $ mOldResult ^? _Just . resultVal
              | otherwise -> return Nothing
            | otherwise -> return mempty

        newExamResult <- for ciqGrade $ \ciqGrade' -> lift $ do
          unless mayEditResults $
            permissionDeniedI MsgUnauthorizedExamCorrectorGrade
          mOldResult <- getBy $ UniqueExamResult eId uid
          if
            | Just (Entity oldId _) <- mOldResult, is _Nothing ciqGrade' -> do
                delete oldId
                audit $ TransactionExamResultDeleted eId uid
                return Nothing
            | Just resultGrade <- ciqGrade' -> let
                mOld = examResultResult . entityVal <$> mOldResult
              in if
                | ciqGrade' /= mOld -> do
                  newResult <- upsert ExamResult
                    { examResultExam        =  eId
                    , examResultUser        =  uid
                    , examResultResult      =  resultGrade
                    , examResultLastChanged =  now
                    }
                    [ ExamResultResult      =. resultGrade
                    , ExamResultLastChanged =. now
                    ]
                  audit $ TransactionExamResultEdit eId uid
                  return $ newResult ^? _entityVal . _examResultResult
                | otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult
            | otherwise -> return Nothing

        user <- userToResponse match
        return CorrectInterfaceResponseSuccess
          { cirsUser    = user
          , cirsResults = newExamPartResults
          , cirsGrade   = newExamResult
          , cirsTime    = now
          }

      -- on match with no exam participant, answer with 400
      | [] <- participantMatches -> return CorrectInterfaceResponseFailure
        { cirfUser      = Nothing
        , cirfMessage   = mr MsgExamCorrectErrorNoMatchingParticipants
        }

      -- on match with multiple exam participants, answer with 400 and a set of all matches
      | otherwise -> do
        users <- traverse userToResponse $ take maxCountUserMatches participantMatches
        return CorrectInterfaceResponseAmbiguous
          { ciraMessage = mr MsgExamCorrectErrorMultipleMatchingParticipants
          , ciraHasMore = length participantMatches > maxCountUserMatches
          , ciraUsers   = Set.fromList users
          }

  whenM acceptsJson $
    sendResponseStatus (ciResponseStatus response) $ toJSON response

  redirect $ CExamR tid ssh csh examn EShowR