achievements

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

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

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

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

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

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

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

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)

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
 

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

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

templates/achievements.hamlet

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

templates/achievements.julius

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

templates/default-layout.hamlet

@@ -9,6 +9,7 @@
                 <li><a href="@{Presentation4RealR}">_{MsgAbout}</a>
                 <li><a href="@{ListChallengesR}">_{MsgListChallenges}</a>
                 <li><a href="@{TagsR}">_{MsgListTags}</a>
+                <li><a href="@{AchievementsR}">_{MsgAchievements}</a>
                 $if userIsAdmin $ entityVal user
                     <li><a href="@{CreateChallengeR}">_{MsgCreateChallenge}</a>
                     <li><a href="@{CreateResetLinkR}">_{MsgCreateResetLink}</a>