filipg/gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

Challenge phase can be set

Browse Source
This commit is contained in:
Filip Gralinski 2021-09-25 18:37:08 +02:00
parent 575ec8d4e4
commit d15264b904
5 changed files with 98 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
Handler/CreateChallenge.hs
View File

@ -45,7 +45,8 @@ data ChallengeMetadata = ChallengeMetadata {
challengeMetadataPrivateGitAnnexRemote :: Maybe Text, challengeMetadataPrivateGitAnnexRemote :: Maybe Text,
challengeMetadataDeadline :: Maybe UTCTime, challengeMetadataDeadline :: Maybe UTCTime,
challengeMetadataValidate :: Bool } challengeMetadataValidate :: Bool,
challengeMetadataPhase :: Maybe Text }
getCreateChallengeR :: Handler Html getCreateChallengeR :: Handler Html
getCreateChallengeR = do getCreateChallengeR = do
@ -93,6 +94,8 @@ doCreateChallenge creationData chan = do
let mDeadline = challengeMetadataDeadline challengeMetadata let mDeadline = challengeMetadataDeadline challengeMetadata
let shouldBeValidated = challengeMetadataValidate challengeMetadata let shouldBeValidated = challengeMetadataValidate challengeMetadata
mPhaseTagId <- fetchPhaseTagId (challengeMetadataPhase challengeMetadata)
maybePublicRepoId <- cloneRepo (RepoCloningSpec { maybePublicRepoId <- cloneRepo (RepoCloningSpec {
cloningSpecRepo = RepoSpec { cloningSpecRepo = RepoSpec {
repoSpecUrl = publicUrl, repoSpecUrl = publicUrl,
@ -118,7 +121,7 @@ doCreateChallenge creationData chan = do
case maybePrivateRepoId of case maybePrivateRepoId of
Just privateRepoId -> do Just privateRepoId -> do
isValidated <- validateChallenge shouldBeValidated privateRepoId chan isValidated <- validateChallenge shouldBeValidated privateRepoId chan
when isValidated $ addChallenge name publicRepoId privateRepoId mDeadline chan when isValidated $ addChallenge name publicRepoId privateRepoId mDeadline mPhaseTagId chan
Nothing -> return () Nothing -> return ()
Nothing -> return () Nothing -> return ()
@ -134,27 +137,31 @@ instance Show ChallengeUpdateType where
show MinorChange = "minor change" show MinorChange = "minor change"
show ChallengePatch = "patch" show ChallengePatch = "patch"
fetchChallengeData :: (MonadIO m, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m (Repo, Repo, Maybe UTCTime) fetchChallengeData :: (MonadIO m, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m (Repo, Repo, Maybe UTCTime, Maybe Tag)
fetchChallengeData challengeId = do fetchChallengeData challengeId = do
challenge <- get404 challengeId challenge <- get404 challengeId
publicRepo <- get404 $ challengePublicRepo challenge publicRepo <- get404 $ challengePublicRepo challenge
privateRepo <- get404 $ challengePrivateRepo challenge privateRepo <- get404 $ challengePrivateRepo challenge
version <- getBy404 $ UniqueVersionByCommit $ challengeVersion challenge version <- getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
return (publicRepo, privateRepo, versionDeadline $ entityVal $ version) mTag <- case versionPhase $ entityVal version of
Just phaseTagId -> get phaseTagId
Nothing -> return Nothing
return (publicRepo, privateRepo, versionDeadline $ entityVal $ version, mTag)
getChallengeUpdateR :: ChallengeId -> Handler Html getChallengeUpdateR :: ChallengeId -> Handler Html
getChallengeUpdateR challengeId = do getChallengeUpdateR challengeId = do
(publicRepo, privateRepo, mDeadline) <- runDB $ fetchChallengeData challengeId (publicRepo, privateRepo, mDeadline, mTag) <- runDB $ fetchChallengeData challengeId
(formWidget, formEnctype) <- generateFormPost $ updateChallengeForm publicRepo privateRepo mDeadline (formWidget, formEnctype) <- generateFormPost $ updateChallengeForm publicRepo privateRepo mDeadline mTag
defaultLayout $ do defaultLayout $ do
setTitle "Welcome To Yesod!" setTitle "Welcome To Yesod!"
$(widgetFile "update-challenge") $(widgetFile "update-challenge")
postChallengeUpdateR :: ChallengeId -> Handler TypedContent postChallengeUpdateR :: ChallengeId -> Handler TypedContent
postChallengeUpdateR challengeId = do postChallengeUpdateR challengeId = do
(publicRepo, privateRepo, mDeadline) <- runDB $ fetchChallengeData challengeId (publicRepo, privateRepo, mDeadline, mTag) <- runDB $ fetchChallengeData challengeId
((result, _), _) <- runFormPost $ updateChallengeForm publicRepo privateRepo mDeadline ((result, _), _) <- runFormPost $ updateChallengeForm publicRepo privateRepo mDeadline mTag
let challengeData' = case result of let challengeData' = case result of
FormSuccess res -> Just res FormSuccess res -> Just res
_ -> Nothing _ -> Nothing
@ -177,6 +184,14 @@ combineMaybeDayAndTime mDeadlineDay mDeadlineTime =
utctDayTime = fromMaybe (secondsToDiffTime 24 * 60 * 60 - 1) $ timeOfDayToTime <$> mDeadlineTime } utctDayTime = fromMaybe (secondsToDiffTime 24 * 60 * 60 - 1) $ timeOfDayToTime <$> mDeadlineTime }
Nothing -> Nothing Nothing -> Nothing
fetchPhaseTagId mPhase = do
mPhaseTagEnt <- case mPhase of
Just phase -> runDB $ getBy $ UniqueTagName phase
Nothing -> return Nothing
return (entityKey <$> mPhaseTagEnt)
doChallengeUpdate :: ChallengeId -> ChallengeUpdateData -> Channel -> Handler () doChallengeUpdate :: ChallengeId -> ChallengeUpdateData -> Channel -> Handler ()
doChallengeUpdate challengeId challengeData chan = do doChallengeUpdate challengeId challengeData chan = do
let updateType = challengeUpdateDataType challengeData let updateType = challengeUpdateDataType challengeData
@ -194,6 +209,9 @@ doChallengeUpdate challengeId challengeData chan = do
let newDeadline = challengeMetadataDeadline metadata let newDeadline = challengeMetadataDeadline metadata
let shouldBeValidated = challengeMetadataValidate metadata let shouldBeValidated = challengeMetadataValidate metadata
mPhaseTagId <- fetchPhaseTagId (challengeMetadataPhase metadata)
challenge <- runDB $ get404 challengeId challenge <- runDB $ get404 challengeId
(Entity _ version) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge (Entity _ version) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
let (newMajor, newMinor, newPatch) = incrementVersion updateType (versionMajor version, let (newMajor, newMinor, newPatch) = incrementVersion updateType (versionMajor version,
@ -239,7 +257,8 @@ doChallengeUpdate challengeId challengeData chan = do
VersionMinor =. newMinor, VersionMinor =. newMinor,
VersionPatch =. newPatch, VersionPatch =. newPatch,
VersionDescription =. versionDescription, VersionDescription =. versionDescription,
VersionStamp =. theNow] VersionStamp =. theNow,
VersionPhase =. mPhaseTagId]
Nothing -> do Nothing -> do
_ <- runDB $ insert $ Version (Just challengeId) _ <- runDB $ insert $ Version (Just challengeId)
@ -250,6 +269,7 @@ doChallengeUpdate challengeId challengeData chan = do
newPatch newPatch
versionDescription versionDescription
theNow theNow
mPhaseTagId
return () return ()
(title, description, mImage) <- extractChallengeMetadata publicRepoId chan (title, description, mImage) <- extractChallengeMetadata publicRepoId chan
@ -307,8 +327,8 @@ extractChallengeMetadata publicRepoId chan = do
return (T.pack $ title, T.pack $ description, mImage) return (T.pack $ title, T.pack $ description, mImage)
addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Maybe UTCTime -> Channel -> Handler () addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Maybe UTCTime -> Maybe TagId -> Channel -> Handler ()
addChallenge name publicRepoId privateRepoId deadline chan = do addChallenge name publicRepoId privateRepoId deadline mPhaseTagId chan = do
msg chan "adding challenge..." msg chan "adding challenge..."
(title, description, mImage) <- extractChallengeMetadata publicRepoId chan (title, description, mImage) <- extractChallengeMetadata publicRepoId chan
@ -340,7 +360,8 @@ addChallenge name publicRepoId privateRepoId deadline chan = do
versionMinor=defaultMinorVersion, versionMinor=defaultMinorVersion,
versionPatch=defaultPatchVersion, versionPatch=defaultPatchVersion,
versionDescription=defaultInitialDescription, versionDescription=defaultInitialDescription,
versionStamp=time} versionStamp=time,
versionPhase=mPhaseTagId }
updateTests challengeId chan updateTests challengeId chan
@ -431,11 +452,11 @@ testDirFilter = (fileType ==? Directory) &&? (SFF.fileName ~~? "dev-*" ||? SFF.f
createChallengeForm :: Form ChallengeCreationData createChallengeForm :: Form ChallengeCreationData
createChallengeForm = renderBootstrap3 BootstrapBasicForm $ ChallengeCreationData createChallengeForm = renderBootstrap3 BootstrapBasicForm $ ChallengeCreationData
<$> (T.strip <$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing) <$> (T.strip <$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing)
<*> challengeMetadataInputs Nothing Nothing Nothing <*> challengeMetadataInputs Nothing Nothing Nothing Nothing
challengeMetadataInputs :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage, RenderMessage (HandlerSite m) AppMessage) challengeMetadataInputs :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage, RenderMessage (HandlerSite m) AppMessage)
=> Maybe Repo -> Maybe Repo -> Maybe UTCTime -> AForm m ChallengeMetadata => Maybe Repo -> Maybe Repo -> Maybe UTCTime -> Maybe Tag -> AForm m ChallengeMetadata
challengeMetadataInputs mPublicRepo mPrivateRepo mDeadline = challengeMetadataInputs mPublicRepo mPrivateRepo mDeadline mPhase =
ChallengeMetadata <$> (T.strip <$> areq textField (bfs MsgPublicUrl) (repoUrl <$> mPublicRepo)) ChallengeMetadata <$> (T.strip <$> areq textField (bfs MsgPublicUrl) (repoUrl <$> mPublicRepo))
<*> (T.strip <$> areq textField (bfs MsgBranch) (Just $ maybe "master" repoBranch mPublicRepo)) <*> (T.strip <$> areq textField (bfs MsgBranch) (Just $ maybe "master" repoBranch mPublicRepo))
<*> (fmap T.strip <$> aopt textField (bfs MsgGitAnnexRemote) (repoGitAnnexRemote <$> mPublicRepo)) <*> (fmap T.strip <$> aopt textField (bfs MsgGitAnnexRemote) (repoGitAnnexRemote <$> mPublicRepo))
@ -445,11 +466,12 @@ challengeMetadataInputs mPublicRepo mPrivateRepo mDeadline =
<*> (combineMaybeDayAndTime <$> aopt dayField (bfs MsgChallengeDeadlineDay) (Just $ utctDay <$> mDeadline) <*> (combineMaybeDayAndTime <$> aopt dayField (bfs MsgChallengeDeadlineDay) (Just $ utctDay <$> mDeadline)
<*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip) (Just $ timeToTimeOfDay <$> utctDayTime <$> mDeadline)) <*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip) (Just $ timeToTimeOfDay <$> utctDayTime <$> mDeadline))
<*> areq checkBoxField (bfs MsgShouldChallengeBeValidated) (Just True) <*> areq checkBoxField (bfs MsgShouldChallengeBeValidated) (Just True)
<*> aopt textField (bfs MsgPhase) (Just (tagName <$> mPhase))
updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Form ChallengeUpdateData updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Maybe Tag -> Form ChallengeUpdateData
updateChallengeForm publicRepo privateRepo mDeadline = renderBootstrap3 BootstrapBasicForm $ ChallengeUpdateData updateChallengeForm publicRepo privateRepo mDeadline mPhase = renderBootstrap3 BootstrapBasicForm $ ChallengeUpdateData
<$> areq (radioField optionsEnum) "change type" (Just ChallengePatch) <$> areq (radioField optionsEnum) "change type" (Just ChallengePatch)
<*> challengeMetadataInputs (Just publicRepo) (Just privateRepo) mDeadline <*> challengeMetadataInputs (Just publicRepo) (Just privateRepo) mDeadline mPhase
-- Validate whether a challenge is correct. -- Validate whether a challenge is correct.
-- Contrary to `GEval.Validate.validationChallenge` do not -- Contrary to `GEval.Validate.validationChallenge` do not

33
Handler/ShowChallenge.hs
View File

@ -77,12 +77,34 @@ import Control.Lens hiding ((.=), (^.))
import Data.Proxy as DPR import Data.Proxy as DPR
import Data.HashMap.Strict.InsOrd (fromList) import Data.HashMap.Strict.InsOrd (fromList)
instance ToJSON Import.Tag where
toJSON t = object
[ "name" .= tagName t
, "description" .= tagDescription t
, "color" .= tagColor t
]
instance ToSchema Import.Tag where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
return $ NamedSchema (Just "Tag") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("name", stringSchema)
, ("description", stringSchema)
, ("color", stringSchema)
]
& required .~ [ "name", "color", "description" ]
instance ToJSON LeaderboardEntry where instance ToJSON LeaderboardEntry where
toJSON entry = object toJSON entry = object
[ "submitter" .= (formatSubmitter $ leaderboardUser entry) [ "submitter" .= (formatSubmitter $ leaderboardUser entry)
, "team" .= (teamIdent <$> entityVal <$> leaderboardTeam entry) , "team" .= (teamIdent <$> entityVal <$> leaderboardTeam entry)
, "when" .= (submissionStamp $ leaderboardBestSubmission entry) , "when" .= (submissionStamp $ leaderboardBestSubmission entry)
, "version" .= leaderboardVersion entry , "version" .= (fst $ leaderboardVersion entry)
, "phase" .= (snd $ leaderboardVersion entry)
, "description" .= descriptionToBeShown (leaderboardBestSubmission entry) , "description" .= descriptionToBeShown (leaderboardBestSubmission entry)
(leaderboardBestVariant entry) (leaderboardBestVariant entry)
(leaderboardParams entry) (leaderboardParams entry)
@ -213,6 +235,7 @@ instance ToSchema LeaderboardEntryView where
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String) stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool) boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool)
evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView]) evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
tagSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Import.Tag)
return $ NamedSchema (Just "LeaderboardEntry") $ mempty return $ NamedSchema (Just "LeaderboardEntry") $ mempty
& type_ .~ SwaggerObject & type_ .~ SwaggerObject
@ -221,6 +244,7 @@ instance ToSchema LeaderboardEntryView where
, ("team", stringSchema) , ("team", stringSchema)
, ("when", stringSchema) , ("when", stringSchema)
, ("version", versionSchema) , ("version", versionSchema)
, ("phase", tagSchema)
, ("description", stringSchema) , ("description", stringSchema)
, ("times", Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int) , ("times", Inline $ toSchema (DPR.Proxy :: DPR.Proxy Int)
& description .~ Just "How many times a submission from the same user/of the same tag was submitted" & description .~ Just "How many times a submission from the same user/of the same tag was submitted"
@ -1559,7 +1583,7 @@ data SubmissionView = SubmissionView {
submissionViewRank :: Int, submissionViewRank :: Int,
submissionViewSubmitter :: Text, submissionViewSubmitter :: Text,
submissionViewWhen :: UTCTime, submissionViewWhen :: UTCTime,
submissionViewVersion :: (Int, Int, Int), submissionViewVersion :: ((Int, Int, Int), Maybe Import.Tag),
submissionViewDescription :: Text, submissionViewDescription :: Text,
submissionViewTags :: [TagView], submissionViewTags :: [TagView],
submissionViewHash :: Text, submissionViewHash :: Text,
@ -1578,7 +1602,8 @@ instance ToJSON SubmissionView where
, "rank" .= submissionViewRank s , "rank" .= submissionViewRank s
, "submitter" .= submissionViewSubmitter s , "submitter" .= submissionViewSubmitter s
, "when" .= submissionViewWhen s , "when" .= submissionViewWhen s
, "version" .= submissionViewVersion s , "version" .= (fst $ submissionViewVersion s)
, "phase" .= (snd $ submissionViewVersion s)
, "description" .= submissionViewDescription s , "description" .= submissionViewDescription s
, "tags" .= submissionViewTags s , "tags" .= submissionViewTags s
, "hash" .= submissionViewHash s , "hash" .= submissionViewHash s
@ -1597,6 +1622,7 @@ instance ToSchema SubmissionView where
intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int) intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int)
tagsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TagView]) tagsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TagView])
evalsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView]) evalsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
tagSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [Import.Tag])
return $ NamedSchema (Just "SubmissionView") $ mempty return $ NamedSchema (Just "SubmissionView") $ mempty
& type_ .~ SwaggerObject & type_ .~ SwaggerObject
& properties .~ & properties .~
@ -1606,6 +1632,7 @@ instance ToSchema SubmissionView where
, ("submitter", submitterSchema) , ("submitter", submitterSchema)
, ("when", stringSchema) , ("when", stringSchema)
, ("version", versionSchema) , ("version", versionSchema)
, ("phase", tagSchema)
, ("description", stringSchema) , ("description", stringSchema)
, ("tags", tagsSchema) , ("tags", tagsSchema)
, ("hash", hashSchema) , ("hash", hashSchema)

