gonito/Handler/Score.hs

114 lines
4.3 KiB
Haskell
Raw Normal View History

2017-05-15 13:55:56 +02:00
module Handler.Score where
import Import
import Handler.Shared
import Handler.Tables
2017-05-15 14:25:54 +02:00
import Control.Monad.Extra
2017-05-15 13:55:56 +02:00
import Handler.AchievementUtils
import qualified Database.Esqueleto as E
import Database.Esqueleto ((^.))
import qualified Yesod.Table as Table
2017-05-15 14:25:54 +02:00
import Data.Text as T
2017-05-15 13:55:56 +02:00
getMyScoreR :: Handler Html
getMyScoreR = do
entUser <- requireAuth
doScore entUser
getScoreR :: UserId -> Handler Html
getScoreR userId = do
user <- runDB $ get404 userId
doScore (Entity userId user)
2017-05-15 14:25:54 +02:00
scoreTable :: Table.Table App (AchievementInfo, (Entity Submission, Bool))
2017-05-15 13:55:56 +02:00
scoreTable = mempty
++ Table.text "name" (achievementInfoName . fst)
++ achievementDescriptionCell fst
++ timestampCell "deadline" (achievementInfoDeadline . fst)
2017-05-15 14:25:54 +02:00
++ timestampCell "submitted" (submissionStamp . entityVal . fst . snd)
++ Table.linked "submission" (submissionDescription . entityVal . fst . snd) (EditSubmissionR . entityKey . fst . snd)
++ Table.text "status" getStatus
2018-01-02 20:37:11 +01:00
extrasTable :: Table.Table App ExtraPoints
extrasTable = mempty
++ Table.text "reason" extraPointsDescription
++ timestampCell "added" extraPointsPosted
++ Table.int "points" extraPointsPoints
2017-05-15 14:25:54 +02:00
getStatus :: (AchievementInfo, (Entity Submission, Bool)) -> Text
getStatus (_, (_, False)) = ""
getStatus (aInfo, (_, True)) = T.pack $ show $ achievementInfoPoints aInfo
2017-05-15 13:55:56 +02:00
2018-01-02 19:34:23 +01:00
getPoints :: (AchievementInfo, (Entity Submission, Bool)) -> Int
getPoints (_, (_, False)) = 0
getPoints (aInfo, (_, True)) = achievementInfoPoints aInfo
2017-05-15 13:55:56 +02:00
doScore :: Entity User -> Handler Html
2018-01-02 19:34:23 +01:00
doScore userEnt@(Entity userId user) = do
courses <- runDB $ selectList [CourseClosed ==. False] [Asc CourseName]
2018-01-02 20:37:11 +01:00
courseUserInfos <- mapM (userScoreForCourse userEnt) courses
2018-01-02 19:34:23 +01:00
2018-01-02 20:37:11 +01:00
let courseInfos = Import.filter (\(_, (points, _, _)) -> points > 0) $ Import.zip courses courseUserInfos
2018-01-02 19:34:23 +01:00
defaultLayout $ do
setTitle "Score"
$(widgetFile "score")
2018-01-02 20:37:11 +01:00
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
2018-01-02 19:34:23 +01:00
let achievementTotal = sum $ Import.map getPoints achievementEntries
2018-01-02 20:37:11 +01:00
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
2018-01-02 19:34:23 +01:00
2018-01-02 20:37:11 +01:00
userAchievementsForCourse :: Entity User -> CourseId -> Handler [(AchievementInfo, (Entity Submission, Bool))]
userAchievementsForCourse (Entity userId user) courseId = do
2017-05-15 13:55:56 +02:00
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
2018-01-02 19:34:23 +01:00
E.&&. working_on ^. WorkingOnUser E.==. E.val userId
E.&&. achievement ^. AchievementCourse E.==. E.val courseId)
2017-05-15 13:55:56 +02:00
E.orderBy [E.asc (submission ^. SubmissionStamp)]
return (achievement, submission)
entries' <- mapM (processEntry (Entity userId user)) entries
2018-01-02 19:34:23 +01:00
return entries'
2017-05-15 13:55:56 +02:00
2017-05-15 14:25:54 +02:00
processEntry :: Entity User -> (Entity Achievement, Entity Submission) -> Handler (AchievementInfo, (Entity Submission, Bool))
2017-05-15 13:55:56 +02:00
processEntry entUser (entAchievement, entSubmission) = do
aInfo <- runDB $ getAchievementInfo (Just entUser) entAchievement
2017-05-15 14:25:54 +02:00
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