155 lines
6.2 KiB
Haskell
155 lines
6.2 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
|
|
|
|
|
|
-- | 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 -- TODO rethink
|
|
|
|
-- | Maximum number of user matches to show. Also serves as an upper limit to the number of query results from user and/or ldap lookups.
|
|
maxCountUserMatches :: Integral a => a
|
|
maxCountUserMatches = 10
|
|
|
|
|
|
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 <- encrypt eeId :: Handler CryptoUUIDExternalExam
|
|
|
|
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 ((>= minNeedleLength) . length) $ euid ^? _Left) $
|
|
CorrectInterfaceResponseFailure Nothing <$> (getMessageRender <*> pure MsgExamCorrectErrorNeedleTooShort)
|
|
|
|
-- TODO additionally call guessUser if this query produces too few results
|
|
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)
|
|
E.limit $ maxCountUserMatches+1
|
|
return user
|
|
|
|
if
|
|
| is _Nothing ciqResults, is _Nothing ciqGrade -> do
|
|
users <- traverse userToResponse $ take maxCountUserMatches matches
|
|
return CorrectInterfaceResponseNoOp
|
|
{ cirnUsers = Set.fromList users
|
|
, cirnHasMore = length matches > maxCountUserMatches
|
|
}
|
|
| [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
|
|
let resultTime = maybe now id externalExamDefaultTime -- TODO add option to override default?
|
|
newResult <- upsert ExternalExamResult
|
|
{ externalExamResultExam = eeId
|
|
, externalExamResultUser = uid
|
|
, externalExamResultResult = resultGrade
|
|
, externalExamResultTime = resultTime
|
|
, externalExamResultLastChanged = now
|
|
}
|
|
[ ExternalExamResultResult =. resultGrade
|
|
, ExternalExamResultTime =. resultTime
|
|
, 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 $ take maxCountUserMatches matches
|
|
return CorrectInterfaceResponseAmbiguous
|
|
{ ciraUsers = Set.fromList users
|
|
, ciraHasMore = length matches > maxCountUserMatches
|
|
, ciraMessage = mr MsgExamCorrectErrorMultipleMatchingParticipants -- TODO use new msg
|
|
}
|
|
|
|
whenM acceptsJson $
|
|
sendResponseStatus (ciResponseStatus response) $ toJSON response
|
|
|
|
redirect $ EExamR tid ssh coursen examn EEShowR
|