Set challenge deadline

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 :: 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 {
                                     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
-    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 = 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 ()
+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
   (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
+               _ <- runDB $ insert $ Version (Just challengeId)
-                           newMajor
+                                            commit
-                           newMinor
+                                            newDeadline
-                           newPatch
+                                            newMajor
-                           versionDescription
+                                            newMinor
-                           theNow
+                                            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 :: 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..."
 
   (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 :: 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 (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 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)

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

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

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

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}