achievements

This commit is contained in:
Filip Gralinski 2017-02-26 21:40:38 +01:00
parent e5e0617a8d
commit a8b8b1e5c8
14 changed files with 139 additions and 15 deletions

View File

@ -51,6 +51,7 @@ import Handler.AccountReset
import Handler.Presentation import Handler.Presentation
import Handler.Tags import Handler.Tags
import Handler.EditSubmission import Handler.EditSubmission
import Handler.Achievements
-- 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 ListChallengesR _ = return Authorized isAuthorized ListChallengesR _ = return Authorized
isAuthorized TagsR _ = return Authorized isAuthorized TagsR _ = return Authorized
isAuthorized AchievementsR _ = return Authorized
isAuthorized (ShowChallengeR _) _ = return Authorized isAuthorized (ShowChallengeR _) _ = return Authorized
isAuthorized (ChallengeReadmeR _) _ = return Authorized isAuthorized (ChallengeReadmeR _) _ = return Authorized

65
Handler/Achievements.hs Normal file
View File

@ -0,0 +1,65 @@
module Handler.Achievements where
import Import
import Handler.Common (checkIfAdmin)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
import Handler.TagUtils
import Handler.Tables
import Data.Time.Clock
import Data.Time.LocalTime
import qualified Yesod.Table as Table
getAchievementsR :: Handler Html
getAchievementsR = do
(formWidget, formEnctype) <- generateFormPost achievementForm
mUser <- maybeAuth
doAchievements mUser formWidget formEnctype
postAchievementsR :: Handler Html
postAchievementsR = do
((result, formWidget), formEnctype) <- runFormPost achievementForm
mUser <- maybeAuth
when (checkIfAdmin mUser) $ do
case result of
FormSuccess (name, description, deadlineDay, deadlineTime, maxSubmitters, mTags) -> do
-- @TODO for the time being hardcoded
Just challengeEnt <- runDB $ getBy $ UniqueName "petite-difference-challenge2"
achievementId <- runDB $ insert $ Achievement name (entityKey challengeEnt) description (UTCTime { utctDay = deadlineDay, utctDayTime = timeOfDayToTime deadlineTime }) maxSubmitters
tids <- runDB $ tagsAsTextToTagIds mTags
_ <- mapM (\tid -> runDB $ insert $ AchievementTag achievementId tid) tids
return ()
_ -> do
return ()
doAchievements mUser formWidget formEnctype
doAchievements mUser formWidget formEnctype = do
achievements <- runDB $ selectList [] [Asc AchievementName]
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
defaultLayout $ do
setTitle "Achievements"
$(widgetFile "achievements")
achievementsTable :: Table.Table App (Entity Achievement)
achievementsTable = mempty
++ Table.text "achievement" (\(Entity _ achievement) -> achievementName achievement)
++ Table.text "description" (\(Entity _ achievement) -> (fromMaybe (""::Text) (achievementDescription achievement)))
++ timestampCell "deadline" (\(Entity _ achievement) -> achievementDeadline achievement)
achievementForm :: Form (Text, Maybe Text, Day, TimeOfDay, Maybe Int, Maybe Text)
achievementForm = renderBootstrap3 BootstrapBasicForm $ (,,,,,)
<$> areq textField (bfs MsgAchievementName) Nothing
<*> aopt textField (bfs MsgAchievementDescription) Nothing
<*> areq dayField (bfs MsgAchievementDeadlineDay) Nothing
<*> areq timeFieldTypeTime (bfs MsgAchievementDeadlineTime) Nothing
<*> aopt intField (bfs MsgAchievementMaxWinners) Nothing
<*> aopt textField (tagsfs MsgAchievementTags) Nothing

View File

