initial work on score

This commit is contained in:
Filip Gralinski 2017-05-15 13:55:56 +02:00
parent e2c5ae179c
commit b033d0c4b5
8 changed files with 119 additions and 48 deletions

View File

@ -52,6 +52,7 @@ import Handler.Presentation
import Handler.Tags
import Handler.EditSubmission
import Handler.Achievements
import Handler.Score
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the

View File

@ -134,6 +134,10 @@ instance Yesod App where
isAuthorized (AvatarR _) _ = return Authorized
isAuthorized CreateResetLinkR _ = isAdmin
isAuthorized (ScoreR _) _ = isAdmin
isAuthorized MyScoreR _ = return Authorized
isAuthorized (ResetPasswordR _) _ = return Authorized
-- Default to Authorized for now.

View File

@ -0,0 +1,51 @@
module Handler.AchievementUtils where
import Import
import Handler.TagUtils
import qualified Yesod.Table as Table
data AchievementInfo = AchievementInfo {
achievementInfoId :: AchievementId,
achievementInfoName :: Text,
achievementInfoChallenge :: Entity Challenge,
achievementInfoDescription :: Maybe Text,
achievementInfoPoints :: Int,
achievementInfoDeadline :: UTCTime,
achievementInfoMaxWinners :: Maybe Int,
achievementInfoWorkingOn :: [Entity User],
achievementInfoCurrentUser :: Maybe (Entity User),
achievementInfoTags :: [Entity Tag] }
achievementDescriptionCell fun = Table.widget "description" ((
\ainfo -> fragmentWithTags (fromMaybe (""::Text) $ achievementInfoDescription ainfo) (achievementInfoTags ainfo)) . fun)
getAchievementInfo mUser (Entity achievementId achievement) = do
es <- selectList [WorkingOnAchievement ==. achievementId] []
let userIds = Import.map (workingOnUser . entityVal) es
users <- mapM get404 userIds
tags <- getAchievementTags achievementId
let challengeId = achievementChallenge achievement
challenge <- get404 challengeId
return $ AchievementInfo {
achievementInfoId = achievementId,
achievementInfoName = achievementName achievement,
achievementInfoChallenge = Entity challengeId challenge,
achievementInfoDescription = achievementDescription achievement,
achievementInfoPoints = achievementPoints achievement,
achievementInfoDeadline = achievementDeadline achievement,
achievementInfoMaxWinners = achievementMaxWinners achievement,
achievementInfoWorkingOn = Import.map (\(i,v) -> Entity i v) $ Import.zip userIds users,
achievementInfoCurrentUser = mUser,
achievementInfoTags = tags }
getAchievementTags achievementId = do
sts <- selectList [AchievementTagAchievement ==. achievementId] []
let tagIds = Import.map (achievementTagTag . entityVal) sts
tags <- mapM get404 $ tagIds
return $ Import.map (\(k, v) -> Entity k v) $ Import.zip tagIds tags

View File

