add extra points

This commit is contained in:
Filip Gralinski 2018-01-02 18:55:35 +01:00
parent 6784d8cec5
commit f3b6f4b050
9 changed files with 73 additions and 0 deletions

View File

@ -51,6 +51,7 @@ import Handler.Tags
import Handler.EditSubmission import Handler.EditSubmission
import Handler.Achievements import Handler.Achievements
import Handler.Score import Handler.Score
import Handler.ExtraPoints
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- of the call to mkYesodData which occurs in Foundation.hs. Please see the

View File

@ -121,6 +121,7 @@ instance Yesod App where
isAuthorized TagsR _ = return Authorized isAuthorized TagsR _ = return Authorized
isAuthorized AchievementsR _ = return Authorized isAuthorized AchievementsR _ = return Authorized
isAuthorized (EditAchievementR _) _ = isAdmin isAuthorized (EditAchievementR _) _ = isAdmin
isAuthorized ExtraPointsR _ = isAdmin
isAuthorized (ShowChallengeR _) _ = return Authorized isAuthorized (ShowChallengeR _) _ = return Authorized
isAuthorized (ChallengeReadmeR _) _ = return Authorized isAuthorized (ChallengeReadmeR _) _ = return Authorized

49
Handler/ExtraPoints.hs Normal file
View File

@ -0,0 +1,49 @@
module Handler.ExtraPoints where
import Import
import Handler.Common (checkIfAdmin)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
getExtraPointsR :: Handler Html
getExtraPointsR = do
(formWidget, formEnctype) <- generateFormPost extraPointsForm
defaultLayout $ do
$(widgetFile "extra-points")
postExtraPointsR :: Handler Html
postExtraPointsR = do
((result, formWidget), formEnctype) <- runFormPost extraPointsForm
mUser <- maybeAuth
when (checkIfAdmin mUser) $ do
case result of
FormSuccess (points, description, userId, courseId) -> do
now <- liftIO getCurrentTime
let (Just (Entity adderId _)) = mUser
_ <- runDB $ insert $ ExtraPoints points description userId courseId now adderId
return ()
_ -> do
return ()
defaultLayout $ do
$(widgetFile "extra-points")
extraPointsForm :: Form (Int, Text, UserId, CourseId)
extraPointsForm = renderBootstrap3 BootstrapBasicForm $ (,,,)
<$> areq intField (bfs MsgExtraPointsPoints) Nothing
<*> areq textField (bfs MsgExtraPointsDescription) Nothing
<*> usersSelectFieldList
<*> coursesSelectFieldList
usersSelectFieldList = areq (selectField users) (bfs MsgUser) Nothing
where
users = do
userEnts <- runDB $ selectList [] [Asc UserName]
optionsPairs $ Import.map (\ch -> (userInSelection $ entityVal ch, entityKey ch)) userEnts
userInSelection :: User -> Text
userInSelection user = (fromMaybe "" $ userLocalId user) ++ " / " ++ (fromMaybe "" $ userName user)
coursesSelectFieldList = areq (selectField courses) (bfs MsgCourse) Nothing
where
courses = do
courseEnts <- runDB $ selectList [] [Asc CourseName]
optionsPairs $ Import.map (\ch -> (courseName $ entityVal ch, entityKey ch)) courseEnts

View File

@ -108,6 +108,13 @@ Course
closed Bool closed Bool
UniqueCourseName name UniqueCourseName name
UniqueCourseCode code UniqueCourseCode code
ExtraPoints
points Int
description Text
user UserId
course CourseId
posted UTCTime default=now()
addedBy UserId
Participant Participant
user UserId user UserId
course CourseId course CourseId

View File

@ -41,6 +41,8 @@
/submission-for-achievement/#SubmissionId/#WorkingOnId SubmissionForAchievementR GET /submission-for-achievement/#SubmissionId/#WorkingOnId SubmissionForAchievementR GET
/toggle-submission-tag/#SubmissionTagId ToggleSubmissionTagR GET /toggle-submission-tag/#SubmissionTagId ToggleSubmissionTagR GET
/extra-points ExtraPointsR GET POST
/score/#UserId ScoreR GET /score/#UserId ScoreR GET
/my-score MyScoreR GET /my-score MyScoreR GET

View File

@ -50,6 +50,7 @@ library
Handler.TagUtils Handler.TagUtils
Handler.Score Handler.Score
Handler.AchievementUtils Handler.AchievementUtils
Handler.ExtraPoints
if flag(dev) || flag(library-only) if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT cpp-options: -DDEVELOPMENT

View File

@ -51,3 +51,7 @@ SubmissionDescriptionTooltip: the first non-empty line of the commit message wil
Challenge: challenge Challenge: challenge
Course: course Course: course
CourseOptional: course (optional) CourseOptional: course (optional)
AddExtraPoints: add points freely
ExtraPointsPoints: Points to be added
ExtraPointsDescription: Describe why they are added
User: User

View File

@ -13,6 +13,7 @@
$if userIsAdmin $ entityVal user $if userIsAdmin $ entityVal user
<li><a href="@{CreateChallengeR}">_{MsgCreateChallenge}</a> <li><a href="@{CreateChallengeR}">_{MsgCreateChallenge}</a>
<li><a href="@{CreateResetLinkR}">_{MsgCreateResetLink}</a> <li><a href="@{CreateResetLinkR}">_{MsgCreateResetLink}</a>
<li><a href="@{ExtraPointsR}">_{MsgAddExtraPoints}</a>
<ul class="nav navbar-nav navbar-right"> <ul class="nav navbar-nav navbar-right">
<li class="dropdown"> <li class="dropdown">

View File

@ -0,0 +1,7 @@
<h2>_{MsgAddExtraPoints}
<p>
<form method=post action=@{ExtraPointsR}#form enctype=#{formEnctype}>
^{formWidget}
<button .btn .btn-primary type="submit">
_{MsgAdd} <span class="glyphicon glyphicon-upload"></span>