@ -63,3 +63,7 @@ checkIfCanEdit submissionId = do
return $ case mUser of return $ case mUser of
Just (Entity userId user) -> userId == submissionSubmitter submission || userIsAdmin user Just (Entity userId user) -> userId == submissionSubmitter submission || userIsAdmin user
Nothing -> False Nothing -> False
checkIfAdmin :: Maybe (Entity User) -> Bool
checkIfAdmin (Just (Entity _ user)) = userIsAdmin user
checkIfAdmin Nothing = False

View File

@ -7,6 +7,8 @@ import Handler.Common (checkIfCanEdit)
import Handler.SubmissionView import Handler.SubmissionView
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
import Handler.TagUtils
import Data.Text as T import Data.Text as T
getEditSubmissionR :: SubmissionId -> Handler Html getEditSubmissionR :: SubmissionId -> Handler Html
@ -44,11 +46,7 @@ postEditSubmissionR submissionId = do
addTags submissionId tagsAsText existingOnes = do addTags submissionId tagsAsText existingOnes = do
let newTags = case tagsAsText of tids <- tagsAsTextToTagIds tagsAsText
Just tags' -> Import.map T.strip $ T.split (== ',') tags'
Nothing -> []
mTs <- mapM (\t -> getBy $ UniqueTagName t) newTags
let tids = Import.map entityKey $ Import.catMaybes mTs
deleteWhere [SubmissionTagSubmission ==. submissionId, SubmissionTagTag /<-. tids] deleteWhere [SubmissionTagSubmission ==. submissionId, SubmissionTagTag /<-. tids]
@ -62,8 +60,7 @@ doEditSubmission formWidget formEnctype submissionId = do
submissionFull <- getFullInfo (Entity submissionId submission) submissionFull <- getFullInfo (Entity submissionId submission)
let view = queryResult submissionFull let view = queryResult submissionFull
tagsAvailable <- runDB $ selectList [] [Asc TagName] tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
let tagsAvailableAsJSON = toJSON $ Import.map (tagName . entityVal) tagsAvailable
defaultLayout $ do defaultLayout $ do
setTitle "Edit a submission" setTitle "Edit a submission"
@ -73,7 +70,3 @@ editSubmissionForm :: Text -> Maybe Text -> Form (Text, Maybe Text)
editSubmissionForm description mTags = renderBootstrap3 BootstrapBasicForm $ (,) editSubmissionForm description mTags = renderBootstrap3 BootstrapBasicForm $ (,)
<$> areq textField (bfs MsgSubmissionDescription) (Just description) <$> areq textField (bfs MsgSubmissionDescription) (Just description)
<*> aopt textField (tagsfs MsgSubmissionTags) (Just mTags) <*> aopt textField (tagsfs MsgSubmissionTags) (Just mTags)
tagsfs :: RenderMessage site msg => msg -> FieldSettings site
tagsfs msg = attrs { fsAttrs = ("data-role"::Text,"tagsinput"::Text):(fsAttrs attrs)}
where attrs = bfs msg

22
Handler/TagUtils.hs Normal file
View File

@ -0,0 +1,22 @@
module Handler.TagUtils where
import Import
import Yesod.Form.Bootstrap3 (bfs)
import Data.Text as T
getAvailableTagsAsJSON = do
tagsAvailable <- selectList [] [Asc TagName]
return $ toJSON $ Import.map (tagName . entityVal) tagsAvailable
tagsfs :: RenderMessage site msg => msg -> FieldSettings site
tagsfs msg = attrs { fsAttrs = ("data-role"::Text,"tagsinput"::Text):(fsAttrs attrs)}
where attrs = bfs msg
tagsAsTextToTagIds mTagsAsText = do
let newTags = case mTagsAsText of
Just tags' -> Import.map T.strip $ T.split (== ',') tags'
Nothing -> []
mTs <- mapM (\t -> getBy $ UniqueTagName t) newTags
return $ Import.map entityKey $ Import.catMaybes mTs

View File

