Introduce a first version of a UI mode that increases accessibility

For now, it mostly addresses users with color vision deficiencies.
Previously, users have to use the color of the different tiles to
determine the state of a pipeline, which is impossible for users
with color blindness.
The new mode can be accessed via a link on the page or by appending
`?ui=no-color` to the URL. The state of each pipeline will appear as
text below the pipeline name. In addition to that, the background of the
tiles contain a checkmark or a cross to indicate whether a pipeline is
healthy or not.

That's only the first iteration, in the future the positioning of the
icons can be improved, there could be an icon for running pipelines, and
there is a lot of room for refactorings behind the scenes.

This addresses #185

src/Core/BuildStatuses.hs

@@ -26,6 +26,7 @@ module Core.BuildStatuses
     ProjectNamespace (..),
     ProjectNamespaceFullPath (..),
     isHealthy,
+    isBroken,
     toResult,
   )
 where
@@ -148,6 +149,21 @@ isHealthy Successful = True
 isHealthy SuccessfulWithWarnings = False
 isHealthy WaitingForResource = True
 
+isBroken :: BuildStatus -> Bool
+isBroken Unknown = True
+isBroken Cancelled = True
+isBroken Created = False
+isBroken Failed = True
+isBroken Manual = False
+isBroken Pending = False
+isBroken Preparing = False
+isBroken Running = False
+isBroken Scheduled = False
+isBroken Skipped = True
+isBroken Successful = False
+isBroken SuccessfulWithWarnings = True
+isBroken WaitingForResource = False
+
 toResult :: Project -> Maybe (BuildStatus, Url Pipeline) -> Result
 toResult Project {..} Nothing = Result projectId projectName (projectNamespaceFullPath projectNamespace) Unknown (Left projectWebUrl)
 toResult Project {..} (Just (status, url)) = Result projectId projectName (projectNamespaceFullPath projectNamespace) status (Right url)

src/Ports/Inbound/HTTP/BuildStatuses/Html.hs

@@ -30,13 +30,14 @@ import Relude
 import Servant
 import Servant.HTML.Lucid
 
-type API = "statuses" :> QueryParam "view" ViewMode :> QueryFlag "norefresh" :> QueryParam "filter" FilterMode :> Get '[HTML] (Html ())
+type API = "statuses" :> QueryParam "view" ViewMode :> QueryFlag "norefresh" :> QueryParam "filter" FilterMode :> QueryParam "ui" UiMode :> Get '[HTML] (Html ())
 
 type Frontend = HtmlT (Reader FrontendState) ()
 
 data FrontendState = FrontendState
   { frontendStateViewMode :: ViewMode,
     frontendStateFilterMode :: FilterMode,
+    frontendStateUiMode :: UiMode,
     frontendStateJobsView :: JobsView,
     frontendStateBuildStatuses :: BuildStatuses,
     frontendStateDataUpdateInterval :: DataUpdateIntervalSeconds,
@@ -56,10 +57,11 @@ template ::
   ) =>
   ViewMode ->
   FilterMode ->
+  UiMode ->
   AutoRefresh ->
   Sem r (Html ())
-template viewMode filterMode autoRefresh = do
-  frontendState <- FrontendState viewMode filterMode <$> R.ask <*> getStatuses <*> R.ask <*> R.ask <*> pure autoRefresh <*> R.ask <*> Time.now
+template viewMode filterMode uiMode autoRefresh = do
+  frontendState <- FrontendState viewMode filterMode uiMode <$> R.ask <*> getStatuses <*> R.ask <*> R.ask <*> pure autoRefresh <*> R.ask <*> Time.now
   pure $ usingReader frontendState $ commuteHtmlT $ do
     pageHeader
     pageBody
@@ -102,10 +104,11 @@ pageBody = body_ $ do
         ShowAll -> buildStatuses
         DontShowSuccessful -> filterResults buildStatuses (\res -> buildStatus res /= Successful)
   (if viewMode == Plain then section_ [class_ "statuses"] else Relude.id) $ statusesToHtml viewMode dataUpdateInterval now buildStatusesFiltered
-  section_ [class_ "statuses"] $ do
+  section_ [classes_ ["statuses", "controls"]] $ do
     linkToViewToggle
     linkToAutoRefreshToggle
     linkToFilterModeToggle
+    linkToUiModeToggle
     linkToJobs
 
 statusesToHtml :: ViewMode -> DataUpdateIntervalSeconds -> UTCTime -> BuildStatuses -> Frontend
