module Handler.Score where import Import import Handler.Shared import Handler.Tables import Control.Monad.Extra import Handler.AchievementUtils import qualified Database.Esqueleto as E import Database.Esqueleto ((^.)) import qualified Yesod.Table as Table import Data.Text as T getMyScoreR :: Handler Html getMyScoreR = do entUser <- requireAuth doScore entUser getScoreR :: UserId -> Handler Html getScoreR userId = do user <- runDB $ get404 userId doScore (Entity userId user) scoreTable :: Table.Table App (AchievementInfo, (Entity Submission, Bool)) scoreTable = mempty ++ Table.text "name" (achievementInfoName . fst) ++ achievementDescriptionCell fst ++ timestampCell "deadline" (achievementInfoDeadline . fst) ++ timestampCell "submitted" (submissionStamp . entityVal . fst . snd) ++ Table.linked "submission" (submissionDescription . entityVal . fst . snd) (EditSubmissionR . entityKey . fst . snd) ++ Table.text "status" getStatus extrasTable :: Table.Table App ExtraPoints extrasTable = mempty ++ Table.text "reason" extraPointsDescription ++ timestampCell "added" extraPointsPosted ++ Table.int "points" extraPointsPoints getStatus :: (AchievementInfo, (Entity Submission, Bool)) -> Text getStatus (_, (_, False)) = "" getStatus (aInfo, (_, True)) = T.pack $ show $ achievementInfoPoints aInfo getPoints :: (AchievementInfo, (Entity Submission, Bool)) -> Int getPoints (_, (_, False)) = 0 getPoints (aInfo, (_, True)) = achievementInfoPoints aInfo doScore :: Entity User -> Handler Html doScore userEnt@(Entity userId user) = do courses <- runDB $ selectList [CourseClosed ==. False] [Asc CourseName] courseUserInfos <- mapM (userScoreForCourse userEnt) courses let courseInfos = Import.filter (\(_, (points, _, _)) -> points > 0) $ Import.zip courses courseUserInfos defaultLayout $ do setTitle "Score" $(widgetFile "score") scoreForCourse (points, entries, extras) = $(widgetFile "score-for-course") userScoreForCourse :: Entity User -> Entity Course -> Handler (Int, [(AchievementInfo, (Entity Submission, Bool))], [ExtraPoints]) userScoreForCourse userEnt@(Entity userId user) courseEnt@(Entity courseId course) = do achievementEntries <- userAchievementsForCourse userEnt courseId let achievementTotal = sum $ Import.map getPoints achievementEntries extraEntries <- userExtraPointsForCourse userId courseId let extraTotal = sum $ Import.map extraPointsPoints extraEntries let total = achievementTotal + extraTotal return (total, achievementEntries, extraEntries) userExtraPointsForCourse :: UserId -> CourseId -> Handler [ExtraPoints] userExtraPointsForCourse userId courseId = do entries <- runDB $ selectList [ExtraPointsUser ==. userId, ExtraPointsCourse ==. courseId] [Asc ExtraPointsPosted] return $ Import.map entityVal entries userAchievementsForCourse :: Entity User -> CourseId -> Handler [(AchievementInfo, (Entity Submission, Bool))] userAchievementsForCourse (Entity userId user) courseId = do entries <- runDB $ E.select $ E.from $ \(working_on, achievement, submission) -> do E.where_ (working_on ^. WorkingOnAchievement E.==. achievement ^. AchievementId E.&&. E.just (submission ^. SubmissionId) E.==. working_on ^. WorkingOnFinalSubmission E.&&. working_on ^. WorkingOnUser E.==. E.val userId E.&&. achievement ^. AchievementCourse E.==. E.val courseId) E.orderBy [E.asc (submission ^. SubmissionStamp)] return (achievement, submission) entries' <- mapM (processEntry (Entity userId user)) entries return entries' processEntry :: Entity User -> (Entity Achievement, Entity Submission) -> Handler (AchievementInfo, (Entity Submission, Bool)) processEntry entUser (entAchievement, entSubmission) = do aInfo <- runDB $ getAchievementInfo (Just entUser) entAchievement accepted <- allM (checkSubmissionTag entSubmission) (achievementInfoTags aInfo) return (aInfo, (entSubmission, accepted)) checkSubmissionTag :: Entity Submission -> Entity Tag -> Handler Bool checkSubmissionTag (Entity submissionId _) (Entity tagId _) = do mSubmissionTag <- runDB $ getBy $ UniqueSubmissionTag submissionId tagId return $ case mSubmissionTag of Just (Entity _ submissionTag) -> case submissionTagAccepted submissionTag of Just b -> b Nothing -> False Nothing -> False courseSummary :: Entity Course -> Widget courseSummary entCourse@(Entity courseId course) = do students <- handlerToWidget $ runDB $ E.select $ E.from $ \(participant, user) -> do E.where_ (participant ^. ParticipantCourse E.==. E.val courseId E.&&. participant ^. ParticipantUser E.==. user ^. UserId) E.orderBy [E.asc (user ^. UserIdent)] return user scores <- mapM (handlerToWidget . ((flip userScoreForCourse) entCourse)) students $(widgetFile "course-summary") getCoursesITeachR :: Handler Html getCoursesITeachR = do (Entity userId _) <- requireAuth teacherCourses <- runDB $ selectList [TeacherUser ==. userId] [] let coursesIds = Import.map (teacherCourse . entityVal) teacherCourses courses <- runDB $ mapM get404 coursesIds let entCourses' = Import.map (\(k, v) -> Entity k v) $ Import.zip coursesIds courses let entCourses = sortBy (\e1 e2 -> (courseName $ entityVal e1) `compare` (courseName $ entityVal e2)) entCourses' defaultLayout $ do setTitle "Courses I teach" $(widgetFile "courses-i-teach")