161 lines
6.0 KiB
Haskell
161 lines
6.0 KiB
Haskell
module Handler.ExternalExam.Correct
|
|
( getEECorrectR, postEECorrectR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Persist.Sql (transactionUndo)
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.ExternalExam
|
|
|
|
import Utils.Exam
|
|
|
|
|
|
getEECorrectR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html
|
|
getEECorrectR tid ssh coursen examn = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
Entity _eeId ExternalExam{..} <- runDB $ fetchExternalExam tid ssh coursen examn
|
|
|
|
mayEditResults <- hasWriteAccessTo $ EExamR tid ssh coursen examn EEUsersR
|
|
|
|
let
|
|
heading = mr $ MsgExternalExamCorrectHeading coursen examn
|
|
|
|
ptsInput :: ExamPartNumber -> Widget
|
|
ptsInput = const mempty
|
|
|
|
examParts :: [ExamPart]
|
|
examParts = []
|
|
|
|
examGrades :: [ExamGrade]
|
|
examGrades = universeF
|
|
|
|
examGradingMode = externalExamGradingMode
|
|
|
|
examCorrectIdent :: Text
|
|
examCorrectIdent = "TODO" -- TODO fix below
|
|
|
|
-- examCorrectIdent <- encrypt eeId :: Handler (CryptoID UUID ExternalExamId)
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
let
|
|
examCorrectExplanation = $(i18nWidgetFile "external-exam-correct-explanation")
|
|
$(widgetFile "exam-correct")
|
|
|
|
|
|
postEECorrectR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Void
|
|
postEECorrectR tid ssh coursen examn = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
CorrectInterfaceRequest{..} <- requireCheckJsonBody
|
|
|
|
mayEditResults <- hasWriteAccessTo $ EExamR tid ssh coursen examn EEUsersR
|
|
|
|
response <- runDB . exceptT (<$ transactionUndo) return $ do
|
|
Entity eeId ExternalExam{..} <- lift $ fetchExternalExam tid ssh coursen examn
|
|
euid <- traverse decrypt ciqUser
|
|
|
|
guardMExceptT (maybe True ((>= 3) . length) $ euid ^? _Left) $ -- TODO rethink max needle length
|
|
CorrectInterfaceResponseFailure Nothing <$> (getMessageRender <*> pure MsgExamCorrectErrorNeedleTooShort)
|
|
|
|
matches <- lift . E.select . E.from $ \user -> do
|
|
let mUserIdent = euid ^? _Left
|
|
E.where_ $ either (const E.false) (\uid -> user E.^. UserId E.==. E.val uid) euid
|
|
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.false)
|
|
return user
|
|
|
|
let
|
|
userToResponse (Entity uid User{..}) = do -- TODO move to util
|
|
uuid <- encrypt uid
|
|
return CorrectInterfaceUser
|
|
{ ciuSurname = userSurname
|
|
, ciuDisplayName = userDisplayName
|
|
, ciuMatNr = userMatrikelnummer
|
|
, ciuId = uuid
|
|
}
|
|
|
|
if
|
|
| is _Nothing ciqResults, is _Nothing ciqGrade -> do
|
|
users <- traverse userToResponse matches
|
|
return CorrectInterfaceResponseNoOp
|
|
{ cirnUsers = Set.fromList users
|
|
}
|
|
| [match@(Entity uid _)] <- matches -> do
|
|
now <- liftIO getCurrentTime
|
|
newExamResult <- for ciqGrade $ \ciqGrade' -> lift $ do
|
|
unless mayEditResults $
|
|
permissionDeniedI MsgUnauthorizedExamCorrectorGrade
|
|
mOldResult <- getBy $ UniqueExternalExamResult eeId uid
|
|
if
|
|
| Just (Entity oldId _) <- mOldResult, is _Nothing ciqGrade' -> do
|
|
delete oldId
|
|
audit $ TransactionExternalExamResultDelete eeId uid
|
|
return Nothing
|
|
| Just resultGrade <- ciqGrade' -> let
|
|
mOld = externalExamResultResult . entityVal <$> mOldResult
|
|
in if
|
|
| ciqGrade' /= mOld -> do
|
|
newResult <- upsert ExternalExamResult
|
|
{ externalExamResultExam = eeId
|
|
, externalExamResultUser = uid
|
|
, externalExamResultResult = resultGrade
|
|
, externalExamResultTime = now -- TODO add and use utcTimeField
|
|
, externalExamResultLastChanged = now
|
|
}
|
|
[ ExternalExamResultResult =. resultGrade
|
|
, ExternalExamResultTime =. now -- TODO add and use utcTimeField
|
|
, ExternalExamResultLastChanged =. now
|
|
]
|
|
audit $ TransactionExternalExamResultEdit eeId uid
|
|
return $ newResult ^? _entityVal . _externalExamResultResult
|
|
| otherwise -> return $ mOldResult ^? _Just . _entityVal . _externalExamResultResult
|
|
| otherwise -> return Nothing
|
|
|
|
user <- userToResponse match
|
|
return CorrectInterfaceResponseSuccess
|
|
{ cirsUser = user
|
|
, cirsResults = mempty
|
|
, cirsGrade = newExamResult
|
|
, cirsTime = now
|
|
}
|
|
|
|
| [] <- matches -> return CorrectInterfaceResponseFailure
|
|
{ cirfUser = Nothing
|
|
, cirfMessage = mr MsgExamCorrectErrorNoMatchingParticipants -- TODO use new msg
|
|
}
|
|
|
|
| otherwise -> do
|
|
users <- traverse userToResponse matches
|
|
return CorrectInterfaceResponseAmbiguous
|
|
{ ciraUsers = Set.fromList users
|
|
, ciraMessage = mr MsgExamCorrectErrorMultipleMatchingParticipants -- TODO use new msg
|
|
}
|
|
|
|
let
|
|
responseStatus = case response of
|
|
CorrectInterfaceResponseSuccess{} -> ok200
|
|
CorrectInterfaceResponseNoOp{} -> ok200
|
|
_ -> badRequest400
|
|
|
|
whenM acceptsJson $
|
|
sendResponseStatus responseStatus $ toJSON response
|
|
|
|
redirect $ EExamR tid ssh coursen examn EEShowR
|