forked from filipg/gonito
142 lines
5.6 KiB
Haskell
142 lines
5.6 KiB
Haskell
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")
|