-- |
-- Module      : ZuulWeeder.UI
-- Description : The User Interface
-- Copyright   : (c) Red Hat, 2022
-- License     : Apache-2.0
--
-- Maintainer  : tdecacqu@redhat.com, fboucher@redhat.com
-- Stability   : provisional
-- Portability : portable
--
-- The web interface for zuul-weeder.
--
-- The UI is implemented with
--
--   * [htmx](https://htmx.org/docs/#introduction)
--   * [tailwind](https://tailwindcss.com/docs/utility-first) (use Ctrl-K to search documentation)
module ZuulWeeder.UI
  ( app,
    BasePath (..),
    dotGraph,
    dotLegend,

    -- * Test helpers
    configLocUrl,
  )
where

-- After adding css class, run `nix run .#tailwind` to update the tailwind.css file. Then hard refresh the web page.

import Algebra.Graph qualified
import Data.Aeson qualified
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import Lucid
import Lucid.Base (makeAttribute)
import Paths_zuul_weeder (version)
import Servant hiding (Context)
import Servant.HTML.Lucid (HTML)
import Servant.Server.StaticFiles qualified
import WaiAppStatic.Storage.Filesystem qualified
import WaiAppStatic.Types qualified
import Web.FormUrlEncoded (FromForm)
import Zuul.Config
import Zuul.ConfigLoader (Config (..), ConfigMap)
import ZuulWeeder.Graph
import ZuulWeeder.Prelude

-- | The request context
data Scope = UnScoped | Scoped (Set TenantName) deriving (Int -> Scope -> String -> String
[Scope] -> String -> String
Scope -> String
(Int -> Scope -> String -> String)
-> (Scope -> String) -> ([Scope] -> String -> String) -> Show Scope
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Scope] -> String -> String
$cshowList :: [Scope] -> String -> String
show :: Scope -> String
$cshow :: Scope -> String
showsPrec :: Int -> Scope -> String -> String
$cshowsPrec :: Int -> Scope -> String -> String
Show)

-- | The base path of the web interface, when served behing a sub path proxy.
newtype BasePath = BasePath
  { BasePath -> Text
basePath :: Text
  }
  deriving newtype (Int -> BasePath -> String -> String
[BasePath] -> String -> String
BasePath -> String
(Int -> BasePath -> String -> String)
-> (BasePath -> String)
-> ([BasePath] -> String -> String)
-> Show BasePath
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [BasePath] -> String -> String
$cshowList :: [BasePath] -> String -> String
show :: BasePath -> String
$cshow :: BasePath -> String
showsPrec :: Int -> BasePath -> String -> String
$cshowsPrec :: Int -> BasePath -> String -> String
Show)

data Context = Context
  { Context -> BasePath
rootURL :: BasePath,
    Context -> Scope
scope :: Scope
  }
  deriving (Int -> Context -> String -> String
[Context] -> String -> String
Context -> String
(Int -> Context -> String -> String)
-> (Context -> String)
-> ([Context] -> String -> String)
-> Show Context
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Context] -> String -> String
$cshowList :: [Context] -> String -> String
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> String -> String
$cshowsPrec :: Int -> Context -> String -> String
Show)

mainBody :: Context -> Text -> Html () -> Html ()
mainBody :: Context -> Text -> HtmlT Identity () -> HtmlT Identity ()
mainBody Context
ctx Text
page HtmlT Identity ()
mainComponent =
  HtmlT Identity () -> HtmlT Identity ()
forall (m :: * -> *) a. Applicative m => HtmlT m a -> HtmlT m a
doctypehtml_ do
    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
head_ do
      HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
title_ HtmlT Identity ()
"Zuul Weeder"
      [Attribute] -> HtmlT Identity ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
charset_ Text
"utf-8"]
      [Attribute] -> HtmlT Identity ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
name_ Text
"viewport", Text -> Attribute
content_ Text
"width=device-width, initial-scale=1.0"]
      Text -> HtmlT Identity ()
forall arg result. TermRaw arg result => arg -> result
script_ Text
jsColors
      Text -> HtmlT Identity ()
forall arg result. TermRaw arg result => arg -> result
style_ Text
css
      [Attribute] -> HtmlT Identity ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
link_ [Text -> Attribute
href_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Context -> Text -> Text
distUrl Context
ctx Text
"remixicon.min.css", Text -> Attribute
rel_ Text
"stylesheet"]
      [Attribute] -> HtmlT Identity ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
link_ [Text -> Attribute
href_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Context -> Text -> Text
distUrl Context
ctx Text
"tailwind.css", Text -> Attribute
rel_ Text
"stylesheet"]
      HtmlT Identity () -> [Attribute] -> HtmlT Identity ()
forall a. With a => a -> [Attribute] -> a
with (Text -> HtmlT Identity ()
forall arg result. TermRaw arg result => arg -> result
script_ Text
forall a. Monoid a => a
mempty) [Text -> Attribute
src_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Context -> Text -> Text
distUrl Context
ctx Text
"d3.v4.min.js"]
      HtmlT Identity () -> [Attribute] -> HtmlT Identity ()
forall a. With a => a -> [Attribute] -> a
with (Text -> HtmlT Identity ()
forall arg result. TermRaw arg result => arg -> result
script_ Text
forall a. Monoid a => a
mempty) [Text -> Attribute
src_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Context -> Text -> Text
distUrl Context
ctx Text
"graph.js"]
      HtmlT Identity () -> [Attribute] -> HtmlT Identity ()
forall a. With a => a -> [Attribute] -> a
with (Text -> HtmlT Identity ()
forall arg result. TermRaw arg result => arg -> result
script_ Text
forall a. Monoid a => a
mempty) [Text -> Attribute
src_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Context -> Text -> Text
distUrl Context
ctx Text
"htmx.min.js"]
    (HtmlT Identity () -> HtmlT Identity ())
-> [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> [Attribute] -> a
with HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
body_ [Text -> Attribute
id_ Text
"main"] do
      Context -> Text -> HtmlT Identity ()
navComponent Context
ctx Text
page
      (HtmlT Identity () -> HtmlT Identity ())
-> [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> [Attribute] -> a
with HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"container grid p-4"] HtmlT Identity ()
mainComponent
  where
    css :: Text
    css :: Text
css =
      [s|
.links line {
  stroke: #999;
  stroke-opacity: 0.6;
}
svg#d3 {
  position: fixed;
  height: 100%;
  width: 100%;
  margin: 0;
  top: 0;
  left: 0;
  z-index: -1;
}
|]
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cssColors

