fradrive/src/Handler/Exam/Correct.hs

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

import Import

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

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

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


data CorrectInterfaceUser
  = CorrectInterfaceUser
    { ciuSurname     :: Text
    , ciuDisplayName :: Text
    , ciuMatNr       :: Maybe UserMatriculation
    , ciuId          :: CryptoUUIDUser
    } deriving (Eq,Ord)
deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''CorrectInterfaceUser

data CorrectInterfaceResponse
  = CorrectInterfaceResponseSuccess
    { cirsUser       :: CorrectInterfaceUser
    , cirsResults    :: Map ExamPartNumber (Maybe Points)
    , cirsTime       :: UTCTime
    }
  | CorrectInterfaceResponseAmbiguous
    { ciraUsers      :: Set CorrectInterfaceUser
    , ciraMessage    :: Text
    }
  | CorrectInterfaceResponseFailure
    { cirfMessage    :: Text
    }
  | CorrectInterfaceResponseNoOp
    { cirnUsers      :: Set CorrectInterfaceUser
    }
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 3
  , fieldLabelModifier     = camelToPathPiece' 1
  , sumEncoding            = TaggedObject "status" "results"
  } ''CorrectInterfaceResponse

data CorrectInterfaceRequest
  = CorrectInterfaceRequest
    { ciqUser        :: Either Text (CryptoID UUID (Key User))
    , ciqResults     :: Maybe (NonNull (Map ExamPartNumber (Maybe Points)))
    }

instance FromJSON CorrectInterfaceRequest where
  parseJSON = JSON.withObject "CorrectInterfaceRequest" $ \o -> do
    ciqUser <- Right <$> o JSON..: "user" <|> Left <$> o JSON..: "user"
    results <- o JSON..:? "results"
    ciqResults <- for results $ maybe (fail "Results may not be nullable") return . fromNullable
    return CorrectInterfaceRequest{..}


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

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

    examCorrectIdent = intercalate "-" [toPathPiece tid, toPathPiece ssh, toPathPiece csh, toPathPiece examn]

  siteLayoutMsg heading $ do
    setTitleI heading
    $(widgetFile "exam-correct")


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

  CorrectInterfaceRequest{ciqUser,ciqResults} <- requireCheckJsonBody

  response <- runDB $ do
    Entity eId _ <- fetchExam tid ssh csh examn
    euid <- traverse decrypt ciqUser

    participantMatches <- 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.||. user E.^. UserMatrikelnummer E.==. E.val mUserIdent
           E.||. user E.^. UserMatrikelnummer `E.hasInfix` E.val mUserIdent
           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
            Nothing -> E.val False)
      return user

    let
      userToResponse (Entity uid User{..}) = do
        uuid <- encrypt uid
        return CorrectInterfaceUser
          { ciuSurname     = userSurname
          , ciuDisplayName = userDisplayName
          , ciuMatNr       = userMatrikelnummer
          , ciuId          = uuid
          }

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

      -- on match with exactly one exam participant, insert results and answer with 200
      | [match@(Entity uid _)] <- participantMatches, Just results <- ciqResults -> do
        now <- liftIO getCurrentTime
        newExamPartResults <- iforM (toNullable results) $ \partNumber mPartResult -> do
            examPartId <- getKeyBy404 $ UniqueExamPartNumber eId partNumber
            mOldResult <- getBy $ UniqueExamPartResult examPartId uid
            if
              | Just (Entity oldId _) <- mOldResult, is _Nothing mPartResult -> do
                delete oldId
                audit $ TransactionExamPartResultDeleted examPartId uid
                return Nothing
              | Just partResult <- mPartResult -> let
                  mOld = (examPartResultResult . entityVal) <$> mOldResult
                  mNew = ExamAttended <$> mPartResult
                  resultVal = _entityVal . _examPartResultResult . _ExamAttended
                in if
                  | mOld /= mNew -> do
                    newExamPartResult <- upsert ExamPartResult
                      { examPartResultExamPart    = examPartId
                      , examPartResultUser        = uid
                      , examPartResultResult      = ExamAttended partResult
                      , examPartResultLastChanged = now
                      }
                      [ ExamPartResultResult      =. ExamAttended partResult
                      , ExamPartResultLastChanged =. now
                      ]
                    audit $ TransactionExamPartResultEdit examPartId uid
                    return $ newExamPartResult ^? resultVal
                  | otherwise -> return $ mOldResult ^? _Just . resultVal
                | otherwise -> return Nothing
        user <- userToResponse match
        return CorrectInterfaceResponseSuccess
          { cirsUser    = user
          , cirsResults = newExamPartResults
          , cirsTime    = now
          }

      -- on match with no exam participant, answer with 400
      | [] <- participantMatches -> return CorrectInterfaceResponseFailure
        { 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