git.iko.soy/typeable/octopod
on master help sign in
Client config support (#56)
commit40a311bb36f42f2afc85fa66b9a703c13abc082e authorNikita <anisimoff.nikita@gmail.com> dateMon 6 Jul 2020, 10:31 (6 years ago) parentfb4c2bc
6 files changed+129−19
compare with master
unifiedsplit
.gitignore+2 Caddyfile+4−2 dm-frontend/dm-frontend.cabal+3 dm-frontend/src/Frontend/API.hs+13−14 dm-frontend/src/Frontend/GHCJS.hs+62 dm-frontend/src/Main.hs+45−3
.gitignore+2
@@ -5,3 +5,5 @@ result
55dms-docker
66*~
77dist-newstyle
8+dm-config.json
9+frontend-result
Caddyfile+4−2
@@ -28,13 +28,15 @@ proxy /api localhost:3002 {
2828 transparent
2929}
3030
31+mime .json application/json
32+rewrite /config.json /dm-config.json
33+
3134rewrite /ghcjs /frontend-result/bin/frontend.jsexe/index.html
3235
3336proxy / localhost:3003 {
3437 transparent
3538 websocket
36− except /dm-css/ /frontend-result/
39+ except /dm-css/ /frontend-result/ /dm-config.json
3740}
3841
39−
4042log / stdout
dm-frontend/dm-frontend.cabal+3
@@ -25,6 +25,7 @@ executable frontend
2525 cpp-options: -DDEVELOPMENT
2626 main-is: Main.hs
2727 other-modules: Frontend.API
28+ , Frontend.GHCJS
2829 , Frontend.Route
2930 , Page.ClassicPopup
3031 , Page.Deployment
@@ -61,8 +62,10 @@ executable frontend
6162 , base >=4.12 && <4.13
6263 , bytestring
6364 , containers
65+ , deriving-aeson
6466 , dependent-sum
6567 , dm-common
68+ , exceptions
6669 , generic-lens
6770 , ghcjs-dom
6871 , jsaddle
dm-frontend/src/Frontend/API.hs+13−14
@@ -14,30 +14,29 @@ import Servant.Reflex as SR
1414
1515import Common.API
1616import Common.Types
17+import Frontend.GHCJS
1718
1819
1920apiClients
2021 :: forall t m. MonadWidget t m
2122 => SR.Client t m API ()
22−apiClients = clientWithOpts
23− (Proxy @API)
24− (Proxy @m)
25− (Proxy @())
26− (constDyn host)
27− tweakRequest
23+apiClients =
24+ clientWithOpts
25+ (Proxy @API)
26+ (Proxy @m)
27+ (Proxy @())
28+ (constDyn host)
29+ tweakRequest
2830 where
29− tweakRequest = ClientOptions $ \req ->
31+ tweakRequest = ClientOptions $ \req -> do
32+ url <- getAppUrl
33+ auth <- getAppAuth
3034 pure $ req
3135 & xhrRequest_config
3236 . xhrRequestConfig_headers
3337 . at "Authorization" ?~ auth
34−#ifdef DEVELOPMENT
35− host = SR.BaseFullUrl SR.Https "dm-genfly-app.stage.thebestagent.pro" 443 "/"
36− auth = "Basic dWk6cVoxZGRKMHZpWkRMbXlKaG5JNVh1QnZMQnZ3MkMwUVBqOTRaZ0VwOQ=="
37−#else
38− host = SR.BaseFullUrl SR.Https "dm-genfly-app.stage.thebestagent.pro" 443 "/"
39− auth = "Basic dWk6cVoxZGRKMHZpWkRMbXlKaG5JNVh1QnZMQnZ3MkMwUVBqOTRaZ0VwOQ=="
40−#endif
38+ & xhrRequest_url %~ (T.replace "#PLACEHOLDER#" url)
39+ host = SR.BaseFullUrl SR.Https "#PLACEHOLDER#" 443 "/"
4140
4241
4342listEndpoint
dm-frontend/src/Frontend/GHCJS.hsnew file+62
@@ -0,0 +1,62 @@
1+module Frontend.GHCJS where
2+
3+import Data.Aeson as A (Value, fromJSON, Result(..))
4+import Control.Monad.Catch
5+import Data.Text as T (pack, Text)
6+import Deriving.Aeson.Stock
7+import GHCJS.DOM
8+import GHCJS.DOM.Response
9+import GHCJS.DOM.Storage
10+import GHCJS.DOM.Types
11+import GHCJS.DOM.Window
12+
13+appUrlKey, wsUrlKey, appAuthKey :: JSString
14+appUrlKey = "app"
15+wsUrlKey = "ws"
16+appAuthKey = "auth"
17+
18+data ProjectConfig = ProjectConfig
19+ { appUrl :: String
20+ , wsUrl :: String
21+ , appAuth :: String }
22+ deriving (Generic, Show, Eq)
23+ deriving (FromJSON, ToJSON) via Snake ProjectConfig
24+
25+data BadConfig = BadConfig
26+ deriving (Show)
27+
28+instance Exception BadConfig
29+
30+initConfig' :: JSM ()
31+initConfig' = do
32+ w <- currentWindowUnchecked
33+ resp <- fetch w ("/config.json" :: JSString) Nothing
34+ jsonVal <- json resp
35+ val :: A.Value <- fromJSValUnchecked jsonVal
36+ let mcfg = fromJSON val
37+ case mcfg of
38+ A.Success cfg -> do
39+ stor <- getSessionStorage w
40+ setItem stor appUrlKey $ appUrl cfg
41+ setItem stor wsUrlKey $ wsUrl cfg
42+ setItem stor appAuthKey $ appAuth cfg
43+ A.Error _ -> throwM BadConfig
44+
45+initConfig :: MonadJSM m => m Bool
46+initConfig = liftJSM $ catchAll (initConfig' >> pure True) (const $ pure False)
47+
48+getVar :: MonadJSM m => JSString -> m T.Text
49+getVar k = do
50+ w <- currentWindowUnchecked
51+ stor <- getSessionStorage w
52+ x <- getItemUnsafe stor k
53+ pure $ pack x
54+
55+getAppUrl :: MonadJSM m => m T.Text
56+getAppUrl = getVar appUrlKey
57+
58+getAppAuth :: MonadJSM m => m T.Text
59+getAppAuth = getVar appAuthKey
60+
61+getWsUrl :: MonadJSM m => m T.Text
62+getWsUrl = getVar wsUrlKey
dm-frontend/src/Main.hs+45−3
@@ -10,11 +10,30 @@ import Frontend.API
1010import Frontend.Route
1111import Page.Deployment
1212import Page.Deployments
13+import Frontend.GHCJS
14+
15+import Data.Text (pack)
1316
1417main :: IO ()
1518main = mainWidgetWithHead headWidget $ do
16− headerWidget
17− routeWidget
19+ initConfigWidget
20+
21+
22+initConfigWidget :: (MonadWidget t m, Prerender js t m) => m ()
23+initConfigWidget = do
24+ pb <- getPostBuild
25+ x <- performEvent (initConfig <$ pb)
26+ widgetHold_ loadingWidget $ leftmost
27+ [ (headerWidget >> routeWidget) <$ ffilter id x
28+ , errorWidget <$ ffilter not x ]
29+
30+tstW :: MonadWidget t m => m ()
31+tstW = do
32+ pb <- getPostBuild
33+ x <- performEvent (initConfig <$ pb)
34+ xd <- holdDyn False x
35+ dynText $ pack . show <$> xd
36+ blank
1837
1938wsUpdate :: forall t m . MonadWidget t m => m (Event t ())
2039wsUpdate = do
@@ -25,7 +44,8 @@ wsUpdate = do
2544 , _webSocketConfig_reconnect = True
2645 , _webSocketConfig_protocols = []
2746 }
28− ws <- webSocket "wss://dm-genfly-ws.stage.thebestagent.pro/event" wsConfig
47+ wsUrl <- getWsUrl
48+ ws <- webSocket wsUrl wsConfig
2949 pure $ () <$ _webSocket_recv ws
3050
3151routeWidget
@@ -74,3 +94,25 @@ headerWidget =
7494 respEv <- projectName pb
7595 nameDyn <- holdDyn "" $ uProjectName <$> fmapMaybe reqSuccess respEv
7696 dynText nameDyn
97+
98+emptyHeaderWidget :: MonadWidget t m => m ()
99+emptyHeaderWidget =
100+ elClass "header" "header" $
101+ divClass "header__wrap container" $ do
102+ elClass "b" "header__logo" $
103+ text "Deployment Manager"
104+ elClass "div" "header__project" blank
105+
106+loadingWidget :: MonadWidget t m => m ()
107+loadingWidget =
108+ divClass "no-page" $
109+ divClass "no-page__inner" $
110+ divClass "loading loading--enlarged loading--alternate" blank
111+
112+errorWidget :: MonadWidget t m => m ()
113+errorWidget =
114+ divClass "no-page" $
115+ divClass "no-page__inner" $
116+ divClass "null null--data" $ do
117+ elClass "b" "null__heading" $ text "Cannot retrieve the data"
118+ divClass "null__message" $ text "Try to reload page"