diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index 1b57f12..5dac15a 100644 --- a/Handler/CreateChallenge.hs +++ b/Handler/CreateChallenge.hs @@ -45,7 +45,8 @@ data ChallengeMetadata = ChallengeMetadata { challengeMetadataPrivateGitAnnexRemote :: Maybe Text, challengeMetadataDeadline :: Maybe UTCTime, - challengeMetadataValidate :: Bool } + challengeMetadataValidate :: Bool, + challengeMetadataPhase :: Maybe Text } getCreateChallengeR :: Handler Html getCreateChallengeR = do @@ -93,6 +94,8 @@ doCreateChallenge creationData chan = do let mDeadline = challengeMetadataDeadline challengeMetadata let shouldBeValidated = challengeMetadataValidate challengeMetadata + mPhaseTagId <- fetchPhaseTagId (challengeMetadataPhase challengeMetadata) + maybePublicRepoId <- cloneRepo (RepoCloningSpec { cloningSpecRepo = RepoSpec { repoSpecUrl = publicUrl, @@ -118,7 +121,7 @@ doCreateChallenge creationData chan = do case maybePrivateRepoId of Just privateRepoId -> do 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 () @@ -134,27 +137,31 @@ instance Show ChallengeUpdateType where show MinorChange = "minor change" 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 challenge <- get404 challengeId publicRepo <- get404 $ challengePublicRepo challenge privateRepo <- get404 $ challengePrivateRepo 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 = do - (publicRepo, privateRepo, mDeadline) <- runDB $ fetchChallengeData challengeId - (formWidget, formEnctype) <- generateFormPost $ updateChallengeForm publicRepo privateRepo mDeadline + (publicRepo, privateRepo, mDeadline, mTag) <- runDB $ fetchChallengeData challengeId + (formWidget, formEnctype) <- generateFormPost $ updateChallengeForm publicRepo privateRepo mDeadline mTag defaultLayout $ do setTitle "Welcome To Yesod!" $(widgetFile "update-challenge") postChallengeUpdateR :: ChallengeId -> Handler TypedContent postChallengeUpdateR challengeId = do - (publicRepo, privateRepo, mDeadline) <- runDB $ fetchChallengeData challengeId - ((result, _), _) <- runFormPost $ updateChallengeForm publicRepo privateRepo mDeadline + (publicRepo, privateRepo, mDeadline, mTag) <- runDB $ fetchChallengeData challengeId + ((result, _), _) <- runFormPost $ updateChallengeForm publicRepo privateRepo mDeadline mTag let challengeData' = case result of FormSuccess res -> Just res _ -> Nothing @@ -177,6 +184,14 @@ combineMaybeDayAndTime mDeadlineDay mDeadlineTime = utctDayTime = fromMaybe (secondsToDiffTime 24 * 60 * 60 - 1) $ timeOfDayToTime <$> mDeadlineTime } 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 challengeData chan = do let updateType = challengeUpdateDataType challengeData @@ -194,6 +209,9 @@ doChallengeUpdate challengeId challengeData chan = do let newDeadline = challengeMetadataDeadline metadata let shouldBeValidated = challengeMetadataValidate metadata + mPhaseTagId <- fetchPhaseTagId (challengeMetadataPhase metadata) + + challenge <- runDB $ get404 challengeId (Entity _ version) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge let (newMajor, newMinor, newPatch) = incrementVersion updateType (versionMajor version, @@ -239,7 +257,8 @@ doChallengeUpdate challengeId challengeData chan = do VersionMinor =. newMinor, VersionPatch =. newPatch, VersionDescription =. versionDescription, - VersionStamp =. theNow] + VersionStamp =. theNow, + VersionPhase =. mPhaseTagId] Nothing -> do _ <- runDB $ insert $ Version (Just challengeId) @@ -250,6 +269,7 @@ doChallengeUpdate challengeId challengeData chan = do newPatch versionDescription theNow + mPhaseTagId return () (title, description, mImage) <- extractChallengeMetadata publicRepoId chan @@ -307,8 +327,8 @@ extractChallengeMetadata publicRepoId chan = do return (T.pack $ title, T.pack $ description, mImage) -addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Maybe UTCTime -> Channel -> Handler () -addChallenge name publicRepoId privateRepoId deadline chan = do +addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Maybe UTCTime -> Maybe TagId -> Channel -> Handler () +addChallenge name publicRepoId privateRepoId deadline mPhaseTagId chan = do msg chan "adding challenge..." (title, description, mImage) <- extractChallengeMetadata publicRepoId chan @@ -340,7 +360,8 @@ addChallenge name publicRepoId privateRepoId deadline chan = do versionMinor=defaultMinorVersion, versionPatch=defaultPatchVersion, versionDescription=defaultInitialDescription, - versionStamp=time} + versionStamp=time, + versionPhase=mPhaseTagId } updateTests challengeId chan @@ -431,11 +452,11 @@ testDirFilter = (fileType ==? Directory) &&? (SFF.fileName ~~? "dev-*" ||? SFF.f createChallengeForm :: Form ChallengeCreationData createChallengeForm = renderBootstrap3 BootstrapBasicForm $ ChallengeCreationData <$> (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) - => Maybe Repo -> Maybe Repo -> Maybe UTCTime -> AForm m ChallengeMetadata -challengeMetadataInputs mPublicRepo mPrivateRepo mDeadline = + => Maybe Repo -> Maybe Repo -> Maybe UTCTime -> Maybe Tag -> AForm m ChallengeMetadata +challengeMetadataInputs mPublicRepo mPrivateRepo mDeadline mPhase = ChallengeMetadata <$> (T.strip <$> areq textField (bfs MsgPublicUrl) (repoUrl <$> mPublicRepo)) <*> (T.strip <$> areq textField (bfs MsgBranch) (Just $ maybe "master" repoBranch 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) <*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip) (Just $ timeToTimeOfDay <$> utctDayTime <$> mDeadline)) <*> areq checkBoxField (bfs MsgShouldChallengeBeValidated) (Just True) + <*> aopt textField (bfs MsgPhase) (Just (tagName <$> mPhase)) -updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Form ChallengeUpdateData -updateChallengeForm publicRepo privateRepo mDeadline = renderBootstrap3 BootstrapBasicForm $ ChallengeUpdateData +updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Maybe Tag -> Form ChallengeUpdateData +updateChallengeForm publicRepo privateRepo mDeadline mPhase = renderBootstrap3 BootstrapBasicForm $ ChallengeUpdateData <$> 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. -- Contrary to `GEval.Validate.validationChallenge` do not diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 3b8cc3f..d3c2923 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -77,12 +77,34 @@ import Control.Lens hiding ((.=), (^.)) import Data.Proxy as DPR 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 toJSON entry = object [ "submitter" .= (formatSubmitter $ leaderboardUser entry) , "team" .= (teamIdent <$> entityVal <$> leaderboardTeam entry) , "when" .= (submissionStamp $ leaderboardBestSubmission entry) - , "version" .= leaderboardVersion entry + , "version" .= (fst $ leaderboardVersion entry) + , "phase" .= (snd $ leaderboardVersion entry) , "description" .= descriptionToBeShown (leaderboardBestSubmission entry) (leaderboardBestVariant entry) (leaderboardParams entry) @@ -213,6 +235,7 @@ instance ToSchema LeaderboardEntryView where stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String) boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool) evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView]) + tagSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Import.Tag) return $ NamedSchema (Just "LeaderboardEntry") $ mempty & type_ .~ SwaggerObject @@ -221,6 +244,7 @@ instance ToSchema LeaderboardEntryView where , ("team", stringSchema) , ("when", stringSchema) , ("version", versionSchema) + , ("phase", tagSchema) , ("description", stringSchema) , ("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" @@ -1559,7 +1583,7 @@ data SubmissionView = SubmissionView { submissionViewRank :: Int, submissionViewSubmitter :: Text, submissionViewWhen :: UTCTime, - submissionViewVersion :: (Int, Int, Int), + submissionViewVersion :: ((Int, Int, Int), Maybe Import.Tag), submissionViewDescription :: Text, submissionViewTags :: [TagView], submissionViewHash :: Text, @@ -1578,7 +1602,8 @@ instance ToJSON SubmissionView where , "rank" .= submissionViewRank s , "submitter" .= submissionViewSubmitter s , "when" .= submissionViewWhen s - , "version" .= submissionViewVersion s + , "version" .= (fst $ submissionViewVersion s) + , "phase" .= (snd $ submissionViewVersion s) , "description" .= submissionViewDescription s , "tags" .= submissionViewTags s , "hash" .= submissionViewHash s @@ -1597,6 +1622,7 @@ instance ToSchema SubmissionView where intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int) tagsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TagView]) evalsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView]) + tagSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [Import.Tag]) return $ NamedSchema (Just "SubmissionView") $ mempty & type_ .~ SwaggerObject & properties .~ @@ -1606,6 +1632,7 @@ instance ToSchema SubmissionView where , ("submitter", submitterSchema) , ("when", stringSchema) , ("version", versionSchema) + , ("phase", tagSchema) , ("description", stringSchema) , ("tags", tagsSchema) , ("hash", hashSchema) diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 6bae598..a905dca 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -73,7 +73,7 @@ data LeaderboardEntry = LeaderboardEntry { leaderboardNumberOfSubmissions :: Int, leaderboardTags :: [(Entity Import.Tag, Entity SubmissionTag)], leaderboardParams :: [Parameter], - leaderboardVersion :: (Int, Int, Int), + leaderboardVersion :: ((Int, Int, Int), (Maybe Import.Tag)), leaderboardIsOwner :: Bool, leaderboardIsVisible :: Bool, leaderboardIsReevaluable :: Bool, @@ -103,7 +103,7 @@ data TableEntry = TableEntry { tableEntryTagsInfo :: [(Entity Import.Tag, Entity SubmissionTag)], tableEntryParams :: [Entity Parameter], tableEntryRank :: Int, - tableEntryVersion :: (Int, Int, Int), + tableEntryVersion :: ((Int, Int, Int), Maybe Import.Tag), tableEntryTeam :: Maybe (Entity Team) } tableEntryStamp :: TableEntry -> UTCTime @@ -120,7 +120,7 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty ++ Table.int "#" tableEntryRank ++ Table.text "submitter" formatSubmittingEntity ++ timestampCell "when" tableEntryStamp - ++ Table.text "ver." (formatVersion . tableEntryVersion) + ++ versionCell tableEntryVersion ++ descriptionCell mauthId ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests) ++ statusCell challengeName repoScheme challengeRepo (\tableEntry -> (entityKey $ tableEntrySubmission tableEntry, @@ -184,12 +184,15 @@ formatSubmittingEntityInLeaderboard 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 mauthId challengeName repoScheme challengeRepo tests = mempty ++ Table.int "#" fst ++ Table.text "submitter" (formatSubmittingEntityInLeaderboard . snd) ++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd) - ++ Table.text "ver." (formatVersion . leaderboardVersion . snd) + ++ versionCell (leaderboardVersion . snd) ++ leaderboardDescriptionCell mauthId ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScoreFromLeaderboardEntry (getTestReference e) . snd)) tests) ++ Table.int "×" (leaderboardNumberOfSubmissions . snd) @@ -328,11 +331,11 @@ getAuxSubmissionEnts testId evaluationMaps = map processEvaluationMap evaluation Nothing -> [])) -compareMajorVersions :: (Int, Int, Int) -> (Int, Int, Int) -> Ordering -compareMajorVersions (aM, _, _) (bM, _, _) = aM `compare` bM +compareMajorVersions :: ((Int, Int, Int), Maybe Import.Tag) -> ((Int, Int, Int), Maybe Import.Tag) -> Ordering +compareMajorVersions ((aM, _, _),_) ((bM, _, _), _) = aM `compare` bM -compareVersions :: (Int, Int, Int) -> (Int, Int, Int) -> Ordering -compareVersions (aM, aN, aP) (bM, bN, bP) = (aM `compare` bM) +compareVersions :: ((Int, Int, Int), Maybe Import.Tag) -> ((Int, Int, Int), Maybe Import.Tag) -> Ordering +compareVersions ((aM, aN, aP), _) ((bM, bN, bP), _) = (aM `compare` bM) <> (aN `compare` bN) <> (aP `compare` bP) @@ -384,6 +387,10 @@ toLeaderboardEntry challengeId tests ss = do submission <- runDB $ get404 submissionId (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, versionMinor itsVersion, versionPatch itsVersion) @@ -416,7 +423,7 @@ toLeaderboardEntry challengeId tests ss = do leaderboardNumberOfSubmissions = length allUserSubmissions, leaderboardTags = tagEnts, leaderboardParams = map entityVal theParameters, - leaderboardVersion = theVersion, + leaderboardVersion = (theVersion, mPhaseTag), leaderboardIsOwner = isOwner, leaderboardIsReevaluable = isReevaluable, leaderboardIsVisible = isVisible, @@ -537,7 +544,7 @@ getScore (Just testId) variantId = do data BasicSubmissionInfo = BasicSubmissionInfo { basicSubmissionInfoUser :: User, basicSubmissionInfoTagEnts :: [(Entity Import.Tag, Entity SubmissionTag)], - basicSubmissionInfoVersion :: Version, + basicSubmissionInfoVersion :: (Version, Maybe Import.Tag), basicSubmissionInfoTeam :: Maybe (Entity Team) } getBasicSubmissionInfo :: (MonadIO m, PersistQueryRead backend, @@ -554,10 +561,15 @@ getBasicSubmissionInfo (Entity submissionId submission) = do tagEnts <- getTags submissionId let versionHash = submissionVersion submission (Entity _ ver) <- getBy404 $ UniqueVersionByCommit versionHash + + mPhaseTag <- case versionPhase ver of + Just phaseId -> get phaseId + Nothing -> return Nothing + return $ (submissionId, BasicSubmissionInfo { basicSubmissionInfoUser = user, basicSubmissionInfoTagEnts = tagEnts, - basicSubmissionInfoVersion = ver, + basicSubmissionInfoVersion = (ver, mPhaseTag), basicSubmissionInfoTeam = mTeam }) getEvaluationMap :: (PersistUniqueRead backend, @@ -573,7 +585,8 @@ getEvaluationMap testsMap submissionsMap (rank, (s@(Entity submissionId submissi let submissionInfo = submissionsMap Map.! submissionId let user = basicSubmissionInfoUser submissionInfo let tagEnts = basicSubmissionInfoTagEnts submissionInfo - let theVersion = basicSubmissionInfoVersion submissionInfo + let theVersion = fst $ basicSubmissionInfoVersion submissionInfo + let mPhase = snd $ basicSubmissionInfoVersion submissionInfo let versionHash = submissionVersion submission let team = basicSubmissionInfoTeam submissionInfo @@ -596,4 +609,4 @@ getEvaluationMap testsMap submissionsMap (rank, (s@(Entity submissionId submissi let minor = versionMinor 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 diff --git a/config/models b/config/models index e96152b..86e0129 100644 --- a/config/models +++ b/config/models @@ -85,6 +85,7 @@ Version UniqueVersion commit major minor patch description Text stamp UTCTime default=now() + phase TagId Maybe Test challenge ChallengeId metric EvaluationScheme diff --git a/messages/en.msg b/messages/en.msg index 09133b1..7c7cc76 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -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 TestAnnouncements: test announcements Color: color name or hex value +Phase: competition phase (use a pre-existing tag)