initial work on score

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

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.

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

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

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)

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

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)

templates/score.hamlet

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