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

Set challenge deadline

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

130
Handler/CreateChallenge.hs
View File

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

13
Handler/ShowChallenge.hs
View File

@ -261,10 +261,22 @@ trigger userId challengeName url mBranch mGitAnnexRemote = do
repoSpecGitAnnexRemote=mGitAnnexRemote}
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 challengeId mDescription mTags repoSpec chan = do
challenge <- runDB $ get404 challengeId
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' (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 withHeader challenge widget = do
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
version <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
maybeUser <- maybeAuth
bc <- widgetToPageContent widget
defaultLayout $ do

14
config/models
View File

@ -43,7 +43,21 @@ Challenge
version SHA1
-- challenge version
Version
-- introduced later, hence Maybe
-- to be replaced with non-Maybe value later
challenge ChallengeId Maybe
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
minor Int
patch Int

3
messages/en.msg
View File

@ -83,3 +83,6 @@ MinorChange: minor change
Patch: patch
ChangeType: change type
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

3
templates/challenge.hamlet
View File

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