fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(exam-correct): request refactor and handling of sent uuids

Browse Source
This commit is contained in:
Sarah Vaupel 2020-01-21 16:45:47 +01:00
parent d8a080d74d
commit 4a36a010f4
1 changed files with 32 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
src/Handler/Exam/Correct.hs
View File

@ -5,7 +5,8 @@ module Handler.Exam.Correct
import Import import Import
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI (original) import qualified Data.CaseInsensitive as CI
import qualified Data.Aeson as JSON
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
@ -46,19 +47,20 @@ deriveJSON defaultOptions
, fieldLabelModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1
, sumEncoding = TaggedObject "status" "results" , sumEncoding = TaggedObject "status" "results"
} ''CorrectInterfaceResponse } ''CorrectInterfaceResponse
-- E.g.: { "status": "success", "user-ident": "Max Musterstudent", "user-matrikelnummer": "123", "results": { "1a": null, "2a": 7, "2c3.5": 12 } }
data CorrectInterfaceRequest data CorrectInterfaceRequest
= CorrectInterfaceRequest = CorrectInterfaceRequest
{ ciqName :: Text { ciqUser :: Either Text (CryptoID UUID (Key User))
, ciqResults :: Map ExamPartNumber (Maybe Points) , ciqResults :: Maybe (NonNull (Map ExamPartNumber (Maybe Points)))
, ciqOp :: Bool -- not no-op
} }
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 instance FromJSON CorrectInterfaceRequest where
} ''CorrectInterfaceRequest parseJSON = JSON.withObject "CorrectInterfaceRequest" $ \o -> do
-- E.g.: { "name": "max", "results": { "1a": null, "2c3.5": 9001.2 }} 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 :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getECorrectR tid ssh csh examn = do getECorrectR tid ssh csh examn = do
@ -90,22 +92,30 @@ postECorrectR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Vo
postECorrectR tid ssh csh examn = do postECorrectR tid ssh csh examn = do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
CorrectInterfaceRequest{ciqName,ciqResults,ciqOp} <- requireCheckJsonBody CorrectInterfaceRequest{ciqUser,ciqResults} <- requireCheckJsonBody
response <- runDB $ do response <- runDB $ do
Entity eId _ <- fetchExam tid ssh csh examn Entity eId _ <- fetchExam tid ssh csh examn
euid <- traverse decrypt ciqUser
participantMatches <- E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do participantMatches <- E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
E.where_ $ user E.^. UserMatrikelnummer E.==. E.val (Just ciqName)
E.||. user E.^. UserMatrikelnummer `E.hasInfix` E.val (Just ciqName) let
E.||. user E.^. UserSurname E.==. E.val ciqName uidMatch = either (const $ E.val False) (\uid -> user E.^. UserId E.==. E.val uid) euid
E.||. user E.^. UserSurname `E.hasInfix` E.val ciqName mUserIdent = euid ^? _Left
E.||. user E.^. UserFirstName E.==. E.val ciqName E.where_ $ uidMatch
E.||. user E.^. UserFirstName `E.hasInfix` E.val ciqName E.||. user E.^. UserMatrikelnummer E.==. E.val mUserIdent
E.||. user E.^. UserDisplayName E.==. E.val ciqName E.||. user E.^. UserMatrikelnummer `E.hasInfix` E.val mUserIdent
E.||. user E.^. UserDisplayName `E.hasInfix` E.val ciqName 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 return user
let let
@ -120,16 +130,16 @@ postECorrectR tid ssh csh examn = do
if if
-- on no-op request, answer with 200 and a set of all participant matches -- on no-op request, answer with 200 and a set of all participant matches
| not ciqOp -> do | is _Nothing ciqResults -> do
users <- traverse userToResponse participantMatches users <- traverse userToResponse participantMatches
return CorrectInterfaceResponseNoOp return CorrectInterfaceResponseNoOp
{ cirnUsers = Set.fromList users { cirnUsers = Set.fromList users
} }
-- on match with exactly one exam participant, insert results and answer with 200 -- on match with exactly one exam participant, insert results and answer with 200
| [match@(Entity uid _)] <- participantMatches -> do | [match@(Entity uid _)] <- participantMatches, Just results <- ciqResults -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
newExamPartResults <- iforM ciqResults $ \partNumber mPartResult -> do newExamPartResults <- iforM (toNullable results) $ \partNumber mPartResult -> do
examPartId <- getKeyBy404 $ UniqueExamPartNumber eId partNumber examPartId <- getKeyBy404 $ UniqueExamPartNumber eId partNumber
mOldResult <- getBy $ UniqueExamPartResult examPartId uid mOldResult <- getBy $ UniqueExamPartResult examPartId uid
if if