add a parameter

This commit is contained in:
Filip Gralinski 2018-07-30 07:59:38 +02:00
parent ff8d8d8e7a
commit b14e675c61
6 changed files with 63 additions and 11 deletions

View File

@ -12,18 +12,40 @@ import Handler.MakePublic
import Data.Text as T import Data.Text as T
postAddVariantParamR :: SubmissionId -> VariantId -> Handler Html
postAddVariantParamR submissionId variantId = do
((result, _), _) <- runFormPost addVariantParamForm
let FormSuccess (pName, pValue) = result
_ <- runDB $ insert $ Parameter {
parameterVariant = variantId,
parameterName = pName,
parameterValue = pValue }
getEditSubmissionAndVariantR submissionId variantId
getEditSubmissionR :: SubmissionId -> Handler Html getEditSubmissionR :: SubmissionId -> Handler Html
getEditSubmissionR submissionId = do getEditSubmissionR submissionId = getEditSubmissionG submissionId Nothing
getEditSubmissionAndVariantR :: SubmissionId -> VariantId -> Handler Html
getEditSubmissionAndVariantR submissionId variantId = getEditSubmissionG submissionId (Just variantId)
getEditSubmissionG :: SubmissionId -> (Maybe VariantId) -> Handler Html
getEditSubmissionG submissionId mVariantId = do
submission <- runDB $ get404 submissionId submission <- runDB $ get404 submissionId
tags <- runDB $ getTags submissionId tags <- runDB $ getTags submissionId
let mTagsAsText = case tags of let mTagsAsText = case tags of
[] -> Nothing [] -> Nothing
_ -> Just $ T.intercalate ", " $ Import.map (tagName . entityVal . fst) tags _ -> Just $ T.intercalate ", " $ Import.map (tagName . entityVal . fst) tags
(formWidget, formEnctype) <- generateFormPost $ editSubmissionForm (submissionDescription submission) mTagsAsText (formWidget, formEnctype) <- generateFormPost $ editSubmissionForm (submissionDescription submission) mTagsAsText
doEditSubmission formWidget formEnctype submissionId doEditSubmission formWidget formEnctype submissionId mVariantId
postEditSubmissionR :: SubmissionId -> Handler Html postEditSubmissionR :: SubmissionId -> Handler Html
postEditSubmissionR submissionId = do postEditSubmissionR submissionId = postEditSubmissionG submissionId Nothing
postEditSubmissionAndVariantR :: SubmissionId -> VariantId -> Handler Html
postEditSubmissionAndVariantR submissionId variantId = postEditSubmissionG submissionId (Just variantId)
postEditSubmissionG :: SubmissionId -> (Maybe VariantId) -> Handler Html
postEditSubmissionG submissionId mVariantId = do
submission <- runDB $ get404 submissionId submission <- runDB $ get404 submissionId
((result, _), _) <- runFormPost $ editSubmissionForm (submissionDescription submission) Nothing ((result, _), _) <- runFormPost $ editSubmissionForm (submissionDescription submission) Nothing
let FormSuccess (description, tags) = result let FormSuccess (description, tags) = result
@ -43,7 +65,7 @@ postEditSubmissionR submissionId = do
do do
setMessage $ toHtml ("Only owner can edit a submission!!!" :: Text) setMessage $ toHtml ("Only owner can edit a submission!!!" :: Text)
return () return ()
getEditSubmissionR submissionId getEditSubmissionG submissionId mVariantId
getPossibleAchievements :: (BaseBackend backend ~ SqlBackend, PersistUniqueRead backend, PersistQueryRead backend, MonadIO m) => Key User -> Key Submission -> ReaderT backend m [(Entity Achievement, Key WorkingOn)] getPossibleAchievements :: (BaseBackend backend ~ SqlBackend, PersistUniqueRead backend, PersistQueryRead backend, MonadIO m) => Key User -> Key Submission -> ReaderT backend m [(Entity Achievement, Key WorkingOn)]
@ -55,7 +77,7 @@ 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
doEditSubmission formWidget formEnctype submissionId = do doEditSubmission formWidget formEnctype submissionId mVariantId = do
submission <- runDB $ get404 submissionId submission <- runDB $ get404 submissionId
submissionFull <- getFullInfo (Entity submissionId submission) submissionFull <- getFullInfo (Entity submissionId submission)
let view = queryResult submissionFull let view = queryResult submissionFull
@ -66,6 +88,12 @@ doEditSubmission formWidget formEnctype submissionId = do
achievements <- runDB $ getPossibleAchievements userId submissionId achievements <- runDB $ getPossibleAchievements userId submissionId
variantParams <- case mVariantId of
Just variantId -> runDB $ selectList [ParameterVariant ==. variantId] [Asc ParameterName]
Nothing -> return []
(addVariantParamWidget, formEnctype2) <- generateFormPost $ addVariantParamForm
defaultLayout $ do defaultLayout $ do
setTitle "Edit a submission" setTitle "Edit a submission"
$(widgetFile "edit-submission") $(widgetFile "edit-submission")
@ -76,6 +104,12 @@ editSubmissionForm description mTags = renderBootstrap3 BootstrapBasicForm $ (,)
<*> aopt textField (tagsfs MsgSubmissionTags) (Just mTags) <*> aopt textField (tagsfs MsgSubmissionTags) (Just mTags)
addVariantParamForm :: Form (Text, Text)
addVariantParamForm = renderBootstrap3 BootstrapBasicForm $ (,)
<$> areq textField (bfs MsgParameterName) Nothing
<*> areq textField (bfs MsgParameterValue) Nothing
getHideSubmissionR :: SubmissionId -> Handler Html getHideSubmissionR :: SubmissionId -> Handler Html
getHideSubmissionR submissionId = changeSubmissionVisibility False submissionId getHideSubmissionR submissionId = changeSubmissionVisibility False submissionId

