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