Set challenge deadline

2019-09-24 22:52:25 +02:00 · 2019-09-24 22:52:25 +02:00 · 80b5ae6b33
commit 80b5ae6b33
parent 22e64bc4ef
5 changed files with 140 additions and 41 deletions
--- 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
+  (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)
--- 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
+
+  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
--- 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
--- 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
--- a/templates/challenge.hamlet
+++ b/templates/challenge.hamlet
@ -16,4 +16,7 @@
        $if withHeader
           <h1>#{challengeTitle challenge}
           <p>#{challengeDescription challenge}
+           $maybe deadline <- versionDeadline $ entityVal version
+              <p>Deadline: #{show deadline}
+           $nothing
        ^{pageBody bc}