add extra points

Application.hs

@@ -51,6 +51,7 @@ import Handler.Tags
 import Handler.EditSubmission
 import Handler.Achievements
 import Handler.Score
+import Handler.ExtraPoints
 
 -- 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

Foundation.hs

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

Handler/ExtraPoints.hs

@@ -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

config/models

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

config/routes

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

gonito.cabal

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

messages/en.msg

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

templates/default-layout.hamlet

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

templates/extra-points.hamlet

@@ -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>