add tags

Application.hs

@@ -49,6 +49,7 @@ import Handler.Shared
 import Handler.YourAccount
 import Handler.AccountReset
 import Handler.Presentation
+import Handler.Tags
 
 -- 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

@@ -120,6 +120,8 @@ instance Yesod App where
     isAuthorized (QueryResultsR _) _ = return Authorized
     isAuthorized ListChallengesR _ = return Authorized
 
+    isAuthorized TagsR _ = return Authorized
+
     isAuthorized (ShowChallengeR _) _ = return Authorized
     isAuthorized (ChallengeReadmeR _) _ = return Authorized
     isAuthorized (ChallengeAllSubmissionsR _) _ = return Authorized

Handler/Tags.hs

@@ -0,0 +1,46 @@
+module Handler.Tags where
+
+import Import
+import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
+
+import qualified Yesod.Table as Table
+
+getTagsR :: Handler Html
+getTagsR = do
+  (formWidget, formEnctype) <- generateFormPost tagForm
+  mUser <- maybeAuth
+  doTags mUser formWidget formEnctype
+
+postTagsR :: Handler Html
+postTagsR = do
+  ((result, formWidget), formEnctype) <- runFormPost tagForm
+  mUser <- maybeAuth
+  when (checkIfAdmin mUser) $ do
+     case result of
+      FormSuccess (t, d) -> do
+                            _ <- runDB $ insert $ Tag t d
+                            return ()
+      _ -> do
+           return ()
+  doTags mUser formWidget formEnctype
+
+doTags mUser formWidget formEnctype = do
+  tags <- runDB $ selectList [] [Asc TagName]
+  defaultLayout $ do
+    setTitle "Tags"
+    $(widgetFile "tags")
+
+tagsTable :: Table.Table App (Entity Tag)
+tagsTable = mempty
+  ++ Table.text "tag" (\(Entity _ tag) -> tagName tag)
+  ++ Table.text "description" (\(Entity _ tag) -> (fromMaybe (""::Text) (tagDescription tag)))
+
+
+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

@@ -74,4 +74,8 @@ Out
     test TestId
     checksum SHA1
     UniqueOutSubmissionTestChecksum submission test checksum
+Tag
+    name Text
+    description Text Maybe
+    UniqueTagName name
 -- By default this file is used in Model.hs (which is imported by Foundation.hs)

config/routes

@@ -31,4 +31,6 @@
 /create-reset-link CreateResetLinkR GET POST
 /reset-password/#Text ResetPasswordR GET POST
 
+/tags TagsR GET POST
+
 /presentation/4real Presentation4RealR GET

gonito.cabal

@@ -45,6 +45,7 @@ library
                      Handler.YourAccount
                      Handler.AccountReset
                      Handler.Presentation
+                     Handler.Tags
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT

messages/en.msg

@@ -29,3 +29,6 @@ Password: new password
 EMail: e-mail
 CreateResetLink: create reset link
 LinkWrongOrExpired: Link wrong or expired, please ask the site admin again
+TagName: tag
+TagDescription: description
+ListTags: list tags

templates/default-layout.hamlet

@@ -8,6 +8,7 @@
                 <li><a href="@{HomeR}">_{MsgHome}</a>
                 <li><a href="@{Presentation4RealR}">_{MsgAbout}</a>
                 <li><a href="@{ListChallengesR}">_{MsgListChallenges}</a>
+                <li><a href="@{TagsR}">_{MsgListTags}</a>
                 $if userIsAdmin $ entityVal user
                     <li><a href="@{CreateChallengeR}">_{MsgCreateChallenge}</a>
                     <li><a href="@{CreateResetLinkR}">_{MsgCreateResetLink}</a>
@@ -23,6 +24,7 @@
                 <li><a href="@{HomeR}">_{MsgHome}</a>
                 <li><a href="@{Presentation4RealR}">_{MsgAbout}</a>
                 <li><a href="@{ListChallengesR}">_{MsgListChallenges}</a>
+                <li><a href="@{TagsR}">_{MsgListTags}</a>
 
             <ul class="nav navbar-nav navbar-right">
                 <li><a href="@{AuthR LoginR}">log in</a>

templates/tags.hamlet

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