Set challenge deadline

This commit is contained in:
Filip Gralinski 2019-09-24 22:52:25 +02:00
parent 22e64bc4ef
commit 80b5ae6b33
5 changed files with 140 additions and 41 deletions

View File

@ -10,6 +10,7 @@ import Handler.Extract
import GEval.Core import GEval.Core
import GEval.OptionsParser import GEval.OptionsParser
import GEval.EvaluationScheme
import Gonito.ExtractMetadata (getLastCommitMessage) import Gonito.ExtractMetadata (getLastCommitMessage)
@ -18,6 +19,9 @@ import System.FilePath.Find as SFF
import System.FilePath import System.FilePath
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Clock (secondsToDiffTime)
import Data.Time.LocalTime (timeOfDayToTime, TimeOfDay, timeToTimeOfDay)
import PersistSHA1 import PersistSHA1
import qualified Data.ByteString as S import qualified Data.ByteString as S
@ -39,7 +43,10 @@ postCreateChallengeR = do
FormSuccess res -> Just res FormSuccess res -> Just res
_ -> Nothing _ -> Nothing
Just (name, publicUrl, publicBranch, publicGitAnnexRemote, Just (name, publicUrl, publicBranch, publicGitAnnexRemote,
privateUrl, privateBranch, privateGitAnnexRemote) = challengeData privateUrl, privateBranch, privateGitAnnexRemote,
mDeadlineDay, mDeadlineTime) = challengeData
let mDeadline = combineMaybeDayAndTime mDeadlineDay mDeadlineTime
userId <- requireAuthId userId <- requireAuthId
user <- runDB $ get404 userId user <- runDB $ get404 userId
@ -57,13 +64,14 @@ postCreateChallengeR = do
(T.strip privateUrl) (T.strip privateUrl)
(T.strip privateBranch) (T.strip privateBranch)
(T.strip <$> privateGitAnnexRemote) (T.strip <$> privateGitAnnexRemote)
mDeadline
else else
runViewProgress $ (flip err) "unexpected challenge ID (use only lower-case letters, digits and hyphens, start with a letter)" runViewProgress $ (flip err) "unexpected challenge ID (use only lower-case letters, digits and hyphens, start with a letter)"
else else
runViewProgress $ (flip err) "MUST BE AN ADMIN TO CREATE A CHALLENGE" runViewProgress $ (flip err) "MUST BE AN ADMIN TO CREATE A CHALLENGE"
doCreateChallenge :: Text -> Text -> Text -> Maybe Text -> Text -> Text -> Maybe Text -> Channel -> Handler () doCreateChallenge :: Text -> Text -> Text -> Maybe Text -> Text -> Text -> Maybe Text -> Maybe UTCTime -> Channel -> Handler ()
doCreateChallenge name publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote chan = do doCreateChallenge name publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote mDeadline chan = do
maybePublicRepoId <- cloneRepo (RepoCloningSpec { maybePublicRepoId <- cloneRepo (RepoCloningSpec {
cloningSpecRepo = RepoSpec { cloningSpecRepo = RepoSpec {
repoSpecUrl = publicUrl, repoSpecUrl = publicUrl,
@ -87,7 +95,7 @@ doCreateChallenge name publicUrl publicBranch publicGitAnnexRemote privateUrl pr
repoSpecBranch = (repoBranch publicRepo), repoSpecBranch = (repoBranch publicRepo),
repoSpecGitAnnexRemote = (repoGitAnnexRemote publicRepo)}}) chan repoSpecGitAnnexRemote = (repoGitAnnexRemote publicRepo)}}) chan
case maybePrivateRepoId of case maybePrivateRepoId of
Just privateRepoId -> addChallenge name publicRepoId privateRepoId chan Just privateRepoId -> addChallenge name publicRepoId privateRepoId mDeadline chan
Nothing -> return () Nothing -> return ()
Nothing -> return () Nothing -> return ()
@ -99,33 +107,76 @@ 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 challengeId = do
challenge <- get404 challengeId
publicRepo <- get404 $ challengePublicRepo challenge
privateRepo <- get404 $ challengePrivateRepo challenge
version <- getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
return (publicRepo, privateRepo, versionDeadline $ entityVal $ version)
getChallengeUpdateR :: ChallengeId -> Handler Html getChallengeUpdateR :: ChallengeId -> Handler Html
getChallengeUpdateR challengeId = do getChallengeUpdateR challengeId = do
(formWidget, formEnctype) <- generateFormPost updateChallengeForm (publicRepo, privateRepo, mDeadline) <- runDB $ fetchChallengeData challengeId
defaultLayout $ do (formWidget, formEnctype) <- generateFormPost $ updateChallengeForm publicRepo privateRepo mDeadline
setTitle "Welcome To Yesod!" defaultLayout $ do
$(widgetFile "update-challenge") setTitle "Welcome To Yesod!"
$(widgetFile "update-challenge")
postChallengeUpdateR :: ChallengeId -> Handler TypedContent postChallengeUpdateR :: ChallengeId -> Handler TypedContent
postChallengeUpdateR challengeId = do postChallengeUpdateR challengeId = do
((result, _), _) <- runFormPost updateChallengeForm (publicRepo, privateRepo, mDeadline) <- runDB $ fetchChallengeData challengeId
((result, _), _) <- runFormPost $ updateChallengeForm publicRepo privateRepo mDeadline
let challengeData = case result of let challengeData = case result of
FormSuccess res -> Just res FormSuccess res -> Just res
_ -> Nothing _ -> Nothing
Just (updateType, publicUrl, publicBranch, publicGitAnnexRemote, Just (updateType, publicUrl, publicBranch, publicGitAnnexRemote,
privateUrl, privateBranch, privateGitAnnexRemote) = challengeData privateUrl, privateBranch, privateGitAnnexRemote,
mDeadlineDay, mDeadlineTime) = challengeData
let mNewDeadline = combineMaybeDayAndTime mDeadlineDay mDeadlineTime
userId <- requireAuthId userId <- requireAuthId
user <- runDB $ get404 userId user <- runDB $ get404 userId
if userIsAdmin user if userIsAdmin user
then then
do do
runViewProgress $ doChallengeUpdate challengeId updateType publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote runViewProgress $ doChallengeUpdate challengeId
updateType
mNewDeadline
publicUrl
publicBranch
publicGitAnnexRemote
privateUrl
privateBranch
privateGitAnnexRemote
else else
runViewProgress $ (flip err) "MUST BE AN ADMIN TO UPDATE A CHALLENGE" runViewProgress $ (flip err) "MUST BE AN ADMIN TO UPDATE A CHALLENGE"
doChallengeUpdate :: ChallengeId -> ChallengeUpdateType -> Text -> Text -> Maybe Text -> Text -> Text -> Maybe Text -> Channel -> Handler () combineMaybeDayAndTime :: Maybe Day -> Maybe TimeOfDay -> Maybe UTCTime
doChallengeUpdate challengeId updateType publicUrl publicBranch publicGitAnnexRemote privateUrl privateBranch privateGitAnnexRemote chan = do combineMaybeDayAndTime mDeadlineDay mDeadlineTime =
case mDeadlineDay of
Just deadlineDay -> Just $ UTCTime {
utctDay = deadlineDay,
utctDayTime = fromMaybe (secondsToDiffTime 24 * 60 * 60 - 1) $ timeOfDayToTime <$> mDeadlineTime }
Nothing -> Nothing
doChallengeUpdate :: ChallengeId -> ChallengeUpdateType -> Maybe UTCTime
-> Text -> Text -> Maybe Text
-> Text -> Text -> Maybe Text
-> Channel -> Handler ()
doChallengeUpdate challengeId
updateType
newDeadline
publicUrl
publicBranch
publicGitAnnexRemote
privateUrl
privateBranch
privateGitAnnexRemote
chan = do
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,
@ -162,19 +213,22 @@ doChallengeUpdate challengeId updateType publicUrl publicBranch publicGitAnnexRe
mAlreadyExistingVersion <- runDB $ getBy $ UniqueVersionByCommit commit mAlreadyExistingVersion <- runDB $ getBy $ UniqueVersionByCommit commit
case mAlreadyExistingVersion of case mAlreadyExistingVersion of
Just (Entity versionId _) -> do Just (Entity versionId _) -> do
runDB $ update versionId [VersionMajor =. newMajor, runDB $ update versionId [VersionDeadline =. newDeadline,
VersionMajor =. newMajor,
VersionMinor =. newMinor, VersionMinor =. newMinor,
VersionPatch =. newPatch, VersionPatch =. newPatch,
VersionDescription =. versionDescription, VersionDescription =. versionDescription,
VersionStamp =. theNow] VersionStamp =. theNow]
Nothing -> do Nothing -> do
_ <- runDB $ insert $ Version commit _ <- runDB $ insert $ Version (Just challengeId)
newMajor commit
newMinor newDeadline
newPatch newMajor
versionDescription newMinor
theNow newPatch
versionDescription
theNow
return () return ()
(title, description, mImage) <- extractChallengeMetadata publicRepoId chan (title, description, mImage) <- extractChallengeMetadata publicRepoId chan
@ -232,8 +286,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) -> Channel -> Handler () addChallenge :: Text -> (Key Repo) -> (Key Repo) -> Maybe UTCTime -> Channel -> Handler ()
addChallenge name publicRepoId privateRepoId chan = do addChallenge name publicRepoId privateRepoId deadline chan = do
msg chan "adding challenge..." msg chan "adding challenge..."
(title, description, mImage) <- extractChallengeMetadata publicRepoId chan (title, description, mImage) <- extractChallengeMetadata publicRepoId chan
@ -243,14 +297,6 @@ addChallenge name publicRepoId privateRepoId chan = do
let commit=repoCurrentCommit $ privateRepo let commit=repoCurrentCommit $ privateRepo
_ <- runDB $ insert $ Version {
versionCommit=commit,
versionMajor=defaultMajorVersion,
versionMinor=defaultMinorVersion,
versionPatch=defaultPatchVersion,
versionDescription=defaultInitialDescription,
versionStamp=time}
challengeId <- runDB $ insert $ Challenge { challengeId <- runDB $ insert $ Challenge {
challengePublicRepo=publicRepoId, challengePublicRepo=publicRepoId,
challengePrivateRepo=privateRepoId, challengePrivateRepo=privateRepoId,
@ -263,6 +309,16 @@ addChallenge name publicRepoId privateRepoId chan = do
challengeArchived=Just False, challengeArchived=Just False,
challengeVersion=commit} challengeVersion=commit}
_ <- runDB $ insert $ Version {
versionChallenge=Just challengeId,
versionCommit=commit,
versionDeadline=deadline,
versionMajor=defaultMajorVersion,
versionMinor=defaultMinorVersion,
versionPatch=defaultPatchVersion,
versionDescription=defaultInitialDescription,
versionStamp=time}
updateTests challengeId chan updateTests challengeId chan
return () return ()
@ -309,6 +365,7 @@ checkTestDir chan challengeId challenge commit testDir = do
msg chan $ concat ["Test dir ", (T.pack testDir), " does not have expected results."] msg chan $ concat ["Test dir ", (T.pack testDir), " does not have expected results."]
return () return ()
insertOrUpdateTest :: (MonadIO m, PersistUniqueRead backend, PersistStoreWrite backend, BaseBackend backend ~ SqlBackend) => FilePath -> Key Challenge -> SHA1 -> SHA1 -> GEvalOptions -> (Int, EvaluationScheme) -> ReaderT backend m ()
insertOrUpdateTest testDir challengeId checksum commit opts (priority, metric) = do insertOrUpdateTest testDir challengeId checksum commit opts (priority, metric) = do
let name=T.pack $ takeFileName testDir let name=T.pack $ takeFileName testDir
mAlreadyExistingTest <- getBy $ UniqueChallengeNameMetricChecksum challengeId name metric checksum mAlreadyExistingTest <- getBy $ UniqueChallengeNameMetricChecksum challengeId name metric checksum
@ -346,8 +403,8 @@ never = depth ==? 0
testDirFilter :: FindClause Bool testDirFilter :: FindClause Bool
testDirFilter = (fileType ==? Directory) &&? (SFF.fileName ~~? "dev-*" ||? SFF.fileName ~~? "test-*") testDirFilter = (fileType ==? Directory) &&? (SFF.fileName ~~? "dev-*" ||? SFF.fileName ~~? "test-*")
createChallengeForm :: Form (Text, Text, Text, Maybe Text, Text, Text, Maybe Text) createChallengeForm :: Form (Text, Text, Text, Maybe Text, Text, Text, Maybe Text, Maybe Day, Maybe TimeOfDay)
createChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,) createChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,,,)
<$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing <$> areq textField (fieldWithTooltip MsgChallengeName MsgChallengeNameTooltip) Nothing
<*> areq textField (bfs MsgPublicUrl) Nothing <*> areq textField (bfs MsgPublicUrl) Nothing
<*> areq textField (bfs MsgBranch) (Just "master") <*> areq textField (bfs MsgBranch) (Just "master")
@ -355,13 +412,22 @@ createChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,)
<*> areq textField (bfs MsgPrivateUrl) Nothing <*> areq textField (bfs MsgPrivateUrl) Nothing
<*> areq textField (bfs MsgBranch) (Just "dont-peek") <*> areq textField (bfs MsgBranch) (Just "dont-peek")
<*> aopt textField (bfs MsgGitAnnexRemote) Nothing <*> aopt textField (bfs MsgGitAnnexRemote) Nothing
<*> aopt dayField (bfs MsgChallengeDeadlineDay) Nothing
<*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip) Nothing
updateChallengeForm :: Form (ChallengeUpdateType, Text, Text, Maybe Text, Text, Text, Maybe Text)
updateChallengeForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,,) updateChallengeForm :: Repo -> Repo -> Maybe UTCTime -> Form (ChallengeUpdateType,
Text, Text, Maybe Text,
Text, Text, Maybe Text,
Maybe Day, Maybe TimeOfDay)
updateChallengeForm publicRepo privateRepo mDeadline = renderBootstrap3 BootstrapBasicForm $ (,,,,,,,,)
<$> areq (radioField optionsEnum) "change type" (Just ChallengePatch) <$> areq (radioField optionsEnum) "change type" (Just ChallengePatch)
<*> areq textField (bfs MsgPublicUrl) Nothing <*> areq textField (bfs MsgPublicUrl) (Just $ repoUrl publicRepo)
<*> areq textField (bfs MsgBranch) (Just "master") <*> areq textField (bfs MsgBranch) (Just $ repoBranch publicRepo)
<*> aopt textField (bfs MsgGitAnnexRemote) Nothing <*> aopt textField (bfs MsgGitAnnexRemote) (Just $ repoGitAnnexRemote publicRepo)
<*> areq textField (bfs MsgPrivateUrl) Nothing <*> areq textField (bfs MsgPrivateUrl) (Just $ repoUrl privateRepo)
<*> areq textField (bfs MsgBranch) (Just "dont-peek") <*> areq textField (bfs MsgBranch) (Just $ repoBranch privateRepo)
<*> aopt textField (bfs MsgGitAnnexRemote) Nothing <*> aopt textField (bfs MsgGitAnnexRemote) (Just $ repoGitAnnexRemote privateRepo)
<*> aopt dayField (bfs MsgChallengeDeadlineDay) (Just $ utctDay <$> mDeadline)
<*> aopt timeFieldTypeTime (fieldWithTooltip MsgChallengeDeadlineTime MsgChallengeDeadlineTooltip)
(Just $ timeToTimeOfDay <$> utctDayTime <$> mDeadline)