navComponent :: Context -> Text -> Html ()
navComponent :: Context -> Text -> HtmlT Identity ()
navComponent Context
ctx Text
page =
  (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
nav_ Text
"bg-slate-700 p-1 shadow w-full flex" do
    (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ Text
"flex-grow" do
      (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ Text
"font-semibold text-white" do
        Text -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
hxNavLink Text
base Maybe Text
forall a. Maybe a
Nothing HtmlT Identity ()
"Zuul Weeder"
      Text -> HtmlT Identity () -> HtmlT Identity ()
navLink Text
"search" HtmlT Identity ()
"Search"
      Text -> HtmlT Identity () -> HtmlT Identity ()
navLink Text
"info" HtmlT Identity ()
"Info"
    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ do
      HtmlT Identity ()
exitScope
      Text -> HtmlT Identity () -> HtmlT Identity ()
navLink Text
"about" HtmlT Identity ()
"About"
      HtmlT Identity ()
spinner
  where
    base :: Text
base = Context -> Text
baseUrl Context
ctx
    navLink :: Text -> HtmlT Identity () -> HtmlT Identity ()
navLink Text
path =
      let navLinkClass :: Text
navLinkClass
            | Text
path Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
page Bool -> Bool -> Bool
|| (Text
path Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"search" Bool -> Bool -> Bool
&& Text
page Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"") = Text
" bg-slate-500"
            | Bool
otherwise = Text
""
          extra :: Text
extra
            | Text
path Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"about" = Text
" right"
            | Bool
otherwise = Text
""
          linkClass :: Text
linkClass = Text
"m-4 p-1 cursor-pointer text-white rounded hover:text-teal-500" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
navLinkClass Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
extra
       in [Attribute]
-> Text -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
hxNavLinkWithAttr [Text -> Attribute
id_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Text
"nav-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path] (Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
linkClass)
    exitScope :: HtmlT Identity ()
exitScope =
      case Context
ctx.scope of
        Scoped Set TenantName
tenants -> Text -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
hxNavLink (BasePath -> Text
basePath Context
ctx.rootURL) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
tenantClass) (Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (Text -> HtmlT Identity ()) -> Text -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Set TenantName -> Text
tenantsList Set TenantName
tenants)
        Scope
UnScoped -> () -> HtmlT Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        tenantClass :: Text
tenantClass = Text
"my-4 p-1 text-white font-semibold "

data VertexType
  = VAbstractJobT
  | VJobT
  | VSemaphoreT
  | VSecretT
  | VNodesetT
  | VNodeLabelT
  | VQueueT
  | VPipelineT
  | VProjectT
  | VProjectPipelineT
  | VProjectRegexT
  | VRegexPipelineT
  | VProjectTemplateT
  | VTemplatePipelineT
  | VTriggerT
  | VReporterT
  deriving (VertexType -> VertexType -> Bool
(VertexType -> VertexType -> Bool)
-> (VertexType -> VertexType -> Bool) -> Eq VertexType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VertexType -> VertexType -> Bool
$c/= :: VertexType -> VertexType -> Bool
== :: VertexType -> VertexType -> Bool
$c== :: VertexType -> VertexType -> Bool
Eq, Eq VertexType
Eq VertexType
-> (VertexType -> VertexType -> Ordering)
-> (VertexType -> VertexType -> Bool)
-> (VertexType -> VertexType -> Bool)
-> (VertexType -> VertexType -> Bool)
-> (VertexType -> VertexType -> Bool)
-> (VertexType -> VertexType -> VertexType)
-> (VertexType -> VertexType -> VertexType)
-> Ord VertexType
VertexType -> VertexType -> Bool
VertexType -> VertexType -> Ordering
VertexType -> VertexType -> VertexType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: VertexType -> VertexType -> VertexType
$cmin :: VertexType -> VertexType -> VertexType
max :: VertexType -> VertexType -> VertexType
$cmax :: VertexType -> VertexType -> VertexType
>= :: VertexType -> VertexType -> Bool
$c>= :: VertexType -> VertexType -> Bool
> :: VertexType -> VertexType -> Bool
$c> :: VertexType -> VertexType -> Bool
<= :: VertexType -> VertexType -> Bool
$c<= :: VertexType -> VertexType -> Bool
< :: VertexType -> VertexType -> Bool
$c< :: VertexType -> VertexType -> Bool
compare :: VertexType -> VertexType -> Ordering
$ccompare :: VertexType -> VertexType -> Ordering
Ord, Int -> VertexType
VertexType -> Int
VertexType -> [VertexType]
VertexType -> VertexType
VertexType -> VertexType -> [VertexType]
VertexType -> VertexType -> VertexType -> [VertexType]
(VertexType -> VertexType)
-> (VertexType -> VertexType)
-> (Int -> VertexType)
-> (VertexType -> Int)
-> (VertexType -> [VertexType])
-> (VertexType -> VertexType -> [VertexType])
-> (VertexType -> VertexType -> [VertexType])
-> (VertexType -> VertexType -> VertexType -> [VertexType])
-> Enum VertexType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: VertexType -> VertexType -> VertexType -> [VertexType]
$cenumFromThenTo :: VertexType -> VertexType -> VertexType -> [VertexType]
enumFromTo :: VertexType -> VertexType -> [VertexType]
$cenumFromTo :: VertexType -> VertexType -> [VertexType]
enumFromThen :: VertexType -> VertexType -> [VertexType]
$cenumFromThen :: VertexType -> VertexType -> [VertexType]
enumFrom :: VertexType -> [VertexType]
$cenumFrom :: VertexType -> [VertexType]
fromEnum :: VertexType -> Int
$cfromEnum :: VertexType -> Int
toEnum :: Int -> VertexType
$ctoEnum :: Int -> VertexType
pred :: VertexType -> VertexType
$cpred :: VertexType -> VertexType
succ :: VertexType -> VertexType
$csucc :: VertexType -> VertexType
Enum, VertexType
VertexType -> VertexType -> Bounded VertexType
forall a. a -> a -> Bounded a
maxBound :: VertexType
$cmaxBound :: VertexType
minBound :: VertexType
$cminBound :: VertexType
Bounded)

instance From VertexName VertexType where
  from :: VertexName -> VertexType
from = \case
    VAbstractJob JobName
_ -> VertexType
VAbstractJobT
    VJob JobName
_ -> VertexType
VJobT
    VSemaphore SemaphoreName
_ -> VertexType
VSemaphoreT
    VSecret SecretName
_ -> VertexType
VSecretT
    VQueue QueueName
_ -> VertexType
VQueueT
    VProject CanonicalProjectName
_ -> VertexType
VProjectT
    VProjectRegex ProjectRegex
_ -> VertexType
VProjectRegexT
    VNodeset NodesetName
_ -> VertexType
VNodesetT
    VProjectTemplate ProjectTemplateName
_ -> VertexType
VProjectTemplateT
    VPipeline PipelineName
_ -> VertexType
VPipelineT
    VNodeLabel NodeLabelName
_ -> VertexType
VNodeLabelT
    VProjectPipeline PipelineName
_ CanonicalProjectName
_ -> VertexType
VProjectPipelineT
    VRegexPipeline PipelineName
_ ProjectRegex
_ -> VertexType
VRegexPipelineT
    VTemplatePipeline PipelineName
_ ProjectTemplateName
_ -> VertexType
VTemplatePipelineT
    VTrigger ConnectionName
_ -> VertexType
VTriggerT
    VReporter ConnectionName
_ -> VertexType
VReporterT

vertexHue :: VertexType -> Int
vertexHue :: VertexType -> Int
vertexHue VertexType
vt = VertexType -> Int
forall a. Enum a => a -> Int
fromEnum VertexType
vt' Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
step
  where
    vt' :: VertexType
vt' = case VertexType
vt of
      VertexType
VTemplatePipelineT -> VertexType
VProjectTemplateT
      VertexType
VProjectPipelineT -> VertexType
VProjectT
      VertexType
_ -> VertexType
vt
    step :: Int
    step :: Int
step = Int
300 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` forall a. Enum a => a -> Int
fromEnum @VertexType VertexType
forall a. Bounded a => a
maxBound

vertexColor :: VertexType -> Text
vertexColor :: VertexType -> Text
vertexColor VertexType
vt = Text
"hsl(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall source target. From source target => source -> target
from (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ VertexType -> Int
vertexHue VertexType
vt) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 50%, 50%)"

cssColors :: Text
cssColors :: Text
cssColors = [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (VertexType -> Text) -> [VertexType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map VertexType -> Text
mkCssColor [VertexType
forall a. Bounded a => a
minBound .. VertexType
forall a. Bounded a => a
maxBound]
  where
    mkCssColor :: VertexType -> Text
    mkCssColor :: VertexType -> Text
mkCssColor VertexType
vt =
      Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VertexType -> Text
vertexTypeName VertexType
vt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" { color: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VertexType -> Text
vertexColor VertexType
vt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";}"

jsColors :: Text
jsColors :: Text
jsColors =
  Text
"const getColor = (group) => { switch (group) {\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines ((VertexType -> Text) -> [VertexType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map VertexType -> Text
mkJsColor [VertexType
forall a. Bounded a => a
minBound .. VertexType
forall a. Bounded a => a
maxBound]) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}};"
  where
    mkJsColor :: VertexType -> Text
    mkJsColor :: VertexType -> Text
mkJsColor VertexType
vt = Text
"case " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall source target. From source target => source -> target
from (Int -> String
forall a. Show a => a -> String
show (VertexType -> Int
forall a. Enum a => a -> Int
fromEnum VertexType
vt)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": return \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VertexType -> Text
vertexColor VertexType
vt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\";"

-- | A text representation of a vertex type, useful for /object url piece.
vertexTypeName :: VertexType -> Text
vertexTypeName :: VertexType -> Text
vertexTypeName = \case
  VertexType
VAbstractJobT -> Text
"abstract-job"
  VertexType
VJobT -> Text
"job"
  VertexType
VSemaphoreT -> Text
"semaphore"
  VertexType
VSecretT -> Text
"secret"
  VertexType
VNodesetT -> Text
"nodeset"
  VertexType
VNodeLabelT -> Text
"label"
  VertexType
VQueueT -> Text
"queue"
  VertexType
VProjectT -> Text
"project"
  VertexType
VProjectRegexT -> Text
"project-regex"
  VertexType
VProjectTemplateT -> Text
"project-template"
  VertexType
VPipelineT -> Text
"pipeline"
  VertexType
VProjectPipelineT -> Text
"project-pipeline"
  VertexType
VRegexPipelineT -> Text
"regex-pipeline"
  VertexType
VTemplatePipelineT -> Text
"template-pipeline"
  VertexType
VTriggerT -> Text
"trigger"
  VertexType
VReporterT -> Text
"reporter"

spinner :: Html ()
spinner :: HtmlT Identity ()
spinner = (HtmlT Identity () -> HtmlT Identity ())
-> [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> [Attribute] -> a
with HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"htmx-indicator font-semibold text-white", Text -> Attribute
id_ Text
"spinner"] HtmlT Identity ()
"◌"

hxNavLinkWithAttr :: [Attribute] -> Text -> Maybe Text -> Html () -> Html ()
hxNavLinkWithAttr :: [Attribute]
-> Text -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
hxNavLinkWithAttr [Attribute]
xs Text
url Maybe Text
extraClass =
  (HtmlT Identity () -> HtmlT Identity ())
-> [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> [Attribute] -> a
with
    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
a_
    ( [Attribute]
xs
        [Attribute] -> [Attribute] -> [Attribute]
forall a. Semigroup a => a -> a -> a
<> [ Text -> Attribute
hxGet Text
url,
             Attribute
hxPushUrl,
             Text -> Attribute
hxIndicator Text
"#spinner",
             Text -> Attribute
hxTarget Text
"#main",
             Text -> Attribute
class_ (Text
"cursor-pointer hover:font-semibold" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
" ") Maybe Text
extraClass),
             Text -> Attribute
href_ Text
url
           ]
    )

hxNavLink :: Text -> Maybe Text -> Html () -> Html ()
hxNavLink :: Text -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
hxNavLink = [Attribute]
-> Text -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
hxNavLinkWithAttr []

welcomeComponent :: Context -> Html ()
welcomeComponent :: Context -> HtmlT Identity ()
welcomeComponent Context
ctx = do
  Context -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
searchComponent Context
ctx Maybe Text
forall a. Maybe a
Nothing HtmlT Identity ()
forall a. Monoid a => a
mempty
  Text -> HtmlT Identity ()
forall arg result. TermRaw arg result => arg -> result
script_ do
    Text
"renderToy('" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Context -> Text
baseUrl Context
ctx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"data.json');"

title :: Text -> Html ()
title :: Text -> HtmlT Identity ()
title = (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
h2_ Text
"font-bold" (HtmlT Identity () -> HtmlT Identity ())
-> (Text -> HtmlT Identity ()) -> Text -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml

mkIconClass :: Maybe Text -> Text -> Html ()
mkIconClass :: Maybe Text -> Text -> HtmlT Identity ()
mkIconClass Maybe Text
cl Text
name = (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
i_ (Text
"pr-1 font-bold align-bottom " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
" ") Maybe Text
cl) HtmlT Identity ()
forall a. Monoid a => a
mempty

mkIcon :: Text -> Html ()
mkIcon :: Text -> HtmlT Identity ()
mkIcon = Maybe Text -> Text -> HtmlT Identity ()
mkIconClass Maybe Text
forall a. Maybe a
Nothing

aboutComponent :: Html ()
aboutComponent :: HtmlT Identity ()
aboutComponent = do
  Text -> HtmlT Identity ()
title Text
"Welcome"
  (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
p_ Text
"pb-5" HtmlT Identity ()
"Zuul Weeder is a web service to inspect Zuul configuration"
  Text -> HtmlT Identity ()
title Text
"Icons"
  (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
ul_ Text
"pb-5" do
    (VertexType -> HtmlT Identity ())
-> [VertexType] -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ VertexType -> HtmlT Identity ()
renderIconLegend [VertexType
forall a. Bounded a => a
minBound .. VertexType
forall a. Bounded a => a
maxBound]
  HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ (HtmlT Identity () -> HtmlT Identity ())
-> (Text -> HtmlT Identity ()) -> Text -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (Text -> HtmlT Identity ()) -> Text -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Text
"Version: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall source target. From source target => source -> target
from (Version -> String
showVersion Version
version) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gitVersion Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  where
    renderIconLegend :: VertexType -> Html ()
    renderIconLegend :: VertexType -> HtmlT Identity ()
renderIconLegend VertexType
vt = HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
li_ do
      VertexType -> HtmlT Identity ()
vertexTypeIcon VertexType
vt
      Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (Text -> HtmlT Identity ()) -> Text -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ VertexType -> Text
vertexTypeName VertexType
vt

tenantsList :: Set TenantName -> Text
tenantsList :: Set TenantName -> Text
tenantsList Set TenantName
tenants = Text -> [Text] -> Text
Text.intercalate Text
"," (TenantName -> Text
forall source target. From source target => source -> target
from (TenantName -> Text) -> [TenantName] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set TenantName -> [TenantName]
forall a. Set a -> [a]
Set.toList Set TenantName
tenants)

distUrl :: Context -> Text -> Text
distUrl :: Context -> Text -> Text
distUrl Context
ctx Text
x = BasePath -> Text
basePath Context
ctx.rootURL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"dists/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x

tenantUrl :: BasePath -> TenantName -> Text
tenantUrl :: BasePath -> TenantName -> Text
tenantUrl (BasePath Text
rootURL) (TenantName Text
name) = Text
rootURL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"tenant/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"

baseUrl :: Context -> Text
baseUrl :: Context -> Text
baseUrl Context
ctx =
  BasePath -> Text
basePath Context
ctx.rootURL Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> case Context
ctx.scope of
    Scope
UnScoped -> Text
""
    Scoped Set TenantName
tenants -> Text
"tenant/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Set TenantName -> Text
tenantsList Set TenantName
tenants Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"

-- | Get the URL of a configuration element location
configLocUrl :: ConfigLoc -> Text
configLocUrl :: ConfigLoc -> Text
configLocUrl ConfigLoc
loc = case ConfigLoc
loc.url of
  GerritUrl Text
url -> Text -> Text
trimedUrl Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/plugins/gitiles/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/+/refs/heads/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path
  GithubUrl Text
url -> Text -> Text
buildGithubUrl Text
url
  GitlabUrl Text
url -> Text -> Text
buildGitlabUrl Text
url
  PagureUrl Text
url -> Text -> Text
buildPagureUrl Text
url
  GitUrl Text
url
    | Text
"gitlab.com" Text -> Text -> Bool
`Text.isInfixOf` Text
url -> Text -> Text
buildGitlabUrl Text
url
    | Text
"github.com" Text -> Text -> Bool
`Text.isInfixOf` Text
url -> Text -> Text
buildGithubUrl Text
url
    | Text
"pagure.io" Text -> Text -> Bool
`Text.isInfixOf` Text
url -> Text -> Text
buildPagureUrl Text
url
    | Text
"src.fedoraproject.io" Text -> Text -> Bool
`Text.isInfixOf` Text
url -> Text -> Text
buildPagureUrl Text
url
  GitUrl Text
url -> Text -> Text
trimedUrl Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/cgit/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/tree/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"?h=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch
  where
    CanonicalProjectName ProviderName
_ (ProjectName Text
name) = ConfigLoc
loc.project
    BranchName Text
branch = ConfigLoc
loc.branch
    FilePathT Text
path = ConfigLoc
loc.path
    trimedUrl :: Text -> Text
trimedUrl = (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
    buildGitlabUrl :: Text -> Text
buildGitlabUrl Text
url = Text -> Text
trimedUrl Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/-/blob/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path
    buildPagureUrl :: Text -> Text
buildPagureUrl Text
url = Text -> Text
trimedUrl Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/blob/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/f/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path
    buildGithubUrl :: Text -> Text
buildGithubUrl Text
url = Text -> Text
trimedUrl Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/blob/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path

-- | The data.json for the d3 graph (see dists/graph.js)
toD3Graph :: Scope -> ConfigGraph -> ZuulWeeder.UI.D3Graph
toD3Graph :: Scope -> ConfigGraph -> D3Graph
toD3Graph Scope
scope ConfigGraph
g =
  ZuulWeeder.UI.D3Graph
    { $sel:nodes:D3Graph :: [D3Node]
ZuulWeeder.UI.nodes = Vertex -> D3Node
toNodes (Vertex -> D3Node) -> [Vertex] -> [D3Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Vertex]
vertexes,
      $sel:links:D3Graph :: [D3Link]
ZuulWeeder.UI.links = (Vertex, Vertex) -> D3Link
toLinks ((Vertex, Vertex) -> D3Link) -> [(Vertex, Vertex)] -> [D3Link]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Vertex, Vertex)]
edges
    }
  where
    -- Keep the edges whose both vertex are in the current tenant
    keepTenant :: (r, r) -> Bool
keepTenant (r
a, r
b) = case Scope
scope of
      Scoped Set TenantName
tenants -> Set TenantName
tenants Set TenantName -> Set TenantName -> Bool
forall a. Eq a => a -> a -> Bool
== r
a.tenants Bool -> Bool -> Bool
&& Set TenantName
tenants Set TenantName -> Set TenantName -> Bool
forall a. Eq a => a -> a -> Bool
== r
b.tenants
      Scope
UnScoped -> Bool
True

    ([(Vertex, Vertex)]
edges, [(Vertex, Vertex)]
_) = Int
-> [(Vertex, Vertex)] -> ([(Vertex, Vertex)], [(Vertex, Vertex)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
500 ([(Vertex, Vertex)] -> ([(Vertex, Vertex)], [(Vertex, Vertex)]))
-> [(Vertex, Vertex)] -> ([(Vertex, Vertex)], [(Vertex, Vertex)])
forall a b. (a -> b) -> a -> b
$ ((Vertex, Vertex) -> Bool)
-> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Vertex, Vertex) -> Bool
forall {r} {r}.
(HasField "tenants" r (Set TenantName),
 HasField "tenants" r (Set TenantName)) =>
(r, r) -> Bool
keepTenant ([(Vertex, Vertex)] -> [(Vertex, Vertex)])
-> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ ConfigGraph -> [(Vertex, Vertex)]
forall a. Ord a => Graph a -> [(a, a)]
Algebra.Graph.edgeList ConfigGraph
g
    -- edges = Algebra.Graph.edgeList g
    vertexes :: [Vertex]
vertexes = [Vertex] -> [Vertex]
forall a. Eq a => [a] -> [a]
nub ([Vertex] -> [Vertex]) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ ((Vertex, Vertex) -> [Vertex]) -> [(Vertex, Vertex)] -> [Vertex]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Vertex
a, Vertex
b) -> [Vertex
a, Vertex
b]) [(Vertex, Vertex)]
edges

    toNodes :: Vertex -> ZuulWeeder.UI.D3Node
    toNodes :: Vertex -> D3Node
toNodes Vertex
v = Text -> Int -> Int -> D3Node
ZuulWeeder.UI.D3Node (VertexName -> Text
forall source target. From source target => source -> target
from Vertex
v.name) (Vertex -> Int
forall a. Hashable a => a -> Int
hash Vertex
v) (Int -> D3Node) -> Int -> D3Node
forall a b. (a -> b) -> a -> b
$ VertexType -> Int
forall a. Enum a => a -> Int
fromEnum (forall target source. From source target => source -> target
into @VertexType Vertex
v.name)

    toLinks :: (Vertex, Vertex) -> ZuulWeeder.UI.D3Link
    toLinks :: (Vertex, Vertex) -> D3Link
toLinks (Vertex
a, Vertex
b) = Int -> Int -> D3Link
ZuulWeeder.UI.D3Link (Vertex -> Int
forall a. Hashable a => a -> Int
hash Vertex
a) (Vertex -> Int
forall a. Hashable a => a -> Int
hash Vertex
b)

vertexTypeIcon :: VertexType -> Html ()
vertexTypeIcon :: VertexType -> HtmlT Identity ()
vertexTypeIcon VertexType
vt = Maybe Text -> Text -> HtmlT Identity ()
mkIconClass (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ VertexType -> Text
vertexTypeName VertexType
vt) (Text
"ri-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
iconName)
  where
    iconName :: Text
iconName = case VertexType
vt of
      VertexType
VAbstractJobT -> Text
"file-text-line"
      VertexType
VJobT -> Text
"file-text-line"
      VertexType
VSemaphoreT -> Text
"lock-line"
      VertexType
VSecretT -> Text
"key-2-line"
      VertexType
VQueueT -> Text
"traffic-light-line"
      VertexType
VProjectT -> Text
"folder-open-line"
      VertexType
VProjectRegexT -> Text
"folder-open-line"
      VertexType
VProjectTemplateT -> Text
"draft-line"
      VertexType
VPipelineT -> Text
"git-merge-line"
      VertexType
VNodeLabelT -> Text
"price-tag-3-line"
      VertexType
VProjectPipelineT -> Text
"git-merge-line"
      VertexType
VRegexPipelineT -> Text
"git-merge-line"
      VertexType
VTemplatePipelineT -> Text
"git-merge-line"
      VertexType
VNodesetT -> Text
"server-line"
      VertexType
VTriggerT -> Text
"download-fill"
      VertexType
VReporterT -> Text
"upload-fill"

data D3Node = D3Node
  { D3Node -> Text
name :: Text,
    D3Node -> Int
id :: Int,
    D3Node -> Int
group :: Int
  }
  deriving ((forall x. D3Node -> Rep D3Node x)
-> (forall x. Rep D3Node x -> D3Node) -> Generic D3Node
forall x. Rep D3Node x -> D3Node
forall x. D3Node -> Rep D3Node x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep D3Node x -> D3Node
$cfrom :: forall x. D3Node -> Rep D3Node x
Generic, D3Node -> D3Node -> Bool
(D3Node -> D3Node -> Bool)
-> (D3Node -> D3Node -> Bool) -> Eq D3Node
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: D3Node -> D3Node -> Bool
$c/= :: D3Node -> D3Node -> Bool
== :: D3Node -> D3Node -> Bool
$c== :: D3Node -> D3Node -> Bool
Eq, Int -> D3Node -> String -> String
[D3Node] -> String -> String
D3Node -> String
(Int -> D3Node -> String -> String)
-> (D3Node -> String)
-> ([D3Node] -> String -> String)
-> Show D3Node
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [D3Node] -> String -> String
$cshowList :: [D3Node] -> String -> String
show :: D3Node -> String
$cshow :: D3Node -> String
showsPrec :: Int -> D3Node -> String -> String
$cshowsPrec :: Int -> D3Node -> String -> String
Show)

data D3Link = D3Link
  { D3Link -> Int
source :: Int,
    D3Link -> Int
target :: Int
  }
  deriving ((forall x. D3Link -> Rep D3Link x)
-> (forall x. Rep D3Link x -> D3Link) -> Generic D3Link
forall x. Rep D3Link x -> D3Link
forall x. D3Link -> Rep D3Link x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep D3Link x -> D3Link
$cfrom :: forall x. D3Link -> Rep D3Link x
Generic, Int -> D3Link -> String -> String
[D3Link] -> String -> String
D3Link -> String
(Int -> D3Link -> String -> String)
-> (D3Link -> String)
-> ([D3Link] -> String -> String)
-> Show D3Link
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [D3Link] -> String -> String
$cshowList :: [D3Link] -> String -> String
show :: D3Link -> String
$cshow :: D3Link -> String
showsPrec :: Int -> D3Link -> String -> String
$cshowsPrec :: Int -> D3Link -> String -> String
Show)

data D3Graph = D3Graph
  { D3Graph -> [D3Node]
nodes :: [D3Node],
    D3Graph -> [D3Link]
links :: [D3Link]
  }
  deriving ((forall x. D3Graph -> Rep D3Graph x)
-> (forall x. Rep D3Graph x -> D3Graph) -> Generic D3Graph
forall x. Rep D3Graph x -> D3Graph
forall x. D3Graph -> Rep D3Graph x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep D3Graph x -> D3Graph
$cfrom :: forall x. D3Graph -> Rep D3Graph x
Generic, Int -> D3Graph -> String -> String
[D3Graph] -> String -> String
D3Graph -> String
(Int -> D3Graph -> String -> String)
-> (D3Graph -> String)
-> ([D3Graph] -> String -> String)
-> Show D3Graph
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [D3Graph] -> String -> String
$cshowList :: [D3Graph] -> String -> String
show :: D3Graph -> String
$cshow :: D3Graph -> String
showsPrec :: Int -> D3Graph -> String -> String
$cshowsPrec :: Int -> D3Graph -> String -> String
Show)

instance Data.Aeson.ToJSON D3Node

instance Data.Aeson.ToJSON D3Link

instance Data.Aeson.ToJSON D3Graph

vertexLink :: Context -> VertexName -> Html () -> Html ()
vertexLink :: Context -> VertexName -> HtmlT Identity () -> HtmlT Identity ()
vertexLink Context
ctx VertexName
name = Text -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
hxNavLink Text
ref Maybe Text
forall a. Maybe a
Nothing
  where
    ref :: Text
ref =
      Text -> [Text] -> Text
Text.intercalate
        Text
"/"
        [ Context -> Text
baseUrl Context
ctx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"object",
          VertexType -> Text
vertexTypeName (VertexName -> VertexType
forall source target. From source target => source -> target
from VertexName
name),
          VertexName -> Text
forall source target. From source target => source -> target
from VertexName
name
        ]

tenantBaseLink :: BasePath -> TenantName -> Html ()
tenantBaseLink :: BasePath -> TenantName -> HtmlT Identity ()
tenantBaseLink BasePath
rootURL TenantName
tenant =
  (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ Text
"ml-2 px-1 bg-slate-300 rounded" do
    Text -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
hxNavLink (BasePath -> TenantName -> Text
tenantUrl BasePath
rootURL TenantName
tenant) Maybe Text
forall a. Maybe a
Nothing (Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (forall target source. From source target => source -> target
into @Text TenantName
tenant))

tenantLink :: BasePath -> VertexName -> TenantName -> Html ()
tenantLink :: BasePath -> VertexName -> TenantName -> HtmlT Identity ()
tenantLink BasePath
rootURL VertexName
name TenantName
tenant =
  (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ Text
"ml-2 px-1 bg-slate-300 rounded" do
    Context -> VertexName -> HtmlT Identity () -> HtmlT Identity ()
vertexLink (BasePath -> Scope -> Context
Context BasePath
rootURL (Set TenantName -> Scope
Scoped (Set TenantName -> Scope) -> Set TenantName -> Scope
forall a b. (a -> b) -> a -> b
$ TenantName -> Set TenantName
forall a. a -> Set a
Set.singleton TenantName
tenant)) VertexName
name (Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (forall target source. From source target => source -> target
into @Text TenantName
tenant))

vertexName :: VertexName -> Html ()
vertexName :: VertexName -> HtmlT Identity ()
vertexName VertexName
n = do
  VertexType -> HtmlT Identity ()
vertexTypeIcon (VertexName -> VertexType
forall source target. From source target => source -> target
from VertexName
n)
  Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (forall target source. From source target => source -> target
into @Text VertexName
n)

-- | Return the search result
searchResults :: Context -> Text -> Map VertexName (Set TenantName) -> (Maybe Text, Html ())
searchResults :: Context
-> Text
-> Map VertexName (Set TenantName)
-> (Maybe Text, HtmlT Identity ())
searchResults Context
ctx (Text -> Text
Text.strip -> Text
query) Map VertexName (Set TenantName)
names
  | Text -> Bool
Text.null Text
query = (Maybe Text
forall a. Maybe a
Nothing, () -> HtmlT Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  | Bool
otherwise = case ((VertexName, Set TenantName)
 -> Maybe (VertexName, Set TenantName))
-> [(VertexName, Set TenantName)] -> [(VertexName, Set TenantName)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (VertexName, Set TenantName) -> Maybe (VertexName, Set TenantName)
matchQuery (Map VertexName (Set TenantName) -> [(VertexName, Set TenantName)]
forall k a. Map k a -> [(k, a)]
Map.toList Map VertexName (Set TenantName)
names) of
      [] -> String
-> (Maybe Text, HtmlT Identity ())
-> (Maybe Text, HtmlT Identity ())
forall a. String -> a -> a
trace (Text -> String
forall source target. From source target => source -> target
from (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Map VertexName (Set TenantName) -> Text
forall a. Show a => a -> Text
pShowNoColor Map VertexName (Set TenantName)
names) (Maybe Text
forall a. Maybe a
Nothing, HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ HtmlT Identity ()
"no results :(")
      [(VertexName, Set TenantName)]
results -> (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
query, HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
ul_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ ((VertexName, Set TenantName) -> HtmlT Identity ())
-> [(VertexName, Set TenantName)] -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (VertexName, Set TenantName) -> HtmlT Identity ()
renderResult [(VertexName, Set TenantName)]
results)
  where
    renderResult :: (VertexName, Set TenantName) -> Html ()
    renderResult :: (VertexName, Set TenantName) -> HtmlT Identity ()
renderResult (VertexName
name, Set TenantName
tenants) =
      (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
li_ Text
"bg-white/75" (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
        Context -> VertexName -> HtmlT Identity () -> HtmlT Identity ()
vertexLink Context
ctx VertexName
name (VertexName -> HtmlT Identity ()
vertexName VertexName
name)
        case Context
ctx.scope of
          -- When scoped, don't display tenant badge
          Scoped Set TenantName
_ -> () -> HtmlT Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Scope
UnScoped -> (TenantName -> HtmlT Identity ())
-> Set TenantName -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BasePath -> VertexName -> TenantName -> HtmlT Identity ()
tenantLink Context
ctx.rootURL VertexName
name) Set TenantName
tenants

    matchTenant :: Set TenantName -> Maybe (Set TenantName)
matchTenant Set TenantName
vertexTenants = case Context
ctx.scope of
      -- The provided context match the vertex, keep the context
      Scoped Set TenantName
tenants | Set TenantName
tenants Set TenantName -> Set TenantName -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set TenantName
vertexTenants -> Set TenantName -> Maybe (Set TenantName)
forall a. a -> Maybe a
Just Set TenantName
tenants
      -- The provided context does not match
      Scoped Set TenantName
_ -> Maybe (Set TenantName)
forall a. Maybe a
Nothing
      -- No context was provided, keep the vertex tenants
      Scope
UnScoped -> Set TenantName -> Maybe (Set TenantName)
forall a. a -> Maybe a
Just Set TenantName
vertexTenants
    matchQuery :: (VertexName, Set TenantName) -> Maybe (VertexName, Set TenantName)
    matchQuery :: (VertexName, Set TenantName) -> Maybe (VertexName, Set TenantName)
matchQuery (VertexName
name, Set TenantName
tenants) = case (Text
query Text -> Text -> Bool
`Text.isInfixOf` VertexName -> Text
forall source target. From source target => source -> target
from VertexName
name, Set TenantName -> Maybe (Set TenantName)
matchTenant Set TenantName
tenants) of
      (Bool
True, Just Set TenantName
matchingTenants) -> (VertexName, Set TenantName) -> Maybe (VertexName, Set TenantName)
forall a. a -> Maybe a
Just (VertexName
name, Set TenantName
matchingTenants)
      (Bool, Maybe (Set TenantName))
_ -> Maybe (VertexName, Set TenantName)
forall a. Maybe a
Nothing

newtype SearchForm = SearchForm {SearchForm -> Text
query :: Text} deriving (SearchForm -> SearchForm -> Bool
(SearchForm -> SearchForm -> Bool)
-> (SearchForm -> SearchForm -> Bool) -> Eq SearchForm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SearchForm -> SearchForm -> Bool
$c/= :: SearchForm -> SearchForm -> Bool
== :: SearchForm -> SearchForm -> Bool
$c== :: SearchForm -> SearchForm -> Bool
Eq, Int -> SearchForm -> String -> String
[SearchForm] -> String -> String
SearchForm -> String
(Int -> SearchForm -> String -> String)
-> (SearchForm -> String)
-> ([SearchForm] -> String -> String)
-> Show SearchForm
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SearchForm] -> String -> String
$cshowList :: [SearchForm] -> String -> String
show :: SearchForm -> String
$cshow :: SearchForm -> String
showsPrec :: Int -> SearchForm -> String -> String
$cshowsPrec :: Int -> SearchForm -> String -> String
Show, (forall x. SearchForm -> Rep SearchForm x)
-> (forall x. Rep SearchForm x -> SearchForm) -> Generic SearchForm
forall x. Rep SearchForm x -> SearchForm
forall x. SearchForm -> Rep SearchForm x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SearchForm x -> SearchForm
$cfrom :: forall x. SearchForm -> Rep SearchForm x
Generic)

instance FromForm SearchForm

with' :: With a => a -> Text -> a
with' :: forall a. With a => a -> Text -> a
with' a
x Text
n = a -> [Attribute] -> a
forall a. With a => a -> [Attribute] -> a
with a
x [Text -> Attribute
class_ Text
n]

searchComponent :: Context -> Maybe Text -> Html () -> Html ()
searchComponent :: Context -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
searchComponent Context
ctx Maybe Text
queryM HtmlT Identity ()
result = do
  (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ Text
"grid p-4 place-content-center" do
    [Attribute] -> HtmlT Identity ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
input_
      [ Text -> Attribute
class_ Text
"form-control",
        Text -> Attribute
size_ Text
"42",
        Text -> Attribute
type_ Text
"search",
        Text -> Attribute
name_ Text
"query",
        Text -> Attribute
hxPost (Context -> Text
baseUrl Context
ctx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"search_results"),
        Text -> Attribute
hxTrigger Text
"keyup changed delay:500ms, search",
        Text -> Attribute
hxTarget Text
"#search-results",
        Attribute
attr
      ]
    (HtmlT Identity () -> HtmlT Identity ())
-> [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> [Attribute] -> a
with HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
id_ Text
"search-results"] HtmlT Identity ()
result
  where
    attr :: Attribute
attr = case Maybe Text
queryM of
      Just Text
q -> Text -> Attribute
value_ Text
q
      Maybe Text
Nothing -> Text -> Attribute
placeholder_ Text
"Begin Typing To Search Config..."

hxTrigger, hxTarget, hxGet, hxPost, hxIndicator :: Text -> Attribute
hxTrigger :: Text -> Attribute
hxTrigger = Text -> Text -> Attribute
makeAttribute Text
"hx-trigger"
hxTarget :: Text -> Attribute
hxTarget = Text -> Text -> Attribute
makeAttribute Text
"hx-target"
hxGet :: Text -> Attribute
hxGet = Text -> Text -> Attribute
makeAttribute Text
"hx-get"
hxPost :: Text -> Attribute
hxPost = Text -> Text -> Attribute
makeAttribute Text
"hx-post"
hxIndicator :: Text -> Attribute
hxIndicator = Text -> Text -> Attribute
makeAttribute Text
"hx-indicator"

hxPushUrl :: Attribute
hxPushUrl :: Attribute
hxPushUrl = Text -> Text -> Attribute
makeAttribute Text
"hx-push-url" Text
"true"

infoComponent :: Context -> Analysis -> Html ()
infoComponent :: Context -> Analysis -> HtmlT Identity ()
infoComponent Context
ctx Analysis
analysis = do
  (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ Text
"grid p-4 place-content-center" do
    (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ Text
"font-semibold pb-3" do
      HtmlT Identity ()
"Config details"
      (TenantName -> HtmlT Identity ())
-> Set TenantName -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BasePath -> TenantName -> HtmlT Identity ()
tenantBaseLink Context
ctx.rootURL) Set TenantName
scope
    (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ Text
"pb-3" do
      Bool -> HtmlT Identity () -> HtmlT Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set TenantName -> Bool
forall a. Set a -> Bool
Set.null Set TenantName
otherTenants) (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
        HtmlT Identity ()
"Available tenants:"
        (TenantName -> HtmlT Identity ())
-> Set TenantName -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BasePath -> TenantName -> HtmlT Identity ()
tenantBaseLink Context
ctx.rootURL) Set TenantName
otherTenants
    (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ Text
"not-prose bg-slate-50 border rounded-xl w-80" do
      (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
table_ Text
"table-auto border-collapse w-80" do
        HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
thead_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
tr_ Text
"border-b text-left" (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ (HtmlT Identity () -> HtmlT Identity ())
-> [HtmlT Identity ()] -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
th_ Text
"p-1") [HtmlT Identity ()
"Object", HtmlT Identity ()
"Count"]
        (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
tbody_ Text
"bg-white" do
          Text -> ConfigMap JobName Job -> HtmlT Identity ()
forall a b. Text -> ConfigMap a b -> HtmlT Identity ()
objectCounts Text
"jobs" Config
config.jobs
          Text -> ConfigMap NodesetName Nodeset -> HtmlT Identity ()
forall a b. Text -> ConfigMap a b -> HtmlT Identity ()
objectCounts Text
"nodesets" Config
config.nodesets
          Text -> ConfigMap PipelineName Pipeline -> HtmlT Identity ()
forall a b. Text -> ConfigMap a b -> HtmlT Identity ()
objectCounts Text
"pipelines" Config
config.pipelines
  where
    scope :: Set TenantName
scope = case Context
ctx.scope of
      Scoped Set TenantName
tenants -> Set TenantName
tenants
      Scope
UnScoped -> Set TenantName
forall a. Monoid a => a
mempty
    otherTenants :: Set TenantName
otherTenants = Set TenantName -> Set TenantName -> Set TenantName
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Analysis
analysis.config.tenants Set TenantName
scope
    config :: Config
config = Analysis
analysis.config
    objectCounts :: Text -> Zuul.ConfigLoader.ConfigMap a b -> Html ()
    objectCounts :: forall a b. Text -> ConfigMap a b -> HtmlT Identity ()
objectCounts Text
n ConfigMap a b
m = do
      (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
tr_ Text
"border-b" do
        (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
td_ Text
"p-1" (Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
n)
        (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
td_ Text
"p-1" (String -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (String -> HtmlT Identity ()) -> String -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ConfigMap a b -> Int
forall k a. Map k a -> Int
Map.size (ConfigMap a b -> Int) -> ConfigMap a b -> Int
forall a b. (a -> b) -> a -> b
$ (a -> [(ConfigLoc, b)] -> Bool) -> ConfigMap a b -> ConfigMap a b
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey a -> [(ConfigLoc, b)] -> Bool
forall a b. a -> [(ConfigLoc, b)] -> Bool
forTenants ConfigMap a b
m)
    forTenants :: a -> [(ConfigLoc, b)] -> Bool
    forTenants :: forall a b. a -> [(ConfigLoc, b)] -> Bool
forTenants a
_ [(ConfigLoc, b)]
xs = case Context
ctx.scope of
      Scoped Set TenantName
tenants -> ((ConfigLoc, b) -> Bool) -> [(ConfigLoc, b)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Set TenantName -> ConfigLoc -> Bool
keepTenants Set TenantName
tenants (ConfigLoc -> Bool)
-> ((ConfigLoc, b) -> ConfigLoc) -> (ConfigLoc, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfigLoc, b) -> ConfigLoc
forall a b. (a, b) -> a
fst) [(ConfigLoc, b)]
xs
      Scope
UnScoped -> Bool
True
    keepTenants :: Set TenantName -> ConfigLoc -> Bool
    keepTenants :: Set TenantName -> ConfigLoc -> Bool
keepTenants Set TenantName
tenants ConfigLoc
loc = Set TenantName
tenants Set TenantName -> Set TenantName -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` ConfigLoc
loc.tenants

debugComponent :: Analysis -> Html ()
debugComponent :: Analysis -> HtmlT Identity ()
debugComponent Analysis
analysis = do
  (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
h2_ Text
"font-bold" HtmlT Identity ()
"Debug Info"
  Bool -> HtmlT Identity () -> HtmlT Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ConfigError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Analysis
analysis.config.configErrors) do
    (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ Text
"font-semibold py-3" HtmlT Identity ()
"Config Error"
    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
ul_ do
      (ConfigError -> HtmlT Identity ())
-> [ConfigError] -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
li_ (HtmlT Identity () -> HtmlT Identity ())
-> (ConfigError -> HtmlT Identity ())
-> ConfigError
-> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (String -> HtmlT Identity ())
-> (ConfigError -> String) -> ConfigError -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
512 (String -> String)
-> (ConfigError -> String) -> ConfigError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigError -> String
forall a. Show a => a -> String
show) Analysis
analysis.config.configErrors
  Bool -> HtmlT Identity () -> HtmlT Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Analysis
analysis.graphErrors) do
    (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ Text
"font-semibold py-3" HtmlT Identity ()
"Graph Error"
    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
ul_ do
      (String -> HtmlT Identity ()) -> [String] -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
li_ (HtmlT Identity () -> HtmlT Identity ())
-> (String -> HtmlT Identity ()) -> String -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (String -> HtmlT Identity ())
-> (String -> String) -> String -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
512) Analysis
analysis.graphErrors

locLink :: ConfigLoc -> Html ()
locLink :: ConfigLoc -> HtmlT Identity ()
locLink ConfigLoc
loc =
  (HtmlT Identity () -> HtmlT Identity ())
-> [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> [Attribute] -> a
with HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ Text
url, Text -> Attribute
class_ Text
"no-underline hover:text-slate-500 p-1 text-slate-700"] do
    Text -> HtmlT Identity ()
mkIcon Text
"ri-link"
    Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
locPath
  where
    -- TODO: render valid link based on config connection
    url :: Text
url = ConfigLoc -> Text
configLocUrl ConfigLoc
loc
    locPath :: Text
locPath = Int -> Text -> Text
Text.drop Int
8 Text
url

objectInfo :: Context -> NonEmpty Vertex -> Analysis -> Html ()
objectInfo :: Context -> NonEmpty Vertex -> Analysis -> HtmlT Identity ()
objectInfo Context
ctx NonEmpty Vertex
vertices Analysis
analysis = do
  HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
h2_ do
    VertexType -> HtmlT Identity ()
vertexTypeIcon (VertexName -> VertexType
forall source target. From source target => source -> target
from Vertex
vertex.name)
    Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (VertexName -> Text
forall source target. From source target => source -> target
from Vertex
vertex.name :: Text)
  HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
ul_ do
    (ConfigLoc -> HtmlT Identity ())
-> [ConfigLoc] -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ConfigLoc -> HtmlT Identity ()
forall {result}.
Term (HtmlT Identity ()) result =>
ConfigLoc -> result
renderConfigLink [ConfigLoc]
configComponents
  (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ Text
"grid grid-cols-2 gap-1 m-4" do
    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ do
      Text -> HtmlT Identity ()
title Text
"Dependents"
      (Tree VertexName -> HtmlT Identity ())
-> [Tree VertexName] -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Int -> Tree VertexName -> HtmlT Identity ()
renderTree Int
0) [Tree VertexName]
dependents
    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ do
      Text -> HtmlT Identity ()
title Text
"Dependencies"
      (Tree VertexName -> HtmlT Identity ())
-> [Tree VertexName] -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Int -> Tree VertexName -> HtmlT Identity ()
renderTree Int
0) [Tree VertexName]
dependencies
  where
    renderConfigLink :: ConfigLoc -> result