View File

@ -53,7 +53,7 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
++ timestampCell "when" (submissionStamp . (\(TableEntry (Entity _ s) _ _ _ _ _) -> s)) ++ timestampCell "when" (submissionStamp . (\(TableEntry (Entity _ s) _ _ _ _ _) -> s))
++ descriptionCell ++ descriptionCell
++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests) ++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests)
++ statusCell challengeName repoScheme challengeRepo (\(TableEntry (Entity submissionId submission) _ (Entity userId _) _ _ _) -> (submissionId, submission, userId, mauthId)) ++ statusCell challengeName repoScheme challengeRepo (\(TableEntry (Entity submissionId submission) (Entity variantId variant) (Entity userId _) _ _ _) -> (submissionId, submission, variantId, variant, userId, mauthId))
descriptionCell :: Table site TableEntry descriptionCell :: Table site TableEntry
descriptionCell = Table.widget "description" ( descriptionCell = Table.widget "description" (
@ -85,6 +85,8 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty
++ Table.int "×" (leaderboardNumberOfSubmissions . snd) ++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e, ++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
leaderboardBestSubmission e, leaderboardBestSubmission e,
leaderboardBestVariantId e,
leaderboardBestVariant e,
leaderboardUserId e, leaderboardUserId e,
mauthId)) mauthId))
@ -106,14 +108,14 @@ timestampCell :: Text -> (a -> UTCTime) -> Table site a
timestampCell h timestampFun = hoverTextCell h (Data.Text.pack . shorterFormat . timestampFun) (Data.Text.pack . show . timestampFun) timestampCell h timestampFun = hoverTextCell h (Data.Text.pack . shorterFormat . timestampFun) (Data.Text.pack . show . timestampFun)
where shorterFormat = formatTime defaultTimeLocale "%Y-%m-%d %H:%M" where shorterFormat = formatTime defaultTimeLocale "%Y-%m-%d %H:%M"
statusCell :: Text -> RepoScheme -> Repo -> (a -> (SubmissionId, Submission, UserId, Maybe UserId)) -> Table App a statusCell :: Text -> RepoScheme -> Repo -> (a -> (SubmissionId, Submission, VariantId, Variant, UserId, Maybe UserId)) -> Table App a
statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusCellWidget challengeName repoScheme challengeRepo . fun) statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusCellWidget challengeName repoScheme challengeRepo . fun)
resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
resultCell test fun = hoverTextCell (formatTest test) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun) resultCell test fun = hoverTextCell (formatTest test) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, a, Maybe a) -> WidgetFor App () statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, a, Maybe a) -> WidgetFor App ()
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status") statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, userId, mauthId) = $(widgetFile "submission-status")
where commitHash = fromSHA1ToText $ submissionCommit submission where commitHash = fromSHA1ToText $ submissionCommit submission
isPublic = submissionIsPublic submission isPublic = submissionIsPublic submission
isOwner = (mauthId == Just userId) isOwner = (mauthId == Just userId)

View File

@ -53,6 +53,8 @@
/my-score MyScoreR GET /my-score MyScoreR GET
/edit-submission/#SubmissionId EditSubmissionR GET POST /edit-submission/#SubmissionId EditSubmissionR GET POST
/edit-submission-and-variant/#SubmissionId/#VariantId EditSubmissionAndVariantR GET POST
/add-variant-param/#SubmissionId/#VariantId AddVariantParamR POST
/presentation/4real Presentation4RealR GET /presentation/4real Presentation4RealR GET
/presentation/datech-2017 PresentationDATeCH2017R GET /presentation/datech-2017 PresentationDATeCH2017R GET

View File

@ -62,3 +62,5 @@ GitAnnexRemote: git-annex remote (if needed)
SubmissionGitAnnexRemote: git-annex remote specification (if needed) SubmissionGitAnnexRemote: git-annex remote specification (if needed)
RemoveSubmission: remove submission RemoveSubmission: remove submission
RestoreSubmission: restore submission RestoreSubmission: restore submission
ParameterName: parameter name
ParameterValue: parameter value

View File

@ -11,7 +11,19 @@
$forall (achievement, workingOnId) <- achievements $forall (achievement, workingOnId) <- achievements
<li><a href=@{SubmissionForAchievementR submissionId workingOnId}>send to review for #{achievementName $ entityVal achievement} achievement <li><a href=@{SubmissionForAchievementR submissionId workingOnId}>send to review for #{achievementName $ entityVal achievement} achievement
<h4> $maybe variantId <- mVariantId
<h4>Variant parameters
$forall param <- variantParams
<p>#{parameterName $ entityVal param} = #{parameterValue $ entityVal param}
<h5>Add new parameter
<form method=post action=@{AddVariantParamR submissionId variantId}#form enctype=#{formEnctype2}>
^{addVariantParamWidget}
<button .btn .btn-primary type="submit">
_{MsgSubmit} <span class="glyphicon glyphicon-upload"></span>
<hr>
$if submissionIsHidden submission == Just True $if submissionIsHidden submission == Just True
<p>Submission is hidden! <p>Submission is hidden!

View File

@ -1,5 +1,5 @@
$if isOwner $if isOwner
<a href="@{EditSubmissionR submissionId}"> <a href="@{EditSubmissionAndVariantR submissionId variantId}">
<span class="glyphicon glyphicon-pencil" title="click to edit the submission" aria-hidden="true"> <span class="glyphicon glyphicon-pencil" title="click to edit the submission" aria-hidden="true">
<a href="@{HideSubmissionR submissionId}"> <a href="@{HideSubmissionR submissionId}">