add "i" icon for submissions

Handler/Query.hs

@@ -33,7 +33,10 @@ getFullInfo (Entity submissionId submission) = do
 
 findSubmissions :: Text -> Handler [FullSubmissionInfo]
 findSubmissions sha1Prefix = do
-  submissions <- runDB $ rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
+  mauthId <- maybeAuth
+  submissions <- runDB $ case mauthId of
+    Just (Entity authId _) -> rawSql "SELECT ?? FROM submission WHERE (is_public OR submitter = ?) AND cast(commit as text) like ?" [toPersistValue authId, PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
+    Nothing -> rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
   mapM getFullInfo submissions
 
 getQueryFormR :: Handler Html

Handler/ShowChallenge.hs

@@ -34,7 +34,9 @@ getShowChallengeR name = do
   (Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
   Just repo <- runDB $ get $ challengePublicRepo challenge
   leaderboard <- getLeaderboardEntries challengeId
-  challengeLayout True challenge (showChallengeWidget challenge repo leaderboard)
+  mauth <- maybeAuth
+  let muserId = (\(Entity uid _) -> uid) <$> mauth
+  challengeLayout True challenge (showChallengeWidget muserId challenge repo leaderboard)
 
 getChallengeReadmeR :: Text -> Handler Html
 getChallengeReadmeR name = do
@@ -45,8 +47,9 @@ getChallengeReadmeR name = do
   contents <- readFile readmeFilePath
   challengeLayout False challenge $ toWidget $ markdown def $ TL.fromStrict contents
 
-showChallengeWidget challenge repo leaderboard = $(widgetFile "show-challenge")
+showChallengeWidget muserId challenge repo leaderboard = $(widgetFile "show-challenge")
   where leaderboardWithRanks = zip [1..] leaderboard
+        leaderboardWithRanksAndCurrentUser = map (\e -> (e, muserId)) leaderboardWithRanks
         maybeRepoLink = getRepoLink repo
 
 
@@ -257,9 +260,12 @@ getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
 getChallengeSubmissions condition name = do
   challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
   (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
-  challengeLayout True challenge (challengeAllSubmissionsWidget challenge evaluationMaps tests)
+  mauth <- maybeAuth
+  let muserId = (\(Entity uid _) -> uid) <$> mauth
+  challengeLayout True challenge (challengeAllSubmissionsWidget muserId challenge evaluationMaps tests)
 
-challengeAllSubmissionsWidget challenge submissions tests = $(widgetFile "challenge-all-submissions")
+challengeAllSubmissionsWidget muserId challenge submissions tests = $(widgetFile "challenge-all-submissions")
+    where submissionsWithCurrentUser = map (\e -> (e, muserId)) submissions
 
 challengeLayout withHeader challenge widget = do
   bc <- widgetToPageContent widget

Handler/Tables.hs

@@ -16,31 +16,39 @@ import qualified Data.List as DL
 
 import Data.Text (pack)
 
+import PersistSHA1
+
 import GEval.Core
 
 data LeaderboardEntry = LeaderboardEntry {
   leaderboardUser :: User,
+  leaderboardUserId :: UserId,
   leaderboardBestSubmission :: Submission,
+  leaderboardBestSubmissionId :: SubmissionId,
   leaderboardEvaluation :: Evaluation,
   leaderboardNumberOfSubmissions :: Int
 }
 
-submissionsTable :: [Entity Test] -> Table site (Entity Submission, Entity User, Map (Key Test) Evaluation)
+submissionsTable :: [Entity Test] -> Table App ((Entity Submission, Entity User, Map (Key Test) Evaluation), Maybe UserId)
 submissionsTable tests = mempty
-  ++ Table.text "submitter" (formatSubmitter . \(_, Entity _ submitter, _) -> submitter)
+  ++ Table.text "submitter" (formatSubmitter . (\(_, Entity _ submitter, _) -> submitter) . fst)
-  ++ timestampCell "when" (submissionStamp . \(Entity _ s, _, _) -> s)
+  ++ timestampCell "when" (submissionStamp . (\(Entity _ s, _, _) -> s) . fst)
-  ++ Table.text "description" (submissionDescription . \(Entity _ s, _,  _) -> s)
+  ++ Table.text "description" (submissionDescription . (\(Entity _ s, _,  _) -> s) . fst)
-  ++ mconcat (map (\(Entity k t) -> Table.string (testName t) (submissionScore k)) tests)
+  ++ mconcat (map (\(Entity k t) -> Table.string (testName t) ((submissionScore k) . fst)) tests)
+  ++ statusCell (\((Entity submissionId submission, Entity userId _, _), mauthId) -> (submissionId, submission, userId, mauthId))
 
-
+leaderboardTable :: Table App ((Int, LeaderboardEntry), Maybe UserId)
-leaderboardTable :: Table site (Int, LeaderboardEntry)
 leaderboardTable = mempty
-  ++ Table.int "#" fst
+  ++ Table.int "#" (fst . fst)
-  ++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
+  ++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd . fst)
-  ++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
+  ++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd . fst)
-  ++ Table.text "description" (submissionDescription . leaderboardBestSubmission . snd)
+  ++ Table.text "description" (submissionDescription . leaderboardBestSubmission . snd . fst)
-  ++ Table.string "result" (presentScore . leaderboardEvaluation . snd)
+  ++ Table.string "result" (presentScore . leaderboardEvaluation . snd . fst)
-  ++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
+  ++ Table.int "×" (leaderboardNumberOfSubmissions . snd . fst)
+  ++ statusCell (\((_, e), mauthId) -> (leaderboardBestSubmissionId e,
+                                       leaderboardBestSubmission e,
+                                       leaderboardUserId e,
+                                       mauthId))
 
 
 hoverTextCell :: Text -> (a -> Text) -> (a -> Text) -> Table site a
@@ -51,6 +59,15 @@ timestampCell :: Text -> (a -> UTCTime) -> Table site a
 timestampCell h timestampFun = hoverTextCell h (Data.Text.pack . shorterFormat . timestampFun) (Data.Text.pack . show . timestampFun)
    where shorterFormat = formatTime defaultTimeLocale "%Y-%m-%d %H:%M"
 
+statusCell :: (a -> (SubmissionId, Submission, UserId, Maybe UserId)) -> Table App a
+statusCell fun = Table.widget "" (statusCellWidget . fun)
+
+statusCellWidget (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status")
+    where commitHash = fromSHA1ToText $ submissionCommit submission
+          isPublic = submissionIsPublic submission
+          isOwner = (mauthId == Just userId)
+          isVisible = isPublic || isOwner
+
 getMainTest :: [Entity Test] -> Entity Test
 getMainTest tests = DL.maximumBy (\(Entity _ a) (Entity _ b) -> ((testName a) `compare` (testName b))) tests
 
@@ -75,15 +92,17 @@ getLeaderboardEntries challengeId = do
   (evaluationMaps, tests) <- getChallengeSubmissionInfos (\_ -> True) challengeId
   let mainTestEnt = getMainTest tests
   let (Entity mainTestId mainTest) = mainTestEnt
-  let auxSubmissions = getAuxSubmissions mainTestId evaluationMaps
+  let auxSubmissions = getAuxSubmissionEnts mainTestId evaluationMaps
   let submissionsByUser = Map.fromListWith (\(u1, l1) (_, l2) -> (u1, l1++l2)) auxSubmissions
   let entryComparator a b = (compareResult mainTest) (evaluationScore $ leaderboardEvaluation a) (evaluationScore $ leaderboardEvaluation b)
   let entries = sortBy (flip entryComparator) $ map (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
   return entries
     where submissionComparator mainTest (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
-          toEntry mainTest (_, (u, ss)) = LeaderboardEntry {
+          toEntry mainTest (ui, (u, ss)) = LeaderboardEntry {
               leaderboardUser = u,
-              leaderboardBestSubmission = fst bestOne,
+              leaderboardUserId = ui,
+              leaderboardBestSubmission = (\(Entity _ s) -> s) $ fst bestOne,
+              leaderboardBestSubmissionId = (\(Entity si _) -> si) $ fst bestOne,
               leaderboardEvaluation = snd bestOne,
               leaderboardNumberOfSubmissions = length ss }
                   where bestOne = DL.maximumBy (submissionComparator mainTest) ss

templates/challenge-all-submissions.hamlet

@@ -1,7 +1,7 @@
 <div class="alert alert-info" role="alert">
             <p>This is a long list of all submissions, if you want to see only the best, click <a href="@{ShowChallengeR (challengeName challenge)}">leaderboard</a>.
 
-^{Table.buildBootstrap (submissionsTable tests) submissions}
+^{Table.buildBootstrap (submissionsTable tests) submissionsWithCurrentUser}
 
 <div id="graph-container">
 

templates/show-challenge.hamlet

@@ -5,7 +5,7 @@ $nothing
 
 <h2>Leaderboard
 
-^{Table.buildBootstrap leaderboardTable leaderboardWithRanks}
+^{Table.buildBootstrap leaderboardTable leaderboardWithRanksAndCurrentUser}
 
 <div id="graph-container">
 

templates/submission-status.hamlet

@@ -0,0 +1,3 @@
+$if isVisible
+  <a href="@{QueryResultsR commitHash}">
+    <span class="glyphicon glyphicon-info-sign" aria-hidden="true">