a submission can be removed now (actually hidden)
This commit is contained in:
parent
252da6316a
commit
7b7001845d
|
|
@ -8,6 +8,7 @@ import Handler.SubmissionView
|
|||
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
|
||||
|
||||
import Handler.TagUtils
|
||||
import Handler.MakePublic
|
||||
|
||||
import Data.Text as T
|
||||
|
||||
|
|
@ -45,6 +46,7 @@ postEditSubmissionR submissionId = do
|
|||
getEditSubmissionR submissionId
|
||||
|
||||
|
||||
getPossibleAchievements :: (BaseBackend backend ~ SqlBackend, PersistUniqueRead backend, PersistQueryRead backend, MonadIO m) => Key User -> Key Submission -> ReaderT backend m [(Entity Achievement, Key WorkingOn)]
|
||||
getPossibleAchievements userId submissionId = do
|
||||
(Just submission) <- get submissionId
|
||||
let challengeId = submissionChallenge submission
|
||||
|
|
@ -60,7 +62,7 @@ doEditSubmission formWidget formEnctype submissionId = do
|
|||
|
||||
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
|
||||
|
||||
(Entity userId user) <- requireAuth
|
||||
(Entity userId _) <- requireAuth
|
||||
|
||||
achievements <- runDB $ getPossibleAchievements userId submissionId
|
||||
|
||||
|
|
@ -72,3 +74,26 @@ editSubmissionForm :: Text -> Maybe Text -> Form (Text, Maybe Text)
|
|||
editSubmissionForm description mTags = renderBootstrap3 BootstrapBasicForm $ (,)
|
||||
<$> areq textField (bfs MsgSubmissionDescription) (Just description)
|
||||
<*> aopt textField (tagsfs MsgSubmissionTags) (Just mTags)
|
||||
|
||||
|
||||
getHideSubmissionR :: SubmissionId -> Handler Html
|
||||
getHideSubmissionR submissionId = changeSubmissionVisibility False submissionId
|
||||
|
||||
getRestoreSubmissionR :: SubmissionId -> Handler Html
|
||||
getRestoreSubmissionR submissionId = changeSubmissionVisibility True submissionId
|
||||
|
||||
|
||||
changeSubmissionVisibility :: Bool -> SubmissionId -> Handler Html
|
||||
changeSubmissionVisibility status submissionId =
|
||||
do
|
||||
isOwner <- checkWhetherUserRepo submissionId
|
||||
if isOwner
|
||||
then
|
||||
do
|
||||
runDB $ update submissionId [SubmissionIsHidden =. Just (not status)]
|
||||
setMessage $ toHtml (("Submission " :: Text) ++ (verb status))
|
||||
else
|
||||
setMessage $ toHtml ("Only owner can edit a submission!!!" :: Text)
|
||||
getEditSubmissionR submissionId
|
||||
where verb True = "restored"
|
||||
verb False = "removed"
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ doMakePublic submissionId chan = do
|
|||
|
||||
pushRepo :: String -> SHA1 -> String -> String -> Channel -> Handler ()
|
||||
pushRepo repoDir commit targetRepoUrl targetBranchName chan = do
|
||||
(exitCode, _) <- runProgram (Just repoDir) gitPath [
|
||||
(_, _) <- runProgram (Just repoDir) gitPath [
|
||||
"push",
|
||||
targetRepoUrl,
|
||||
(T.unpack $ fromSHA1ToText commit) ++ ":refs/heads/" ++ targetBranchName] chan
|
||||
|
|
|
|||
|
|
@ -215,7 +215,8 @@ getSubmission userId repoId commit challengeId description chan = do
|
|||
submissionDescription=description,
|
||||
submissionStamp=time,
|
||||
submissionSubmitter=userId,
|
||||
submissionIsPublic=False }
|
||||
submissionIsPublic=False,
|
||||
submissionIsHidden=Just False }
|
||||
|
||||
parseCommitMessage :: Maybe Text -> (Maybe Text, Maybe Text)
|
||||
parseCommitMessage Nothing = (Nothing, Nothing)
|
||||
|
|
@ -425,7 +426,7 @@ getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name
|
|||
|
||||
getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
|
||||
getChallengeSubmissions condition name = do
|
||||
challengeEnt@(Entity challengeId challenge) <- runDB $ getBy404 $ UniqueName name
|
||||
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name
|
||||
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
|
||||
mauth <- maybeAuth
|
||||
let muserId = (\(Entity uid _) -> uid) <$> mauth
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@ import qualified Data.List as DL
|
|||
|
||||
import GEval.Core
|
||||
|
||||
import Text.Printf
|
||||
|
||||
data LeaderboardEntry = LeaderboardEntry {
|
||||
leaderboardUser :: User,
|
||||
|
|
@ -40,6 +39,7 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
|
|||
++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests)
|
||||
++ statusCell challengeName repoScheme challengeRepo (\(Entity submissionId submission, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId))
|
||||
|
||||
descriptionCell :: Foldable t => Table site (Entity Submission, b, c, t (Entity Tag, Entity SubmissionTag))
|
||||
descriptionCell = Table.widget "description" (
|
||||
\(Entity _ s, _, _ ,tagEnts) -> fragmentWithSubmissionTags (submissionDescription s) tagEnts)
|
||||
|
||||
|
|
@ -59,6 +59,7 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty
|
|||
leaderboardUserId e,
|
||||
mauthId))
|
||||
|
||||
leaderboardDescriptionCell :: Table site (a, LeaderboardEntry)
|
||||
leaderboardDescriptionCell = Table.widget "description" (
|
||||
\(_,entry) -> fragmentWithSubmissionTags (submissionDescription $ leaderboardBestSubmission entry) (leaderboardTags entry))
|
||||
|
||||
|
|
@ -78,6 +79,7 @@ statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusC
|
|||
resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
|
||||
resultCell test fun = hoverTextCell ((testName test) ++ "/" ++ (Data.Text.pack $ show $ testMetric test)) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
|
||||
|
||||
statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, a, Maybe a) -> WidgetFor App ()
|
||||
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status")
|
||||
where commitHash = fromSHA1ToText $ submissionCommit submission
|
||||
isPublic = submissionIsPublic submission
|
||||
|
|
@ -91,15 +93,15 @@ statusCellWidget challengeName repoScheme challengeRepo (submissionId, submissio
|
|||
Nothing
|
||||
|
||||
getAuxSubmissions :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation)] -> [(Key User, (User, [(Submission, Evaluation)]))]
|
||||
getAuxSubmissions testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
|
||||
where processEvaluationMap testId ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup testId m of
|
||||
getAuxSubmissions testId evaluationMaps = map processEvaluationMap evaluationMaps
|
||||
where processEvaluationMap ((Entity _ s), (Entity ui u), m) = (ui, (u, case Map.lookup testId m of
|
||||
Just e -> [(s, e)]
|
||||
Nothing -> []))
|
||||
|
||||
|
||||
getAuxSubmissionEnts :: Key Test -> [(Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])] -> [(Key User, (User, [((Entity Submission), Evaluation)]))]
|
||||
getAuxSubmissionEnts testId evaluationMaps = map (processEvaluationMap testId) evaluationMaps
|
||||
where processEvaluationMap testId (s, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of
|
||||
getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluationMaps
|
||||
where processEvaluationMap (s, (Entity ui u), m, _) = (ui, (u, case Map.lookup testId m of
|
||||
Just e -> [(s, e)]
|
||||
Nothing -> []))
|
||||
|
||||
|
|
@ -114,25 +116,28 @@ getLeaderboardEntries challengeId = do
|
|||
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)
|
||||
entries' <- mapM (toEntry mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
|
||||
entries' <- mapM (toEntry challengeId mainTest) $ filter (\(_, (_, s)) -> not (null s)) $ Map.toList submissionsByUser
|
||||
let entries = sortBy (flip entryComparator) entries'
|
||||
return (mainTest, entries)
|
||||
|
||||
|
||||
toEntry mainTest (ui, (u, ss)) = do
|
||||
let bestOne = DL.maximumBy (submissionComparator mainTest) ss
|
||||
toEntry :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistQueryRead (YesodPersistBackend site), YesodPersist site, Foldable t) => Key Challenge -> Test -> (Key User, (User, t (Entity Submission, Evaluation))) -> HandlerFor site LeaderboardEntry
|
||||
toEntry challengeId mainTest (ui, (u, ss)) = do
|
||||
let bestOne = DL.maximumBy submissionComparator ss
|
||||
let submissionId = entityKey $ fst bestOne
|
||||
tagEnts <- runDB $ getTags submissionId
|
||||
-- get all user submissions, including hidden ones
|
||||
allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionSubmitter ==. ui] [Desc SubmissionStamp]
|
||||
return $ LeaderboardEntry {
|
||||
leaderboardUser = u,
|
||||
leaderboardUserId = ui,
|
||||
leaderboardBestSubmission = (\(Entity _ s) -> s) $ fst bestOne,
|
||||
leaderboardBestSubmissionId = (\(Entity si _) -> si) $ fst bestOne,
|
||||
leaderboardEvaluation = snd bestOne,
|
||||
leaderboardNumberOfSubmissions = length ss,
|
||||
leaderboardNumberOfSubmissions = length allUserSubmissions,
|
||||
leaderboardTags = tagEnts
|
||||
}
|
||||
where submissionComparator mainTest (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
|
||||
where submissionComparator (_, e1) (_, e2) = (compareResult mainTest) (evaluationScore e1) (evaluationScore e2)
|
||||
|
||||
|
||||
compareResult :: Test -> Maybe Double -> Maybe Double -> Ordering
|
||||
|
|
@ -147,7 +152,7 @@ compareFun TheHigherTheBetter = compare
|
|||
|
||||
getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) -> Key Challenge -> Handler ([(Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])], [Entity Test])
|
||||
getChallengeSubmissionInfos condition challengeId = do
|
||||
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId] [Desc SubmissionStamp]
|
||||
allSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionIsHidden !=. Just True] [Desc SubmissionStamp]
|
||||
let submissions = filter condition allSubmissions
|
||||
tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
|
||||
evaluationMaps <- mapM getEvaluationMap submissions
|
||||
|
|
|
|||
|
|
@ -57,6 +57,7 @@ Submission
|
|||
stamp UTCTime default=now()
|
||||
submitter UserId
|
||||
isPublic Bool default=False
|
||||
isHidden Bool Maybe
|
||||
UniqueSubmissionRepoCommitChallenge repo commit challenge
|
||||
Fork
|
||||
source SubmissionId
|
||||
|
|
|
|||
|
|
@ -30,6 +30,8 @@
|
|||
/api/txt/score/#Text ApiTxtScoreR GET
|
||||
|
||||
/make-public/#SubmissionId MakePublicR GET
|
||||
/hide-submission/#SubmissionId HideSubmissionR GET
|
||||
/restore-submission/#SubmissionId RestoreSubmissionR GET
|
||||
|
||||
/account YourAccountR GET POST
|
||||
/avatar/#UserId AvatarR GET
|
||||
|
|
|
|||
|
|
@ -60,3 +60,5 @@ Presentation: presentation
|
|||
GonitoInClass: Gonito in class
|
||||
GitAnnexRemote: git-annex remote (if needed)
|
||||
SubmissionGitAnnexRemote: git-annex remote specification (if needed)
|
||||
RemoveSubmission: remove submission
|
||||
RestoreSubmission: restore submission
|
||||
|
|
|
|||
|
|
@ -10,3 +10,13 @@
|
|||
<ul>
|
||||
$forall (achievement, workingOnId) <- achievements
|
||||
<li><a href=@{SubmissionForAchievementR submissionId workingOnId}>send to review for #{achievementName $ entityVal achievement} achievement
|
||||
|
||||
<h4>
|
||||
|
||||
$if submissionIsHidden submission == Just True
|
||||
<p>Submission is hidden!
|
||||
<p>
|
||||
<a href=@{RestoreSubmissionR submissionId}>_{MsgRestoreSubmission}
|
||||
$else
|
||||
<p>
|
||||
<a href=@{HideSubmissionR submissionId}>_{MsgRemoveSubmission}
|
||||
|
|
|
|||
|
|
@ -2,6 +2,9 @@ $if isOwner
|
|||
<a href="@{EditSubmissionR submissionId}">
|
||||
<span class="glyphicon glyphicon-pencil" title="click to edit the submission" aria-hidden="true">
|
||||
|
||||
<a href="@{HideSubmissionR submissionId}">
|
||||
<span class="glyphicon glyphicon-remove" title="click to remove the submission" aria-hidden="true">
|
||||
|
||||
$if isVisible
|
||||
<a href="@{QueryResultsR commitHash}">
|
||||
<span class="glyphicon glyphicon-info-sign" title="click to see the detailed information" aria-hidden="true">
|
||||
|
|
|
|||
Loading…
Reference in New Issue