From 80b5ae6b3341c1ec2f94cbe04d49b1c17131aab7 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Tue, 24 Sep 2019 22:52:25 +0200 Subject: [PATCH] Set challenge deadline --- Handler/CreateChallenge.hs | 146 +++++++++++++++++++++++++++---------- Handler/ShowChallenge.hs | 15 +++- config/models | 14 ++++ messages/en.msg | 3 + templates/challenge.hamlet | 3 + 5 files changed, 140 insertions(+), 41 deletions(-) diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index c7db92e..6ed47ea 100644 --- a/Handler/CreateChallenge.hs +++ b/Handler/CreateChallenge.hs @@ -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 - defaultLayout $ do - setTitle "Welcome To Yesod!" - $(widgetFile "update-challenge") + (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,19 +213,22 @@ 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 - newMajor - newMinor - newPatch - versionDescription - theNow + _ <- runDB $ insert $ Version (Just challengeId) + commit + newDeadline + newMajor + newMinor + newPatch + versionDescription + theNow return () (title, description, mImage) <- extractChallengeMetadata publicRepoId chan @@ -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) diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 35b64d8..4f0eaf4 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -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 - 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' (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 diff --git a/config/models b/config/models index 935728a..9157b5f 100644 --- a/config/models +++ b/config/models @@ -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 diff --git a/messages/en.msg b/messages/en.msg index 2ac03e4..14ae7a3 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -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 diff --git a/templates/challenge.hamlet b/templates/challenge.hamlet index deb02d1..dd17252 100644 --- a/templates/challenge.hamlet +++ b/templates/challenge.hamlet @@ -16,4 +16,7 @@ $if withHeader

#{challengeTitle challenge}

#{challengeDescription challenge} + $maybe deadline <- versionDeadline $ entityVal version +

Deadline: #{show deadline} + $nothing ^{pageBody bc}