View File

@ -261,10 +261,22 @@ trigger userId challengeName url mBranch mGitAnnexRemote = do
repoSpecGitAnnexRemote=mGitAnnexRemote} repoSpecGitAnnexRemote=mGitAnnexRemote}
Nothing -> return $ toTypedContent (("Unknown challenge `" ++ (Data.Text.unpack challengeName) ++ "`. Cannot be triggered, must be submitted manually at Gonito.net!\n") :: String) Nothing -> return $ toTypedContent (("Unknown challenge `" ++ (Data.Text.unpack challengeName) ++ "`. Cannot be triggered, must be submitted manually at Gonito.net!\n") :: String)
isBefore :: UTCTime -> Maybe UTCTime -> Bool
isBefore _ Nothing = True
isBefore moment (Just deadline) = moment <= deadline
doCreateSubmission :: UserId -> Key Challenge -> Maybe Text -> Maybe Text -> RepoSpec -> Channel -> Handler () doCreateSubmission :: UserId -> Key Challenge -> Maybe Text -> Maybe Text -> RepoSpec -> Channel -> Handler ()
doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
challenge <- runDB $ get404 challengeId challenge <- runDB $ get404 challengeId
doCreateSubmission' (challengeArchived challenge) userId challengeId mDescription mTags repoSpec chan
version <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
theNow <- liftIO getCurrentTime
if theNow `isBefore` (versionDeadline $ entityVal version)
then
doCreateSubmission' (challengeArchived challenge) userId challengeId mDescription mTags repoSpec chan
else
msg chan "Submission is past the deadline, no submission will be accepted from now on."
doCreateSubmission' :: Maybe Bool -> UserId -> Key Challenge -> Maybe Text -> Maybe Text -> RepoSpec -> Channel -> Handler () doCreateSubmission' :: Maybe Bool -> UserId -> Key Challenge -> Maybe Text -> Maybe Text -> RepoSpec -> Channel -> Handler ()
doCreateSubmission' (Just True) _ _ _ _ _ chan = msg chan "This challenge is archived, you cannot submit to it. Ask the site admin to unarchive it." doCreateSubmission' (Just True) _ _ _ _ _ chan = msg chan "This challenge is archived, you cannot submit to it. Ask the site admin to unarchive it."
@ -731,6 +743,7 @@ $.getJSON("@{ChallengeParamGraphDataR (challengeName challenge) testId param}",
challengeLayout :: Bool -> Challenge -> WidgetFor App () -> HandlerFor App Html challengeLayout :: Bool -> Challenge -> WidgetFor App () -> HandlerFor App Html
challengeLayout withHeader challenge widget = do challengeLayout withHeader challenge widget = do
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
version <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
maybeUser <- maybeAuth maybeUser <- maybeAuth
bc <- widgetToPageContent widget bc <- widgetToPageContent widget
defaultLayout $ do defaultLayout $ do

View File

@ -43,7 +43,21 @@ Challenge
version SHA1 version SHA1
-- challenge version -- challenge version
Version Version
-- introduced later, hence Maybe
-- to be replaced with non-Maybe value later
challenge ChallengeId Maybe
commit SHA1 commit SHA1
-- Optional challenge deadline. After the deadline
-- no submission will be accepted, though a new
-- challenge version might be uploaded and then
-- new submissions could be sent. This could be used
-- for organizing a "post-track" after the competition
-- has ended. Note, however, that, when sorting submissions,
-- the ones uploaded under the version with a deadline (i.e. within
-- the main track) will be preferred against the ones
-- uploaded under the version without a deadline (no matter what
-- is the major version).
deadline UTCTime Maybe
major Int major Int
minor Int minor Int
patch Int patch Int

View File

@ -83,3 +83,6 @@ MinorChange: minor change
Patch: patch Patch: patch
ChangeType: change type ChangeType: change type
Update: Update Update: Update
ChallengeDeadlineDay: challenge deadline day
ChallengeDeadlineTime: challenge deadline time
ChallengeDeadlineTooltip: no submissions will be accepted after the deadline; this can be used for organizing competitions set in time

View File

@ -16,4 +16,7 @@
$if withHeader $if withHeader
<h1>#{challengeTitle challenge} <h1>#{challengeTitle challenge}
<p>#{challengeDescription challenge} <p>#{challengeDescription challenge}
$maybe deadline <- versionDeadline $ entityVal version
<p>Deadline: #{show deadline}
$nothing
^{pageBody bc} ^{pageBody bc}