@@ -123,9 +126,17 @@ statusesToHtml Plain dataUpdateInterval now (Statuses (lastUpdated, results)) =
   traverse_ resultToHtml results
   lastUpdatedToHtml dataUpdateInterval now lastUpdated
 
-resultToHtml :: (Monad m) => Result -> HtmlT m ()
-resultToHtml Result {..} =
-  a_ [href_ (either show show url), target_ "_blank", classesForStatus buildStatus, title_ (buildStatusToString buildStatus)] $ div_ (toHtml name)
+resultToHtml :: Result -> Frontend
+resultToHtml result = do
+  uiMode <- asks frontendStateUiMode
+  case uiMode of
+    Colored -> resultToHtml' result
+    NoColor -> resultToHtml'' result
+
+resultToHtml' :: (Monad m) => Result -> HtmlT m ()
+resultToHtml' Result {..} =
+  a_ [href_ (either show show url), target_ "_blank", classesForStatus buildStatus, title_ (buildStatusToString buildStatus)] $ do
+    div_ [class_ "status-content"] $ p_ (toHtml name)
   where
     classesForStatus Unknown = class_ "status unknown"
     classesForStatus Cancelled = class_ "status cancelled"
@@ -141,19 +152,34 @@ resultToHtml Result {..} =
     classesForStatus SuccessfulWithWarnings = class_ "status passed-with-warnings"
     classesForStatus WaitingForResource = class_ "status waiting-for-resource"
 
-    buildStatusToString Unknown = "unknown"
-    buildStatusToString Cancelled = "cancelled"
-    buildStatusToString Created = "created"
-    buildStatusToString Failed = "failed"
-    buildStatusToString Manual = "manual"
-    buildStatusToString Pending = "pending"
-    buildStatusToString Preparing = "preparing"
-    buildStatusToString Running = "running"
-    buildStatusToString Scheduled = "scheduled"
-    buildStatusToString Skipped = "skipped"
-    buildStatusToString Successful = "successful"
-    buildStatusToString SuccessfulWithWarnings = "successful with warnings"
-    buildStatusToString WaitingForResource = "waiting for resource"
+resultToHtml'' :: (Monad m) => Result -> HtmlT m ()
+resultToHtml'' Result {..} =
+  a_ [href_ (either show show url), target_ "_blank", classes_ ["status", "no-color"], title_ (buildStatusToString buildStatus), style_ "position: relative"] $ do
+    div_ [class_ "status-content"] $ do
+      p_ (toHtml name)
+      p_ [class_ "textual-status"] (buildStatusToString buildStatus)
+    section_ [class_ "icon-box", style_ "position: absolute; height: 100%; width: 100%; display: grid; grid-template-columns: repeat(4, 1fr); grid-auto-rows: 48px;"] $ do
+      if isBroken buildStatus
+        then replicateM_ 16 (toHtmlRaw ("<svg viewBox=\"0 0 48 48\"><polygon fill=\"#c41934\" points=\"36,0 0,37.4 2.8,40.2 38.8,2.7\"/><polygon fill=\"#c41934\" points=\"0,2.8 2.8,0 38.8,37.4 36,40.2\"/></svg>" :: String))
+        else pure ()
+      if isHealthy buildStatus
+        then replicateM_ 16 (toHtmlRaw ("<svg viewBox=\"0 0 48 48\"><polygon fill=\"#43A047\" points=\"36,0 12.4,23.6 2.8,14.0 0,16.9 12.4,29.1 38.8,2.7\"/></svg>" :: String))
+        else pure ()
+
+buildStatusToString :: (IsString a) => BuildStatus -> a
+buildStatusToString Unknown = "unknown"
+buildStatusToString Cancelled = "cancelled"
+buildStatusToString Created = "created"
+buildStatusToString Failed = "failed"
+buildStatusToString Manual = "manual"
+buildStatusToString Pending = "pending"
+buildStatusToString Preparing = "preparing"
+buildStatusToString Running = "running"
+buildStatusToString Scheduled = "scheduled"
+buildStatusToString Skipped = "skipped"
+buildStatusToString Successful = "successful"
+buildStatusToString SuccessfulWithWarnings = "successful with warnings"
+buildStatusToString WaitingForResource = "waiting for resource"
 
 emptyResults :: Frontend
 emptyResults = do
@@ -203,5 +229,16 @@ linkToFilterModeToggle = do
         DontShowSuccessful -> "Show all pipelines"
   div_ [class_ "status"] $ div_ $ a_ [class_ "link-control", href_ (toUrlPiece (linkForState (frontendState {frontendStateFilterMode = toggle filterMode})))] txt
 
