Challenge phase can be set

2021-09-25 18:37:08 +02:00 · 2021-09-25 18:37:08 +02:00 · d15264b904
commit d15264b904
parent 575ec8d4e4
5 changed files with 98 additions and 34 deletions
--- 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
--- 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)
--- 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
--- 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
--- 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)