renderConfigLink ConfigLoc
loc =
      HtmlT Identity () -> result
forall arg result. Term arg result => arg -> result
li_ do
        ConfigLoc -> HtmlT Identity ()
locLink ConfigLoc
loc
        (TenantName -> HtmlT Identity ())
-> Set TenantName -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BasePath -> VertexName -> TenantName -> HtmlT Identity ()
tenantLink Context
ctx.rootURL Vertex
vertex.name) ConfigLoc
loc.tenants

    vertex :: Vertex
vertex = NonEmpty Vertex -> Vertex
forall a. NonEmpty a -> a
NE.head NonEmpty Vertex
vertices
    forTenant :: ConfigLoc -> Bool
    forTenant :: ConfigLoc -> Bool
forTenant ConfigLoc
loc = case Context
ctx.scope of
      Scoped Set TenantName
tenants -> Set TenantName
tenants Set TenantName -> Set TenantName -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` ConfigLoc
loc.tenants
      Scope
UnScoped -> Bool
True

    getLocs :: Maybe [(ConfigLoc, a)] -> [ConfigLoc]
    getLocs :: forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs = (ConfigLoc -> Bool) -> [ConfigLoc] -> [ConfigLoc]
forall a. (a -> Bool) -> [a] -> [a]
filter ConfigLoc -> Bool
forTenant ([ConfigLoc] -> [ConfigLoc])
-> (Maybe [(ConfigLoc, a)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, a)]
-> [ConfigLoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ConfigLoc]
-> ([(ConfigLoc, a)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, a)]
-> [ConfigLoc]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((ConfigLoc, a) -> ConfigLoc) -> [(ConfigLoc, a)] -> [ConfigLoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ConfigLoc, a) -> ConfigLoc
forall a b. (a, b) -> a
fst)
    configComponents :: [ConfigLoc]
    configComponents :: [ConfigLoc]
configComponents = case Vertex
vertex.name of
      VAbstractJob JobName
name -> Maybe [(ConfigLoc, Job)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, Job)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, Job)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ JobName -> ConfigMap JobName Job -> Maybe [(ConfigLoc, Job)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup JobName
name Analysis
analysis.config.jobs
      VJob JobName
name -> Maybe [(ConfigLoc, Job)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, Job)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, Job)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ JobName -> ConfigMap JobName Job -> Maybe [(ConfigLoc, Job)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup JobName
name Analysis
analysis.config.jobs
      VSecret SecretName
name -> Maybe [(ConfigLoc, SecretName)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, SecretName)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, SecretName)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ SecretName
-> Map SecretName [(ConfigLoc, SecretName)]
-> Maybe [(ConfigLoc, SecretName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SecretName
name Analysis
analysis.config.secrets
      VSemaphore SemaphoreName
name -> Maybe [(ConfigLoc, SemaphoreName)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, SemaphoreName)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, SemaphoreName)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ SemaphoreName
-> Map SemaphoreName [(ConfigLoc, SemaphoreName)]
-> Maybe [(ConfigLoc, SemaphoreName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SemaphoreName
name Analysis
analysis.config.semaphores
      VQueue QueueName
name -> Maybe [(ConfigLoc, QueueName)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, QueueName)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, QueueName)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ QueueName
-> Map QueueName [(ConfigLoc, QueueName)]
-> Maybe [(ConfigLoc, QueueName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QueueName
name Analysis
analysis.config.queues
      VProject CanonicalProjectName
name -> Maybe [(ConfigLoc, Project)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, Project)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, Project)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ CanonicalProjectName
-> Map CanonicalProjectName [(ConfigLoc, Project)]
-> Maybe [(ConfigLoc, Project)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CanonicalProjectName
name Analysis
analysis.config.projects
      VProjectRegex ProjectRegex
name -> Maybe [(ConfigLoc, Project)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, Project)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, Project)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ ProjectRegex
-> Map ProjectRegex [(ConfigLoc, Project)]
-> Maybe [(ConfigLoc, Project)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProjectRegex
name Analysis
analysis.config.projectRegexs
      VProjectTemplate ProjectTemplateName
name -> Maybe [(ConfigLoc, ProjectTemplate)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, ProjectTemplate)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, ProjectTemplate)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ ProjectTemplateName
-> Map ProjectTemplateName [(ConfigLoc, ProjectTemplate)]
-> Maybe [(ConfigLoc, ProjectTemplate)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProjectTemplateName
name Analysis
analysis.config.projectTemplates
      VPipeline PipelineName
name -> Maybe [(ConfigLoc, Pipeline)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, Pipeline)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, Pipeline)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ PipelineName
-> ConfigMap PipelineName Pipeline -> Maybe [(ConfigLoc, Pipeline)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PipelineName
name Analysis
analysis.config.pipelines
      VNodeset NodesetName
name -> Maybe [(ConfigLoc, Nodeset)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, Nodeset)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, Nodeset)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ NodesetName
-> ConfigMap NodesetName Nodeset -> Maybe [(ConfigLoc, Nodeset)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodesetName
name Analysis
analysis.config.nodesets
      VNodeLabel NodeLabelName
name -> Maybe [(ConfigLoc, NodeLabelName)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, NodeLabelName)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, NodeLabelName)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ NodeLabelName
-> Map NodeLabelName [(ConfigLoc, NodeLabelName)]
-> Maybe [(ConfigLoc, NodeLabelName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeLabelName
name Analysis
analysis.config.nodeLabels
      VProjectPipeline PipelineName
_ CanonicalProjectName
name -> Maybe [(ConfigLoc, Project)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, Project)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, Project)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ CanonicalProjectName
-> Map CanonicalProjectName [(ConfigLoc, Project)]
-> Maybe [(ConfigLoc, Project)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CanonicalProjectName
name Analysis
analysis.config.projects
      VRegexPipeline PipelineName
_ ProjectRegex
name -> Maybe [(ConfigLoc, Project)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, Project)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, Project)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ ProjectRegex
-> Map ProjectRegex [(ConfigLoc, Project)]
-> Maybe [(ConfigLoc, Project)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProjectRegex
name Analysis
analysis.config.projectRegexs
      VTemplatePipeline PipelineName
_ ProjectTemplateName
name -> Maybe [(ConfigLoc, ProjectTemplate)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, ProjectTemplate)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, ProjectTemplate)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ ProjectTemplateName
-> Map ProjectTemplateName [(ConfigLoc, ProjectTemplate)]
-> Maybe [(ConfigLoc, ProjectTemplate)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProjectTemplateName
name Analysis
analysis.config.projectTemplates
      VTrigger ConnectionName
name -> Maybe [(ConfigLoc, ConnectionName)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, ConnectionName)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, ConnectionName)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ ConnectionName
-> Map ConnectionName [(ConfigLoc, ConnectionName)]
-> Maybe [(ConfigLoc, ConnectionName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConnectionName
name Analysis
analysis.config.triggers
      VReporter ConnectionName
name -> Maybe [(ConfigLoc, ConnectionName)] -> [ConfigLoc]
forall a. Maybe [(ConfigLoc, a)] -> [ConfigLoc]
getLocs (Maybe [(ConfigLoc, ConnectionName)] -> [ConfigLoc])
-> Maybe [(ConfigLoc, ConnectionName)] -> [ConfigLoc]
forall a b. (a -> b) -> a -> b
$ ConnectionName
-> Map ConnectionName [(ConfigLoc, ConnectionName)]
-> Maybe [(ConfigLoc, ConnectionName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ConnectionName
name Analysis
analysis.config.reporters
    dependencies :: [Tree VertexName]
dependencies = ConfigGraph -> [Tree VertexName]
getForest Analysis
analysis.dependencyGraph
    dependents :: [Tree VertexName]
dependents = ConfigGraph -> [Tree VertexName]
getForest Analysis
analysis.dependentGraph
    getForest :: ConfigGraph -> [Tree VertexName]
getForest = Maybe (Set TenantName)
-> NonEmpty Vertex -> ConfigGraph -> [Tree VertexName]
ZuulWeeder.Graph.findReachableForest Maybe (Set TenantName)
tenantsM NonEmpty Vertex
vertices
      where
        tenantsM :: Maybe (Set TenantName)
tenantsM = case Context
ctx.scope of
          Scope
UnScoped -> Maybe (Set TenantName)
forall a. Maybe a
Nothing
          Scoped Set TenantName
xs -> Set TenantName -> Maybe (Set TenantName)
forall a. a -> Maybe a
Just Set TenantName
xs

    renderTree :: Int -> Tree VertexName -> Html ()
    renderTree :: Int -> Tree VertexName -> HtmlT Identity ()
renderTree Int
depth (Node VertexName
root [Tree VertexName]
childs) = do
      let listStyle :: Text
listStyle
            | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Text
"pl-2 border-solid rounded border-l-2 border-slate-500"
            | Bool
otherwise = Text
""
      (HtmlT Identity () -> HtmlT Identity ())
-> Text -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> Text -> a
with' HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
ul_ Text
listStyle do
        HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
li_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Context -> VertexName -> HtmlT Identity () -> HtmlT Identity ()
vertexLink Context
ctx VertexName
root (VertexName -> HtmlT Identity ()
vertexName VertexName
root)
        (Tree VertexName -> HtmlT Identity ())
-> [Tree VertexName] -> HtmlT Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Int -> Tree VertexName -> HtmlT Identity ()
renderTree (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [Tree VertexName]
childs

vertexScope :: Scope -> Set Vertex -> [Vertex]
vertexScope :: Scope -> Set Vertex -> [Vertex]
vertexScope Scope
scope Set Vertex
vertices = Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList (Set Vertex -> [Vertex]) -> Set Vertex -> [Vertex]
forall a b. (a -> b) -> a -> b
$ case Scope
scope of
  Scope
UnScoped -> Set Vertex
vertices
  Scoped Set TenantName
tenants -> (Vertex -> Bool) -> Set Vertex -> Set Vertex
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Set TenantName -> Vertex -> Bool
forall {a} {r}.
(Ord a, HasField "tenants" r (Set a)) =>
Set a -> r -> Bool
matchTenant Set TenantName
tenants) Set Vertex
vertices
  where
    matchTenant :: Set a -> r -> Bool
matchTenant Set a
tenants r
v = Set a
tenants Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` r
v.tenants

