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

Refactor challenge submissions

Browse Source
This commit is contained in:
Filip Gralinski 2020-03-28 18:08:44 +01:00
parent fc5570b2dc
commit 7e48e0c9fc
1 changed files with 37 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
Handler/ShowChallenge.hs
View File

@ -237,16 +237,13 @@ postChallengeSubmissionR :: Text -> Handler TypedContent
postChallengeSubmissionR name = do postChallengeSubmissionR name = do
(Entity challengeId _) <- runDB $ getBy404 $ UniqueName name (Entity challengeId _) <- runDB $ getBy404 $ UniqueName name
((result, _), _) <- runFormPost $ submissionForm Nothing Nothing Nothing ((result, _), _) <- runFormPost $ submissionForm Nothing Nothing Nothing
let submissionData = case result of let submissionData' = case result of
FormSuccess res -> Just res FormSuccess res -> Just res
_ -> Nothing _ -> Nothing
Just (mDescription, mTags, submissionUrl, submissionBranch, submissionGitAnnexRemote) = submissionData Just submissionData = submissionData'
userId <- requireAuthId userId <- requireAuthId
runViewProgress $ doCreateSubmission userId challengeId mDescription mTags RepoSpec { runViewProgress $ doCreateSubmission userId challengeId submissionData
repoSpecUrl=submissionUrl,
repoSpecBranch=submissionBranch,
repoSpecGitAnnexRemote=submissionGitAnnexRemote}
postTriggerLocallyR :: Handler TypedContent postTriggerLocallyR :: Handler TypedContent
postTriggerLocallyR = do postTriggerLocallyR = do
@ -288,20 +285,26 @@ trigger :: UserId -> Text -> Text -> Maybe Text -> Maybe Text -> Handler TypedCo
trigger userId challengeName url mBranch mGitAnnexRemote = do trigger userId challengeName url mBranch mGitAnnexRemote = do
let branch = fromMaybe "master" mBranch let branch = fromMaybe "master" mBranch
mChallengeEnt <- runDB $ getBy $ UniqueName challengeName mChallengeEnt <- runDB $ getBy $ UniqueName challengeName
let defSubmission = ChallengeSubmissionData {
challengeSubmissionDataDescription = Nothing,
challengeSubmissionDataTags = Nothing,
challengeSubmissionDataRepo = RepoSpec {
repoSpecUrl=url,
repoSpecBranch=branch,
repoSpecGitAnnexRemote=mGitAnnexRemote}
}
case mChallengeEnt of case mChallengeEnt of
Just (Entity challengeId _) -> runOpenViewProgress $ doCreateSubmission userId challengeId Just (Entity challengeId _) -> runOpenViewProgress $ doCreateSubmission userId challengeId defSubmission
Nothing Nothing
RepoSpec {repoSpecUrl=url,
repoSpecBranch=branch,
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 :: UTCTime -> Maybe UTCTime -> Bool
isBefore _ Nothing = True isBefore _ Nothing = True
isBefore moment (Just deadline) = moment <= deadline isBefore moment (Just deadline) = moment <= deadline
doCreateSubmission :: UserId -> Key Challenge -> Maybe Text -> Maybe Text -> RepoSpec -> Channel -> Handler () doCreateSubmission :: UserId -> Key Challenge -> ChallengeSubmissionData-> Channel -> Handler ()
doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do doCreateSubmission userId challengeId challengeSubmissionData chan = do
challenge <- runDB $ get404 challengeId challenge <- runDB $ get404 challengeId
version <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge version <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
@ -309,15 +312,19 @@ doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
if theNow `isBefore` (versionDeadline $ entityVal version) if theNow `isBefore` (versionDeadline $ entityVal version)
then then
doCreateSubmission' (challengeArchived challenge) userId challengeId mDescription mTags repoSpec chan doCreateSubmission' (challengeArchived challenge) userId challengeId challengeSubmissionData chan
else else
msg chan "Submission is past the deadline, no submission will be accepted from now on." 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 -> ChallengeSubmissionData -> 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."
doCreateSubmission' _ userId challengeId mDescription mTags repoSpec chan = do doCreateSubmission' _ userId challengeId challengeSubmissionData chan = do
maybeRepoKey <- getSubmissionRepo userId challengeId repoSpec chan let mDescription = challengeSubmissionDataDescription challengeSubmissionData
case maybeRepoKey of let mTags = challengeSubmissionDataTags challengeSubmissionData
let repoSpec = challengeSubmissionDataRepo challengeSubmissionData
maybeRepoKey <- getSubmissionRepo userId challengeId repoSpec chan
case maybeRepoKey of
Just repoId -> do Just repoId -> do
challenge <- runDB $ get404 challengeId challenge <- runDB $ get404 challengeId
@ -545,13 +552,19 @@ checkRepoAvailibility challengeId repoId chan = do
challengeSubmissionWidget :: (ToMarkup a1, ToWidget App a2) => a2 -> a1 -> Challenge -> WidgetFor App () challengeSubmissionWidget :: (ToMarkup a1, ToWidget App a2) => a2 -> a1 -> Challenge -> WidgetFor App ()
challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission") challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission")
submissionForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Text, Text, Maybe Text) data ChallengeSubmissionData = ChallengeSubmissionData {
submissionForm defaultUrl defBranch defaultGitAnnexRemote = renderBootstrap3 BootstrapBasicForm $ (,,,,) challengeSubmissionDataDescription :: Maybe Text,
challengeSubmissionDataTags :: Maybe Text,
challengeSubmissionDataRepo :: RepoSpec }
submissionForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form ChallengeSubmissionData
submissionForm defaultUrl defBranch defaultGitAnnexRemote = renderBootstrap3 BootstrapBasicForm $ ChallengeSubmissionData
<$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing <$> aopt textField (fieldWithTooltip MsgSubmissionDescription MsgSubmissionDescriptionTooltip) Nothing
<*> aopt textField (tagsfs MsgSubmissionTags) Nothing <*> aopt textField (tagsfs MsgSubmissionTags) Nothing
<*> areq textField (bfs MsgSubmissionUrl) defaultUrl <*> (RepoSpec <$> areq textField (bfs MsgSubmissionUrl) defaultUrl
<*> areq textField (bfs MsgSubmissionBranch) defBranch <*> areq textField (bfs MsgSubmissionBranch) defBranch
<*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote) <*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote))
getChallengeMySubmissionsR :: Text -> Handler Html getChallengeMySubmissionsR :: Text -> Handler Html
getChallengeMySubmissionsR name = do getChallengeMySubmissionsR name = do