diff --git a/.hlint.yaml b/.hlint.yaml
new file mode 100644
index 0000000..86f8639
--- /dev/null
+++ b/.hlint.yaml
@@ -0,0 +1,55 @@
+# HLint configuration file
+# https://github.com/ndmitchell/hlint
+##########################
+
+# This file contains a template configuration file, which is typically
+# placed as .hlint.yaml in the root of your project
+
+# Specify additional command line arguments
+#
+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
+
+# Control which extensions/flags/modules/functions can be used
+#
+# - extensions:
+# - default: false # all extension are banned by default
+# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
+# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
+#
+# - flags:
+# - {name: -w, within: []} # -w is allowed nowhere
+#
+# - modules:
+# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
+# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
+#
+# - functions:
+# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
+
+# Add custom hints for this project
+#
+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
+
+# Turn on hints that are off by default
+#
+# Ban "module X(module X) where", to require a real export list
+# - warn: {name: Use explicit module export list}
+#
+# Replace a $ b $ c with a . b $ c
+# - group: {name: dollar, enabled: true}
+#
+# Generalise map to fmap, ++ to <>
+# - group: {name: generalise, enabled: true}
+
+# Ignore some builtin hints
+# - ignore: {name: Use let}
+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
+
+- ignore: { name: Replace case with maybe }
+- ignore: { name: Use if }
+# Define some custom infix operators
+# - fixity: infixr 3 ~^#^~
+
+# To generate a suitable file for HLint do:
+# $ hlint --default > .hlint.yaml
diff --git a/charts/octopod/Chart.yaml b/charts/octopod/Chart.yaml
index 5c40711..1c609cd 100644
--- a/charts/octopod/Chart.yaml
+++ b/charts/octopod/Chart.yaml
@@ -7,7 +7,7 @@ appVersion: 1.3.1
keywords:
- kubernetes
- octopod
-home: https://octopod.site
+home: https://github.com/typeable/octopod
sources:
- https://github.com/typeable/octopod
maintainers:
diff --git a/charts/octopod/README.md b/charts/octopod/README.md
index 7de147f..3dd0a77 100644
--- a/charts/octopod/README.md
+++ b/charts/octopod/README.md
@@ -1,6 +1,6 @@
# Octopod
-[Octopod](https://octopod.site/) is a fully open-source self-hosted solution for managing multiple deployments in a Kubernetes cluster with a user-friendly web interface. Managing deployments does not require any technical expertise.
+[Octopod](https://github.com/typeable/octopod) is a fully open-source self-hosted solution for managing multiple deployments in a Kubernetes cluster with a user-friendly web interface. Managing deployments does not require any technical expertise.
## TL;DR
```console
diff --git a/octopod-css/development/layouts/staging.html b/octopod-css/development/layouts/staging.html
index 45e2dd3..e157515 100755
--- a/octopod-css/development/layouts/staging.html
+++ b/octopod-css/development/layouts/staging.html
@@ -127,6 +127,15 @@
SECRET_CODE:
asdfaisdjri235868ear7%lorem-ipsum-dolor-sit-amen
+
+ SECRET_CODE:
+ asdfaisdjri235868ear7%lorem-ipsum-dolor-sit-amen
+
+
INFO:
New Project Staging
diff --git a/octopod-css/development/markups/_dash.html b/octopod-css/development/markups/_dash.html
index 85b6ce2..13db50c 100755
--- a/octopod-css/development/markups/_dash.html
+++ b/octopod-css/development/markups/_dash.html
@@ -32,7 +32,7 @@
-
.dash--add
+ .dash--back
All deployments
diff --git a/octopod-css/development/styles/_listing.css b/octopod-css/development/styles/_listing.css
index ba44dfc..ef83e7a 100755
--- a/octopod-css/development/styles/_listing.css
+++ b/octopod-css/development/styles/_listing.css
@@ -38,6 +38,10 @@
text-overflow: ellipsis;
}
+ .listing--for-text .deleted > span {
+ text-decoration-line: line-through;
+ opacity: 0.2;
+ }
.listing--for-text .listing__item:first-child {
margin-top: 0;
}
@@ -59,6 +63,26 @@
font-style: italic;
}
+ .listing__placeholder {
+ content: "";
+ display: inline-block;
+ height: 14px;
+ width: 140px;
+ border-radius: 2px;
+ background: rgba(143, 143, 143, 0.2);
+ margin-right: 4px;
+ margin-top: 3px;
+ }
+
+ .listing__placeholder__value {
+ width: 70px;
+ }
+
+ .listing--info-text {
+ font-style: italic;
+ color: rgba(143, 143, 143);
+ }
+
.listing--for-text .listing__more {
margin-top: 8px;
}
@@ -68,3 +92,23 @@
font-size: 16px;
line-height: 24px;
}
+
+.listing__spinner {
+ display: inline-block;
+ vertical-align: top;
+ border: none;
+ background-color: transparent;
+ background-repeat: no-repeat;
+ background-position: center center;
+ background-size: 20px 20px;
+ padding: 0;
+ width: 20px;
+ height: 20px;
+ cursor: pointer;
+ text-indent: 200%;
+ white-space: nowrap;
+ overflow: hidden;
+ opacity: 1;
+ background-image: url("../vectors/spot-loader.svg");
+ animation: loading 2.2s linear infinite;
+}
diff --git a/octopod-css/package.json b/octopod-css/package.json
index 5e54e08..185faea 100755
--- a/octopod-css/package.json
+++ b/octopod-css/package.json
@@ -6,7 +6,7 @@
"gulp": "3.9.1",
"gulp-base64": "0.1.3",
"gulp-change": "1.0.0",
- "gulp-clean-css": "2.0.6",
+ "gulp-clean-css": "4.2.0",
"gulp-plumber": "1.1.0",
"gulp-postcss": "6.1.0",
"gulp-size": "2.1.0",
diff --git a/octopod-css/yarn.lock b/octopod-css/yarn.lock
index 5de3712..536c617 100644
--- a/octopod-css/yarn.lock
+++ b/octopod-css/yarn.lock
@@ -30,6 +30,13 @@ amdefine@>=0.0.4:
resolved "https://registry.yarnpkg.com/amdefine/-/amdefine-1.0.1.tgz#4a5282ac164729e93619bcfd3ad151f817ce91f5"
integrity sha1-SlKCrBZHKek2Gbz9OtFR+BfOkfU=
+ansi-colors@^1.0.1:
+ version "1.1.0"
+ resolved "https://registry.yarnpkg.com/ansi-colors/-/ansi-colors-1.1.0.tgz#6374b4dd5d4718ff3ce27a671a3b1cad077132a9"
+ integrity sha512-SFKX67auSNoVR38N3L+nvsPjOE0bybKTYbkf5tRvushrAPQ9V75huw0ZxBkKVeRU9kqH3d6HA4xTckbwZ4ixmA==
+ dependencies:
+ ansi-wrap "^0.1.0"
+
ansi-gray@^0.1.1:
version "0.1.1"
resolved "https://registry.yarnpkg.com/ansi-gray/-/ansi-gray-0.1.1.tgz#2962cf54ec9792c48510a3deb524436861ef7251"
@@ -66,7 +73,7 @@ ansi-styles@^4.1.0:
dependencies:
color-convert "^2.0.1"
-ansi-wrap@0.1.0:
+ansi-wrap@0.1.0, ansi-wrap@^0.1.0:
version "0.1.0"
resolved "https://registry.yarnpkg.com/ansi-wrap/-/ansi-wrap-0.1.0.tgz#a82250ddb0015e9a27ca82e82ea603bbfa45efaf"
integrity sha1-qCJQ3bABXponyoLoLqYDu/pF768=
@@ -344,13 +351,6 @@ buffers@~0.1.1:
resolved "https://registry.yarnpkg.com/buffers/-/buffers-0.1.1.tgz#b24579c3bed4d6d396aeee6d9a8ae7f5482ab7bb"
integrity sha1-skV5w77U1tOWru5tmorn9Ugqt7s=
-bufferstreams@1.0.1:
- version "1.0.1"
- resolved "https://registry.yarnpkg.com/bufferstreams/-/bufferstreams-1.0.1.tgz#cfb1ad9568d3ba3cfe935ba9abdd952de88aab2a"
- integrity sha1-z7GtlWjTujz+k1upq92VLeiKqyo=
- dependencies:
- readable-stream "^1.0.33"
-
cache-base@^1.0.1:
version "1.0.1"
resolved "https://registry.yarnpkg.com/cache-base/-/cache-base-1.0.1.tgz#0a7f46416831c8b662ee36fe4e7c59d76f666ab2"
@@ -471,13 +471,12 @@ class-utils@^0.3.5:
isobject "^3.0.0"
static-extend "^0.1.1"
-clean-css@^3.4.12:
- version "3.4.28"
- resolved "https://registry.yarnpkg.com/clean-css/-/clean-css-3.4.28.tgz#bf1945e82fc808f55695e6ddeaec01400efd03ff"
- integrity sha1-vxlF6C/ICPVWlebd6uwBQA79A/8=
+clean-css@4.2.1:
+ version "4.2.1"
+ resolved "https://registry.yarnpkg.com/clean-css/-/clean-css-4.2.1.tgz#2d411ef76b8569b6d0c84068dabe85b0aa5e5c17"
+ integrity sha512-4ZxI6dy4lrY6FHzfiy1aEOXgu4LIsW2MhwG0VBKdcoGoH/XLFgaHSdLTGr4O8Be6A8r3MOphEiI8Gc1n0ecf3g==
dependencies:
- commander "2.8.x"
- source-map "0.4.x"
+ source-map "~0.6.0"
cliui@^3.0.3:
version "3.2.0"
@@ -629,13 +628,6 @@ combined-stream@~0.0.4:
dependencies:
delayed-stream "0.0.5"
-commander@2.8.x:
- version "2.8.1"
- resolved "https://registry.yarnpkg.com/commander/-/commander-2.8.1.tgz#06be367febfda0c330aa1e2a072d3dc9762425d4"
- integrity sha1-Br42f+v9oMMwqh4qBy09yXYkJdQ=
- dependencies:
- graceful-readlink ">= 1.0.0"
-
component-emitter@^1.2.1:
version "1.3.0"
resolved "https://registry.yarnpkg.com/component-emitter/-/component-emitter-1.3.0.tgz#16e4070fba8ae29b679f2215853ee181ab2eabc0"
@@ -1531,11 +1523,6 @@ graceful-fs@~1.2.0:
resolved "https://registry.yarnpkg.com/graceful-fs/-/graceful-fs-1.2.3.tgz#15a4806a57547cb2d2dbf27f42e89a8c3451b364"
integrity sha1-FaSAaldUfLLS2/J/QuiajDRRs2Q=
-"graceful-readlink@>= 1.0.0":
- version "1.0.1"
- resolved "https://registry.yarnpkg.com/graceful-readlink/-/graceful-readlink-1.0.1.tgz#4cafad76bc62f02fa039b2f94e9a3dd3a391a725"
- integrity sha1-TK+tdrxi8C+gObL5Tpo906ORpyU=
-
gulp-base64@0.1.3:
version "0.1.3"
resolved "https://registry.yarnpkg.com/gulp-base64/-/gulp-base64-0.1.3.tgz#164bd9d4f336dc16d669b331cebc139343579145"
@@ -1555,17 +1542,15 @@ gulp-change@1.0.0:
dependencies:
event-stream "^3.1.7"
-gulp-clean-css@2.0.6:
- version "2.0.6"
- resolved "https://registry.yarnpkg.com/gulp-clean-css/-/gulp-clean-css-2.0.6.tgz#c664d5e2f19faad7750d62e543b21d07f6aa3c8d"
- integrity sha1-xmTV4vGfqtd1DWLlQ7IdB/aqPI0=
+gulp-clean-css@4.2.0:
+ version "4.2.0"
+ resolved "https://registry.yarnpkg.com/gulp-clean-css/-/gulp-clean-css-4.2.0.tgz#915ec258dc6d3e6a50043f610066d5c2eac4f54e"
+ integrity sha512-r4zQsSOAK2UYUL/ipkAVCTRg/2CLZ2A+oPVORopBximRksJ6qy3EX1KGrIWT4ZrHxz3Hlobb1yyJtqiut7DNjA==
dependencies:
- clean-css "^3.4.12"
- gulp-util "^3.0.7"
- object-assign "^4.0.1"
- readable-stream "^2.0.6"
- vinyl-bufferstream "^1.0.1"
- vinyl-sourcemaps-apply "^0.2.1"
+ clean-css "4.2.1"
+ plugin-error "1.0.1"
+ through2 "3.0.1"
+ vinyl-sourcemaps-apply "0.2.1"
gulp-plumber@1.1.0:
version "1.1.0"
@@ -3108,6 +3093,16 @@ pleeease-filters@^3.0.0:
onecolor "~2.4.0"
postcss "^5.0.4"
+plugin-error@1.0.1:
+ version "1.0.1"
+ resolved "https://registry.yarnpkg.com/plugin-error/-/plugin-error-1.0.1.tgz#77016bd8919d0ac377fdcdd0322328953ca5781c"
+ integrity sha512-L1zP0dk7vGweZME2i+EeakvUNqSrdiI3F91TwEoYiGrAfUXmVv6fJIq4g82PAXxNsWOp0J7ZqQy/3Szz0ajTxA==
+ dependencies:
+ ansi-colors "^1.0.1"
+ arr-diff "^4.0.0"
+ arr-union "^3.1.0"
+ extend-shallow "^3.0.2"
+
plur@^2.0.0, plur@^2.1.2:
version "2.1.2"
resolved "https://registry.yarnpkg.com/plur/-/plur-2.1.2.tgz#7482452c1a0f508e3e344eaec312c91c29dc655a"
@@ -3520,6 +3515,15 @@ read-pkg@^1.0.0:
normalize-package-data "^2.3.2"
path-type "^1.0.0"
+"readable-stream@2 || 3", readable-stream@^3.1.1:
+ version "3.6.0"
+ resolved "https://registry.yarnpkg.com/readable-stream/-/readable-stream-3.6.0.tgz#337bbda3adc0706bd3e024426a286d4b4b2c9198"
+ integrity sha512-BViHy7LKeTz4oNnkcLJ+lVSL6vpiFeX6/d3oSH8zCW7UxP2onchk+vTGB143xuFjHS3deTgkKoXXymXqymiIdA==
+ dependencies:
+ inherits "^2.0.3"
+ string_decoder "^1.1.1"
+ util-deprecate "^1.0.1"
+
"readable-stream@>=1.0.33-1 <1.1.0-0", readable-stream@~1.0.17, readable-stream@~1.0.33-1:
version "1.0.34"
resolved "https://registry.yarnpkg.com/readable-stream/-/readable-stream-1.0.34.tgz#125820e34bc842d2f2aaafafe4c2916ee32c157c"
@@ -3540,28 +3544,6 @@ readable-stream@^1.0.33, readable-stream@~1.1.9:
isarray "0.0.1"
string_decoder "~0.10.x"
-readable-stream@^2.0.6, readable-stream@~2.3.6:
- version "2.3.7"
- resolved "https://registry.yarnpkg.com/readable-stream/-/readable-stream-2.3.7.tgz#1eca1cf711aef814c04f62252a36a62f6cb23b57"
- integrity sha512-Ebho8K4jIbHAxnuxi7o42OrZgF/ZTNcsZj6nRKyUmkhLFq8CHItp/fy6hQZuZmP/n3yZ9VBUbp4zz/mX8hmYPw==
- dependencies:
- core-util-is "~1.0.0"
- inherits "~2.0.3"
- isarray "~1.0.0"
- process-nextick-args "~2.0.0"
- safe-buffer "~5.1.1"
- string_decoder "~1.1.1"
- util-deprecate "~1.0.1"
-
-readable-stream@^3.1.1:
- version "3.6.0"
- resolved "https://registry.yarnpkg.com/readable-stream/-/readable-stream-3.6.0.tgz#337bbda3adc0706bd3e024426a286d4b4b2c9198"
- integrity sha512-BViHy7LKeTz4oNnkcLJ+lVSL6vpiFeX6/d3oSH8zCW7UxP2onchk+vTGB143xuFjHS3deTgkKoXXymXqymiIdA==
- dependencies:
- inherits "^2.0.3"
- string_decoder "^1.1.1"
- util-deprecate "^1.0.1"
-
readable-stream@~2.0.0:
version "2.0.6"
resolved "https://registry.yarnpkg.com/readable-stream/-/readable-stream-2.0.6.tgz#8f90341e68a53ccc928788dacfcd11b36eb9b78e"
@@ -3574,6 +3556,19 @@ readable-stream@~2.0.0:
string_decoder "~0.10.x"
util-deprecate "~1.0.1"
+readable-stream@~2.3.6:
+ version "2.3.7"
+ resolved "https://registry.yarnpkg.com/readable-stream/-/readable-stream-2.3.7.tgz#1eca1cf711aef814c04f62252a36a62f6cb23b57"
+ integrity sha512-Ebho8K4jIbHAxnuxi7o42OrZgF/ZTNcsZj6nRKyUmkhLFq8CHItp/fy6hQZuZmP/n3yZ9VBUbp4zz/mX8hmYPw==
+ dependencies:
+ core-util-is "~1.0.0"
+ inherits "~2.0.3"
+ isarray "~1.0.0"
+ process-nextick-args "~2.0.0"
+ safe-buffer "~5.1.1"
+ string_decoder "~1.1.1"
+ util-deprecate "~1.0.1"
+
rechoir@^0.6.2:
version "0.6.2"
resolved "https://registry.yarnpkg.com/rechoir/-/rechoir-0.6.2.tgz#85204b54dba82d5742e28c96756ef43af50e3384"
@@ -3900,7 +3895,7 @@ source-map-url@^0.4.0:
resolved "https://registry.yarnpkg.com/source-map-url/-/source-map-url-0.4.1.tgz#0af66605a745a5a2f91cf1bbf8a7afbc283dec56"
integrity sha512-cPiFOTLUKvJFIg4SKVScy4ilPPW6rFgMgfuZJPNoDuMs3nC1HbMUycBoJw77xFIp6z1UJQJOfx6C9GMH80DiTw==
-source-map@0.4.x, source-map@^0.4.2:
+source-map@^0.4.2:
version "0.4.4"
resolved "https://registry.yarnpkg.com/source-map/-/source-map-0.4.4.tgz#eba4f5da9c0dc999de68032d8b4f76173652036b"
integrity sha1-66T12pwNyZneaAMti092FzZSA2s=
@@ -3912,6 +3907,11 @@ source-map@^0.5.1, source-map@^0.5.3, source-map@^0.5.6:
resolved "https://registry.yarnpkg.com/source-map/-/source-map-0.5.7.tgz#8a039d2d1021d22d1ea14c80d8ea468ba2ef3fcc"
integrity sha1-igOdLRAh0i0eoUyA2OpGi6LvP8w=
+source-map@~0.6.0:
+ version "0.6.1"
+ resolved "https://registry.yarnpkg.com/source-map/-/source-map-0.6.1.tgz#74722af32e9614e9c287a8d0bbde48b5e2f1a263"
+ integrity sha512-UjgapumWlbMhkBgzT7Ykc5YXUT46F0iKu8SGXq0bcwP5dz/h0Plj6enJqjz1Zbq2l5WaqYnrVbwWOWMyF3F47g==
+
sparkles@^1.0.0:
version "1.0.1"
resolved "https://registry.yarnpkg.com/sparkles/-/sparkles-1.0.1.tgz#008db65edce6c50eec0c5e228e1945061dd0437c"
@@ -4248,6 +4248,13 @@ text-table@^0.2.0:
resolved "https://registry.yarnpkg.com/text-table/-/text-table-0.2.0.tgz#7f5ee823ae805207c00af2df4a84ec3fcfa570b4"
integrity sha1-f17oI66AUgfACvLfSoTsP8+lcLQ=
+through2@3.0.1:
+ version "3.0.1"
+ resolved "https://registry.yarnpkg.com/through2/-/through2-3.0.1.tgz#39276e713c3302edf9e388dd9c812dd3b825bd5a"
+ integrity sha512-M96dvTalPT3YbYLaKaCuwu+j06D/8Jfib0o/PxbVt6Amhv3dUAtW6rTV1jPgJSBG83I/e04Y6xkVdVhSRhi0ww==
+ dependencies:
+ readable-stream "2 || 3"
+
through2@^0.6.1, through2@^0.6.3, through2@~0.6.1:
version "0.6.5"
resolved "https://registry.yarnpkg.com/through2/-/through2-0.6.5.tgz#41ab9c67b29d57209071410e1d7a7a968cd3ad48"
@@ -4452,13 +4459,6 @@ verror@1.10.0:
core-util-is "1.0.2"
extsprintf "^1.2.0"
-vinyl-bufferstream@^1.0.1:
- version "1.0.1"
- resolved "https://registry.yarnpkg.com/vinyl-bufferstream/-/vinyl-bufferstream-1.0.1.tgz#0537869f580effa4ca45acb47579e4b9fe63081a"
- integrity sha1-BTeGn1gO/6TKRay0dXnkuf5jCBo=
- dependencies:
- bufferstreams "1.0.1"
-
vinyl-file@~1.3.0:
version "1.3.0"
resolved "https://registry.yarnpkg.com/vinyl-file/-/vinyl-file-1.3.0.tgz#aa05634d3a867ba91447bedbb34afcb26f44f6e7"
@@ -4483,7 +4483,7 @@ vinyl-fs@^0.3.0:
through2 "^0.6.1"
vinyl "^0.4.0"
-vinyl-sourcemaps-apply@^0.2.0, vinyl-sourcemaps-apply@^0.2.1:
+vinyl-sourcemaps-apply@0.2.1, vinyl-sourcemaps-apply@^0.2.0:
version "0.2.1"
resolved "https://registry.yarnpkg.com/vinyl-sourcemaps-apply/-/vinyl-sourcemaps-apply-0.2.1.tgz#ab6549d61d172c2b1b87be5c508d239c8ef87705"
integrity sha1-q2VJ1h0XLCsbh75cUI0jnI74dwU=
diff --git a/octopod-frontend/octopod-frontend.cabal b/octopod-frontend/octopod-frontend.cabal
index 0c55846..398428f 100644
--- a/octopod-frontend/octopod-frontend.cabal
+++ b/octopod-frontend/octopod-frontend.cabal
@@ -41,6 +41,15 @@ executable frontend
, Data.Text.Search
, Data.UniqMap
, Data.WorkingOverrides
+ , Frontend.UIKit
+ , Frontend.UIKit.Button.Large
+ , Frontend.UIKit.Button.Dash
+ , Frontend.Classes
+ , Frontend.UIKit.Button.Common
+ , Frontend.UIKit.Button.Expander
+ , Frontend.UIKit.Button.Static
+ , Frontend.UIKit.Button.Action
+ , Frontend.UIKit.Button.Sort
ghc-options:
-Weverything
-Wno-implicit-prelude
@@ -113,5 +122,6 @@ executable frontend
, ordered-containers
, witherable
, reflex
+ , data-default
hs-source-dirs: src
default-language: Haskell2010
diff --git a/octopod-frontend/src/Data/Text/Search.hs b/octopod-frontend/src/Data/Text/Search.hs
index 460d2ef..7d22ce8 100644
--- a/octopod-frontend/src/Data/Text/Search.hs
+++ b/octopod-frontend/src/Data/Text/Search.hs
@@ -1,5 +1,6 @@
module Data.Text.Search
( fuzzySearch,
+ fuzzySearchMany,
FuzzySearchStringChunk (..),
)
where
@@ -8,7 +9,9 @@ import Control.Applicative
import Data.Bifunctor
import Data.Char
import Data.Function
+import Data.Functor
import qualified Data.List as L
+import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
@@ -44,5 +47,15 @@ fuzzySearch n h = case fuzzySearch' n h 0 0 of
[] -> Nothing
xs@(_ : _) -> Just . (first . fmap . fmap) T.pack $ L.maximumBy (compare `on` snd) xs
+fuzzySearchMany :: Needle -> [Haystack] -> [(Haystack, [FuzzySearchStringChunk Text])]
+fuzzySearchMany needle haystacks =
+ fmap fst . L.sortOn snd $
+ mapMaybe
+ ( \haystack ->
+ fuzzySearch needle haystack
+ <&> \(res, score) -> ((haystack, res), score)
+ )
+ haystacks
+
data FuzzySearchStringChunk a = NotMatched !a | Matched !a
deriving stock (Show, Eq, Functor)
diff --git a/octopod-frontend/src/Frontend/Classes.hs b/octopod-frontend/src/Frontend/Classes.hs
new file mode 100644
index 0000000..788f255
--- /dev/null
+++ b/octopod-frontend/src/Frontend/Classes.hs
@@ -0,0 +1,18 @@
+module Frontend.Classes
+ ( Classes,
+ destructClasses,
+ )
+where
+
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+
+newtype Classes = Classes [Text]
+ deriving newtype (Semigroup, Monoid)
+
+instance IsString Classes where
+ fromString s = Classes [fromString s]
+
+destructClasses :: Classes -> Text
+destructClasses (Classes cs) = T.unwords cs
diff --git a/octopod-frontend/src/Frontend/UIKit.hs b/octopod-frontend/src/Frontend/UIKit.hs
new file mode 100644
index 0000000..dd7269e
--- /dev/null
+++ b/octopod-frontend/src/Frontend/UIKit.hs
@@ -0,0 +1,318 @@
+-- | Most of HTML details should be implemented here with a domain API.
+module Frontend.UIKit
+ ( deploymentSection,
+ loadingCommonWidget,
+ errorCommonWidget,
+ octopodTextInput',
+ loadingOverride,
+ loadingOverrides,
+ overrideField,
+ OverrideField (..),
+ popupOverlay,
+ Default (..),
+ module X,
+ (.~~),
+ (?~~),
+ OverrideFieldType (..),
+ deletedOverride,
+ showNonEditableWorkingOverride,
+ NonEditableWorkingOverrideStyle (..),
+ )
+where
+
+import Control.Lens
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Align
+import Data.Default
+import Data.Functor
+import Data.Generics.Labels ()
+import qualified Data.Map as M
+import Data.Text (Text)
+import Data.Text.Search
+import Data.These
+import Data.WorkingOverrides
+import Frontend.Classes as X
+import Frontend.UIKit.Button.Action as X
+import Frontend.UIKit.Button.Dash as X
+import Frontend.UIKit.Button.Expander as X
+import Frontend.UIKit.Button.Large as X
+import Frontend.UIKit.Button.Sort as X
+import Frontend.UIKit.Button.Static as X
+import GHC.Generics (Generic)
+import Reflex.Dom
+import Reflex.Network
+
+(.~~) :: ASetter' s a -> a -> s -> s
+(.~~) = (.~)
+
+(?~~) :: ASetter' s (Maybe a) -> a -> s -> s
+(?~~) = (?~)
+
+deploymentSection :: DomBuilder t m => Text -> m a -> m a
+deploymentSection n m = elClass "section" "deployment__section" $ do
+ elClass "h3" "deployment__sub-heading" $ text n
+ elDiv "deployment__widget" m
+
+-- | Widget with a loading spinner.
+loadingCommonWidget :: MonadWidget t m => m ()
+loadingCommonWidget =
+ divClass "loading loading--enlarged loading--alternate" $
+ text "Loading..."
+
+-- | Widget with an error message.
+errorCommonWidget :: MonadWidget t m => m ()
+errorCommonWidget =
+ divClass "null null--data" $
+ divClass "null__content" $ do
+ elClass "b" "null__heading" $ text "Cannot retrieve the data"
+ divClass "null__message" $ text "Try to reload the page"
+
+data OverrideField t = OverrideField
+ { fieldValue :: Dynamic t Text
+ , fieldError :: Event t Text
+ , fieldDisabled :: Dynamic t Bool
+ , fieldType :: Dynamic t OverrideFieldType
+ }
+ deriving stock (Generic)
+
+data OverrideFieldType
+ = DefaultOverrideFieldType
+ | EditedOverrideFieldType
+
+overrideFieldTypeClasses :: OverrideFieldType -> Classes
+overrideFieldTypeClasses DefaultOverrideFieldType = "input--default"
+overrideFieldTypeClasses EditedOverrideFieldType = mempty
+
+overrideField :: MonadWidget t m => Dynamic t [Text] -> OverrideField t -> OverrideField t -> m (Dynamic t Text, Dynamic t Text, Event t ())
+overrideField overrideKeyValues keyDyn valueDyn = do
+ elDiv "overrides__item" $ do
+ (keyInp, _) <-
+ octopodTextInput'
+ overrideKeyValues
+ (keyDyn ^. #fieldDisabled)
+ ( do
+ t <- keyDyn ^. #fieldType
+ pure $ "overrides__key" <> overrideFieldTypeClasses t
+ )
+ "key"
+ (keyDyn ^. #fieldValue)
+ (keyDyn ^. #fieldError)
+ let keyTextDyn = value keyInp
+ (value -> valTextDyn, _) <-
+ octopodTextInput'
+ (pure [])
+ (valueDyn ^. #fieldDisabled)
+ ( do
+ t <- keyDyn ^. #fieldType
+ pure $ "overrides__value" <> overrideFieldTypeClasses t
+ )
+ "value"
+ (valueDyn ^. #fieldValue)
+ (valueDyn ^. #fieldError)
+ closeEv <- deleteOverrideButton
+ pure (keyTextDyn, valTextDyn, closeEv)
+
+deletedOverride :: MonadWidget t m => Text -> Maybe Text -> m (Event t ())
+deletedOverride k vM = do
+ elDiv "overrides__item" $ do
+ elDiv "overrides__key input input--deleted" $ field k
+ case vM of
+ Nothing -> do
+ elDiv "overrides__placeholder overrides__value" blank
+ loadingOverrideSpinner
+ pure never
+ Just v -> do
+ elDiv "overrides__value input input--deleted" $ field $ v
+ undoOverrideButton
+ where
+ field t =
+ void $
+ inputElement $
+ def
+ & inputElementConfig_initialValue .~ t
+ & initialAttributes .~ ("type" =: "text" <> "class" =: "input__widget")
+
+loadingOverrideField :: MonadWidget t m => m ()
+loadingOverrideField = elDiv "overrides__placeholder" blank
+
+loadingOverrideSpinner :: MonadWidget t m => m ()
+loadingOverrideSpinner = elDiv "overrides__delete spot spot--loader" blank
+
+loadingOverride :: MonadWidget t m => m ()
+loadingOverride = do
+ elDiv "overrides__item loader" $ do
+ loadingOverrideField
+ loadingOverrideField
+ loadingOverrideSpinner
+
+loadingOverrides :: MonadWidget t m => m ()
+loadingOverrides = do
+ loadingOverride
+ loadingOverride
+ loadingOverride
+
+elDiv :: DomBuilder t m => Text -> m a -> m a
+elDiv = elClass "div"
+
+-- | The only text input field that is used in project forms. This input
+-- provides automatic error message hiding after user starts typing.
+octopodTextInput' ::
+ MonadWidget t m =>
+ -- | Value to suggest
+ (Dynamic t [Text]) ->
+ -- | Disabled?
+ Dynamic t Bool ->
+ -- | Input field classes.
+ Dynamic t Classes ->
+ -- | Placeholder for input field.
+ Text ->
+ -- | Init value.
+ (Dynamic t Text) ->
+ -- | Event carrying the error message.
+ Event t Text ->
+ m (InputElement EventResult GhcjsDomSpace t, Dynamic t Bool)
+octopodTextInput' valuesDyn disabledDyn clssDyn placeholder inValDyn' errEv = mdo
+ inValDyn <- holdUniqDyn inValDyn'
+ let valDyn = value inp
+ inValEv =
+ align (leftmost [selectedValue, updated inValDyn]) (updated valDyn)
+ & fmapMaybe
+ ( \case
+ This x -> Just x
+ These inV currV | inV /= currV -> Just inV
+ _ -> Nothing
+ )
+ isValid <-
+ holdDyn True $
+ leftmost
+ [ False <$ errEv
+ , True <$ updated valDyn
+ ]
+
+ errorClassesDyn <-
+ holdDyn mempty $
+ leftmost
+ [ "input--error" <$ errEv
+ , mempty <$ updated valDyn
+ ]
+
+ let classDyn = do
+ errClasses <- errorClassesDyn
+ additionalClasses <- clssDyn
+ pure . destructClasses $ "input" <> errClasses <> additionalClasses
+
+ inVal <- sample . current $ inValDyn
+ disabled <- sample . current $ disabledDyn
+ (inp, selectedValue) <- elDynClass "div" classDyn $ do
+ inp' <-
+ inputElement $
+ def
+ & initialAttributes
+ .~ ( "type" =: "text"
+ <> "class" =: "input__widget"
+ <> "placeholder" =: placeholder
+ )
+ & inputElementConfig_setValue .~ inValEv
+ & inputElementConfig_initialValue .~ inVal
+ & inputElementConfig_elementConfig . elementConfig_initialAttributes
+ %~ (if disabled then M.insert "disabled" "disabled" else id)
+ & inputElementConfig_elementConfig . elementConfig_modifyAttributes
+ <>~ updated
+ ( do
+ disabled' <- disabledDyn
+ pure $
+ M.singleton "disabled" $
+ if disabled' then Just "disabled" else Nothing
+ )
+ widgetHold_ blank $
+ leftmost
+ [ divClass "input__output" . text <$> errEv
+ , blank <$ updated valDyn
+ ]
+ delayedFalseFocus <- delayFalse $ _inputElement_hasFocus inp'
+ selectedValue' <- networkView >=> switchHoldPromptly never $ do
+ hasFocus <- delayedFalseFocus
+ values <- valuesDyn
+ case hasFocus of
+ True | (_ : _) <- values -> do
+ currVal <- valDyn
+ case fuzzySearchMany currVal values of
+ [] -> pure $ pure never
+ ress ->
+ pure $ do
+ elClass "ul" "overrides__search" $ do
+ fmap leftmost $
+ forM ress $ \(initialText, res) -> do
+ (resEl, ()) <- elClass' "li" "overrides__search-item" $
+ forM_ res $ \case
+ Matched t -> elAttr "span" ("style" =: "font-weight: bold;") $ text t
+ NotMatched t -> text t
+ pure $ domEvent Click resEl $> initialText
+ _ -> pure $ pure never
+ pure (inp', selectedValue')
+ pure (inp, isValid)
+
+delayFalse :: (MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => Dynamic t Bool -> m (Dynamic t Bool)
+delayFalse x = do
+ initVal <- sample . current $ x
+ let trueEv = ffilter id $ updated x
+ falseEv = ffilter not $ updated x
+ delayedFalseEv <- delay 0.1 falseEv
+ holdDyn initVal $ leftmost [trueEv, delayedFalseEv]
+
+-- | Dark unclickable background for opened sidebar.
+popupOverlay :: DomBuilder t m => m ()
+popupOverlay =
+ elAttr "div" ("class" =: "popup__overlay" <> "aria-hidden" =: "true") blank
+
+data NonEditableWorkingOverrideStyle
+ = RegularNonEditableWorkingOverrideStyle
+ | LargeNonEditableWorkingOverrideStyle
+
+nonEditableWorkingOverrideStyleClasses :: NonEditableWorkingOverrideStyle -> Classes
+nonEditableWorkingOverrideStyleClasses RegularNonEditableWorkingOverrideStyle = mempty
+nonEditableWorkingOverrideStyleClasses LargeNonEditableWorkingOverrideStyle = "listing--larger"
+
+-- | Widget that shows overrides list. It does not depend on their type.
+showNonEditableWorkingOverride ::
+ MonadWidget t m =>
+ -- | Loading?
+ Bool ->
+ NonEditableWorkingOverrideStyle ->
+ -- | Overrides list.
+ [WorkingOverride] ->
+ m ()
+showNonEditableWorkingOverride loading style cfg =
+ divClass
+ ( destructClasses $
+ "listing" <> "listing--for-text" <> nonEditableWorkingOverrideStyleClasses style
+ )
+ $ do
+ case cfg of
+ [] ->
+ divClass "listing__item" $
+ elClass "span" "listing--info-text" $ text "no custom configuration"
+ _ -> forM_ cfg $ \(WorkingOverrideKey keyType key, val) -> do
+ let wrapper = case val of
+ WorkingDeletedValue _ -> divClass "listing__item deleted"
+ _ -> divClass "listing__item"
+ wrapper $ do
+ let keyWrapper = case keyType of
+ CustomWorkingOverrideKey -> elClass "span" "listing__key"
+ DefaultWorkingOverrideKey -> elClass "span" "listing__key default"
+ keyWrapper $ do
+ text key
+ text ": "
+
+ case val of
+ WorkingCustomValue txt -> elClass "span" "listing__value" $ text txt
+ WorkingDefaultValue txt -> elClass "span" "listing__value default" $ text txt
+ WorkingDeletedValue (Just txt) -> elClass "span" "listing__value default" $ text txt
+ WorkingDeletedValue Nothing -> do
+ elClass "div" "listing__placeholder listing__placeholder__value" $ pure ()
+ elClass "div" "listing__spinner" $ pure ()
+ when loading $
+ divClass "listing__item" $ do
+ elClass "div" "listing__placeholder" $ pure ()
+ elClass "div" "listing__spinner" $ pure ()
diff --git a/octopod-frontend/src/Frontend/UIKit/Button/Action.hs b/octopod-frontend/src/Frontend/UIKit/Button/Action.hs
new file mode 100644
index 0000000..a4e596d
--- /dev/null
+++ b/octopod-frontend/src/Frontend/UIKit/Button/Action.hs
@@ -0,0 +1,63 @@
+module Frontend.UIKit.Button.Action
+ ( actionButton,
+ ActionButtonConfig (..),
+ ActionButtonType (..),
+ )
+where
+
+import Control.Lens
+import Data.Default
+import Data.Generics.Labels ()
+import Data.Text (Text)
+import Frontend.Classes
+import Frontend.UIKit.Button.Common
+import GHC.Generics (Generic)
+import Reflex.Dom
+
+data ActionButtonConfig t = ActionButtonConfig
+ { buttonText :: Text
+ , buttonEnabled :: Dynamic t Bool
+ , buttonType :: Maybe ActionButtonType
+ , buttonBaseTag :: BaseButtonTag
+ }
+ deriving stock (Generic)
+
+instance Reflex t => Default (ActionButtonConfig t) where
+ def =
+ ActionButtonConfig
+ { buttonText = ""
+ , buttonEnabled = pure True
+ , buttonType = Nothing
+ , buttonBaseTag = ButtonTag
+ }
+
+data ActionButtonType
+ = ArchiveActionButtonType
+ | EditActionButtonType
+ | RestoreActionButtonType
+ | LogsActionButtonType
+
+buttonTypeClasses :: ActionButtonType -> Classes
+buttonTypeClasses = \case
+ ArchiveActionButtonType -> "action--archive"
+ EditActionButtonType -> "action--edit"
+ RestoreActionButtonType -> "action--restore"
+ LogsActionButtonType -> "action--logs"
+
+actionButton ::
+ (DomBuilder t m, PostBuild t m) =>
+ ActionButtonConfig t ->
+ m (Event t ())
+actionButton cfg =
+ buttonEl
+ CommonButtonConfig
+ { constantClasses =
+ pure $
+ "action"
+ <> maybe mempty buttonTypeClasses (cfg ^. #buttonType)
+ , enabledClasses = mempty
+ , disabledClasses = "action--disabled"
+ , buttonEnabled = cfg ^. #buttonEnabled
+ , buttonText = pure $ cfg ^. #buttonText
+ , buttonBaseTag = cfg ^. #buttonBaseTag
+ }
diff --git a/octopod-frontend/src/Frontend/UIKit/Button/Common.hs b/octopod-frontend/src/Frontend/UIKit/Button/Common.hs
new file mode 100644
index 0000000..bbb71e2
--- /dev/null
+++ b/octopod-frontend/src/Frontend/UIKit/Button/Common.hs
@@ -0,0 +1,49 @@
+module Frontend.UIKit.Button.Common
+ ( CommonButtonConfig (..),
+ BaseButtonTag (..),
+ buttonEl,
+ )
+where
+
+import Control.Lens
+import Data.Generics.Labels ()
+import Data.Map (Map)
+import Data.Text (Text)
+import Frontend.Classes
+import GHC.Generics (Generic)
+import Reflex.Dom
+
+data CommonButtonConfig t = CommonButtonConfig
+ { constantClasses :: Dynamic t Classes
+ , enabledClasses :: Classes
+ , disabledClasses :: Classes
+ , buttonEnabled :: Dynamic t Bool
+ , buttonText :: Dynamic t Text
+ , buttonBaseTag :: BaseButtonTag
+ }
+ deriving stock (Generic)
+
+data BaseButtonTag = ButtonTag | ATag Text
+
+baseTag :: BaseButtonTag -> (Text, Map Text Text)
+baseTag ButtonTag = ("button", "type" =: "button")
+baseTag (ATag url) = ("a", "href" =: url <> "target" =: "_blank")
+
+buttonEl ::
+ (DomBuilder t m, PostBuild t m) =>
+ CommonButtonConfig t ->
+ m (Event t ())
+buttonEl cfg = do
+ let (t, staticAttrs) = baseTag (cfg ^. #buttonBaseTag)
+ attrsDyn = do
+ enabled <- cfg ^. #buttonEnabled
+ let (enabledClasses, enabledAttrs) = case enabled of
+ True -> (cfg ^. #enabledClasses, mempty)
+ False -> (cfg ^. #disabledClasses, "disabled" =: "")
+ cs <- cfg ^. #constantClasses
+ pure $
+ staticAttrs
+ <> "class" =: destructClasses (enabledClasses <> cs)
+ <> enabledAttrs
+ (bEl, _) <- elDynAttr' t attrsDyn $ dynText $ cfg ^. #buttonText
+ pure $ domEvent Click bEl
diff --git a/octopod-frontend/src/Frontend/UIKit/Button/Dash.hs b/octopod-frontend/src/Frontend/UIKit/Button/Dash.hs
new file mode 100644
index 0000000..c8cfb7f
--- /dev/null
+++ b/octopod-frontend/src/Frontend/UIKit/Button/Dash.hs
@@ -0,0 +1,71 @@
+module Frontend.UIKit.Button.Dash
+ ( dashButton,
+ DashButtonType (..),
+ DashButtonConfig (..),
+ DashButtonStyle (..),
+ )
+where
+
+import Control.Lens
+import Data.Default
+import Data.Generics.Labels ()
+import Data.Text (Text)
+import Frontend.Classes
+import Frontend.UIKit.Button.Common
+import GHC.Generics (Generic)
+import Reflex.Dom
+
+data DashButtonConfig t = DashButtonConfig
+ { buttonText :: Text
+ , buttonEnabled :: Dynamic t Bool
+ , buttonType :: Maybe DashButtonType
+ , buttonStyle :: DashButtonStyle
+ }
+ deriving stock (Generic)
+
+data DashButtonStyle
+ = RegularDashButtonStyle
+ | SmallDashButtonStyle
+ | OverridesDashButtonStyle
+
+dashButtonStyleClasses :: DashButtonStyle -> Classes
+dashButtonStyleClasses RegularDashButtonStyle = mempty
+dashButtonStyleClasses SmallDashButtonStyle = "dash--smaller"
+dashButtonStyleClasses OverridesDashButtonStyle = "overrides__add"
+
+instance Reflex t => Default (DashButtonConfig t) where
+ def =
+ DashButtonConfig
+ { buttonText = ""
+ , buttonEnabled = pure True
+ , buttonType = Nothing
+ , buttonStyle = RegularDashButtonStyle
+ }
+
+data DashButtonType
+ = AddDashButtonType
+ | BackDashButtonType
+
+buttonTypeClasses :: DashButtonType -> Classes
+buttonTypeClasses = \case
+ AddDashButtonType -> "dash--add"
+ BackDashButtonType -> "dash--back"
+
+dashButton ::
+ (DomBuilder t m, PostBuild t m) =>
+ DashButtonConfig t ->
+ m (Event t ())
+dashButton cfg =
+ buttonEl
+ CommonButtonConfig
+ { constantClasses =
+ pure $
+ "dash"
+ <> maybe mempty buttonTypeClasses (cfg ^. #buttonType)
+ <> dashButtonStyleClasses (cfg ^. #buttonStyle)
+ , enabledClasses = mempty
+ , disabledClasses = "dash--disabled"
+ , buttonEnabled = cfg ^. #buttonEnabled
+ , buttonText = pure $ cfg ^. #buttonText
+ , buttonBaseTag = ButtonTag
+ }
diff --git a/octopod-frontend/src/Frontend/UIKit/Button/Expander.hs b/octopod-frontend/src/Frontend/UIKit/Button/Expander.hs
new file mode 100644
index 0000000..6f7d269
--- /dev/null
+++ b/octopod-frontend/src/Frontend/UIKit/Button/Expander.hs
@@ -0,0 +1,85 @@
+module Frontend.UIKit.Button.Expander
+ ( expanderButton,
+ ExpanderButtonConfig (..),
+ ExpanderButtonStyle (..),
+ ExpanderState (..),
+ ExpanderButtonType (..),
+ )
+where
+
+import Control.Lens
+import Control.Monad.Fix
+import Data.Default
+import Data.Generics.Labels ()
+import Data.Text (Text)
+import Frontend.Classes
+import Frontend.UIKit.Button.Common
+import GHC.Generics (Generic)
+import Reflex.Dom
+
+data ExpanderButtonConfig t = ExpanderButtonConfig
+ { buttonText :: Dynamic t Text
+ , buttonInitialState :: ExpanderState
+ , buttonType :: Maybe ExpanderButtonType
+ , buttonStyle :: ExpanderButtonStyle
+ }
+ deriving stock (Generic)
+
+data ExpanderState = ExpandedState | ContractedState
+ deriving stock (Eq)
+
+toggleState :: ExpanderState -> ExpanderState
+toggleState ExpandedState = ContractedState
+toggleState ContractedState = ExpandedState
+
+expanderButtonStateClasses :: ExpanderState -> Classes
+expanderButtonStateClasses ExpandedState = "expander--open"
+expanderButtonStateClasses ContractedState = mempty
+
+instance Reflex t => Default (ExpanderButtonConfig t) where
+ def =
+ ExpanderButtonConfig
+ { buttonText = ""
+ , buttonInitialState = ContractedState
+ , buttonType = Nothing
+ , buttonStyle = RegularExpanderButtonStyle
+ }
+
+data ExpanderButtonType
+ = ListingExpanderButton
+
+buttonTypeClasses :: ExpanderButtonType -> Classes
+buttonTypeClasses = \case
+ ListingExpanderButton -> "listing__more"
+
+buttonStyleClasses :: ExpanderButtonStyle -> Classes
+buttonStyleClasses RegularExpanderButtonStyle = mempty
+buttonStyleClasses StandaloneExpanderButtonStyle = "expander--stand-alone"
+
+data ExpanderButtonStyle
+ = RegularExpanderButtonStyle
+ | StandaloneExpanderButtonStyle
+
+expanderButton ::
+ (DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m) =>
+ ExpanderButtonConfig t ->
+ m (Dynamic t ExpanderState)
+expanderButton cfg = mdo
+ stateDyn <- foldDyn (\() -> toggleState) (cfg ^. #buttonInitialState) toggleEv
+ let constantClasses =
+ "expander"
+ <> maybe mempty buttonTypeClasses (cfg ^. #buttonType)
+ <> buttonStyleClasses (cfg ^. #buttonStyle)
+ toggleEv <-
+ buttonEl
+ CommonButtonConfig
+ { constantClasses = do
+ state <- stateDyn
+ pure $ constantClasses <> expanderButtonStateClasses state
+ , enabledClasses = mempty
+ , disabledClasses = mempty
+ , buttonEnabled = pure True
+ , buttonText = cfg ^. #buttonText
+ , buttonBaseTag = ButtonTag
+ }
+ pure stateDyn
diff --git a/octopod-frontend/src/Frontend/UIKit/Button/Large.hs b/octopod-frontend/src/Frontend/UIKit/Button/Large.hs
new file mode 100644
index 0000000..27e5933
--- /dev/null
+++ b/octopod-frontend/src/Frontend/UIKit/Button/Large.hs
@@ -0,0 +1,96 @@
+module Frontend.UIKit.Button.Large
+ ( largeButton,
+ LargeButtonType (..),
+ LargeButtonConfig (..),
+ LargeButtonStyle (..),
+ LargeButtonPriority (..),
+ BaseButtonTag (..),
+ )
+where
+
+import Control.Lens
+import Data.Default
+import Data.Generics.Labels ()
+import Data.Text (Text)
+import Frontend.Classes
+import Frontend.UIKit.Button.Common
+import GHC.Generics (Generic)
+import Reflex.Dom
+
+data LargeButtonConfig t = LargeButtonConfig
+ { buttonText :: Text
+ , buttonEnabled :: Dynamic t Bool
+ , buttonType :: Dynamic t (Maybe LargeButtonType)
+ , buttonPriority :: LargeButtonPriority
+ , buttonStyle :: LargeButtonStyle
+ , buttonBaseTag :: BaseButtonTag
+ }
+ deriving stock (Generic)
+
+data LargeButtonPriority = PrimaryLargeButton | SecondaryLargeButton
+
+buttonPriorityClasses :: LargeButtonPriority -> Classes
+buttonPriorityClasses PrimaryLargeButton = mempty
+buttonPriorityClasses SecondaryLargeButton = "button--secondary"
+
+data LargeButtonStyle
+ = RegularLargeButtonStyle
+ | PopupActionLargeButtonStyle
+ | DialogActionLargeButtonStyle
+ | PageActionLargeButtonStyle
+
+buttonStyleClasses :: LargeButtonStyle -> Classes
+buttonStyleClasses RegularLargeButtonStyle = mempty
+buttonStyleClasses PopupActionLargeButtonStyle = "popup__action"
+buttonStyleClasses DialogActionLargeButtonStyle = "dialog__action"
+buttonStyleClasses PageActionLargeButtonStyle = "page__action"
+
+instance Reflex t => Default (LargeButtonConfig t) where
+ def =
+ LargeButtonConfig
+ { buttonText = ""
+ , buttonEnabled = pure True
+ , buttonType = pure Nothing
+ , buttonStyle = RegularLargeButtonStyle
+ , buttonPriority = PrimaryLargeButton
+ , buttonBaseTag = ButtonTag
+ }
+
+data LargeButtonType
+ = AddLargeButtonType
+ | ArchiveLargeButtonType
+ | RestoreLargeButtonType
+ | EditLargeButtonType
+ | LogsLargeButtonType
+ | SaveLargeButtonType
+ | LoadingLargeButtonType
+
+buttonTypeClasses :: LargeButtonType -> Classes
+buttonTypeClasses AddLargeButtonType = "button--add"
+buttonTypeClasses ArchiveLargeButtonType = "button--archive"
+buttonTypeClasses RestoreLargeButtonType = "button--restore"
+buttonTypeClasses EditLargeButtonType = "button--edit"
+buttonTypeClasses LogsLargeButtonType = "button--logs"
+buttonTypeClasses SaveLargeButtonType = "button--save"
+buttonTypeClasses LoadingLargeButtonType = "button--save-loading"
+
+largeButton ::
+ (DomBuilder t m, PostBuild t m) =>
+ LargeButtonConfig t ->
+ m (Event t ())
+largeButton cfg =
+ buttonEl
+ CommonButtonConfig
+ { constantClasses = do
+ bType <- cfg ^. #buttonType
+ pure $
+ "button"
+ <> maybe mempty buttonTypeClasses bType
+ <> buttonStyleClasses (cfg ^. #buttonStyle)
+ <> buttonPriorityClasses (cfg ^. #buttonPriority)
+ , enabledClasses = mempty
+ , disabledClasses = "button--disabled"
+ , buttonEnabled = cfg ^. #buttonEnabled
+ , buttonText = pure $ cfg ^. #buttonText
+ , buttonBaseTag = cfg ^. #buttonBaseTag
+ }
diff --git a/octopod-frontend/src/Frontend/UIKit/Button/Sort.hs b/octopod-frontend/src/Frontend/UIKit/Button/Sort.hs
new file mode 100644
index 0000000..638a1ed
--- /dev/null
+++ b/octopod-frontend/src/Frontend/UIKit/Button/Sort.hs
@@ -0,0 +1,58 @@
+module Frontend.UIKit.Button.Sort
+ ( sortButton,
+ SortButtonConfig (..),
+ SortButtonState (..),
+ )
+where
+
+import Control.Lens
+import Data.Default
+import Data.Generics.Labels ()
+import Data.Text (Text)
+import Frontend.Classes
+import Frontend.UIKit.Button.Common
+import GHC.Generics (Generic)
+import Reflex.Dom
+
+data SortButtonConfig t = SortButtonConfig
+ { buttonText :: Text
+ , buttonEnabled :: Dynamic t Bool
+ , buttonState :: Dynamic t (Maybe SortButtonState)
+ }
+ deriving stock (Generic)
+
+instance Reflex t => Default (SortButtonConfig t) where
+ def =
+ SortButtonConfig
+ { buttonText = ""
+ , buttonEnabled = pure True
+ , buttonState = pure Nothing
+ }
+
+data SortButtonState
+ = SortAscButtonState
+ | SortDescButtonState
+
+buttonSortStateClasses :: SortButtonState -> Classes
+buttonSortStateClasses = \case
+ SortAscButtonState -> "sort--active sort--asc"
+ SortDescButtonState -> "sort--active sort--desc"
+
+sortButton ::
+ (DomBuilder t m, PostBuild t m) =>
+ SortButtonConfig t ->
+ m (Event t ())
+sortButton cfg =
+ buttonEl
+ CommonButtonConfig
+ { constantClasses = do
+ state <- cfg ^. #buttonState
+ pure $
+ "sort"
+ <> maybe mempty buttonSortStateClasses state
+ , enabledClasses = mempty
+ , disabledClasses = mempty
+ , buttonEnabled = cfg ^. #buttonEnabled
+ , buttonText = pure $ cfg ^. #buttonText
+ , buttonBaseTag = ButtonTag
+ }
diff --git a/octopod-frontend/src/Frontend/UIKit/Button/Static.hs b/octopod-frontend/src/Frontend/UIKit/Button/Static.hs
new file mode 100644
index 0000000..e35a9da
--- /dev/null
+++ b/octopod-frontend/src/Frontend/UIKit/Button/Static.hs
@@ -0,0 +1,71 @@
+module Frontend.UIKit.Button.Static
+ ( closeNotificationButton,
+ closeClassicPopupButton,
+ closePopupButton,
+ deleteOverrideButton,
+ undoOverrideButton,
+ )
+where
+
+import Frontend.UIKit.Button.Common
+import Reflex.Dom
+
+closeNotificationButton :: (DomBuilder t m, PostBuild t m) => m (Event t ())
+closeNotificationButton =
+ buttonEl
+ CommonButtonConfig
+ { constantClasses = pure "notification__close"
+ , enabledClasses = mempty
+ , disabledClasses = mempty
+ , buttonEnabled = pure True
+ , buttonText = pure ""
+ , buttonBaseTag = ButtonTag
+ }
+
+closeClassicPopupButton :: (DomBuilder t m, PostBuild t m) => m (Event t ())
+closeClassicPopupButton =
+ buttonEl
+ CommonButtonConfig
+ { constantClasses = pure "classic-popup__close"
+ , enabledClasses = mempty
+ , disabledClasses = mempty
+ , buttonEnabled = pure True
+ , buttonText = pure ""
+ , buttonBaseTag = ButtonTag
+ }
+
+closePopupButton :: (DomBuilder t m, PostBuild t m) => m (Event t ())
+closePopupButton =
+ buttonEl
+ CommonButtonConfig
+ { constantClasses = pure "popup__close"
+ , enabledClasses = mempty
+ , disabledClasses = mempty
+ , buttonEnabled = pure True
+ , buttonText = pure ""
+ , buttonBaseTag = ButtonTag
+ }
+
+deleteOverrideButton :: (DomBuilder t m, PostBuild t m) => m (Event t ())
+deleteOverrideButton =
+ buttonEl
+ CommonButtonConfig
+ { constantClasses = pure "overrides__delete spot spot--cancel"
+ , enabledClasses = mempty
+ , disabledClasses = mempty
+ , buttonEnabled = pure True
+ , buttonText = pure ""
+ , buttonBaseTag = ButtonTag
+ }
+
+undoOverrideButton :: (DomBuilder t m, PostBuild t m) => m (Event t ())
+undoOverrideButton =
+ buttonEl
+ CommonButtonConfig
+ { constantClasses = pure "overrides__delete spot spot--undo"
+ , enabledClasses = mempty
+ , disabledClasses = mempty
+ , buttonEnabled = pure True
+ , buttonText = pure ""
+ , buttonBaseTag = ButtonTag
+ }
diff --git a/octopod-frontend/src/Frontend/Utils.hs b/octopod-frontend/src/Frontend/Utils.hs
index 948499c..ea2b299 100644
--- a/octopod-frontend/src/Frontend/Utils.hs
+++ b/octopod-frontend/src/Frontend/Utils.hs
@@ -6,22 +6,14 @@
--frontend modules.
module Frontend.Utils
( sidebar,
- buttonClass,
- buttonClassEnabled,
wrapRequestErrors,
octopodTextInput,
deploymentPopupBody,
ClickedElement (..),
pageNotification,
- aButtonClassEnabled,
- buttonClassEnabled',
kubeDashboardUrl,
- loadingCommonWidget,
- errorCommonWidget,
- aButtonDynClass',
formatPosixToDate,
overridesWidget,
- aButtonClass',
statusWidget,
elementClick,
showT,
@@ -29,12 +21,15 @@ module Frontend.Utils
formatPosixToDateTime,
dropdownWidget,
dropdownWidget',
- buttonDynClass,
deploymentConfigProgressiveComponents,
deploymentConfigProgressive,
holdClearingWith,
unitEv,
- deploymentSection,
+ (<&&>),
+ ProgressiveFullConfig (..),
+ RequestErrorHandler,
+ deploymentOverridesWidget,
+ applicationOverridesWidget,
)
where
@@ -42,18 +37,14 @@ import Common.Types as CT
import Control.Lens
import Control.Monad
import Control.Monad.Reader
-import Data.Align
import qualified Data.Foldable as F
import Data.Functor
import Data.Generics.Labels ()
import Data.Generics.Sum
-import Data.Map (Map)
import qualified Data.Map as M
-import qualified Data.Map.Ordered.Strict as OM
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid
import Data.Text as T (Text, intercalate, null, pack)
-import Data.These
import Data.Time
import Data.UniqMap
import Data.Unique
@@ -61,6 +52,8 @@ import Data.Witherable
import Data.WorkingOverrides
import Frontend.API
import Frontend.GHCJS
+import Frontend.UIKit
+import GHC.Generics (Generic)
import GHCJS.DOM
import GHCJS.DOM.Element as DOM
import GHCJS.DOM.EventM (on, target)
@@ -162,148 +155,6 @@ sidebar showEv closeEv m = mdo
]
pure $ switchDyn $ fst <$> resultEvDyn
--- | Dark unclickable background for opened sidebar.
-popupOverlay :: DomBuilder t m => m ()
-popupOverlay =
- elAttr "div" ("class" =: "popup__overlay" <> "aria-hidden" =: "true") blank
-
--- | Button with customizable classes and label text.
-buttonClass ::
- (DomBuilder t m, PostBuild t m) =>
- -- | Classes.
- Text ->
- -- | Label text.
- Text ->
- m (Event t ())
-buttonClass cl lbl = do
- (bEl, _) <-
- elDynAttr'
- "button"
- (constDyn $ "class" =: cl <> "type" =: "button")
- $ text lbl
- return $ domEvent Click bEl
-
--- | Advanced version of 'buttonClass' with dynamic arguments.
-buttonDynClass ::
- (DomBuilder t m, PostBuild t m) =>
- -- | Classes.
- Dynamic t Text ->
- -- | Label text.
- Dynamic t Text ->
- m (Event t ())
-buttonDynClass clDyn lblDyn = do
- let attrDyn = ffor clDyn $ \cl -> "class" =: cl <> "type" =: "button"
- (bEl, _) <-
- elDynAttr' "button" attrDyn $
- dynText lblDyn
- return $ domEvent Click bEl
-
--- | Advanced version of 'buttonClass' with a disabled state.
-buttonClassEnabled ::
- (DomBuilder t m, PostBuild t m) =>
- -- | Classes.
- Text ->
- -- | Label text.
- Text ->
- -- | Enabled flag.
- Dynamic t Bool ->
- m (Event t ())
-buttonClassEnabled cl lbl dDyn = do
- let attrDyn = ffor dDyn $ \case
- True -> "class" =: cl <> "type" =: "button"
- False ->
- "class" =: (cl <> " button--disabled")
- <> "type" =: "button"
- <> "disabled" =: ""
- (bEl, _) <-
- elDynAttr' "button" attrDyn $
- text lbl
- return $ domEvent Click bEl
-
--- | Special version of 'buttonClassEnabled' that supports custom classes for
--- the disabled state.
-buttonClassEnabled' ::
- (DomBuilder t m, PostBuild t m) =>
- -- | Classes.
- Text ->
- -- | Label text.
- Text ->
- -- | Enabled flag.
- Dynamic t Bool ->
- -- | Custom classes for disabled state.
- Text ->
- m (Event t ())
-buttonClassEnabled' cl lbl dDyn disClass = do
- let attrDyn = ffor dDyn $ \case
- True -> "class" =: cl <> "type" =: "button"
- False ->
- "class" =: (cl <> " " <> disClass)
- <> "type" =: "button"
- <> "disabled" =: ""
- (bEl, _) <-
- elDynAttr' "button" attrDyn $
- text lbl
- return $ domEvent Click bEl
-
--- | Version of 'buttonClass' for links that should look like buttons.
-aButtonClass' ::
- (DomBuilder t m, PostBuild t m) =>
- -- | Classes.
- Text ->
- -- | Label text.
- Text ->
- -- | Extra attributes
- Dynamic t (Map Text Text) ->
- m (Event t ())
-aButtonClass' cl lbl eAttrs = do
- (bEl, _) <-
- elDynAttr'
- "a"
- (fmap (<> ("class" =: cl)) eAttrs)
- $ text lbl
- return $ domEvent Click bEl
-
--- | Version of 'buttonDynClass' for links that should look like
--- buttons.
-aButtonDynClass' ::
- (DomBuilder t m, PostBuild t m) =>
- -- | Classes.
- Dynamic t Text ->
- -- | Label text.
- Dynamic t Text ->
- -- | Extra attributes
- Dynamic t (Map Text Text) ->
- m (Event t ())
-aButtonDynClass' clDyn lblDyn eAttrs = do
- let attrDyn' = ffor clDyn $ \cl -> "class" =: cl
- attrDyn = (<>) <$> eAttrs <*> attrDyn'
- (bEl, _) <-
- elDynAttr' "a" attrDyn $
- dynText lblDyn
- return $ domEvent Click bEl
-
--- | Version of 'buttonClassEnabled' for links that should look like
--- buttons.
-aButtonClassEnabled ::
- (DomBuilder t m, PostBuild t m) =>
- -- | Classes.
- Text ->
- -- | Label text.
- Text ->
- -- | Enabled flag.
- Dynamic t Bool ->
- m (Event t ())
-aButtonClassEnabled cl lbl dDyn = do
- let attrDyn = ffor dDyn $ \case
- True -> "class" =: cl
- False ->
- "class" =: (cl <> " button--disabled")
- <> "disabled" =: ""
- (bEl, _) <-
- elDynAttr' "a" attrDyn $
- text lbl
- return $ domEvent Click bEl
-
-- | Formats posix seconds to date in iso8601.
formatPosixToDate :: FormatTime t => t -> Text
formatPosixToDate = pack . formatTime defaultTimeLocale (iso8601DateFormat Nothing)
@@ -332,7 +183,7 @@ statusWidget stDyn = do
octopodTextInput ::
MonadWidget t m =>
-- | Input field classes.
- Text ->
+ Classes ->
-- | Label text.
Text ->
-- | Placeholder for input field.
@@ -345,92 +196,9 @@ octopodTextInput ::
octopodTextInput clss lbl placeholder val errEv =
elClass "section" "deployment__section" $ do
elClass "h3" "deployment__sub-heading" $ text lbl
- elClass "div" "deployment__widget" $
- octopodTextInput' (pure False) clss placeholder (pure . fromMaybe "" $ val) errEv
-
--- | The only text input field that is used in project forms. This input
--- provides automatic error message hiding after user starts typing.
-octopodTextInput' ::
- MonadWidget t m =>
- -- | Disabled?
- Dynamic t Bool ->
- -- | Input field classes.
- Text ->
- -- | Placeholder for input field.
- Text ->
- -- | Possible init value.
- (Dynamic t Text) ->
- -- | Event carrying the error message.
- Event t Text ->
- m (Dynamic t Text, Dynamic t Bool)
-octopodTextInput' disabledDyn clss placeholder inValDyn' errEv = mdo
- inValDyn <- holdUniqDyn inValDyn'
- let inValEv =
- align (updated inValDyn) (updated valDyn)
- & fmapMaybe
- ( \case
- This x -> Just x
- These inV currV | inV /= currV -> Just inV
- _ -> Nothing
- )
- let inpClass = " input"
- inpErrClass = " input input--error"
- isValid <-
- holdDyn True $
- leftmost
- [ False <$ errEv
- , True <$ updated valDyn
- ]
- classDyn <-
- holdDyn (clss <> inpClass) $
- leftmost
- [ (clss <> inpErrClass) <$ errEv
- , (clss <> inpClass) <$ updated valDyn
- ]
- inVal <- sample . current $ inValDyn
- disabled <- sample . current $ disabledDyn
- valDyn <- elDynClass "div" classDyn $ do
- inp <-
- inputElement $
- def
- & initialAttributes
- .~ ( "type" =: "text"
- <> "class" =: "input__widget"
- <> "placeholder" =: placeholder
- )
- & inputElementConfig_setValue .~ inValEv
- & inputElementConfig_initialValue .~ inVal
- & inputElementConfig_elementConfig . elementConfig_initialAttributes
- %~ (if disabled then M.insert "disabled" "disabled" else id)
- & inputElementConfig_elementConfig . elementConfig_modifyAttributes
- <>~ updated
- ( do
- disabled' <- disabledDyn
- pure $
- M.singleton "disabled" $
- if disabled' then Just "disabled" else Nothing
- )
- widgetHold_ blank $
- leftmost
- [ divClass "input__output" . text <$> errEv
- , blank <$ updated valDyn
- ]
- pure $ value inp
- pure (valDyn, isValid)
-
--- | Widget with a loading spinner.
-loadingCommonWidget :: MonadWidget t m => m ()
-loadingCommonWidget =
- divClass "loading loading--enlarged loading--alternate" $
- text "Loading..."
-
--- | Widget with an error message.
-errorCommonWidget :: MonadWidget t m => m ()
-errorCommonWidget =
- divClass "null null--data" $
- divClass "null__content" $ do
- elClass "b" "null__heading" $ text "Cannot retrieve the data"
- divClass "null__message" $ text "Try to reload the page"
+ elClass "div" "deployment__widget" $ do
+ (value -> valDyn, validDyn) <- octopodTextInput' (pure []) (pure False) (pure clss) placeholder (pure . fromMaybe "" $ val) errEv
+ pure (valDyn, validDyn)
-- | Widget that can show and hide overrides if there are more than 3. This
-- widget is used in the deployments table and the deployment action table.
@@ -438,51 +206,62 @@ overridesWidget ::
MonadWidget t m =>
-- | List of overrides.
Overrides l ->
+ (Event t () -> m (Event t (DefaultConfig l))) ->
m ()
-overridesWidget (Overrides (OM.assocs -> envs)) = divClass "listing listing--for-text" $ do
- let visible = take 3 envs
- envLength = length envs
- listing visible
- when (envLength > 3) $ mdo
- let hidden = drop 3 envs
- showDyn <- toggle False toggleEv
- dyn_ $
- showDyn <&> \case
- True -> listing hidden
- False -> blank
- let btnClassDyn =
- ifThenElseDyn
- showDyn
- "listing__more expander expander--open"
- "listing__more expander"
- btnTextDyn =
- ifThenElseDyn showDyn "Hide" $
- "Show all (" <> showT envLength <> ")"
- toggleEv <- buttonDynClass btnClassDyn btnTextDyn
- blank
- where
- listing envs' = do
- forM_ envs' $ \(var, val) ->
- divClass "listing__item" $ do
- el "b" $ text $ var <> ": "
- case val of
- ValueAdded v -> text v
- ValueDeleted -> el "i" $ text ""
+overridesWidget ovs getDef = divClass "listing listing--for-text" $ mdo
+ defMDyn <- getDef firstExpand >>= holdDynMaybe
+ dyn_ $
+ expandState <&> \case
+ ExpandedState ->
+ void $
+ networkView $
+ do
+ defM <- defMDyn
+ pure $
+ showNonEditableWorkingOverride (isNothing defM) RegularNonEditableWorkingOverrideStyle $
+ elemsUniq $ constructWorkingOverrides defM ovs
+ ContractedState ->
+ let ovsList = elemsUniq $ constructWorkingOverrides Nothing ovs
+ in showNonEditableWorkingOverride False RegularNonEditableWorkingOverrideStyle $
+ take 3 ovsList
--- | @if-then-else@ helper for cases when bool value is wrapped in 'Dynamic'.
-ifThenElseDyn ::
- Reflex t =>
- -- | Condition wrapped in `Dynamic`.
- Dynamic t Bool ->
- -- | `then` branch.
- b ->
- -- | `else` branch.
- b ->
- Dynamic t b
-ifThenElseDyn bDyn t f =
- bDyn <&> \case
- True -> t
- False -> f
+ expandState <-
+ expanderButton
+ ExpanderButtonConfig
+ { buttonText = do
+ state <- expandState
+ pure $ case state of
+ ExpandedState -> "Hide"
+ ContractedState -> "Show all"
+ , buttonInitialState = ContractedState
+ , buttonType = Just ListingExpanderButton
+ , buttonStyle = RegularExpanderButtonStyle
+ }
+ firstExpand <- headE $ ($> ()) $ ffilter (== ExpandedState) $ updated expandState
+ pure ()
+
+deploymentOverridesWidget ::
+ MonadWidget t m =>
+ RequestErrorHandler t m ->
+ Overrides 'DeploymentLevel ->
+ m ()
+deploymentOverridesWidget hReq depOvs =
+ overridesWidget depOvs $ defaultDeploymentOverrides >=> hReq
+
+applicationOverridesWidget ::
+ MonadWidget t m =>
+ RequestErrorHandler t m ->
+ Overrides 'DeploymentLevel ->
+ Overrides 'ApplicationLevel ->
+ m ()
+applicationOverridesWidget hReq depOvs appOvs =
+ overridesWidget appOvs $ \fire -> do
+ depDefEv <- defaultDeploymentOverrides fire >>= hReq
+ fmap switchDyn $
+ networkHold (pure never) $
+ depDefEv <&> \depDef -> do
+ pb <- getPostBuild
+ defaultApplicationOverrides (pure $ Right $ applyOverrides depOvs depDef) pb >>= hReq
-- | Type of notification at the top of pages.
data DeploymentPageNotification
@@ -506,7 +285,7 @@ pageNotification notEv = mdo
messageClassWidget txt cl =
divClass ("page__output notification " <> cl) $ do
text txt
- buttonClass "notification__close" ""
+ closeNotificationButton
closeEv = switchDyn closeEvDyn
closeEvDyn <-
widgetHold (pure never) $
@@ -549,28 +328,25 @@ deploymentPopupBody hReq defTag defAppOv defDepOv errEv = mdo
(tagDyn, tOkEv) <- octopodTextInput "tag" "Tag" "Tag" (unDeploymentTag <$> defTag) tagErrEv
- let holdDCfg :: Dynamic t (Maybe (DefaultConfig l)) -> Overrides l -> m (Dynamic t (Overrides l))
- holdDCfg dCfgDyn ovs = mdo
+ let holdDCfg ::
+ Dynamic t [Text] ->
+ Dynamic t (Maybe (DefaultConfig l)) ->
+ Overrides l ->
+ m (Dynamic t (Overrides l))
+ holdDCfg values dCfgDyn ovs = mdo
ovsDyn <- holdDyn ovs ovsEv
x <- attachDyn (current ovsDyn) dCfgDyn
- ovsEv <- dyn (x <&> \(ovs', dCfg) -> envVarsInput dCfg ovs') >>= switchHold never >>= debounce 0.5
+ ovsEv <- dyn (x <&> \(ovs', dCfg) -> envVarsInput values dCfg ovs') >>= switchHold never >>= debounce 0.5
pure ovsDyn
- holdDKeys n keysDyn = do
- let loading = loadingCommonWidget
- deploymentSection n $
- widgetHold_ loading $
- keysDyn <&> \case
- Just keys -> el "ul" $
- forM_ keys $ \key -> el "li" $ text key
- Nothing -> loading
- deploymentOvsDyn <- deploymentSection "Deployment overrides" $ holdDCfg defDep defDepOv
- holdDKeys "Deployment keys" (Just <$> depKeys)
+ depKeysDyn <- holdDyn [] depKeys
+ deploymentOvsDyn <- deploymentSection "Deployment overrides" $ holdDCfg depKeysDyn defDep defDepOv
+
appKeys <- waitForValuePromptly depCfgEv $ \deploymentCfg -> do
pb' <- getPostBuild
applicationOverrideKeys (pure $ Right deploymentCfg) pb' >>= hReq >>= immediateNothing
- applicationOvsDyn <- deploymentSection "App overrides" $ holdDCfg defAppM defAppOv
- holdDKeys "App keys" appKeys
+ appKeysDyn <- holdDyn [] $ catMaybes appKeys
+ applicationOvsDyn <- deploymentSection "App overrides" $ holdDCfg appKeysDyn defAppM defAppOv
validDyn <- holdDyn True $ updated tOkEv
pure $
@@ -625,23 +401,31 @@ deploymentConfigProgressive ::
RequestErrorHandler t m ->
Dynamic t (Overrides 'DeploymentLevel) ->
Dynamic t (Overrides 'ApplicationLevel) ->
- m (Event t FullConfig)
+ m (Dynamic t ProgressiveFullConfig)
deploymentConfigProgressive hReq depOvsDyn appOvsDyn = do
- (_, defAppEv, depCfgEv) <- deploymentConfigProgressiveComponents hReq depOvsDyn
+ (depCfgEv, defAppEv, _) <- deploymentConfigProgressiveComponents hReq depOvsDyn
defAppMDyn <- holdDynMaybe defAppEv
- depCfgMDyn <- holdDynMaybe depCfgEv
- pure . catMaybes . updated $ do
+ defCfgMDyn <- holdDynMaybe depCfgEv
+ pure $ do
defAppM <- defAppMDyn
appOvs <- appOvsDyn
- depCfgM <- depCfgMDyn
- pure $ do
- defApp <- defAppM
- depCfg <- depCfgM
- pure
- FullConfig
- { appConfig = applyOverrides appOvs defApp
- , depConfig = depCfg
- }
+ defDepM <- defCfgMDyn
+ depOvs <- depOvsDyn
+ pure
+ ProgressiveFullConfig
+ { appConfig = constructWorkingOverrides defAppM appOvs
+ , appConfigLoading = isNothing defAppM
+ , depConfig = constructWorkingOverrides defDepM depOvs
+ , depConfigLoading = isNothing defDepM
+ }
+
+data ProgressiveFullConfig = ProgressiveFullConfig
+ { appConfig :: WorkingOverrides
+ , appConfigLoading :: Bool
+ , depConfig :: WorkingOverrides
+ , depConfigLoading :: Bool
+ }
+ deriving stock (Generic)
waitForValuePromptly :: (MonadHold t m, Adjustable t m) => Event t x -> (x -> m (Event t y)) -> m (Event t y)
waitForValuePromptly ev f = fmap switchPromptlyDyn $ networkHold (pure never) $ f <$> ev
@@ -682,65 +466,91 @@ errorHeader appErr = do
envVarsInput ::
forall l t m.
MonadWidget t m =>
+ Dynamic t [Text] ->
Maybe (DefaultConfig l) ->
-- | Initial deployment overrides.
Overrides l ->
-- | Updated deployment overrides.
m (Event t (Overrides l))
-envVarsInput dCfg ovs = mdo
+envVarsInput values dCfg ovs = mdo
envsDyn <- foldDyn appEndo (constructWorkingOverrides dCfg ovs) $ leftmost [addEv, updEv]
let addEv = clickEv $> Endo (fst . insertUniqStart newWorkingOverride)
clickEv <-
- buttonClassEnabled'
- "overrides__add dash dash--add"
- "Add an override"
- addingIsEnabled
- "dash--disabled"
+ dashButton
+ DashButtonConfig
+ { buttonText = "Add an override"
+ , buttonEnabled = addingIsEnabled
+ , buttonType = Just AddDashButtonType
+ , buttonStyle = OverridesDashButtonStyle
+ }
updEv <-
switchDyn . fmap F.fold
<$> listWithKey
(uniqMap <$> envsDyn)
- (\i x -> fmap (performUserOverrideAction (lookupDefaultConfig <$> dCfg) i) <$> envVarInput x)
+ (\i x -> fmap (performUserOverrideAction (lookupDefaultConfig <$> dCfg) i) <$> envVarInput values x)
let addingIsEnabled = all (\(WorkingOverrideKey _ x, _) -> not . T.null $ x) . elemsUniq <$> envsDyn
case dCfg of
Just _ -> pure ()
- Nothing -> loadingCommonWidget
+ Nothing -> loadingOverrides
pure . updated $ destructWorkingOverrides <$> envsDyn
-deploymentSection :: DomBuilder t m => Text -> m a -> m a
-deploymentSection n m = elClass "section" "deployment__section" $ do
- elClass "h3" "deployment__sub-heading" $ text n
- elClass "div" "deployment__widget" m
-
-- | Widget for entering a key-value pair. The updated overrides list is
-- written to the 'EventWriter'.
envVarInput ::
(MonadWidget t m) =>
+ -- | The key values to suggest to the user
+ Dynamic t [Text] ->
-- | Current variable key and value.
Dynamic t WorkingOverride ->
m (Event t UserOverrideAction)
-envVarInput val = do
- let v =
- val <&> snd <&> \case
- WorkingCustomValue x -> x
- WorkingDefaultValue x -> x
- WorkingDeletedValue (Just x) -> x
- WorkingDeletedValue Nothing -> ""
- k = val <&> \(WorkingOverrideKey _ x, _) -> x
- disabledKey = val <&> \(WorkingOverrideKey t _, _) -> t == DefaultWorkingOverrideKey
-
- divClass "overrides__item" $ do
- (keyTextDyn, _) <-
- octopodTextInput' disabledKey "overrides__key" "key" k never
- (valTextDyn, _) <-
- octopodTextInput' (pure False) "overrides__value" "value" v never
- closeEv <- buttonClass "overrides__delete spot spot--cancel" "Delete"
- pure $
- leftmost
- [ UpdateKey <$> updated keyTextDyn
- , UpdateValue <$> updated valTextDyn
- , closeEv $> DeleteOverride
- ]
+envVarInput values val = do
+ let kDyn = val <&> \(WorkingOverrideKey _ x, _) -> x
+ -- Either
+ d <-
+ eitherDyn $
+ val <&> snd <&> \case
+ WorkingCustomValue v -> Right (v, EditedOverrideFieldType)
+ WorkingDefaultValue v -> Right (v, DefaultOverrideFieldType)
+ WorkingDeletedValue v -> Left v
+ networkView >=> switchHold never $
+ d <&> \case
+ Right vtDyn -> do
+ let (vDyn, vTypeDyn) = splitDynPure vtDyn
+ (keyTextDyn, valTextDyn, closeEv) <-
+ overrideField
+ values
+ OverrideField
+ { fieldValue = kDyn
+ , fieldError = never
+ , fieldDisabled =
+ val <&> \(WorkingOverrideKey t _, _) -> t == DefaultWorkingOverrideKey
+ , fieldType =
+ val <&> \(WorkingOverrideKey t _, _) -> case t of
+ CustomWorkingOverrideKey -> EditedOverrideFieldType
+ DefaultWorkingOverrideKey -> DefaultOverrideFieldType
+ }
+ OverrideField
+ { fieldValue = vDyn
+ , fieldError = never
+ , fieldDisabled = pure False
+ , fieldType = vTypeDyn
+ }
+ pure $
+ leftmost
+ [ UpdateKey <$> updated keyTextDyn
+ , UpdateValue <$> updated valTextDyn
+ , closeEv $> DeleteOverride
+ ]
+ Left vDyn -> do
+ restoreEv <-
+ networkView >=> switchHold never $ do
+ v <- vDyn
+ k <- kDyn
+ pure $ deletedOverride k v
+ pure $
+ flip push restoreEv $ \() -> do
+ v <- sample . current $ vDyn
+ pure $ UpdateValue <$> v
data UserOverrideAction = UpdateKey !Text | UpdateValue !Text | DeleteOverride
@@ -790,3 +600,6 @@ holdClearingWith aEv clear =
unitEv :: Reflex t => Dynamic t a -> Event t ()
unitEv = fmapCheap (const ()) . updated
+
+(<&&>) :: (Functor f1, Functor f2) => f1 (f2 a) -> (a -> b) -> f1 (f2 b)
+x <&&> f = (fmap . fmap) f x
diff --git a/octopod-frontend/src/Main.hs b/octopod-frontend/src/Main.hs
index 60de8a4..e490899 100644
--- a/octopod-frontend/src/Main.hs
+++ b/octopod-frontend/src/Main.hs
@@ -18,7 +18,7 @@ import qualified Data.Text as T
import Frontend.API
import Frontend.GHCJS
import Frontend.Route
-import Frontend.Utils (errorCommonWidget, loadingCommonWidget)
+import Frontend.UIKit
import Page.Deployment
import Page.Deployments
diff --git a/octopod-frontend/src/Page/ClassicPopup.hs b/octopod-frontend/src/Page/ClassicPopup.hs
index 5651bc1..3699328 100644
--- a/octopod-frontend/src/Page/ClassicPopup.hs
+++ b/octopod-frontend/src/Page/ClassicPopup.hs
@@ -12,7 +12,8 @@ where
import Reflex.Dom
-import Frontend.Utils
+import Data.Generics.Labels ()
+import Frontend.UIKit
-- | The root function of a popup.
classicPopup ::
@@ -51,7 +52,7 @@ popupWidget m =
divClass "classic-popup__viewport" $
divClass "classic-popup__slot" $ do
(okEv, cancelEv) <- m
- closeEv <- buttonClass "classic-popup__close" "Close"
+ closeEv <- closeClassicPopupButton
pure $ (okEv, leftmost [cancelEv, closeEv])
-- | Popup that requires confirmation of deployment deletion.
@@ -65,8 +66,16 @@ confirmArchivePopup showEv txt = do
divClass "dialog dialog--archive" $ do
divClass "dialog__content" txt
divClass "dialog__footer" $ do
- okEv <- buttonClass "dialog__action button" "Archive"
+ okEv <-
+ largeButton $
+ def
+ & #buttonStyle .~~ DialogActionLargeButtonStyle
+ & #buttonText .~~ "Archive"
cancelEv <-
- buttonClass "dialog__action button--secondary button" "Cancel"
+ largeButton $
+ def
+ & #buttonStyle .~~ DialogActionLargeButtonStyle
+ & #buttonPriority .~~ SecondaryLargeButton
+ & #buttonText .~~ "Cancel"
pure (okEv, cancelEv)
classicPopup showEv body
diff --git a/octopod-frontend/src/Page/Deployment.hs b/octopod-frontend/src/Page/Deployment.hs
index 2b7c4cb..35631d7 100644
--- a/octopod-frontend/src/Page/Deployment.hs
+++ b/octopod-frontend/src/Page/Deployment.hs
@@ -19,11 +19,12 @@ import Common.Utils
import Control.Monad.Reader
import Data.Align
import Data.Generics.Labels ()
-import qualified Data.Map.Ordered.Strict as OM
import Data.Time
+import Data.UniqMap
import Frontend.API
import Frontend.GHCJS
import Frontend.Route
+import Frontend.UIKit
import Frontend.Utils
import Page.ClassicPopup
import Page.Elements.Links
@@ -117,29 +118,33 @@ deploymentHead dfiDyn sentEv =
let btnState = not $ isPending . recordedStatus $ dfi ^. field @"status"
btnEnabledDyn <- holdDyn btnState $ leftmost [False <$ btnEv, sentEv]
btnEv <-
- aButtonClassEnabled
- "page__action button button--secondary button--restore \
- \classic-popup-handler"
- "Recover from archive"
- btnEnabledDyn
+ largeButton $
+ def
+ & #buttonType .~~ pure (Just RestoreLargeButtonType)
+ & #buttonPriority .~~ SecondaryLargeButton
+ & #buttonStyle .~~ PageActionLargeButtonStyle
+ & #buttonText .~~ "Recover from archive"
+ & #buttonEnabled .~~ btnEnabledDyn
void $ restoreEndpoint (Right . coerce <$> dname) btnEv
pure (never, never)
else mdo
let btnState = not $ isPending . recordedStatus $ dfi ^. field @"status"
btnEnabledDyn <- holdDyn btnState $ not <$> sentEv
editEv <-
- buttonClassEnabled'
- "page__action button button--edit popup-handler"
- "Edit deployment"
- btnEnabledDyn
- "button--disabled"
+ largeButton $
+ def
+ & #buttonType .~~ pure (Just EditLargeButtonType)
+ & #buttonStyle .~~ PageActionLargeButtonStyle
+ & #buttonText .~~ "Edit deployment"
+ & #buttonEnabled .~~ btnEnabledDyn
archEv <-
- buttonClassEnabled'
- "page__action button button--secondary button--archive \
- \classic-popup-handler"
- "Move to archive"
- btnEnabledDyn
- "button--disabled"
+ largeButton $
+ def
+ & #buttonType .~~ pure (Just ArchiveLargeButtonType)
+ & #buttonPriority .~~ SecondaryLargeButton
+ & #buttonStyle .~~ PageActionLargeButtonStyle
+ & #buttonText .~~ "Move to archive"
+ & #buttonEnabled .~~ btnEnabledDyn
pure (R.tag (current dfiDyn) editEv, archEv)
url' <- kubeDashboardUrl dfiDyn
void . dyn $
@@ -148,10 +153,14 @@ deploymentHead dfiDyn sentEv =
blank
( \url ->
void $
- aButtonDynClass'
- "page__action button button--secondary button--logs"
- "Details"
- (pure $ "href" =: url <> "target" =: "_blank")
+ largeButton $
+ def
+ { buttonText = "Details"
+ , buttonType = pure $ Just LogsLargeButtonType
+ , buttonPriority = SecondaryLargeButton
+ , buttonStyle = PageActionLargeButtonStyle
+ , buttonBaseTag = ATag url
+ }
)
delEv <- confirmArchivePopup archEv $ do
text "Are you sure you want to archive the"
@@ -183,10 +192,7 @@ deploymentBody updEv dfiDyn = deploymentBodyWrapper $
wrapRequestErrors $ \hReq -> do
let nameDyn = dfiDyn <^.> dfiName
depDyn = dfiDyn <^.> #deployment
- cfgEv <- deploymentConfigProgressive hReq (depDyn <^.> #deploymentOverrides) (depDyn <^.> #appOverrides)
- cfgMDyn <-
- holdClearingWith cfgEv $
- leftmost [unitEv $ depDyn <^.> #deploymentOverrides, unitEv $ depDyn <^.> #appOverrides]
+ cfgDyn <- deploymentConfigProgressive hReq (depDyn <^.> #deploymentOverrides) (depDyn <^.> #appOverrides)
divClass "deployment__summary" $ do
divClass "deployment__stat" $ do
elClass "b" "deployment__param" $ text "Status"
@@ -212,47 +218,29 @@ deploymentBody updEv dfiDyn = deploymentBodyWrapper $
void $ simpleList urlsDyn renderMetadataLink
void $
networkView $
- cfgMDyn <&> \cfgM -> do
- let showVars :: Getting (Config l) FullConfig (Config l) -> _
- showVars l = case cfgM of
- Just cfg -> allEnvsWidget (pure $ cfg ^. l)
- Nothing -> loadingCommonWidget
- deploymentSection "App overrides" $ showVars #appConfig
- deploymentSection "Deployment overrides" $ showVars #depConfig
+ cfgDyn <&> \cfg -> do
+ let showVars bL l =
+ divClass "deployment__widget" $
+ showNonEditableWorkingOverride (cfg ^. bL) LargeNonEditableWorkingOverrideStyle $
+ elemsUniq (cfg ^. l)
+ deploymentSection "Deployment overrides" $ showVars #depConfigLoading #depConfig
+ deploymentSection "App overrides" $ showVars #appConfigLoading #appConfig
deploymentSection "Actions" $
divClass "table table--actions" $
- actionsTable updEv nameDyn
+ actionsTable hReq updEv nameDyn
--- | Widget that shows overrides list. It does not depend on their type.
-allEnvsWidget ::
- MonadWidget t m =>
- -- | Overrides list.
- Dynamic t (Config l) ->
- m ()
-allEnvsWidget envsDyn =
- divClass "deployment__widget" $
- divClass "listing listing--for-text listing--larger" $
- void $
- simpleList (OM.assocs . unConfig <$> envsDyn) $ \envDyn -> do
- let varDyn = fst <$> envDyn
- valDyn = snd <$> envDyn
- divClass "listing__item" $ do
- el "b" $ do
- dynText varDyn
- text ": "
- dynText valDyn
--- ^ Widget with a table of actions that can be performed on a deployment.
+-- | Widget with a table of actions that can be performed on a deployment.
-- It requests deployment data.
-- If a request fails it shows an error message,
-- otherwise it calls 'actionsTableData', passing the received data.
-
actionsTable ::
MonadWidget t m =>
+ RequestErrorHandler t m ->
-- | Event notifying about the need to update data.
Event t () ->
Dynamic t DeploymentName ->
m ()
-actionsTable updEv nameDyn = do
+actionsTable hReq updEv nameDyn = do
pb <- getPostBuild
respEv <- infoEndpoint (Right <$> nameDyn) pb
let okEv = join . fmap logs <$> fmapMaybe reqSuccess respEv
@@ -262,7 +250,7 @@ actionsTable updEv nameDyn = do
widgetHold_ actionsTableLoading $
leftmost
[ actionsTableError <$ errEv
- , actionsTableData updEv nameDyn <$> okEv
+ , actionsTableData hReq updEv nameDyn <$> okEv
]
-- | Header of the actions table.
@@ -272,8 +260,8 @@ actionsTableHead =
el "tr" $ do
el "th" $ text "Action type"
el "th" $ text "Image tag"
- el "th" $ text "App overrides"
el "th" $ text "Deployment overrides"
+ el "th" $ text "App overrides"
el "th" $ text "Exit code"
el "th" $ text "Created"
el "th" $ text "Deployment duration"
@@ -301,24 +289,25 @@ actionsTableError = do
-- It updates data every time when the supplied event fires.
actionsTableData ::
MonadWidget t m =>
+ RequestErrorHandler t m ->
-- | Event notifying about the need to update data.
Event t () ->
Dynamic t DeploymentName ->
-- | Initial logs.
[DeploymentLog] ->
m ()
-actionsTableData updEv nameDyn initLogs = do
+actionsTableData hReq updEv nameDyn initLogs = do
respEv <- infoEndpoint (Right <$> nameDyn) updEv
- let okEv = join . fmap logs <$> fmapMaybe reqSuccess respEv
+ let okEv = (>>= logs) <$> fmapMaybe reqSuccess respEv
logsDyn <- holdDyn initLogs okEv
el "tbody" $
void $
simpleList logsDyn $ \logDyn -> do
- dyn_ $ actinRow <$> logDyn
+ dyn_ $ actinRow hReq <$> logDyn
-- | Data row of the actions table.
-actinRow :: MonadWidget t m => DeploymentLog -> m ()
-actinRow DeploymentLog {..} = do
+actinRow :: RequestErrorHandler t m -> MonadWidget t m => DeploymentLog -> m ()
+actinRow hReq DeploymentLog {..} = do
el "tr" $ do
el "td" $ do
text $ actionToText action
@@ -327,8 +316,8 @@ actinRow DeploymentLog {..} = do
<> if exitCode == 0 then "status--success" else "status--failure"
divClass statusClass blank
el "td" $ text $ coerce deploymentTag
- el "td" $ overridesWidget $ deploymentAppOverrides
- el "td" $ overridesWidget $ deploymentDepOverrides
+ el "td" $ deploymentOverridesWidget hReq deploymentDepOverrides
+ el "td" $ applicationOverridesWidget hReq deploymentDepOverrides deploymentAppOverrides
el "td" $ text $ showT $ exitCode
el "td" $ text $ formatPosixToDateTime createdAt
el "td" $ text $ formatDuration duration
diff --git a/octopod-frontend/src/Page/Deployments.hs b/octopod-frontend/src/Page/Deployments.hs
index 270706e..94412e3 100644
--- a/octopod-frontend/src/Page/Deployments.hs
+++ b/octopod-frontend/src/Page/Deployments.hs
@@ -33,6 +33,7 @@ import Data.These
import Frontend.API
import Frontend.GHCJS
import Frontend.Route
+import Frontend.UIKit
import Frontend.Utils
import Page.ClassicPopup
import Page.Elements.Links
@@ -77,18 +78,19 @@ deploymentsWidget ::
[DeploymentFullInfo] ->
m ()
deploymentsWidget updAllEv dfis = do
- (showNewDeploymentEv, editEv) <- deploymentsWidgetWrapper $ mdo
- pageNotification $
- leftmost
- [ DPMError
- "Deployment list update failed, deployment list\
- \ may be slightly outdated."
- <$ errUpdEv
- , DPMClear <$ okUpdEv
- ]
- (showNewDeploymentEv', termDyn) <- deploymentsHeadWidget True okUpdEv
- (okUpdEv, errUpdEv, editEv) <- deploymentsListWidget updAllEv termDyn dfis
- pure (showNewDeploymentEv', editEv)
+ (showNewDeploymentEv, editEv) <- deploymentsWidgetWrapper $
+ wrapRequestErrors $ \hReq -> mdo
+ pageNotification $
+ leftmost
+ [ DPMError
+ "Deployment list update failed, deployment list\
+ \ may be slightly outdated."
+ <$ errUpdEv
+ , DPMClear <$ okUpdEv
+ ]
+ (showNewDeploymentEv', termDyn) <- deploymentsHeadWidget True okUpdEv
+ (okUpdEv, errUpdEv, editEv) <- deploymentsListWidget hReq updAllEv termDyn dfis
+ pure (showNewDeploymentEv', editEv)
void $ newDeploymentPopup showNewDeploymentEv never
void $ editDeploymentPopup editEv never
@@ -172,12 +174,13 @@ deploymentsListWidget ::
, SetRoute t (R Routes) m
, MonadReader ProjectConfig m
) =>
+ RequestErrorHandler t m ->
Event t () ->
Dynamic t Text ->
-- | Initial deployment data
[DeploymentFullInfo] ->
m (Event t (), Event t (), Event t DeploymentFullInfo)
-deploymentsListWidget updAllEv termDyn ds = dataWidgetWrapper $ mdo
+deploymentsListWidget hReq updAllEv termDyn ds = dataWidgetWrapper $ mdo
retryEv <- delay 10 errUpdEv
updRespEv <- listEndpoint $ leftmost [updAllEv, () <$ retryEv]
let okUpdEv = fmapMaybe reqSuccess updRespEv
@@ -192,8 +195,8 @@ deploymentsListWidget updAllEv termDyn ds = dataWidgetWrapper $ mdo
<$> filteredDyn
searchSorting = termDyn $> Just (SortDesc (view #score))
clickedEv <- elementClick
- editEv <- activeDeploymentsWidget searchSorting clickedEv activeDsDyn
- archivedDeploymentsWidget searchSorting clickedEv archivedDsDyn
+ editEv <- activeDeploymentsWidget hReq searchSorting clickedEv activeDsDyn
+ archivedDeploymentsWidget hReq searchSorting clickedEv archivedDsDyn
pure (() <$ okUpdEv, () <$ errUpdEv, editEv)
data SearchedDeploymentFullInfo = SearchedDeploymentFullInfo
@@ -235,6 +238,7 @@ activeDeploymentsWidget ::
, SetRoute t (R Routes) m
, MonadReader ProjectConfig m
) =>
+ RequestErrorHandler t m ->
Dynamic t (Maybe (SortDir SearchedDeploymentFullInfo)) ->
-- | Event that carries the clicked DOM element. This event is required by
-- `dropdownWidget'`.
@@ -243,7 +247,7 @@ activeDeploymentsWidget ::
-- | Returns an event carrying editable deployment
-- to \"edit deployment\" sidebar.
m (Event t DeploymentFullInfo)
-activeDeploymentsWidget searchSorting clickedEv dsDyn =
+activeDeploymentsWidget hReq searchSorting clickedEv dsDyn =
divClass "data__primary" $
tableWrapper (updated searchSorting $> SortingChanged) $ \sortDyn -> do
let colSortDyn = fmap (contramap (view #deployment)) <$> sortDyn
@@ -255,7 +259,7 @@ activeDeploymentsWidget searchSorting clickedEv dsDyn =
dyn $
emptyDyn <&> \case
False -> do
- editEvs <- simpleList dsSortedDyn (activeDeploymentWidget clickedEv)
+ editEvs <- simpleList dsSortedDyn (activeDeploymentWidget hReq clickedEv)
pure $ switchDyn $ leftmost <$> editEvs
True -> do
emptyTableBody $ noDeploymentsWidget
@@ -275,6 +279,7 @@ activeDeploymentWidget ::
, SetRoute t (R Routes) m
, MonadReader ProjectConfig m
) =>
+ RequestErrorHandler t m ->
-- | Event that carries the clicked DOM element. This event is required by
-- `dropdownWidget'`.
Event t ClickedElement ->
@@ -282,7 +287,7 @@ activeDeploymentWidget ::
-- | Returns event carrying editable deployment
-- that is required by \"edit deployment\" sidebar.
m (Event t DeploymentFullInfo)
-activeDeploymentWidget clickedEv dDyn' = do
+activeDeploymentWidget hReq clickedEv dDyn' = do
dDyn <- holdUniqDyn dDyn'
editEvEv <- dyn $
ffor dDyn $ \s@SearchedDeploymentFullInfo {deployment = d@DeploymentFullInfo {..}} -> do
@@ -297,9 +302,12 @@ activeDeploymentWidget clickedEv dDyn' = do
forM_ (unDeploymentMetadata metadata) (renderMetadataLink . pure)
el "td" tag'
el "td" $
- overridesWidget $ deployment ^. field @"appOverrides" . coerced
+ deploymentOverridesWidget hReq (deployment ^. field @"deploymentOverrides" . coerced)
el "td" $
- overridesWidget $ deployment ^. field @"deploymentOverrides" . coerced
+ applicationOverridesWidget
+ hReq
+ (deployment ^. field @"deploymentOverrides" . coerced)
+ (deployment ^. field @"appOverrides" . coerced)
el "td" $
text $ formatPosixToDate createdAt
el "td" $
@@ -316,8 +324,18 @@ activeDeploymentWidget clickedEv dDyn' = do
)
$ text "Actions"
body = do
- btnEditEv <- buttonClassEnabled' "action action--edit" "Edit" (pure enabled) "action--disabled"
- btnArcEv <- buttonClassEnabled' "action action--archive" "Move to archive" (pure enabled) "action--disabled"
+ btnEditEv <-
+ actionButton $
+ def
+ & #buttonText .~~ "Edit"
+ & #buttonEnabled .~~ pure enabled
+ & #buttonType .~~ Just EditActionButtonType
+ btnArcEv <-
+ actionButton $
+ def
+ & #buttonText .~~ "Move to archive"
+ & #buttonEnabled .~~ pure enabled
+ & #buttonType .~~ Just ArchiveActionButtonType
url' <- kubeDashboardUrl (view #deployment <$> dDyn)
void . dyn $
url'
@@ -325,10 +343,12 @@ activeDeploymentWidget clickedEv dDyn' = do
blank
( \url ->
void $
- aButtonClass'
- "action action--logs"
- "Details"
- (pure $ "href" =: url <> "target" =: "_blank")
+ actionButton
+ def
+ { buttonText = "Details"
+ , buttonType = Just LogsActionButtonType
+ , buttonBaseTag = ATag url
+ }
)
pure $
leftmost
@@ -370,13 +390,14 @@ archivedDeploymentsWidget ::
( MonadWidget t m
, SetRoute t (R Routes) m
) =>
+ RequestErrorHandler t m ->
Dynamic t (Maybe (SortDir SearchedDeploymentFullInfo)) ->
-- | Event that carries the clicked DOM element. This event is required by
-- `dropdownWidget'`.
Event t ClickedElement ->
Dynamic t [SearchedDeploymentFullInfo] ->
m ()
-archivedDeploymentsWidget searchSorting clickedEv dsDyn = do
+archivedDeploymentsWidget hReq searchSorting clickedEv dsDyn = do
showDyn <- toggleButton
let classDyn = ffor showDyn $ \case
True -> "data__archive data__archive--open"
@@ -394,7 +415,7 @@ archivedDeploymentsWidget searchSorting clickedEv dsDyn = do
void $
simpleList
dsSortedDyn
- (archivedDeploymentWidget clickedEv)
+ (archivedDeploymentWidget hReq clickedEv)
True -> emptyTableBody $ noDeploymentsWidget
-- | Row with archived deployment.
@@ -402,10 +423,11 @@ archivedDeploymentWidget ::
( MonadWidget t m
, SetRoute t (R Routes) m
) =>
+ RequestErrorHandler t m ->
Event t ClickedElement ->
Dynamic t SearchedDeploymentFullInfo ->
m ()
-archivedDeploymentWidget clickedEv dDyn' = do
+archivedDeploymentWidget hReq clickedEv dDyn' = do
dDyn <- holdUniqDyn dDyn'
dyn_ $
ffor dDyn $ \s@SearchedDeploymentFullInfo {deployment = DeploymentFullInfo {..}} -> do
@@ -418,9 +440,12 @@ archivedDeploymentWidget clickedEv dDyn' = do
el "td" $ text "..."
el "td" tag'
el "td" $
- overridesWidget $ deployment ^. field @"appOverrides" . coerced
+ deploymentOverridesWidget hReq (deployment ^. field @"deploymentOverrides" . coerced)
el "td" $
- overridesWidget $ deployment ^. field @"deploymentOverrides" . coerced
+ applicationOverridesWidget
+ hReq
+ (deployment ^. field @"deploymentOverrides" . coerced)
+ (deployment ^. field @"appOverrides" . coerced)
el "td" $
text $ formatPosixToDate createdAt
el "td" $
@@ -435,12 +460,12 @@ archivedDeploymentWidget clickedEv dDyn' = do
<> "id" =: elId
)
$ text "Actions"
- body = do
- btnArcEv <-
- buttonClass
- "action action--archive"
- "Restore from archive"
- pure btnArcEv
+ body =
+ actionButton
+ def
+ { buttonText = "Restore from archive"
+ , buttonType = Just ArchiveActionButtonType
+ }
btnEv <- dropdownWidget' clickedEv btn body
void $ restoreEndpoint (constDyn $ Right $ dName) btnEv
let route = DashboardRoute :/ Just dName
@@ -485,8 +510,8 @@ tableHeader = do
sortHeader (view dfiName) "Name" SortAsc
el "th" $ text "Links"
el "th" $ text "Tag"
- el "th" $ text "App overrides"
el "th" $ text "Deployment overrides"
+ el "th" $ text "App overrides"
sortHeader (view $ field @"createdAt") "Created" SortDesc
sortHeaderInitially (view $ field @"updatedAt") "Changed" SortDesc
el "th" $
@@ -570,13 +595,16 @@ sortHeaderWithInitial f l defaultSorting initSortingM = do
sortBtnEv
sortingChanged
tellMultiEvent . fmapMaybe id $ updated sortDyn
- let classDyn =
- fmap ("sort " <>) $
- sortDyn <&> \case
- Just (SortDesc _) -> "sort--active sort--desc"
- Just (SortAsc _) -> "sort--active sort--asc"
- Nothing -> ""
- sortBtnEv <- buttonDynClass classDyn (pure l)
+ sortBtnEv <-
+ sortButton $
+ def
+ & #buttonText .~~ l
+ & #buttonState
+ .~~ ( sortDyn <&&> \case
+ SortDesc _ -> SortDescButtonState
+ SortAsc _ -> SortAscButtonState
+ )
+
tellMultiEvent $ sortBtnEv $> SortingChanged
pure ()
diff --git a/octopod-frontend/src/Page/Popup/EditDeployment.hs b/octopod-frontend/src/Page/Popup/EditDeployment.hs
index 4ef5af8..14fd0e2 100644
--- a/octopod-frontend/src/Page/Popup/EditDeployment.hs
+++ b/octopod-frontend/src/Page/Popup/EditDeployment.hs
@@ -16,8 +16,10 @@ import Prelude as P
import Common.Types
import Common.Utils
+import Data.Generics.Labels ()
import Data.Maybe
import Frontend.API
+import Frontend.UIKit
import Frontend.Utils
import Reflex.Network
import Servant.Reflex
@@ -34,7 +36,7 @@ editDeploymentPopup ::
editDeploymentPopup showEv hideEv = sidebar showEv hideEv $ \dfi -> mdo
divClass "popup__body" $ mdo
let dname = dfi ^. dfiName
- (closeEv', saveEv) <- editDeploymentPopupHeader dname enabledDyn
+ (closeEv', saveEv) <- editDeploymentPopupHeader dname enabledDyn sentDyn
deploymentMDyn <- editDeploymentPopupBody dfi respEv
respEv <-
holdDyn (pure never) >=> networkView >=> switchHold never $
@@ -64,15 +66,27 @@ editDeploymentPopupHeader ::
DeploymentName ->
-- | Form validation state.
Dynamic t Bool ->
+ -- | Loading
+ Dynamic t Bool ->
-- | \"Close\" event and \"Save\" click event.
m (Event t (), Event t ())
-editDeploymentPopupHeader dname validDyn =
+editDeploymentPopupHeader dname validDyn loadingDyn =
divClass "popup__head" $ do
- closeEv <- buttonClass "popup__close" "Close popup"
+ closeEv <- closePopupButton
elClass "h2" "popup__project" $ text $ "Edit " <> coerce dname
saveEv <-
divClass "popup__operations" $
- buttonClassEnabled "popup__action button button--save" "Save" validDyn
+ largeButton $
+ def
+ & #buttonStyle .~~ PopupActionLargeButtonStyle
+ & #buttonText .~~ "Save"
+ & #buttonEnabled .~~ validDyn
+ & #buttonType
+ .~~ ( loadingDyn <&> \case
+ False -> Just SaveLargeButtonType
+ True -> Just LoadingLargeButtonType
+ )
+
divClass "popup__menu drop drop--actions" blank
pure (closeEv, saveEv)
diff --git a/octopod-frontend/src/Page/Popup/NewDeployment.hs b/octopod-frontend/src/Page/Popup/NewDeployment.hs
index 97ce0b1..51d732a 100644
--- a/octopod-frontend/src/Page/Popup/NewDeployment.hs
+++ b/octopod-frontend/src/Page/Popup/NewDeployment.hs
@@ -18,6 +18,7 @@ import Common.Types
import Common.Validation (isNameValid)
import Data.Maybe
import Frontend.API
+import Frontend.UIKit
import Frontend.Utils
import Reflex.Network
import Servant.Reflex
@@ -34,7 +35,7 @@ newDeploymentPopup showEv hideEv = void $
sidebar showEv hideEv $
const $ mdo
divClass "popup__body" $ mdo
- (closeEv', saveEv) <- newDeploymentPopupHeader enabledDyn
+ (closeEv', saveEv) <- newDeploymentPopupHeader enabledDyn sentDyn
deploymentMDyn <- newDeploymentPopupBody respEv
respEv <-
holdDyn (pure never) >=> networkView >=> switchHold never $
@@ -59,14 +60,25 @@ newDeploymentPopup showEv hideEv = void $
newDeploymentPopupHeader ::
MonadWidget t m =>
Dynamic t Bool ->
+ -- | Loading
+ Dynamic t Bool ->
m (Event t (), Event t ())
-newDeploymentPopupHeader enabledDyn =
+newDeploymentPopupHeader enabledDyn loadingDyn =
divClass "popup__head" $ do
- closeEv <- buttonClass "popup__close" "Close popup"
+ closeEv <- closePopupButton
elClass "h2" "popup__project" $ text "Create new deployment"
saveEv <-
divClass "popup__operations" $
- buttonClassEnabled "popup__action button button--save" "Save" enabledDyn
+ largeButton $
+ def
+ & #buttonStyle .~~ PopupActionLargeButtonStyle
+ & #buttonText .~~ "Save"
+ & #buttonEnabled .~~ enabledDyn
+ & #buttonType
+ .~~ ( loadingDyn <&> \case
+ False -> Just SaveLargeButtonType
+ True -> Just LoadingLargeButtonType
+ )
divClass "popup__menu drop drop--actions" blank
pure (closeEv, saveEv)