diff --git a/Application.hs b/Application.hs index d7b05e5..0ea9753 100644 --- a/Application.hs +++ b/Application.hs @@ -51,6 +51,7 @@ import Handler.AccountReset import Handler.Presentation import Handler.Tags import Handler.EditSubmission +import Handler.Achievements -- 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 diff --git a/Foundation.hs b/Foundation.hs index 22792dd..665d674 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -121,6 +121,7 @@ instance Yesod App where isAuthorized ListChallengesR _ = return Authorized isAuthorized TagsR _ = return Authorized + isAuthorized AchievementsR _ = return Authorized isAuthorized (ShowChallengeR _) _ = return Authorized isAuthorized (ChallengeReadmeR _) _ = return Authorized diff --git a/Handler/Achievements.hs b/Handler/Achievements.hs new file mode 100644 index 0000000..f092b39 --- /dev/null +++ b/Handler/Achievements.hs @@ -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 diff --git a/Handler/Common.hs b/Handler/Common.hs index 8de20ec..b11e5f1 100644 --- a/Handler/Common.hs +++ b/Handler/Common.hs @@ -63,3 +63,7 @@ checkIfCanEdit submissionId = do return $ case mUser of Just (Entity userId user) -> userId == submissionSubmitter submission || userIsAdmin user Nothing -> False + +checkIfAdmin :: Maybe (Entity User) -> Bool +checkIfAdmin (Just (Entity _ user)) = userIsAdmin user +checkIfAdmin Nothing = False diff --git a/Handler/EditSubmission.hs b/Handler/EditSubmission.hs index b48fd8e..17ecf65 100644 --- a/Handler/EditSubmission.hs +++ b/Handler/EditSubmission.hs @@ -7,6 +7,8 @@ import Handler.Common (checkIfCanEdit) import Handler.SubmissionView import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) +import Handler.TagUtils + import Data.Text as T getEditSubmissionR :: SubmissionId -> Handler Html @@ -44,11 +46,7 @@ postEditSubmissionR submissionId = do addTags submissionId tagsAsText existingOnes = do - let newTags = case tagsAsText of - 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 + tids <- tagsAsTextToTagIds tagsAsText deleteWhere [SubmissionTagSubmission ==. submissionId, SubmissionTagTag /<-. tids] @@ -62,8 +60,7 @@ doEditSubmission formWidget formEnctype submissionId = do submissionFull <- getFullInfo (Entity submissionId submission) let view = queryResult submissionFull - tagsAvailable <- runDB $ selectList [] [Asc TagName] - let tagsAvailableAsJSON = toJSON $ Import.map (tagName . entityVal) tagsAvailable + tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON defaultLayout $ do setTitle "Edit a submission" @@ -73,7 +70,3 @@ editSubmissionForm :: Text -> Maybe Text -> Form (Text, Maybe Text) editSubmissionForm description mTags = renderBootstrap3 BootstrapBasicForm $ (,) <$> areq textField (bfs MsgSubmissionDescription) (Just description) <*> 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 diff --git a/Handler/TagUtils.hs b/Handler/TagUtils.hs new file mode 100644 index 0000000..17cae1d --- /dev/null +++ b/Handler/TagUtils.hs @@ -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 diff --git a/Handler/Tags.hs b/Handler/Tags.hs index ed9f792..e6ef43f 100644 --- a/Handler/Tags.hs +++ b/Handler/Tags.hs @@ -1,6 +1,7 @@ module Handler.Tags where import Import +import Handler.Common (checkIfAdmin) import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) import qualified Yesod.Table as Table @@ -40,7 +41,3 @@ tagForm :: Form (Text, Maybe Text) tagForm = renderBootstrap3 BootstrapBasicForm $ (,) <$> areq textField (bfs MsgTagName) Nothing <*> aopt textField (bfs MsgTagDescription) Nothing - -checkIfAdmin :: Maybe (Entity User) -> Bool -checkIfAdmin (Just (Entity _ user)) = userIsAdmin user -checkIfAdmin Nothing = False diff --git a/config/models b/config/models index 95e5005..584dc9f 100644 --- a/config/models +++ b/config/models @@ -83,4 +83,15 @@ SubmissionTag tag TagId accepted Bool Maybe 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) diff --git a/config/routes b/config/routes index b6dbb81..fe26fd7 100644 --- a/config/routes +++ b/config/routes @@ -32,6 +32,7 @@ /reset-password/#Text ResetPasswordR GET POST /tags TagsR GET POST +/achievements AchievementsR GET POST /edit-submission/#SubmissionId EditSubmissionR GET POST diff --git a/gonito.cabal b/gonito.cabal index 8a9a8b4..97966ed 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -48,6 +48,8 @@ library Handler.Tags Handler.EditSubmission Handler.SubmissionView + Handler.Achievements + Handler.TagUtils if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT diff --git a/messages/en.msg b/messages/en.msg index 1bf1880..76cab8b 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -33,3 +33,10 @@ LinkWrongOrExpired: Link wrong or expired, please ask the site admin again TagName: tag TagDescription: description 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 diff --git a/templates/achievements.hamlet b/templates/achievements.hamlet new file mode 100644 index 0000000..0b0e65b --- /dev/null +++ b/templates/achievements.hamlet @@ -0,0 +1,13 @@ +

Achievements + +^{Table.buildBootstrap achievementsTable achievements} + +
+ +$if (checkIfAdmin mUser) +

Create a new achievement + +
+ ^{formWidget} +