39
Handler/Tables.hs
View File

@ -73,7 +73,7 @@ data LeaderboardEntry = LeaderboardEntry {
leaderboardNumberOfSubmissions :: Int, leaderboardNumberOfSubmissions :: Int,
leaderboardTags :: [(Entity Import.Tag, Entity SubmissionTag)], leaderboardTags :: [(Entity Import.Tag, Entity SubmissionTag)],
leaderboardParams :: [Parameter], leaderboardParams :: [Parameter],
leaderboardVersion :: (Int, Int, Int), leaderboardVersion :: ((Int, Int, Int), (Maybe Import.Tag)),
leaderboardIsOwner :: Bool, leaderboardIsOwner :: Bool,
leaderboardIsVisible :: Bool, leaderboardIsVisible :: Bool,
leaderboardIsReevaluable :: Bool, leaderboardIsReevaluable :: Bool,
@ -103,7 +103,7 @@ data TableEntry = TableEntry {
tableEntryTagsInfo :: [(Entity Import.Tag, Entity SubmissionTag)], tableEntryTagsInfo :: [(Entity Import.Tag, Entity SubmissionTag)],
tableEntryParams :: [Entity Parameter], tableEntryParams :: [Entity Parameter],
tableEntryRank :: Int, tableEntryRank :: Int,
tableEntryVersion :: (Int, Int, Int), tableEntryVersion :: ((Int, Int, Int), Maybe Import.Tag),
tableEntryTeam :: Maybe (Entity Team) } tableEntryTeam :: Maybe (Entity Team) }
tableEntryStamp :: TableEntry -> UTCTime tableEntryStamp :: TableEntry -> UTCTime
@ -120,7 +120,7 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.int "#" tableEntryRank ++ Table.int "#" tableEntryRank
++ Table.text "submitter" formatSubmittingEntity ++ Table.text "submitter" formatSubmittingEntity
++ timestampCell "when" tableEntryStamp ++ timestampCell "when" tableEntryStamp
++ Table.text "ver." (formatVersion . tableEntryVersion) ++ versionCell tableEntryVersion
++ descriptionCell mauthId ++ descriptionCell mauthId
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests) ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests)
++ statusCell challengeName repoScheme challengeRepo (\tableEntry -> (entityKey $ tableEntrySubmission tableEntry, ++ statusCell challengeName repoScheme challengeRepo (\tableEntry -> (entityKey $ tableEntrySubmission tableEntry,
@ -184,12 +184,15 @@ formatSubmittingEntityInLeaderboard entry =
Nothing -> formatSubmitter $ leaderboardUser entry Nothing -> formatSubmitter $ leaderboardUser entry
versionCell :: (a -> ((Int, Int, Int), (Maybe Import.Tag))) -> Table site a
versionCell fun = Table.text "ver." (formatVersion . fst . fun)
leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry) leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Int, LeaderboardEntry)
leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty leaderboardTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ Table.int "#" fst ++ Table.int "#" fst
++ Table.text "submitter" (formatSubmittingEntityInLeaderboard . snd) ++ Table.text "submitter" (formatSubmittingEntityInLeaderboard . snd)
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd) ++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
++ Table.text "ver." (formatVersion . leaderboardVersion . snd) ++ versionCell (leaderboardVersion . snd)
++ leaderboardDescriptionCell mauthId ++ leaderboardDescriptionCell mauthId
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScoreFromLeaderboardEntry (getTestReference e) . snd)) tests) ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScoreFromLeaderboardEntry (getTestReference e) . snd)) tests)
++ Table.int "×" (leaderboardNumberOfSubmissions . snd) ++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
@ -328,11 +331,11 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation
Nothing -> [])) Nothing -> []))
compareMajorVersions :: (Int, Int, Int) -> (Int, Int, Int) -> Ordering compareMajorVersions :: ((Int, Int, Int), Maybe Import.Tag) -> ((Int, Int, Int), Maybe Import.Tag) -> Ordering
compareMajorVersions (aM, _, _) (bM, _, _) = aM `compare` bM compareMajorVersions ((aM, _, _),_) ((bM, _, _), _) = aM `compare` bM
compareVersions :: (Int, Int, Int) -> (Int, Int, Int) -> Ordering compareVersions :: ((Int, Int, Int), Maybe Import.Tag) -> ((Int, Int, Int), Maybe Import.Tag) -> Ordering
compareVersions (aM, aN, aP) (bM, bN, bP) = (aM `compare` bM) compareVersions ((aM, aN, aP), _) ((bM, bN, bP), _) = (aM `compare` bM)
<> (aN `compare` bN) <> (aN `compare` bN)
<> (aP `compare` bP) <> (aP `compare` bP)
@ -384,6 +387,10 @@ toLeaderboardEntry challengeId tests ss = do
submission <- runDB $ get404 submissionId submission <- runDB $ get404 submissionId
(Just (Entity _ itsVersion)) <- runDB $ getBy $ UniqueVersionByCommit $ submissionVersion submission (Just (Entity _ itsVersion)) <- runDB $ getBy $ UniqueVersionByCommit $ submissionVersion submission
mPhaseTag <- case versionPhase itsVersion of
Just phaseId -> runDB $ get phaseId
Nothing -> return Nothing
let theVersion = (versionMajor itsVersion, let theVersion = (versionMajor itsVersion,
versionMinor itsVersion, versionMinor itsVersion,
versionPatch itsVersion) versionPatch itsVersion)
@ -416,7 +423,7 @@ toLeaderboardEntry challengeId tests ss = do
leaderboardNumberOfSubmissions = length allUserSubmissions, leaderboardNumberOfSubmissions = length allUserSubmissions,
leaderboardTags = tagEnts, leaderboardTags = tagEnts,
leaderboardParams = map entityVal theParameters, leaderboardParams = map entityVal theParameters,
leaderboardVersion = theVersion, leaderboardVersion = (theVersion, mPhaseTag),
leaderboardIsOwner = isOwner, leaderboardIsOwner = isOwner,
leaderboardIsReevaluable = isReevaluable, leaderboardIsReevaluable = isReevaluable,
leaderboardIsVisible = isVisible, leaderboardIsVisible = isVisible,
@ -537,7 +544,7 @@ getScore (Just testId) variantId = do
data BasicSubmissionInfo = BasicSubmissionInfo { data BasicSubmissionInfo = BasicSubmissionInfo {
basicSubmissionInfoUser :: User, basicSubmissionInfoUser :: User,
basicSubmissionInfoTagEnts :: [(Entity Import.Tag, Entity SubmissionTag)], basicSubmissionInfoTagEnts :: [(Entity Import.Tag, Entity SubmissionTag)],
basicSubmissionInfoVersion :: Version, basicSubmissionInfoVersion :: (Version, Maybe Import.Tag),
basicSubmissionInfoTeam :: Maybe (Entity Team) } basicSubmissionInfoTeam :: Maybe (Entity Team) }
getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend, getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend,
@ -554,10 +561,15 @@ getBasicSubmissionInfo (Entity submissionId submission) = do
tagEnts <- getTags submissionId tagEnts <- getTags submissionId
let versionHash = submissionVersion submission let versionHash = submissionVersion submission
(Entity _ ver) <- getBy404 $ UniqueVersionByCommit versionHash (Entity _ ver) <- getBy404 $ UniqueVersionByCommit versionHash
mPhaseTag <- case versionPhase ver of
Just phaseId -> get phaseId
Nothing -> return Nothing
return $ (submissionId, BasicSubmissionInfo { return $ (submissionId, BasicSubmissionInfo {
basicSubmissionInfoUser = user, basicSubmissionInfoUser = user,
basicSubmissionInfoTagEnts = tagEnts, basicSubmissionInfoTagEnts = tagEnts,
basicSubmissionInfoVersion = ver, basicSubmissionInfoVersion = (ver, mPhaseTag),
basicSubmissionInfoTeam = mTeam }) basicSubmissionInfoTeam = mTeam })
getEvaluationMap :: (PersistUniqueRead backend, getEvaluationMap :: (PersistUniqueRead backend,
@ -573,7 +585,8 @@ getEvaluationMap testsMap submissionsMap (rank, (s@(Entity submissionId submissi
let submissionInfo = submissionsMap Map.! submissionId let submissionInfo = submissionsMap Map.! submissionId
let user = basicSubmissionInfoUser submissionInfo let user = basicSubmissionInfoUser submissionInfo
let tagEnts = basicSubmissionInfoTagEnts submissionInfo let tagEnts = basicSubmissionInfoTagEnts submissionInfo
let theVersion = basicSubmissionInfoVersion submissionInfo let theVersion = fst $ basicSubmissionInfoVersion submissionInfo
let mPhase = snd $ basicSubmissionInfoVersion submissionInfo
let versionHash = submissionVersion submission let versionHash = submissionVersion submission
let team = basicSubmissionInfoTeam submissionInfo let team = basicSubmissionInfoTeam submissionInfo
@ -596,4 +609,4 @@ getEvaluationMap testsMap submissionsMap (rank, (s@(Entity submissionId submissi
let minor = versionMinor theVersion let minor = versionMinor theVersion
let pat = versionPatch theVersion let pat = versionPatch theVersion
return $ TableEntry s v (Entity (submissionSubmitter submission) user) m tagEnts params rank (major, minor, pat) team return $ TableEntry s v (Entity (submissionSubmitter submission) user) m tagEnts params rank ((major, minor, pat), mPhase) team

1
config/models
View File

@ -85,6 +85,7 @@ Version
UniqueVersion commit major minor patch UniqueVersion commit major minor patch
description Text description Text
stamp UTCTime default=now() stamp UTCTime default=now()
phase TagId Maybe
Test Test
challenge ChallengeId challenge ChallengeId
metric EvaluationScheme metric EvaluationScheme

1
messages/en.msg
View File

@ -108,3 +108,4 @@ Join: Join
NoTests: SOMETHING IS WRONG WITH THE CHALLENGE, THERE ARE NO TESTS DEFINED. MAYBE TEST DIRECTORY ARE MISSING OR THE CHALLENGE WAS CREATED/UPDATE IN THE INVALID MANNER NoTests: SOMETHING IS WRONG WITH THE CHALLENGE, THERE ARE NO TESTS DEFINED. MAYBE TEST DIRECTORY ARE MISSING OR THE CHALLENGE WAS CREATED/UPDATE IN THE INVALID MANNER
TestAnnouncements: test announcements TestAnnouncements: test announcements
Color: color name or hex value Color: color name or hex value
Phase: competition phase (use a pre-existing tag)