newtype VertexTypeUrl = VTU (Text -> VertexName)

data DecodeProject = DecodeCanonical | DecodeTemplate | DecodeRegex

instance FromHttpApiData VertexTypeUrl where
  parseUrlPiece :: Text -> Either Text VertexTypeUrl
parseUrlPiece Text
txt = VertexTypeUrl -> Either Text VertexTypeUrl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VertexTypeUrl -> Either Text VertexTypeUrl)
-> ((Text -> VertexName) -> VertexTypeUrl)
-> (Text -> VertexName)
-> Either Text VertexTypeUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> VertexName) -> VertexTypeUrl
VTU ((Text -> VertexName) -> Either Text VertexTypeUrl)
-> (Text -> VertexName) -> Either Text VertexTypeUrl
forall a b. (a -> b) -> a -> b
$ case Text
txt of
    Text
"abstract-job" -> JobName -> VertexName
VAbstractJob (JobName -> VertexName) -> (Text -> JobName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JobName
JobName
    Text
"job" -> JobName -> VertexName
VJob (JobName -> VertexName) -> (Text -> JobName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JobName
JobName
    Text
"semaphore" -> SemaphoreName -> VertexName
VSemaphore (SemaphoreName -> VertexName)
-> (Text -> SemaphoreName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SemaphoreName
SemaphoreName
    Text
"secret" -> SecretName -> VertexName
VSecret (SecretName -> VertexName)
-> (Text -> SecretName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SecretName
SecretName
    Text
"nodeset" -> NodesetName -> VertexName
VNodeset (NodesetName -> VertexName)
-> (Text -> NodesetName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NodesetName
NodesetName
    Text
"label" -> NodeLabelName -> VertexName
VNodeLabel (NodeLabelName -> VertexName)
-> (Text -> NodeLabelName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NodeLabelName
NodeLabelName
    Text
"queue" -> QueueName -> VertexName
VQueue (QueueName -> VertexName)
-> (Text -> QueueName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> QueueName
QueueName
    Text
"project" -> CanonicalProjectName -> VertexName
VProject (CanonicalProjectName -> VertexName)
-> (Text -> CanonicalProjectName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CanonicalProjectName
decodeCanonical
    Text
"project-regex" -> ProjectRegex -> VertexName
VProjectRegex (ProjectRegex -> VertexName)
-> (Text -> ProjectRegex) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ProjectRegex
ProjectRegex
    Text
"project-template" -> ProjectTemplateName -> VertexName
VProjectTemplate (ProjectTemplateName -> VertexName)
-> (Text -> ProjectTemplateName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ProjectTemplateName
ProjectTemplateName
    Text
"pipeline" -> PipelineName -> VertexName
VPipeline (PipelineName -> VertexName)
-> (Text -> PipelineName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PipelineName
PipelineName
    Text
"project-pipeline" -> DecodeProject -> Text -> VertexName
splitPipeline DecodeProject
DecodeCanonical
    Text
"regex-pipeline" -> DecodeProject -> Text -> VertexName
splitPipeline DecodeProject
DecodeRegex
    Text
"template-pipeline" -> DecodeProject -> Text -> VertexName
splitPipeline DecodeProject
DecodeTemplate
    Text
"trigger" -> ConnectionName -> VertexName
VTrigger (ConnectionName -> VertexName)
-> (Text -> ConnectionName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ConnectionName
ConnectionName
    Text
"reporter" -> ConnectionName -> VertexName
VReporter (ConnectionName -> VertexName)
-> (Text -> ConnectionName) -> Text -> VertexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ConnectionName
ConnectionName
    Text
_ -> String -> Text -> VertexName
forall a. HasCallStack => String -> a
error (String -> Text -> VertexName) -> String -> Text -> VertexName
forall a b. (a -> b) -> a -> b
$ String
"Unknown obj type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall source target. From source target => source -> target
from Text
txt
    where
      -- Assume the provider name is the first element of a '/' separated path
      decodeCanonical :: Text -> CanonicalProjectName
      decodeCanonical :: Text -> CanonicalProjectName
decodeCanonical Text
t =
        let (Text -> ProviderName
ProviderName -> ProviderName
provider, Text -> Text
Text.tail -> Text
name) = (Char -> Bool) -> Text -> (Text, Text)
Text.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
t
         in ProviderName -> ProjectName -> CanonicalProjectName
CanonicalProjectName ProviderName
provider (Text -> ProjectName
ProjectName Text
name)

      -- Project/Template Pipeline name is separated by a ':'
      splitPipeline :: DecodeProject -> Text -> VertexName
      splitPipeline :: DecodeProject -> Text -> VertexName
splitPipeline DecodeProject
dp Text
t =
        let (Text -> PipelineName
PipelineName -> PipelineName
pipeline, Text -> Text
Text.tail -> Text
name) = (Char -> Bool) -> Text -> (Text, Text)
Text.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') Text
t
         in case DecodeProject
dp of
              DecodeProject
DecodeCanonical -> PipelineName -> CanonicalProjectName -> VertexName
VProjectPipeline PipelineName
pipeline (Text -> CanonicalProjectName
decodeCanonical Text
name)
              DecodeProject
DecodeTemplate -> PipelineName -> ProjectTemplateName -> VertexName
VTemplatePipeline PipelineName
pipeline (Text -> ProjectTemplateName
ProjectTemplateName Text
name)
              DecodeProject
DecodeRegex -> PipelineName -> ProjectRegex -> VertexName
VRegexPipeline PipelineName
pipeline (Text -> ProjectRegex
ProjectRegex Text
name)

newtype VertexNameUrl = VNU {VertexNameUrl -> Text
getVNU :: Text}

instance FromHttpApiData VertexNameUrl where
  parseUrlPiece :: Text -> Either Text VertexNameUrl
parseUrlPiece = VertexNameUrl -> Either Text VertexNameUrl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VertexNameUrl -> Either Text VertexNameUrl)
-> (Text -> VertexNameUrl) -> Text -> Either Text VertexNameUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> VertexNameUrl
VNU

newtype TenantsUrl = TNU {TenantsUrl -> Set TenantName
getTNU :: Set TenantName}

instance FromHttpApiData TenantsUrl where
  parseUrlPiece :: Text -> Either Text TenantsUrl
parseUrlPiece Text
piece = TenantsUrl -> Either Text TenantsUrl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TenantsUrl -> Either Text TenantsUrl)
-> (Set TenantName -> TenantsUrl)
-> Set TenantName
-> Either Text TenantsUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TenantName -> TenantsUrl
TNU (Set TenantName -> Either Text TenantsUrl)
-> Set TenantName -> Either Text TenantsUrl
forall a b. (a -> b) -> a -> b
$ [TenantName] -> Set TenantName
forall a. Ord a => [a] -> Set a
Set.fromList (Text -> TenantName
TenantName (Text -> TenantName) -> [Text] -> [TenantName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') Text
piece)

type GetRequest = Header "HX-Request" Text :> Get '[HTML] (Html ())

-- | The zuul-weeder base HTTP API.
-- The HX-Request header is set by inline navigation, when it is missing, the full body is returned.
type BaseAPI =
  GetRequest
    :<|> "about" :> GetRequest
    :<|> "search" :> GetRequest
    :<|> "info" :> GetRequest
    :<|> "debug" :> GetRequest
    :<|> "export" :> Get '[JSON] Config
    :<|> "object" :> Capture "type" VertexTypeUrl :> CaptureAll "name" VertexNameUrl :> GetRequest
    :<|> "search_results" :> SearchPath
    :<|> "search" :> Capture "query" Text :> Get '[HTML] (Html ())
    :<|> "data.json" :> Get '[JSON] D3Graph

type SearchPath =
  ReqBody '[FormUrlEncoded] SearchForm
    :> Post '[HTML] (Headers '[Header "HX-Push" Text] (Html ()))

type TenantAPI = "tenant" :> Capture "tenant" TenantsUrl :> BaseAPI

type StaticAPI = "dists" :> Raw

type API = StaticAPI :<|> BaseAPI :<|> TenantAPI

-- | Creates the Web Application Interface (wai).
app ::
  -- | An action to refresh the analysis
  IO Analysis ->
  -- | The base path of the interface, used to render absolute links
  BasePath ->
  -- | The location of the static files
  FilePath ->
  -- | The application to serve
  Application
app :: IO Analysis -> BasePath -> String -> Application
app IO Analysis
config BasePath
rootURL String
distPath = Proxy API -> Server API -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @API) Server API
rootServer
  where
    rootServer :: Server API
    rootServer :: Server API
rootServer =
      StaticSettings -> ServerT Raw Handler
forall (m :: * -> *). StaticSettings -> ServerT Raw m
Servant.Server.StaticFiles.serveDirectoryWith StaticSettings
staticSettings
        Tagged Handler Application
-> (((Maybe Text -> Handler (HtmlT Identity ()))
     :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
           :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                 :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                       :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                             :<|> (Handler Config
                                   :<|> ((VertexTypeUrl
                                          -> [VertexNameUrl]
                                          -> Maybe Text
                                          -> Handler (HtmlT Identity ()))
                                         :<|> ((SearchForm
                                                -> Handler
                                                     (Headers
                                                        '[Header "HX-Push" Text]
                                                        (HtmlT Identity ())))
                                               :<|> ((Text -> Handler (HtmlT Identity ()))
                                                     :<|> Handler D3Graph)))))))))
    :<|> (TenantsUrl
          -> (Maybe Text -> Handler (HtmlT Identity ()))
             :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                   :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                         :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                               :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                                     :<|> (Handler Config
                                           :<|> ((VertexTypeUrl
                                                  -> [VertexNameUrl]
                                                  -> Maybe Text
                                                  -> Handler (HtmlT Identity ()))
                                                 :<|> ((SearchForm
                                                        -> Handler
                                                             (Headers
                                                                '[Header "HX-Push" Text]
                                                                (HtmlT Identity ())))
                                                       :<|> ((Text -> Handler (HtmlT Identity ()))
                                                             :<|> Handler D3Graph))))))))))
