tags can be added during submission

This commit is contained in:
Filip Gralinski 2017-09-27 19:38:42 +02:00
parent 2949ce3a8a
commit ef00b8d9d1
4 changed files with 24 additions and 16 deletions

View File

@ -53,16 +53,6 @@ getPossibleAchievements userId submissionId = do
let rets = Import.zip achievements workingOns let rets = Import.zip achievements workingOns
return $ Import.map (\(a, (Just w)) -> (a, entityKey w)) $ Import.filter (\(_, mw) -> isJust mw) $ rets return $ Import.map (\(a, (Just w)) -> (a, entityKey w)) $ Import.filter (\(_, mw) -> isJust mw) $ rets
addTags submissionId tagsAsText existingOnes = do
tids <- tagsAsTextToTagIds tagsAsText
deleteWhere [SubmissionTagSubmission ==. submissionId, SubmissionTagTag /<-. tids]
_ <- mapM (\tid -> insert $ SubmissionTag submissionId tid Nothing) (Import.filter (not . (`elem` existingOnes)) tids)
return ()
doEditSubmission formWidget formEnctype submissionId = do doEditSubmission formWidget formEnctype submissionId = do
submission <- runDB $ get404 submissionId submission <- runDB $ get404 submissionId
submissionFull <- getFullInfo (Entity submissionId submission) submissionFull <- getFullInfo (Entity submissionId submission)

View File

@ -17,6 +17,7 @@ import qualified Yesod.Table as Table
import Handler.Extract import Handler.Extract
import Handler.Shared import Handler.Shared
import Handler.Tables import Handler.Tables
import Handler.TagUtils
import GEval.Core import GEval.Core
import GEval.OptionsParser import GEval.OptionsParser
@ -106,18 +107,19 @@ postChallengeSubmissionR name = do
let submissionData = case result of let submissionData = case result of
FormSuccess res -> Just res FormSuccess res -> Just res
_ -> Nothing _ -> Nothing
Just (description, submissionUrl, submissionBranch) = submissionData Just (description, mTags, submissionUrl, submissionBranch) = submissionData
runViewProgress $ doCreateSubmission challengeId description submissionUrl submissionBranch runViewProgress $ doCreateSubmission challengeId description mTags submissionUrl submissionBranch
doCreateSubmission :: Key Challenge -> Text -> Text -> Text -> Channel -> Handler () doCreateSubmission :: Key Challenge -> Text -> Maybe Text -> Text -> Text -> Channel -> Handler ()
doCreateSubmission challengeId description url branch chan = do doCreateSubmission challengeId description mTags url branch chan = do
maybeRepoKey <- getSubmissionRepo challengeId url branch chan maybeRepoKey <- getSubmissionRepo challengeId url branch chan
case maybeRepoKey of case maybeRepoKey of
Just repoId -> do Just repoId -> do
repo <- runDB $ get404 repoId repo <- runDB $ get404 repoId
submissionId <- getSubmission repoId (repoCurrentCommit repo) challengeId description chan submissionId <- getSubmission repoId (repoCurrentCommit repo) challengeId description chan
_ <- getOuts chan submissionId _ <- getOuts chan submissionId
runDB $ addTags submissionId mTags []
msg chan "Done" msg chan "Done"
Nothing -> return () Nothing -> return ()
@ -254,9 +256,10 @@ checkRepoAvailibility challengeId repoId chan = do
challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission") challengeSubmissionWidget formWidget formEnctype challenge = $(widgetFile "challenge-submission")
submissionForm :: Maybe Text -> Form (Text, Text, Text) submissionForm :: Maybe Text -> Form (Text, Maybe Text, Text, Text)
submissionForm defaultUrl = renderBootstrap3 BootstrapBasicForm $ (,,) submissionForm defaultUrl = renderBootstrap3 BootstrapBasicForm $ (,,,)
<$> areq textField (bfs MsgSubmissionDescription) Nothing <$> areq textField (bfs MsgSubmissionDescription) Nothing
<*> aopt textField (tagsfs MsgSubmissionTags) Nothing
<*> areq textField (bfs MsgSubmissionUrl) defaultUrl <*> areq textField (bfs MsgSubmissionUrl) defaultUrl
<*> areq textField (bfs MsgSubmissionBranch) (Just "master") <*> areq textField (bfs MsgSubmissionBranch) (Just "master")
@ -279,6 +282,7 @@ getChallengeSubmissions condition name = do
challengeAllSubmissionsWidget muserId challenge submissions tests = $(widgetFile "challenge-all-submissions") challengeAllSubmissionsWidget muserId challenge submissions tests = $(widgetFile "challenge-all-submissions")
challengeLayout withHeader challenge widget = do challengeLayout withHeader challenge widget = do
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
maybeUser <- maybeAuth maybeUser <- maybeAuth
bc <- widgetToPageContent widget bc <- widgetToPageContent widget
defaultLayout $ do defaultLayout $ do

View File

@ -13,6 +13,13 @@ tagsfs :: RenderMessage site msg => msg -> FieldSettings site
tagsfs msg = attrs { fsAttrs = ("data-role"::Text,"tagsinput"::Text):(fsAttrs attrs)} tagsfs msg = attrs { fsAttrs = ("data-role"::Text,"tagsinput"::Text):(fsAttrs attrs)}
where attrs = bfs msg where attrs = bfs msg
addTags submissionId tagsAsText existingOnes = do
tids <- tagsAsTextToTagIds tagsAsText
deleteWhere [SubmissionTagSubmission ==. submissionId, SubmissionTagTag /<-. tids]
_ <- mapM (\tid -> insert $ SubmissionTag submissionId tid Nothing) (Import.filter (not . (`elem` existingOnes)) tids)
return ()
tagsAsTextToTagIds mTagsAsText = do tagsAsTextToTagIds mTagsAsText = do
let newTags = case mTagsAsText of let newTags = case mTagsAsText of

View File

@ -7,3 +7,10 @@ $(document).ready(function () {
} }
}); });
}); });
var input = document.querySelector('input[data-role=tagsinput]'),
tagify = new Tagify( input, {
whitelist: #{tagsAvailableAsJSON},
autocomplete: true,
enforeWhitelist: true});
input.style.display = 'none';