Allow customizing badge color with query string

With this change, the /package/#PackageNameP/badge/#SnapshotBranch/
endpoint takes a new query string "color" that controls the badge color.
The color can be specified as a hex code or a named color from
Graphics.Badge.Barrier.Color in the barrier library. The badge color
defaults to "brightgreen", preserving default behavior when no query
string is supplied.

src/Handler/Package.hs

@@ -43,21 +43,40 @@ getPackageBadgeR pname branch = track "Handler.Package.getPackageBadgeR" $ do
 
     mLabel <- lookupGetParam "label"
     mStyle <- lookupGetParam "style"
+    mColor <- lookupGetParam "color"
+    let color = decodeColor mColor
 
     respond typeSvg $ case mStyle of
-      Just "plastic"     -> renderStackageBadge plastic    mLabel snapName mVersion
+      Just "plastic"     -> renderStackageBadge plastic    mLabel snapName color mVersion
-      Just "flat-square" -> renderStackageBadge flatSquare mLabel snapName mVersion
+      Just "flat-square" -> renderStackageBadge flatSquare mLabel snapName color mVersion
-      _                  -> renderStackageBadge flat       mLabel snapName mVersion
+      _                  -> renderStackageBadge flat       mLabel snapName color mVersion
+
+decodeColor :: Maybe Text -> Color
+decodeColor = \case
+  Nothing -> brightgreen
+  Just colorName ->
+    case colorName of
+      "brightgreen" -> brightgreen
+      "green" -> green
+      "yellow" -> yellow
+      "yellowgreen" -> yellowgreen
+      "orange" -> orange
+      "red" -> red
+      "blue" -> blue
+      "gray" -> gray
+      "lightgray" -> lightgray
+      _ -> Color colorName
 
 renderStackageBadge :: (Badge b, HasRightColor b)
                     => b          -- ^ Style
                     -> Maybe Text -- ^ Label
                     -> SnapName
+                    -> Color
                     -> Maybe VersionP
                     -> LByteString
-renderStackageBadge style mLabel snapName = \case
+renderStackageBadge style mLabel snapName color = \case
     Nothing -> renderBadge (style & right .~ lightgray) badgeLabel "not available"
-    Just v -> renderBadge style badgeLabel $ toPathPiece v
+    Just v -> renderBadge (style & right .~ color) badgeLabel $ toPathPiece v
   where
     badgeLabel = fromMaybe ("stackage " <> badgeSnapName snapName) mLabel