246 lines
10 KiB
Haskell
246 lines
10 KiB
Haskell
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 ExamResultPoints)
|
|
, cirsGrade :: Maybe ExamResultPassedGrade
|
|
, 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)))
|
|
, ciqGrade :: Maybe ExamResultPassedGrade
|
|
}
|
|
|
|
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
|
|
ciqGrade <- o JSON..:? "grade"
|
|
return CorrectInterfaceRequest{..}
|
|
|
|
|
|
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)
|
|
|
|
-- TODO submit exam results: work in progress
|
|
-- mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR
|
|
let mayEditResults = False
|
|
|
|
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
|
|
|
|
response <- runDB $ do
|
|
Entity eId Exam{..} <- 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, 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{..}) <- getBy404 $ 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
|
|
in if
|
|
| mOld /= mNew -> let
|
|
-- cut off part results that exceed the maximum number of points for this exam part for now
|
|
-- TODO answer with new failure response type instead
|
|
partResult' = if
|
|
| Just maxPts <- examPartMaxPoints, maxPts < partResult -> maxPts
|
|
| otherwise -> partResult
|
|
in 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
|
|
| otherwise -> return mempty
|
|
|
|
newExamResult <- do
|
|
mOldResult <- getBy $ UniqueExamResult eId uid
|
|
if
|
|
| Just (Entity oldId _) <- mOldResult, is _Nothing ciqGrade -> do
|
|
delete oldId
|
|
audit $ TransactionExamResultDeleted eId uid
|
|
return Nothing
|
|
| Just result <- ciqGrade -> let
|
|
mOld = view passedGrade . examResultResult . entityVal <$> mOldResult
|
|
resultGrade = review passedGrade result
|
|
passedGrade :: Iso' ExamResultGrade ExamResultPassedGrade
|
|
passedGrade = iso (fmap $ bool (Left . view passingGrade) Right examShowGrades) (fmap $ either (review passingGrade) id)
|
|
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 . passedGrade
|
|
| otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult . passedGrade
|
|
| 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
|
|
{ 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
|