-> Tagged Handler Application
   :<|> (((Maybe Text -> Handler (HtmlT Identity ()))
          :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                      :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                            :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                                  :<|> (Handler Config
                                        :<|> ((VertexTypeUrl
                                               -> [VertexNameUrl]
                                               -> Maybe Text
                                               -> Handler (HtmlT Identity ()))
                                              :<|> ((SearchForm
                                                     -> Handler
                                                          (Headers
                                                             '[Header "HX-Push" Text]
                                                             (HtmlT Identity ())))
                                                    :<|> ((Text -> Handler (HtmlT Identity ()))
                                                          :<|> Handler D3Graph)))))))))
         :<|> (TenantsUrl
               -> (Maybe Text -> Handler (HtmlT Identity ()))
                  :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                        :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                              :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                                    :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                                          :<|> (Handler Config
                                                :<|> ((VertexTypeUrl
                                                       -> [VertexNameUrl]
                                                       -> Maybe Text
                                                       -> Handler (HtmlT Identity ()))
                                                      :<|> ((SearchForm
                                                             -> Handler
                                                                  (Headers
                                                                     '[Header "HX-Push" Text]
                                                                     (HtmlT Identity ())))
                                                            :<|> ((Text
                                                                   -> Handler (HtmlT Identity ()))
                                                                  :<|> Handler D3Graph))))))))))