+linkToUiModeToggle :: Frontend
+linkToUiModeToggle = do
+  frontendState <- ask
+  let uiMode = frontendStateUiMode frontendState
+      toggle Colored = NoColor
+      toggle NoColor = Colored
+      txt = case uiMode of
+        Colored -> "Switch to accessibility mode"
+        NoColor -> "Switch to colored mode"
+  div_ [class_ "status"] $ div_ $ a_ [class_ "link-control", href_ (toUrlPiece (linkForState (frontendState {frontendStateUiMode = toggle uiMode})))] txt
+
 linkForState :: FrontendState -> Link
-linkForState frontendState = safeLink (Proxy @API) (Proxy @API) (Just (frontendStateViewMode frontendState)) (frontendStateAutoRefresh frontendState == NoRefresh) (Just (frontendStateFilterMode frontendState))
+linkForState frontendState = safeLink (Proxy @API) (Proxy @API) (Just (frontendStateViewMode frontendState)) (frontendStateAutoRefresh frontendState == NoRefresh) (Just (frontendStateFilterMode frontendState)) (Just (frontendStateUiMode frontendState))

src/Ports/Inbound/HTTP/Server.hs

@@ -48,7 +48,7 @@ server = s :<|> s
   where
     s =
       getCurrentHealthStatus
-        :<|> (\mvm b mfm -> BuildStatuses.template (fromMaybe Plain mvm) (fromMaybe ShowAll mfm) (norefreshFlag b))
+        :<|> (\mvm b mfm mum -> BuildStatuses.template (fromMaybe Plain mvm) (fromMaybe ShowAll mfm) (fromMaybe Colored mum) (norefreshFlag b))
         :<|> (Runners.template . norefreshFlag)
         :<|> serveDirectoryWebApp "/service/static"
 

src/Ports/Inbound/HTTP/Util.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module Ports.Inbound.HTTP.Util (AutoRefresh (..), ViewMode (..), FilterMode (..), lastUpdatedToHtml) where
+module Ports.Inbound.HTTP.Util (AutoRefresh (..), ViewMode (..), FilterMode (..), UiMode (..), lastUpdatedToHtml) where
 
 import Core.Shared
 import Data.Time (UTCTime, diffUTCTime)
@@ -42,6 +42,18 @@ instance ToHtml (Id a) where
 
 deriving newtype instance ToHtml (Name a)
 
+data UiMode = Colored | NoColor deriving stock (Bounded, Eq, Enum)
+
+uiModeToText :: UiMode -> Text
+uiModeToText Colored = "colored"
+uiModeToText NoColor = "no-color"
+
+instance FromHttpApiData UiMode where
+  parseQueryParam = maybeToRight "can't parse UiMode param" . inverseMap uiModeToText
+
+instance ToHttpApiData UiMode where
+  toQueryParam = uiModeToText
+
 lastUpdatedToHtml :: (Monad m) => DataUpdateIntervalSeconds -> UTCTime -> UTCTime -> HtmlT m ()
 lastUpdatedToHtml (DataUpdateIntervalSeconds updateInterval) now lastUpdate = div_ ([class_ classes] <> staleDataTitle) $ div_ $ do
   p_ "Last Update at:"

static/statuses-11c70488b8.css

@@ -6,6 +6,21 @@ a {
     color: black;
 }
 
+a.status > div > p:first-child {
+    margin-bottom: 0;
+}
+
+p.textual-status {
+    font-weight: normal;
+    font-size: smaller;
+    margin-top: 0;
+}
+
+a.no-color > div {
+    background-color: white;
+    padding: 5px;
+}
+
 html {
     height: 100%;
     font-family: 'Noto Sans', sans-serif;
@@ -24,6 +39,10 @@ body {
     display: grid;
 }
 
+.status.no-color {
+    border: 1px solid white;
+}
+
 .status::before {
     content: "";
     padding-bottom: 60%;
@@ -76,6 +95,10 @@ a.link-to-jobs, a.link-control {
     background-color: #8936b2;
 }
 
+.unknown {
+    background-color: white;
+}
+
 .statuses {
     width: 100%;
     display: grid;
@@ -93,4 +116,21 @@ a.link-to-jobs, a.link-control {
     grid-auto-rows: 1fr;
     grid-template-columns: repeat(auto-fill, minmax(11em, 10fr));
     margin-bottom: 0.4em
-}
+}
+
+.icon-box {
+    overflow-y: hidden;
+}
+
+.controls {
+    padding-top: 8px;
+}
+
+.status-content {
+    z-index: 1;
+}
+
+.status-content > p {
+    margin-top: 0;
+    margin-bottom: 0;
+}