From b14e675c61066c1e9dead4c0aa2b465b53ed5fbc Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Mon, 30 Jul 2018 07:59:38 +0200 Subject: [PATCH] add a parameter --- Handler/EditSubmission.hs | 44 ++++++++++++++++++++++++++---- Handler/Tables.hs | 10 ++++--- config/routes | 2 ++ messages/en.msg | 2 ++ templates/edit-submission.hamlet | 14 +++++++++- templates/submission-status.hamlet | 2 +- 6 files changed, 63 insertions(+), 11 deletions(-) diff --git a/Handler/EditSubmission.hs b/Handler/EditSubmission.hs index 8685ea1..8b91388 100644 --- a/Handler/EditSubmission.hs +++ b/Handler/EditSubmission.hs @@ -12,18 +12,40 @@ import Handler.MakePublic 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 = 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 tags <- runDB $ getTags submissionId let mTagsAsText = case tags of [] -> Nothing _ -> Just $ T.intercalate ", " $ Import.map (tagName . entityVal . fst) tags (formWidget, formEnctype) <- generateFormPost $ editSubmissionForm (submissionDescription submission) mTagsAsText - doEditSubmission formWidget formEnctype submissionId + doEditSubmission formWidget formEnctype submissionId mVariantId 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 ((result, _), _) <- runFormPost $ editSubmissionForm (submissionDescription submission) Nothing let FormSuccess (description, tags) = result @@ -43,7 +65,7 @@ postEditSubmissionR submissionId = do do setMessage $ toHtml ("Only owner can edit a submission!!!" :: Text) 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)] @@ -55,7 +77,7 @@ getPossibleAchievements userId submissionId = do let rets = Import.zip achievements workingOns 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 submissionFull <- getFullInfo (Entity submissionId submission) let view = queryResult submissionFull @@ -66,6 +88,12 @@ doEditSubmission formWidget formEnctype submissionId = do 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 setTitle "Edit a submission" $(widgetFile "edit-submission") @@ -76,6 +104,12 @@ editSubmissionForm description mTags = renderBootstrap3 BootstrapBasicForm $ (,) <*> 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 = changeSubmissionVisibility False submissionId diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 512335f..073aa09 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -53,7 +53,7 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty ++ timestampCell "when" (submissionStamp . (\(TableEntry (Entity _ s) _ _ _ _ _) -> s)) ++ descriptionCell ++ 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.widget "description" ( @@ -85,6 +85,8 @@ leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty ++ Table.int "×" (leaderboardNumberOfSubmissions . snd) ++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e, leaderboardBestSubmission e, + leaderboardBestVariantId e, + leaderboardBestVariant e, leaderboardUserId e, 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) 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) resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a 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 challengeName repoScheme challengeRepo (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status") +statusCellWidget :: Eq a => Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, a, Maybe a) -> WidgetFor App () +statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, userId, mauthId) = $(widgetFile "submission-status") where commitHash = fromSHA1ToText $ submissionCommit submission isPublic = submissionIsPublic submission isOwner = (mauthId == Just userId) diff --git a/config/routes b/config/routes index efb8647..81193bc 100644 --- a/config/routes +++ b/config/routes @@ -53,6 +53,8 @@ /my-score MyScoreR GET /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/datech-2017 PresentationDATeCH2017R GET diff --git a/messages/en.msg b/messages/en.msg index ae15c3c..904d7e4 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -62,3 +62,5 @@ GitAnnexRemote: git-annex remote (if needed) SubmissionGitAnnexRemote: git-annex remote specification (if needed) RemoveSubmission: remove submission RestoreSubmission: restore submission +ParameterName: parameter name +ParameterValue: parameter value diff --git a/templates/edit-submission.hamlet b/templates/edit-submission.hamlet index 6faaab0..fe0e589 100644 --- a/templates/edit-submission.hamlet +++ b/templates/edit-submission.hamlet @@ -11,7 +11,19 @@ $forall (achievement, workingOnId) <- achievements
  • send to review for #{achievementName $ entityVal achievement} achievement -

    +$maybe variantId <- mVariantId +

    Variant parameters + + $forall param <- variantParams +

    #{parameterName $ entityVal param} = #{parameterValue $ entityVal param} + +

    Add new parameter + +
    + ^{addVariantParamWidget} +