Add colors for tags

(Without any visualization for the time being.)

Handler/ShowChallenge.hs

@@ -1426,6 +1426,7 @@ convertTagInfoToView tagInfo =
   TagView {
      tagViewName = tagName $ entityVal $ fst tagInfo,
      tagViewDescription = tagDescription $ entityVal $ fst tagInfo,
+     tagViewColor = tagColor $ entityVal $ fst tagInfo,
      tagViewAccepted = submissionTagAccepted $ entityVal $ snd tagInfo
      }
 
@@ -1526,12 +1527,14 @@ instance ToSchema EvaluationView where
 data TagView = TagView {
   tagViewName :: Text,
   tagViewDescription :: Maybe Text,
+  tagViewColor :: Maybe Text,
   tagViewAccepted :: Maybe Bool }
 
 instance ToJSON TagView where
   toJSON t = object
        [ "name" .= tagViewName t
        , "description" .= tagViewDescription t
+       , "color" .= tagViewColor t
        , "accepted" .= tagViewAccepted t
        ]
 
@@ -1544,9 +1547,10 @@ instance ToSchema TagView where
         & properties .~
            fromList [  ("name", stringSchema)
                      , ("description", stringSchema)
+                     , ("color", stringSchema)
                      , ("accepted", boolSchema)
                     ]
-        & required .~ [ "name", "description" ]
+        & required .~ [ "name", "color", "description" ]
 
 
 data SubmissionView = SubmissionView {

Handler/Tags.hs

@@ -20,6 +20,7 @@ instance ToJSON (Entity Tag) where
     toJSON v = object
         [ "name" .= (tagName $ entityVal v)
         , "description" .= (tagDescription $ entityVal v)
+        , "color" .= (tagColor $ entityVal v)
         , "id" .= (entityKey v)
         ]
 
@@ -32,9 +33,10 @@ instance ToSchema (Entity Tag) where
         & properties .~
            fromList [  ("name", stringSchema)
                      , ("description", stringSchema)
+                     , ("color", stringSchema)
                      , ("id", intSchema)
                     ]
-        & required .~ [ "name", "description", "id" ]
+        & required .~ [ "name", "description", "color", "id" ]
 
 listTagsApi :: Swagger
 listTagsApi = spec & definitions .~ defs
@@ -70,8 +72,8 @@ postTagsR = do
   canTagsBeAdded <- canAddTags
   when canTagsBeAdded $ do
      case result of
-      FormSuccess (t, d) -> do
-                            _ <- runDB $ insert $ Tag t d
+      FormSuccess (t, d, c) -> do
+                            _ <- runDB $ insert $ Tag t d c
                             return ()
       _ -> do
            return ()
@@ -107,12 +109,13 @@ tagsTable :: Table.Table App (Entity Tag)
 tagsTable = mempty
   ++ Table.text "tag" (\(Entity _ tag) -> tagName tag)
   ++ Table.text "description" (\(Entity _ tag) -> (fromMaybe (""::Text) (tagDescription tag)))
+  ++ Table.text "color" (\(Entity _ tag) -> (fromMaybe (""::Text) (tagColor tag)))
 
-
-tagForm :: Form (Text, Maybe Text)
-tagForm = renderBootstrap3 BootstrapBasicForm $ (,)
+tagForm :: Form (Text, Maybe Text, Maybe Text)
+tagForm = renderBootstrap3 BootstrapBasicForm $ (,,)
     <$> areq textField (bfs MsgTagName) Nothing
     <*> aopt textField (bfs MsgTagDescription) Nothing
+    <*> aopt textField (bfs MsgColor) Nothing
 
 getToggleSubmissionTagR :: SubmissionTagId -> Handler RepPlain
 getToggleSubmissionTagR submissionTagId = do

config/models

@@ -164,6 +164,7 @@ Out
 Tag
     name Text
     description Text Maybe
+    color Text Maybe
     UniqueTagName name
 SubmissionTag
     submission SubmissionId

messages/en.msg

@@ -107,3 +107,4 @@ InviteToTeam: Invite to team (give the identifier/login of a user)
 Join: Join
 NoTests: SOMETHING IS WRONG WITH THE CHALLENGE, THERE ARE NO TESTS DEFINED. MAYBE TEST DIRECTORY ARE MISSING OR THE CHALLENGE WAS CREATED/UPDATE IN THE INVALID MANNER
 TestAnnouncements: test announcements
+Color: color name or hex value