75 lines
2.6 KiB
Haskell
75 lines
2.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
|
|
|
|
getStatus :: (AchievementInfo, (Entity Submission, Bool)) -> Text
|
|
getStatus (_, (_, False)) = ""
|
|
getStatus (aInfo, (_, True)) = T.pack $ show $ achievementInfoPoints aInfo
|
|
|
|
doScore :: Entity User -> Handler Html
|
|
doScore (Entity userId user) = 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.orderBy [E.asc (submission ^. SubmissionStamp)]
|
|
return (achievement, submission)
|
|
|
|
entries' <- mapM (processEntry (Entity userId user)) entries
|
|
|
|
defaultLayout $ do
|
|
setTitle "Score"
|
|
$(widgetFile "score")
|
|
|
|
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
|