87caa3e · typeable/octopod

git.iko.soy/typeable/octopod

Client routing (#42)

commit87caa3e896c8c1fe6330217367eb929493e823cd authorNikita <anisimoff.nikita@gmail.com> dateMon 29 Jun 2020, 15:14 (6 years ago) parent69cb3f4

6 files changed+107−9

compare with master

unifiedsplit

default.nix+3 dm-frontend/dm-frontend.cabal+4 dm-frontend/src/Frontend/Route.hs+36 dm-frontend/src/Main.hs+15−2 dm-frontend/src/Page/Deployments.hs+37−7 nix/sources.json+12

default.nix+3

@@ -22,6 +22,9 @@

2222 amazonka-test = hsuper.callPackage nix/amazonka-test-1.6.1.nix {};

2323 deriving-aeson = hsuper.callCabal2nix "deriving-aeson" sources.deriving-aeson { };

2424 servant-reflex = hsuper.callCabal2nix "servant-reflex" sources.servant-reflex { };

25+ tabulation = hsuper.callCabal2nix "tabulation" "${sources.obelisk}/lib/tabulation" { };

26+ obelisk-executable-config-lookup = hsuper.callCabal2nix "obelisk-executable-config-lookup" "${sources.obelisk}/lib/executable-config/lookup" { };

27+ obelisk-route = hsuper.callCabal2nix "obelisk-route" "${sources.obelisk}/lib/route" { };

2528 servant = pkgs.haskell.lib.overrideCabal hsuper.servant (old: {

2629 postInstall = "";

2730 });

dm-frontend/dm-frontend.cabal+4

@@ -25,6 +25,7 @@ executable frontend

2525 cpp-options: -DDEVELOPMENT

2626 main-is: Main.hs

2727 other-modules: Frontend.API

28+ , Frontend.Route

2829 , Page.Deployments

2930 , Page.NewStagingPopup

3031 , Page.Utils

@@ -39,6 +40,7 @@ executable frontend

3940 , DeriveGeneric

4041 , DerivingVia

4142 , DuplicateRecordFields

43+ , GADTs

4244 , FlexibleContexts

4345 , GeneralizedNewtypeDeriving

4446 , LambdaCase

@@ -56,11 +58,13 @@ executable frontend

5658 , base >=4.12 && <4.13

5759 , bytestring

5860 , containers

61+ , dependent-sum

5962 , dm-common

6063 , generic-lens

6164 , ghcjs-dom

6265 , jsaddle

6366 , lens

67+ , obelisk-route

6468 , reflex-dom

6569 , reflex-dom-helpers

6670 , regex-tdfa

dm-frontend/src/Frontend/Route.hsnew file+36

@@ -0,0 +1,36 @@

1+{-# LANGUAGE GADTs #-}

2+{-# LANGUAGE RankNTypes #-}

3+{-# LANGUAGE TemplateHaskell #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# OPTIONS_GHC -fno-warn-orphans #-}

8+module Frontend.Route where

10+import Control.Category ((.))

11+import Control.Lens (makeWrapped)

12+import Data.Text (Text)

13+import Data.Functor.Identity

14+import Obelisk.Route

15+import Obelisk.Route.TH

16+import Prelude hiding ((.))

17+

18+import Common.Types

19+

20+makeWrapped ''DeploymentName

21+

22+data Routes :: * -> * where

23+ DashboardRoute :: Routes (Maybe DeploymentName)

24+deriving instance Show (Routes a)

25+

26+concat <$> mapM deriveRouteComponent

27+ [ ''Routes

28+ ]

29+

30+routeEncoder

31+ :: Encoder (Either Text) Identity (R Routes) PageName

32+routeEncoder = handleEncoder (const (DashboardRoute :/ Nothing)) $

33+ pathComponentEncoder $ \case

34+ DashboardRoute -> PathSegment "stagings"

35+ $ maybeEncoder (unitEncoder mempty)

36+ $ singlePathSegmentEncoder . unwrappedEncoder

dm-frontend/src/Main.hs+15−2

@@ -1,14 +1,27 @@

11module Main where

3+import Obelisk.Route.Frontend

34import Reflex.Dom

6+import Frontend.Route

57import Page.Deployments

7−

89main :: IO ()

910main = mainWidgetWithHead headWidget $

10− deploymentsPage

11+ routeWidget

1112

13+routeWidget :: MonadWidget t m => m ()

14+routeWidget = do

15+ let Right encoder = checkEncoder routeEncoder

16+ pb <- getPostBuild

17+ runRouteViewT encoder pb True $ mdo

18+ subRoute_ $ \case

19+ DashboardRoute -> do

20+ r <- askRoute

21+ dyn_ $ ffor r $ \case

22+ Nothing -> deploymentsPage

23+ Just _ -> blank

24+ blank

1225

1326headWidget :: DomBuilder t m => m ()

1427headWidget = do

dm-frontend/src/Page/Deployments.hs+37−7

@@ -11,15 +11,22 @@ import Data.Map as M (Map, fromList, partition, toList)

1111import Data.Text as T (pack)

1212import Data.Time

1313import Data.Time.Clock.POSIX

14+import Obelisk.Route.Frontend

1415import Reflex.Dom

1516import Servant.Reflex

1617

1718import Common.Types as CT

1819import Frontend.API

20+import Frontend.Route

1921import Page.NewStagingPopup

2022import Page.Utils

2123

22−deploymentsPage :: MonadWidget t m => m ()

24+deploymentsPage

25+ ::

26+ ( MonadWidget t m

27+ , RouteToUrl (R Routes) m

28+ , SetRoute t (R Routes) m )

29+ => m ()

2330deploymentsPage = do

2431 headWidget

2532 deploymentsWidget

@@ -41,7 +48,12 @@ deploymentsWidgetWrapper m =

4148 divClass "page" $

4249 divClass "page__wrap container" m

4350

44−deploymentsWidget :: forall t m . MonadWidget t m => m ()

51+deploymentsWidget

52+ ::

53+ ( MonadWidget t m

54+ , RouteToUrl (R Routes) m

55+ , SetRoute t (R Routes) m )

56+ => m ()

4557deploymentsWidget = do

4658 showNewStagingEv <- deploymentsWidgetWrapper $ mdo

4759 showNewStagingEv' <- deploymentsHeadWidget

@@ -67,7 +79,12 @@ deploymentsHeadWidget =

6779 text "New staging"

6880 pure $ domEvent Click nsEl

6981

70−initDeploymentsListWidget :: forall t m . MonadWidget t m => m ()

82+initDeploymentsListWidget

83+ ::

84+ ( MonadWidget t m

85+ , RouteToUrl (R Routes) m

86+ , SetRoute t (R Routes) m )

87+ => m ()

7188initDeploymentsListWidget = dataWidgetWrapper $ do

7289 pb <- getPostBuild

7390 respEv <- listEndpoint pb

@@ -90,7 +107,12 @@ wsUpdate = do

90107 ws <- webSocket "wss://dm-genfly-ws.stage.thebestagent.pro/event" wsConfig

91108 pure $ () <$ _webSocket_recv ws

92109

93−deploymentsListWidget :: forall t m . MonadWidget t m => [DeploymentFullInfo] -> m ()

110+deploymentsListWidget

111+ ::

112+ ( MonadWidget t m

113+ , RouteToUrl (R Routes) m

114+ , SetRoute t (R Routes) m )

115+ => [DeploymentFullInfo] -> m ()

94116deploymentsListWidget ds = mdo

95117 updAllEv <- wsUpdate

96118 updRespEv <- listEndpoint updAllEv

@@ -122,7 +144,10 @@ flatDynMapDyn x =

122144 f (k, d) = (k,) <$> d

123145

124146activeDeploymentsWidget

125− :: MonadWidget t m

147+ ::

148+ ( MonadWidget t m

149+ , RouteToUrl (R Routes) m

150+ , SetRoute t (R Routes) m )

126151 => Event t ClickedElement

127152 -> Dynamic t

128153 (Map DeploymentName (DeploymentFullInfo, Event t DeploymentStatus))

@@ -148,7 +173,10 @@ statusWidget dsEv = do

148173 CT.Error -> divClass "status status--failure" $ text "Failure"

149174

150175activeDeploymentWidget

151− :: MonadWidget t m

176+ ::

177+ ( MonadWidget t m

178+ , RouteToUrl (R Routes) m

179+ , SetRoute t (R Routes) m )

152180 => Event t ClickedElement

153181 -> DeploymentName

154182 -> Dynamic t (DeploymentFullInfo, Event t DeploymentStatus)

@@ -157,7 +185,7 @@ activeDeploymentWidget clickedEv dname dDyn' = do

157185 dDyn <- holdUniqDyn $ fst <$> dDyn'

158186 let wstDyn = switchDyn $ snd <$> dDyn'

159187 dyn_ $ ffor dDyn $ \DeploymentFullInfo{..} -> do

160− el "tr" $ do

188+ (linkEl, _) <- el' "tr" $ do

161189 el "td" $ do

162190 text $ coerce dname

163191 statusWidget wstDyn

@@ -197,6 +225,8 @@ activeDeploymentWidget clickedEv dname dDyn' = do

197225 ( "class" =: "action action--delete"

198226 <> "type" =: "button") $ text "Move to archive"

199227 dropdownWidget' clickedEv btn body

228+ let route = DashboardRoute :/ Just dname

229+ setRoute $ route <$ domEvent Click linkEl

200230

201231archivedDeploymentsWidget

202232 :: MonadWidget t m

nix/sources.json+12

@@ -35,6 +35,18 @@

3535 "url": "https://github.com/NixOS/nixpkgs/archive/3eea039a964ecefbc657498b3829dfa19727f069.tar.gz",

3636 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

3737 },

38+ "obelisk": {

39+ "branch": "master",

40+ "description": "Functional reactive web and mobile applications, with batteries included.",

41+ "homepage": "https://reflex-frp.org",

42+ "owner": "obsidiansystems",

43+ "repo": "obelisk",

44+ "rev": "4f2d3f1c1312d833ae814b7a86cf7b65ea0614ec",

45+ "sha256": "1shk8yy5pbakcw8aq6b8s3g2xblzf24l78mq0ca0asnvifnp83yb",

46+ "type": "tarball",

47+ "url": "https://github.com/obsidiansystems/obelisk/archive/4f2d3f1c1312d833ae814b7a86cf7b65ea0614ec.tar.gz",

48+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

49+ },

3850 "servant-reflex": {

3951 "branch": "master",

4052 "description": "Generate reflex client functions for querying a servant API",