@ -9,6 +9,8 @@ import Handler.TagUtils
import Handler.Tables
import Handler.Shared
import Handler.AchievementUtils
import Data.Time.Clock
import Data.Time.LocalTime
@ -16,20 +18,6 @@ import Data.Text
import qualified Yesod.Table as Table
data AchievementInfo = AchievementInfo {
achievementInfoId :: AchievementId,
achievementInfoName :: Text,
achievementInfoChallenge :: Entity Challenge,
achievementInfoDescription :: Maybe Text,
achievementInfoPoints :: Int,
achievementInfoDeadline :: UTCTime,
achievementInfoMaxWinners :: Maybe Int,
achievementInfoWorkingOn :: [Entity User],
achievementInfoCurrentUser :: Maybe (Entity User),
achievementInfoTags :: [Entity Tag] }
getAchievementsR :: Handler Html
getAchievementsR = do
(formWidget, formEnctype) <- generateFormPost achievementForm
@ -68,40 +56,11 @@ doAchievements mUser formWidget formEnctype = do
setTitle "Achievements"
$(widgetFile "achievements")
getAchievementInfo mUser (Entity achievementId achievement) = do
es <- selectList [WorkingOnAchievement ==. achievementId] []
let userIds = Import.map (workingOnUser . entityVal) es
users <- mapM get404 userIds
tags <- getAchievementTags achievementId
let challengeId = achievementChallenge achievement
challenge <- get404 challengeId
return $ AchievementInfo {
achievementInfoId = achievementId,
achievementInfoName = achievementName achievement,
achievementInfoChallenge = Entity challengeId challenge,
achievementInfoDescription = achievementDescription achievement,
achievementInfoPoints = achievementPoints achievement,
achievementInfoDeadline = achievementDeadline achievement,
achievementInfoMaxWinners = achievementMaxWinners achievement,
achievementInfoWorkingOn = Import.map (\(i,v) -> Entity i v) $ Import.zip userIds users,
achievementInfoCurrentUser = mUser,
achievementInfoTags = tags }
getAchievementTags achievementId = do
sts <- selectList [AchievementTagAchievement ==. achievementId] []
let tagIds = Import.map (achievementTagTag . entityVal) sts
tags <- mapM get404 $ tagIds
return $ Import.map (\(k, v) -> Entity k v) $ Import.zip tagIds tags
achievementsTable :: Table.Table App (AchievementInfo)
achievementsTable = mempty
++ Table.text "achievement" achievementInfoName
++ Table.linked "challenge" (challengeTitle . entityVal . achievementInfoChallenge) (ShowChallengeR . challengeName . entityVal . achievementInfoChallenge)
++ achievementDescriptionCell
++ achievementDescriptionCell id
++ Table.int "points" achievementInfoPoints
++ timestampCell "deadline" achievementInfoDeadline
++ Table.string "max submitters" (formatMaxSubmitters . achievementInfoMaxWinners)
@ -197,10 +156,6 @@ determineWhetherCanGiveUpWorkingOn (Just (Entity userId user)) peopleWorkingOn =
checkLimit _ Nothing = True
checkLimit peopleWorkingOn (Just m) = (Import.length peopleWorkingOn) < m
achievementDescriptionCell = Table.widget "description" (
\ainfo -> fragmentWithTags (fromMaybe (""::Text) $ achievementInfoDescription ainfo) (achievementInfoTags ainfo))
formatSubmitters userEnts = Data.Text.intercalate ", " $ Import.map (formatSubmitter . entityVal) userEnts
formatMaxSubmitters :: Maybe Int -> String

51
Handler/Score.hs Normal file
View File

@ -0,0 +1,51 @@
module Handler.Score where
import Import
import Handler.Shared
import Handler.Tables
import Handler.AchievementUtils
import qualified Database.Esqueleto as E
import Database.Esqueleto ((^.))
import qualified Yesod.Table as Table
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)
scoreTable = mempty
++ Table.text "name" (achievementInfoName . fst)
++ achievementDescriptionCell fst
++ timestampCell "deadline" (achievementInfoDeadline . fst)
++ Table.text "submission" (submissionDescription . entityVal . snd)
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)
processEntry entUser (entAchievement, entSubmission) = do
aInfo <- runDB $ getAchievementInfo (Just entUser) entAchievement
return (aInfo, entSubmission)

View File

@ -37,6 +37,9 @@
/give-up-working-on/#AchievementId GiveUpWorkingOnR GET
/submission-for-achievement/#SubmissionId/#WorkingOnId SubmissionForAchievementR GET
/score/#UserId ScoreR GET
/my-score MyScoreR GET
/edit-submission/#SubmissionId EditSubmissionR GET POST
/presentation/4real Presentation4RealR GET

View File

@ -50,6 +50,8 @@ library
Handler.SubmissionView
Handler.Achievements
Handler.TagUtils
Handler.Score
Handler.AchievementUtils
if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT
@ -136,6 +138,7 @@ library
, yesod-auth-hashdb
, pwstore-fast
, nonce
, esqueleto
executable gonito
if flag(library-only)

3
templates/score.hamlet Normal file
View File

@ -0,0 +1,3 @@
<h1>Score for #{formatSubmitter user}
^{Table.buildBootstrap scoreTable entries'}