forall a b. a -> b -> a :<|> b
:<|> Context -> Server BaseAPI
server (BasePath -> Scope -> Context
Context BasePath
rootURL Scope
UnScoped)
        ((Maybe Text -> Handler (HtmlT Identity ()))
 :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
       :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
             :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                   :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                         :<|> (Handler Config
                               :<|> ((VertexTypeUrl
                                      -> [VertexNameUrl]
                                      -> Maybe Text
                                      -> Handler (HtmlT Identity ()))
                                     :<|> ((SearchForm
                                            -> Handler
                                                 (Headers
                                                    '[Header "HX-Push" Text] (HtmlT Identity ())))
                                           :<|> ((Text -> Handler (HtmlT Identity ()))
                                                 :<|> Handler D3Graph)))))))))
-> (TenantsUrl
    -> (Maybe Text -> Handler (HtmlT Identity ()))
       :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
             :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                   :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                         :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                               :<|> (Handler Config
                                     :<|> ((VertexTypeUrl
                                            -> [VertexNameUrl]
                                            -> Maybe Text
                                            -> Handler (HtmlT Identity ()))
                                           :<|> ((SearchForm
                                                  -> Handler
                                                       (Headers
                                                          '[Header "HX-Push" Text]
                                                          (HtmlT Identity ())))
                                                 :<|> ((Text -> Handler (HtmlT Identity ()))
                                                       :<|> Handler D3Graph)))))))))
-> ((Maybe Text -> Handler (HtmlT Identity ()))
    :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
          :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                      :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                            :<|> (Handler Config
                                  :<|> ((VertexTypeUrl
                                         -> [VertexNameUrl]
                                         -> Maybe Text
                                         -> Handler (HtmlT Identity ()))
                                        :<|> ((SearchForm
                                               -> Handler
                                                    (Headers
                                                       '[Header "HX-Push" Text]
                                                       (HtmlT Identity ())))
                                              :<|> ((Text -> Handler (HtmlT Identity ()))
                                                    :<|> Handler D3Graph)))))))))
   :<|> (TenantsUrl
         -> (Maybe Text -> Handler (HtmlT Identity ()))
            :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                  :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                        :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                              :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                                    :<|> (Handler Config
                                          :<|> ((VertexTypeUrl
                                                 -> [VertexNameUrl]
                                                 -> Maybe Text
                                                 -> Handler (HtmlT Identity ()))
                                                :<|> ((SearchForm
                                                       -> Handler
                                                            (Headers
                                                               '[Header "HX-Push" Text]
                                                               (HtmlT Identity ())))
                                                      :<|> ((Text -> Handler (HtmlT Identity ()))
                                                            :<|> Handler D3Graph)))))))))
