fradrive/src/Handler/Exam/Edit.hs

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

module Handler.Exam.Edit
  ( getEEditR, postEEditR
  ) where

import Import
import Handler.Exam.Form
import Handler.Exam.CorrectorInvite

import qualified Data.Set as Set

import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Invitations

import Jobs.Queue

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E


data ExamEditException
  = ExamEditExamNameTaken ExamName
  | ExamEditWouldBreakSheetTypeReference
  deriving (Eq, Ord, Read, Show, Generic)
  deriving anyclass (Exception)

embedRenderMessage ''UniWorX ''ExamEditException id


getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEEditR = postEEditR
postEEditR tid ssh csh examn = do
  (template, (editExamAct, (editExamWidget, editExamEnctype))) <- runDBJobs $ do
    (cid, exam@(Entity eId oldExam)) <- fetchCourseIdExam tid ssh csh examn
    course <- getEntity404 cid

    template <- examFormTemplate exam

    ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm course $ Just template

    editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> do
      res <- trySql @ExamEditException $ do
        examAuthorshipStatement <- traverse insertAuthorshipStatement efAuthorshipStatement
        insertRes <- myReplaceUnique eId Exam
          { examCourse           = cid
          , examName             = efName
          , examGradingRule      = efGradingRule
          , examBonusRule        = efBonusRule
          , examOccurrenceRule   = efOccurrenceRule
          , examExamOccurrenceMapping = examExamOccurrenceMapping oldExam
          , examVisibleFrom      = efVisibleFrom
          , examRegisterFrom     = efRegisterFrom
          , examRegisterTo       = efRegisterTo
          , examDeregisterUntil  = efDeregisterUntil
          , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
          , examStart            = efStart
          , examEnd              = efEnd
          , examFinished         = efFinished
          , examClosed           = examClosed oldExam
          , examPublicStatistics = efPublicStatistics
          , examGradingMode      = efGradingMode
          , examDescription      = efDescription
          , examExamMode         = efExamMode
          , examStaff            = efStaff
          , examPartsFrom        = efPartsFrom
          , examAuthorshipStatement
          }

        when (is _Just insertRes) $
          throwM $ ExamEditExamNameTaken efName

        occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId
        deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ]
        forM_ (Set.toList efOccurrences) $ \case
          ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
            ExamOccurrence
              { examOccurrenceExam = eId
              , examOccurrenceName = eofName
              , examOccurrenceExaminer = eofExaminer
              , examOccurrenceRoom = eofRoom
              , examOccurrenceRoomHidden = eofRoomHidden
              , examOccurrenceCapacity = eofCapacity
              , examOccurrenceStart = eofStart
              , examOccurrenceEnd = eofEnd
              , examOccurrenceDescription = eofDescription
              }
          ExamOccurrenceForm{ .. } -> void . runMaybeT $ do
            cID <- hoistMaybe eofId
            eofId' <- decrypt cID
            oldOcc <- MaybeT $ get eofId'
            guard $ examOccurrenceExam oldOcc == eId
            lift $ replace eofId' ExamOccurrence
              { examOccurrenceExam = eId
              , examOccurrenceName = eofName
              , examOccurrenceExaminer = eofExaminer
              , examOccurrenceRoom = eofRoom
              , examOccurrenceRoomHidden = eofRoomHidden
              , examOccurrenceCapacity = eofCapacity
              , examOccurrenceStart = eofStart
              , examOccurrenceEnd = eofEnd
              , examOccurrenceDescription = eofDescription
              }

        pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId

        brokenRefs <- E.selectExists . E.from $ \examPart -> do
          E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId
               E.&&. examPart E.^. ExamPartId `E.notIn` E.valList pIds
          E.where_ . E.exists . E.from $ \sheet -> do
            let
              sheetTypeExamPart :: E.SqlExpr (E.Value (Maybe Value))
              sheetTypeExamPart = sheet E.^. SheetType E.->. "exam-part"
              examPartId' :: E.SqlExpr (E.Value Value)
              examPartId' = E.explicitUnsafeCoerceSqlExprValue @Value "jsonb" . E.explicitUnsafeCoerceSqlExprValue @Text "text" $ examPart E.^. ExamPartId
            E.where_ $ E.maybe E.false (E.==. examPartId') sheetTypeExamPart

        when brokenRefs $
          throwM ExamEditWouldBreakSheetTypeReference

        deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ]
        forM_ (Set.toList efExamParts) $ \case
          ExamPartForm{ epfId = Nothing, .. } -> insert_
            ExamPart
              { examPartExam = eId
              , examPartNumber = epfNumber
              , examPartName = epfName
              , examPartMaxPoints = epfMaxPoints
              , examPartWeight = epfWeight
              }
          ExamPartForm{ .. } -> void . runMaybeT $ do
            cID <- hoistMaybe epfId
            epfId' <- decrypt cID
            oldPart <- MaybeT $ get epfId'
            guard $ examPartExam oldPart == eId
            lift $ replace epfId' ExamPart
              { examPartExam = eId
              , examPartNumber = epfNumber
              , examPartName = epfName
              , examPartMaxPoints = epfMaxPoints
              , examPartWeight = epfWeight
              }

        deleteWhere [ ExamOfficeSchoolExam ==. eId ]
        insertMany_ [ ExamOfficeSchool ssh' eId | ssh' <- Set.toList efOfficeSchools ]

        let (invites, adds) = partitionEithers $ Set.toList efCorrectors

        deleteWhere [ ExamCorrectorExam ==. eId ]
        insertMany_ $ map (ExamCorrector eId) adds
        memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId)
        memcachedInvalidateClass MemcachedKeyClassExamOccurrences

        deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
        sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites

        return insertRes

      return . Just $ case res of
        Left exc -> addMessageI Error exc
        Right _ -> do
          addMessageI Success $ MsgExamEdited efName
          redirect $ CExamR tid ssh csh efName EShowR

    return (template, (editExamAct, (editExamWidget, editExamEnctype)))

  sequence_ editExamAct

  let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template

  siteLayoutMsg heading $ do
    setTitleI heading
    let
      editExamForm = wrapForm editExamWidget def
        { formMethod = POST
        , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR
        , formEncoding = editExamEnctype
        }
    $(widgetFile "exam-edit")