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


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 ((>= 3) . 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
            Nothing -> E.val False)
      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 participantMatches
        return CorrectInterfaceResponseNoOp
          { cirnUsers = Set.fromList users
          }

      -- 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 participantMatches
        return CorrectInterfaceResponseAmbiguous
          { ciraMessage = mr MsgExamCorrectErrorMultipleMatchingParticipants
          , ciraUsers   = Set.fromList users
          }
  
  let
    responseStatus = case response of
      CorrectInterfaceResponseSuccess{} -> ok200
      CorrectInterfaceResponseNoOp{}    -> ok200
      _                                 -> badRequest400

  whenM acceptsJson $
    sendResponseStatus responseStatus $ toJSON response
  
  redirect $ CExamR tid ssh csh examn EShowR