forall a b. a -> b -> a :<|> b
:<|> Context
-> (Maybe Text -> Handler (HtmlT Identity ()))
   :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
         :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
               :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                     :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                           :<|> (Handler Config
                                 :<|> ((VertexTypeUrl
                                        -> [VertexNameUrl]
                                        -> Maybe Text
                                        -> Handler (HtmlT Identity ()))
                                       :<|> ((SearchForm
                                              -> Handler
                                                   (Headers
                                                      '[Header "HX-Push" Text] (HtmlT Identity ())))
                                             :<|> ((Text -> Handler (HtmlT Identity ()))
                                                   :<|> Handler D3Graph))))))))
Context -> Server BaseAPI
server (Context
 -> (Maybe Text -> Handler (HtmlT Identity ()))
    :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
          :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                      :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                            :<|> (Handler Config
                                  :<|> ((VertexTypeUrl
                                         -> [VertexNameUrl]
                                         -> Maybe Text
                                         -> Handler (HtmlT Identity ()))
                                        :<|> ((SearchForm
                                               -> Handler
                                                    (Headers
                                                       '[Header "HX-Push" Text]
                                                       (HtmlT Identity ())))
                                              :<|> ((Text -> Handler (HtmlT Identity ()))
                                                    :<|> Handler D3Graph)))))))))
-> (TenantsUrl -> Context)
-> TenantsUrl
-> (Maybe Text -> Handler (HtmlT Identity ()))
   :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
         :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
               :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                     :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                           :<|> (Handler Config
                                 :<|> ((VertexTypeUrl
                                        -> [VertexNameUrl]
                                        -> Maybe Text
                                        -> Handler (HtmlT Identity ()))
                                       :<|> ((SearchForm
                                              -> Handler
                                                   (Headers
                                                      '[Header "HX-Push" Text] (HtmlT Identity ())))
                                             :<|> ((Text -> Handler (HtmlT Identity ()))
                                                   :<|> Handler D3Graph))))))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BasePath -> Scope -> Context
Context BasePath
rootURL (Scope -> Context)
-> (TenantsUrl -> Scope) -> TenantsUrl -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set TenantName -> Scope
Scoped (Set TenantName -> Scope)
-> (TenantsUrl -> Set TenantName) -> TenantsUrl -> Scope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TenantsUrl -> Set TenantName
getTNU

    staticSettings :: StaticSettings
staticSettings =
      (String -> StaticSettings
WaiAppStatic.Storage.Filesystem.defaultWebAppSettings String
distPath)
        { ssMaxAge :: MaxAge
WaiAppStatic.Types.ssMaxAge = MaxAge
WaiAppStatic.Types.NoMaxAge
        }

    server :: Context -> Server BaseAPI
    server :: Context -> Server BaseAPI
server Context
ctx =
      Text
-> Handler (HtmlT Identity ())
-> Maybe Text
-> Handler (HtmlT Identity ())
forall a.
Text
-> Handler (HtmlT Identity ())
-> Maybe a
-> Handler (HtmlT Identity ())
indexRoute Text
"" (HtmlT Identity () -> Handler (HtmlT Identity ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HtmlT Identity () -> Handler (HtmlT Identity ()))
-> HtmlT Identity () -> Handler (HtmlT Identity ())
forall a b. (a -> b) -> a -> b
$ Context -> HtmlT Identity ()
welcomeComponent Context
ctx)
        (Maybe Text -> Handler (HtmlT Identity ()))
-> ((Maybe Text -> Handler (HtmlT Identity ()))
    :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
          :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                      :<|> (Handler Config
                            :<|> ((VertexTypeUrl
                                   -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
                                  :<|> ((SearchForm
                                         -> Handler
                                              (Headers
                                                 '[Header "HX-Push" Text] (HtmlT Identity ())))
                                        :<|> ((Text -> Handler (HtmlT Identity ()))
                                              :<|> Handler D3Graph))))))))
-> (Maybe Text -> Handler (HtmlT Identity ()))
   :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
         :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
               :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                     :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                           :<|> (Handler Config
                                 :<|> ((VertexTypeUrl
                                        -> [VertexNameUrl]
                                        -> Maybe Text
                                        -> Handler (HtmlT Identity ()))
                                       :<|> ((SearchForm
                                              -> Handler
                                                   (Headers
                                                      '[Header "HX-Push" Text] (HtmlT Identity ())))
                                             :<|> ((Text -> Handler (HtmlT Identity ()))
                                                   :<|> Handler D3Graph))))))))
