diff --git a/Application.hs b/Application.hs index 0ea9753..f750074 100644 --- a/Application.hs +++ b/Application.hs @@ -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 diff --git a/Foundation.hs b/Foundation.hs index b6dc8cc..8c67970 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -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. diff --git a/Handler/AchievementUtils.hs b/Handler/AchievementUtils.hs new file mode 100644 index 0000000..12342da --- /dev/null +++ b/Handler/AchievementUtils.hs @@ -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 diff --git a/Handler/Achievements.hs b/Handler/Achievements.hs index 1dd0f50..79a1515 100644 --- a/Handler/Achievements.hs +++ b/Handler/Achievements.hs @@ -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 diff --git a/Handler/Score.hs b/Handler/Score.hs new file mode 100644 index 0000000..91c238b --- /dev/null +++ b/Handler/Score.hs @@ -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) diff --git a/config/routes b/config/routes index 69b7621..09cf1e3 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/gonito.cabal b/gonito.cabal index 97966ed..5504204 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -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) diff --git a/templates/score.hamlet b/templates/score.hamlet new file mode 100644 index 0000000..d531035 --- /dev/null +++ b/templates/score.hamlet @@ -0,0 +1,3 @@ +

Score for #{formatSubmitter user} + +^{Table.buildBootstrap scoreTable entries'}