@ -1,6 +1,7 @@
module Handler.Tags where module Handler.Tags where
import Import import Import
import Handler.Common (checkIfAdmin)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
import qualified Yesod.Table as Table import qualified Yesod.Table as Table
@ -40,7 +41,3 @@ tagForm :: Form (Text, Maybe Text)
tagForm = renderBootstrap3 BootstrapBasicForm $ (,) tagForm = renderBootstrap3 BootstrapBasicForm $ (,)
<$> areq textField (bfs MsgTagName) Nothing <$> areq textField (bfs MsgTagName) Nothing
<*> aopt textField (bfs MsgTagDescription) Nothing <*> aopt textField (bfs MsgTagDescription) Nothing
checkIfAdmin :: Maybe (Entity User) -> Bool
checkIfAdmin (Just (Entity _ user)) = userIsAdmin user
checkIfAdmin Nothing = False

View File

@ -83,4 +83,15 @@ SubmissionTag
tag TagId tag TagId
accepted Bool Maybe accepted Bool Maybe
UniqueSubmissionTag submission tag UniqueSubmissionTag submission tag
Achievement
name Text
challenge ChallengeId
description Text Maybe
deadline UTCTime
maxWinners Int Maybe
UniqueAchievementName name
AchievementTag
achievement AchievementId
tag TagId
UniqueAchievementTag achievement tag
-- By default this file is used in Model.hs (which is imported by Foundation.hs) -- By default this file is used in Model.hs (which is imported by Foundation.hs)

View File

@ -32,6 +32,7 @@
/reset-password/#Text ResetPasswordR GET POST /reset-password/#Text ResetPasswordR GET POST
/tags TagsR GET POST /tags TagsR GET POST
/achievements AchievementsR GET POST
/edit-submission/#SubmissionId EditSubmissionR GET POST /edit-submission/#SubmissionId EditSubmissionR GET POST

View File

@ -48,6 +48,8 @@ library
Handler.Tags Handler.Tags
Handler.EditSubmission Handler.EditSubmission
Handler.SubmissionView Handler.SubmissionView
Handler.Achievements
Handler.TagUtils
if flag(dev) || flag(library-only) if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT cpp-options: -DDEVELOPMENT

View File

@ -33,3 +33,10 @@ LinkWrongOrExpired: Link wrong or expired, please ask the site admin again
TagName: tag TagName: tag
TagDescription: description TagDescription: description
ListTags: list tags ListTags: list tags
AchievementName: achievement name
AchievementDescription: optional description
AchievementDeadlineDay: achievement deadline day
AchievementDeadlineTime: achievement deadline hour
AchievementMaxWinners: maximum number of submitters
AchievementTags: tags required for an achievement
Achievements: achievements

View File

@ -0,0 +1,13 @@
<h1>Achievements
^{Table.buildBootstrap achievementsTable achievements}
<hr>
$if (checkIfAdmin mUser)
<h2>Create a new achievement
<form method=post action=@{AchievementsR}#form enctype=#{formEnctype}>
^{formWidget}
<button .btn .btn-primary type="submit">
_{MsgSubmit} <span class="glyphicon glyphicon-upload"></span>

View File

@ -0,0 +1,6 @@
var input = document.querySelector('input[data-role=tagsinput]'),
tagify = new Tagify( input, {
whitelist: #{tagsAvailableAsJSON},
autocomplete: true,
enforeWhitelist: true});
input.style.display = 'none';

View File

@ -9,6 +9,7 @@
<li><a href="@{Presentation4RealR}">_{MsgAbout}</a> <li><a href="@{Presentation4RealR}">_{MsgAbout}</a>
<li><a href="@{ListChallengesR}">_{MsgListChallenges}</a> <li><a href="@{ListChallengesR}">_{MsgListChallenges}</a>
<li><a href="@{TagsR}">_{MsgListTags}</a> <li><a href="@{TagsR}">_{MsgListTags}</a>
<li><a href="@{AchievementsR}">_{MsgAchievements}</a>
$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>