forall a b. a -> b -> a :<|> b
:<|> Text
-> Handler (HtmlT Identity ())
-> Maybe Text
-> Handler (HtmlT Identity ())
forall a.
Text
-> Handler (HtmlT Identity ())
-> Maybe a
-> Handler (HtmlT Identity ())
indexRoute Text
"about" (HtmlT Identity () -> Handler (HtmlT Identity ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure HtmlT Identity ()
aboutComponent)
        (Maybe Text -> Handler (HtmlT Identity ()))
-> ((Maybe Text -> Handler (HtmlT Identity ()))
    :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
          :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                :<|> (Handler Config
                      :<|> ((VertexTypeUrl
                             -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
                            :<|> ((SearchForm
                                   -> Handler
                                        (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
                                  :<|> ((Text -> Handler (HtmlT Identity ()))
                                        :<|> Handler D3Graph)))))))
-> (Maybe Text -> Handler (HtmlT Identity ()))
   :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
         :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
               :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
                     :<|> (Handler Config
                           :<|> ((VertexTypeUrl
                                  -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
                                 :<|> ((SearchForm
                                        -> Handler
                                             (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
                                       :<|> ((Text -> Handler (HtmlT Identity ()))
                                             :<|> Handler D3Graph)))))))
forall a b. a -> b -> a :<|> b
:<|> (Maybe Text -> Maybe Text -> Handler (HtmlT Identity ()))
-> Maybe Text -> Maybe Text -> Handler (HtmlT Identity ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe Text -> Maybe Text -> Handler (HtmlT Identity ())
forall {a}. Maybe a -> Maybe Text -> Handler (HtmlT Identity ())
searchRoute Maybe Text
forall a. Maybe a
Nothing
        (Maybe Text -> Handler (HtmlT Identity ()))
-> ((Maybe Text -> Handler (HtmlT Identity ()))
    :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
          :<|> (Handler Config
                :<|> ((VertexTypeUrl
                       -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
                      :<|> ((SearchForm
                             -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
                            :<|> ((Text -> Handler (HtmlT Identity ()))
                                  :<|> Handler D3Graph))))))
-> (Maybe Text -> Handler (HtmlT Identity ()))
   :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
         :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
               :<|> (Handler Config
                     :<|> ((VertexTypeUrl
                            -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
                           :<|> ((SearchForm
                                  -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
                                 :<|> ((Text -> Handler (HtmlT Identity ()))
                                       :<|> Handler D3Graph))))))
forall a b. a -> b -> a :<|> b
:<|> Text
-> Handler (HtmlT Identity ())
-> Maybe Text
-> Handler (HtmlT Identity ())
forall a.
Text
-> Handler (HtmlT Identity ())
-> Maybe a
-> Handler (HtmlT Identity ())
indexRoute Text
"info" (Context -> Analysis -> HtmlT Identity ()
infoComponent Context
ctx (Analysis -> HtmlT Identity ())
-> Handler Analysis -> Handler (HtmlT Identity ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Analysis -> Handler Analysis
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Analysis
config)
        (Maybe Text -> Handler (HtmlT Identity ()))
-> ((Maybe Text -> Handler (HtmlT Identity ()))
    :<|> (Handler Config
          :<|> ((VertexTypeUrl
                 -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
                :<|> ((SearchForm
                       -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
                      :<|> ((Text -> Handler (HtmlT Identity ()))
                            :<|> Handler D3Graph)))))
-> (Maybe Text -> Handler (HtmlT Identity ()))
   :<|> ((Maybe Text -> Handler (HtmlT Identity ()))
         :<|> (Handler Config
               :<|> ((VertexTypeUrl
                      -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
                     :<|> ((SearchForm
                            -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
                           :<|> ((Text -> Handler (HtmlT Identity ()))
                                 :<|> Handler D3Graph)))))
forall a b. a -> b -> a :<|> b
:<|> Text
-> Handler (HtmlT Identity ())
-> Maybe Text
-> Handler (HtmlT Identity ())
forall a.
Text
-> Handler (HtmlT Identity ())
-> Maybe a
-> Handler (HtmlT Identity ())
indexRoute Text
"debug" (Analysis -> HtmlT Identity ()
debugComponent (Analysis -> HtmlT Identity ())
-> Handler Analysis -> Handler (HtmlT Identity ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Analysis -> Handler Analysis
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Analysis
config)
        (Maybe Text -> Handler (HtmlT Identity ()))
-> (Handler Config
    :<|> ((VertexTypeUrl
           -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
          :<|> ((SearchForm
                 -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
                :<|> ((Text -> Handler (HtmlT Identity ()))
                      :<|> Handler D3Graph))))
-> (Maybe Text -> Handler (HtmlT Identity ()))
   :<|> (Handler Config
         :<|> ((VertexTypeUrl
                -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
               :<|> ((SearchForm
                      -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
                     :<|> ((Text -> Handler (HtmlT Identity ()))
                           :<|> Handler D3Graph))))
forall a b. a -> b -> a :<|> b
:<|> Handler Config
exportRoute
        Handler Config
-> ((VertexTypeUrl
     -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
    :<|> ((SearchForm
           -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
          :<|> ((Text -> Handler (HtmlT Identity ())) :<|> Handler D3Graph)))
-> Handler Config
   :<|> ((VertexTypeUrl
          -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
         :<|> ((SearchForm
                -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
               :<|> ((Text -> Handler (HtmlT Identity ())) :<|> Handler D3Graph)))
forall a b. a -> b -> a :<|> b
:<|> VertexTypeUrl
-> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ())
objectRoute
        (VertexTypeUrl
 -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
-> ((SearchForm
     -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
    :<|> ((Text -> Handler (HtmlT Identity ())) :<|> Handler D3Graph))
-> (VertexTypeUrl
    -> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ()))
   :<|> ((SearchForm
          -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
         :<|> ((Text -> Handler (HtmlT Identity ())) :<|> Handler D3Graph))
forall a b. a -> b -> a :<|> b
:<|> SearchForm
-> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ()))
forall {m :: * -> *} {h :: Symbol} {p}.
(MonadIO m, KnownSymbol h, HasField "query" p Text) =>
p -> m (Headers '[Header h Text] (HtmlT Identity ()))
searchResultRoute
        (SearchForm
 -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
-> ((Text -> Handler (HtmlT Identity ())) :<|> Handler D3Graph)
-> (SearchForm
    -> Handler (Headers '[Header "HX-Push" Text] (HtmlT Identity ())))
   :<|> ((Text -> Handler (HtmlT Identity ())) :<|> Handler D3Graph)
forall a b. a -> b -> a :<|> b
:<|> Text -> Handler (HtmlT Identity ())
searchRouteWithQuery
        (Text -> Handler (HtmlT Identity ()))
-> Handler D3Graph
-> (Text -> Handler (HtmlT Identity ())) :<|> Handler D3Graph
forall a b. a -> b -> a :<|> b
:<|> Handler D3Graph
d3Route
      where
        indexRoute :: Text -> Handler (Html ()) -> Maybe a -> Handler (Html ())
        -- The HX-Request header is missing, return the full body
        indexRoute :: forall a.
Text
-> Handler (HtmlT Identity ())
-> Maybe a
-> Handler (HtmlT Identity ())
indexRoute Text
name Handler (HtmlT Identity ())
component Maybe a
Nothing = Context -> Text -> HtmlT Identity () -> HtmlT Identity ()
mainBody Context
ctx Text
name (HtmlT Identity () -> HtmlT Identity ())
-> Handler (HtmlT Identity ()) -> Handler (HtmlT Identity ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler (HtmlT Identity ())
component
        -- The HX-Request header is set, return the component and update the nav links
        indexRoute Text
name Handler (HtmlT Identity ())
component (Just a
_htmxRequest) = do
          HtmlT Identity ()
componentHtml <- Handler (HtmlT Identity ())
component
          HtmlT Identity () -> Handler (HtmlT Identity ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
            Context -> Text -> HtmlT Identity ()
navComponent Context
ctx Text
name
            (HtmlT Identity () -> HtmlT Identity ())
-> [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall a. With a => a -> [Attribute] -> a
with HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"container grid p-4"] HtmlT Identity ()
componentHtml

        objectRoute :: VertexTypeUrl -> [VertexNameUrl] -> Maybe Text -> Handler (Html ())
        objectRoute :: VertexTypeUrl
-> [VertexNameUrl] -> Maybe Text -> Handler (HtmlT Identity ())
objectRoute (VTU Text -> VertexName
mkName) [VertexNameUrl]
name Maybe Text
htmxRequest = do
          Analysis
analysis <- IO Analysis -> Handler Analysis
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Analysis
config
          let vname :: VertexName
vname = Text -> VertexName
mkName (Text -> VertexName) -> Text -> VertexName
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ VertexNameUrl -> Text
getVNU (VertexNameUrl -> Text) -> [VertexNameUrl] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VertexNameUrl]
name
          let vertices :: [Vertex]
vertices = Scope -> Set Vertex -> [Vertex]
vertexScope Context
ctx.scope (Set Vertex -> [Vertex]) -> Set Vertex -> [Vertex]
forall a b. (a -> b) -> a -> b
$ (Vertex -> Bool) -> Set Vertex -> Set Vertex
forall a. (a -> Bool) -> Set a -> Set a
Set.filter Vertex -> Bool
forall {r}. HasField "name" r VertexName => r -> Bool
matchVertex Analysis
analysis.vertices
                where
                  matchVertex :: r -> Bool
matchVertex r
v = r
v.name VertexName -> VertexName -> Bool
forall a. Eq a => a -> a -> Bool
== VertexName
vname
          let component :: Handler (HtmlT Identity ())
component = case [Vertex] -> Maybe (NonEmpty Vertex)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Vertex]
vertices of
                Just NonEmpty Vertex
xs -> HtmlT Identity () -> Handler (HtmlT Identity ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> NonEmpty Vertex -> Analysis -> HtmlT Identity ()
objectInfo Context
ctx NonEmpty Vertex
xs Analysis
analysis)
                Maybe (NonEmpty Vertex)
Nothing -> HtmlT Identity () -> Handler (HtmlT Identity ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure HtmlT Identity ()
"not found!"
          Text
-> Handler (HtmlT Identity ())
-> Maybe Text
-> Handler (HtmlT Identity ())
forall a.
Text
-> Handler (HtmlT Identity ())
-> Maybe a
-> Handler (HtmlT Identity ())
indexRoute Text
"object" Handler (HtmlT Identity ())
component Maybe Text
htmxRequest

        -- /search/query does not come from htmx, the body is always served
        searchRouteWithQuery :: Text -> Handler (HtmlT Identity ())
searchRouteWithQuery Text
query = Maybe Any -> Maybe Text -> Handler (HtmlT Identity ())
forall {a}. Maybe a -> Maybe Text -> Handler (HtmlT Identity ())
searchRoute Maybe Any
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
query)

        searchRoute :: Maybe a -> Maybe Text -> Handler (HtmlT Identity ())
searchRoute Maybe a
htmxRequest Maybe Text
queryM = do
          HtmlT Identity ()
result <- case Maybe Text
queryM of
            Just Text
query -> do
              Analysis
analysis <- IO Analysis -> Handler Analysis
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Analysis
config
              HtmlT Identity () -> Handler (HtmlT Identity ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HtmlT Identity () -> Handler (HtmlT Identity ()))
-> ((Maybe Text, HtmlT Identity ()) -> HtmlT Identity ())
-> (Maybe Text, HtmlT Identity ())
-> Handler (HtmlT Identity ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text, HtmlT Identity ()) -> HtmlT Identity ()
forall a b. (a, b) -> b
snd ((Maybe Text, HtmlT Identity ()) -> Handler (HtmlT Identity ()))
-> (Maybe Text, HtmlT Identity ()) -> Handler (HtmlT Identity ())
forall a b. (a -> b) -> a -> b
$ Context
-> Text
-> Map VertexName (Set TenantName)
-> (Maybe Text, HtmlT Identity ())
searchResults Context
ctx Text
query Analysis
analysis.names
            Maybe Text
Nothing -> HtmlT Identity () -> Handler (HtmlT Identity ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure HtmlT Identity ()
forall a. Monoid a => a
mempty
          Text
-> Handler (HtmlT Identity ())
-> Maybe a
-> Handler (HtmlT Identity ())
forall a.
Text
-> Handler (HtmlT Identity ())
-> Maybe a
-> Handler (HtmlT Identity ())
indexRoute Text
"search" (HtmlT Identity () -> Handler (HtmlT Identity ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HtmlT Identity () -> Handler (HtmlT Identity ()))
-> HtmlT Identity () -> Handler (HtmlT Identity ())
forall a b. (a -> b) -> a -> b
$ Context -> Maybe Text -> HtmlT Identity () -> HtmlT Identity ()
searchComponent Context
ctx Maybe Text
queryM HtmlT Identity ()
result) Maybe a
htmxRequest

        searchResultRoute :: p -> m (Headers '[Header h Text] (HtmlT Identity ()))
searchResultRoute p
req = do
          Analysis
analysis <- IO Analysis -> m Analysis
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Analysis
config
          let (Maybe Text
value, HtmlT Identity ()
result) = Context
-> Text
-> Map VertexName (Set TenantName)
-> (Maybe Text, HtmlT Identity ())
searchResults Context
ctx p
req.query Analysis
analysis.names
          Headers '[Header h Text] (HtmlT Identity ())
-> m (Headers '[Header h Text] (HtmlT Identity ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Headers '[Header h Text] (HtmlT Identity ())
 -> m (Headers '[Header h Text] (HtmlT Identity ())))
-> Headers '[Header h Text] (HtmlT Identity ())
-> m (Headers '[Header h Text] (HtmlT Identity ()))
forall a b. (a -> b) -> a -> b
$ Text
-> HtmlT Identity ()
-> Headers '[Header h Text] (HtmlT Identity ())
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"false" (Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend (Context -> Text
baseUrl Context
ctx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"search/")) Maybe Text
value) HtmlT Identity ()
result

        d3Route :: Handler D3Graph
d3Route = do
          Analysis
analysis <- IO Analysis -> Handler Analysis
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Analysis
config
          let graph :: ConfigGraph
graph = Analysis -> ConfigGraph
dependencyGraph Analysis
analysis
          D3Graph -> Handler D3Graph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scope -> ConfigGraph -> D3Graph
toD3Graph Context
ctx.scope ConfigGraph
graph)

        exportRoute :: Handler Config
exportRoute = do
          Analysis
analysis <- IO Analysis -> Handler Analysis
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Analysis
config
          -- TODO: filter with tenant scope
          Config -> Handler Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Analysis
analysis.config)

-- | Render the analysis as a graphviz graph.
dotGraph :: Analysis -> Text
dotGraph :: Analysis -> Text
dotGraph Analysis
analysis = Text
"digraph G {" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines [Text]
dotGraph' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
  where
    dotGraph' :: [Text]
dotGraph' =
      ([Text] -> Text
Text.unlines ([Text] -> Text)
-> ((VertexType, [Text]) -> [Text]) -> (VertexType, [Text]) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VertexType, [Text]) -> [Text]
nodeStyles ((VertexType, [Text]) -> Text) -> [(VertexType, [Text])] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map VertexType [Text] -> [(VertexType, [Text])]
forall k a. Map k a -> [(k, a)]
Map.toList Map VertexType [Text]
allNodes)
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"edge [color=\"gold2\"]"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ConfigGraph -> [Text]
dotEdges Analysis
analysis.dependencyGraph
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"edge [color=\"pink\"]"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ConfigGraph -> [Text]
dotEdges Analysis
analysis.dependentGraph
    nodeStyles :: (VertexType, [Text]) -> [Text]
    nodeStyles :: (VertexType, [Text]) -> [Text]
nodeStyles (VertexType
vt, [Text]
objs) =
      Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
"   "
        (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Text
"node [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VertexType -> Text
dotShape VertexType
vt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VertexType -> Text
dotColor VertexType
vt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"];",
              [Text] -> Text
Text.unwords ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
v -> Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"") [Text]
objs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"
            ]
    allNodes :: Map VertexType [Text]
    allNodes :: Map VertexType [Text]
allNodes =
      ([Text] -> [Text] -> [Text])
-> [(VertexType, [Text])] -> Map VertexType [Text]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Text] -> [Text] -> [Text]
forall a. Monoid a => a -> a -> a
mappend ([(VertexType, [Text])] -> Map VertexType [Text])
-> [(VertexType, [Text])] -> Map VertexType [Text]
forall a b. (a -> b) -> a -> b
$
        Set (VertexType, [Text]) -> [(VertexType, [Text])]
forall a. Set a -> [a]
Set.toList (Set (VertexType, [Text]) -> [(VertexType, [Text])])
-> Set (VertexType, [Text]) -> [(VertexType, [Text])]
forall a b. (a -> b) -> a -> b
$ (Vertex -> (VertexType, [Text]))
-> Set Vertex -> Set (VertexType, [Text])
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\Vertex
v -> (VertexName -> VertexType
forall source target. From source target => source -> target
from Vertex
v.name, [VertexName -> Text
forall source target. From source target => source -> target
from Vertex
v.name])) (Set Vertex -> Set (VertexType, [Text]))
-> Set Vertex -> Set (VertexType, [Text])
forall a b. (a -> b) -> a -> b
$ Analysis
analysis.vertices

    dotEdges :: ConfigGraph -> [Text]
    dotEdges :: ConfigGraph -> [Text]
dotEdges = ((Vertex, Vertex) -> Text) -> [(Vertex, Vertex)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Vertex, Vertex) -> Text
dotEdge ([(Vertex, Vertex)] -> [Text])
-> (ConfigGraph -> [(Vertex, Vertex)]) -> ConfigGraph -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigGraph -> [(Vertex, Vertex)]
forall a. Ord a => Graph a -> [(a, a)]
Algebra.Graph.edgeList
    dotEdge :: (Vertex, Vertex) -> Text
    dotEdge :: (Vertex, Vertex) -> Text
dotEdge (Vertex
v1, Vertex
v2) = Text
"  \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VertexName -> Text
forall source target. From source target => source -> target
from Vertex
v1.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" -> \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VertexName -> Text
forall source target. From source target => source -> target
from Vertex
v2.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""

dotColor :: VertexType -> Text
dotColor :: VertexType -> Text
dotColor VertexType
vt = String -> Text
forall source target. From source target => source -> target
from String
msg
  where
    msg :: String
    msg :: String
msg = String -> Float -> String
forall r. PrintfType r => String -> r
printf String
"color=\"%0.2f+0.5+0.5\"" (Integer -> Float
forall a. Num a => Integer -> a
fromInteger (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (VertexType -> Int
vertexHue VertexType
vt)) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
360.0 :: Float)

dotShape :: VertexType -> Text
dotShape :: VertexType -> Text
dotShape VertexType
vt = String -> Text
forall source target. From source target => source -> target
from String
msg
  where
    msg :: String
    msg :: String
msg = String -> String -> String
forall r. PrintfType r => String -> r
printf String
"shape=%s style=filled" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ case VertexType
vt of
      VertexType
VProjectT -> String
"box"
      VertexType
VProjectTemplateT -> String
"box"
      VertexType
VProjectRegexT -> String
"box"
      VertexType
VPipelineT -> String
pipelineShape
      VertexType
VProjectPipelineT -> String
pipelineShape
      VertexType
VRegexPipelineT -> String
pipelineShape
      VertexType
VTemplatePipelineT -> String
pipelineShape
      VertexType
VReporterT -> String
"rarrow"
      VertexType
VTriggerT -> String
"larrow"
      VertexType
VJobT -> String
"ellipse"
      VertexType
VAbstractJobT -> String
"ellipse"
      VertexType
VNodeLabelT -> String
"tab"
      VertexType
VNodesetT -> String
"component"
      VertexType
_ -> String
"cylinder"
    pipelineShape :: String
    pipelineShape :: String
pipelineShape = String
"hexagon"

-- | A graphviz graph for the legend.
dotLegend :: Text
dotLegend :: Text
dotLegend = Text
"digraph G {" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines [Text]
dotGraph' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
  where
    dotGraph' :: [Text]
dotGraph' =
      Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
" "
        (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Text
"rankdir=\"RL\";",
              Text
"label = \"Legend\";",
              Text
"shape = rectable;",
              Text
"color = black;",
              Text
"\"-dependent->\" [fontcolor=pink shape=plaintext fontsize=20 fontname=\"times bold\"];",
              Text
"\"-dependency->\" [fontcolor=gold2 shape=plaintext fontsize=20 fontname=\"times bold\"];"
            ]
          [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (VertexType -> Text) -> [VertexType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map VertexType -> Text
mkLegend [VertexType
forall a. Bounded a => a
minBound .. VertexType
forall a. Bounded a => a
maxBound]
    mkLegend :: VertexType -> Text
    mkLegend :: VertexType -> Text
mkLegend VertexType
vt =
      [Text] -> Text
Text.unwords
        [ Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> VertexType -> Text
vertexTypeName VertexType
vt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"",
          Text
"[",
          VertexType -> Text
dotShape VertexType
vt,
          VertexType -> Text
dotColor VertexType
vt,
          Text
"];"
        ]