8c4081c · obelisk · git.iko.soy

git.iko.soy/obelisk

Merge remote-tracking branch

'origin/jd-headration-2' into develop

commit8c4081c670c3be99f33479d01a7585a563c90020 authorAli Abrar <aliabrar@gmail.com> dateThu 16 May 2019, 15:50 (7 years ago) parent8b57099 23096c4

31 files changed+586−187

compare with master

unifiedsplit

ChangeLog.md+2

@@ -10,6 +10,8 @@ This project's release branch is `master`. This log is written from the perspect

1010* Make asset path hashing strict (see `Obelisk.Asset.Gather`)

1111* Add the `ob shell` command to enter a nix shell for an obelisk project

1212* Allow skeleton's obelisk to be overridden. This changes the skeleton's default.nix interface: the arguments that it used to take are now part of the new "obelisk" argument.

13+* Removed `MonadIO` from `ObeliskWidget` to prevent accidental IO during prerendering. If you need to do IO in a widget it should be on the right hand side of a `prerender`.

14+* Significantly changed the interface to the "executable config" packages. `obelisk-executable-config-lookup` is a new internal package which looks up all configs in a platform-specific way. `obelisk-executable-frontend` and `obelisk-executable-backend` provide MTL-style monad classes (`HasFrontendConfigs` and `HasBackendConfigs`) which the frontend and backend, respectively, can use to look up configs. This replaces the old `get` function which ran in `IO`.

1315

1416## v0.1.0.0 - 2019-03-29

1517

default.nix+2−1

@@ -49,11 +49,12 @@ let

4949 } + /template) {};

5050 })

5151

52+ pkgs.obeliskExecutableConfig.haskellOverlay

53+

5254 # Add obelisk packages

5355 (self: super: let

5456 pkgs = self.callPackage ({ pkgs }: pkgs) {};

5557 in {

56− obelisk-executable-config = pkgs.obeliskExecutableConfig.haskellPackage self;

5758 obelisk-executable-config-inject = pkgs.obeliskExecutableConfig.platforms.web.inject self;

5859

5960 obelisk-asset-manifest = self.callCabal2nix "obelisk-asset-manifest" (hackGet ./lib/asset + "/manifest") {};

lib/backend/obelisk-backend.cabal+3

@@ -8,6 +8,7 @@ library

88 build-depends: base,

99 bytestring,

1010 categories,

11+ containers,

1112 cookie,

1213 data-default,

1314 dependent-sum,

@@ -15,6 +16,8 @@ library

1516 lens,

1617 mtl,

1718 obelisk-asset-serve-snap,

19+ obelisk-executable-config-backend,

20+ obelisk-executable-config-lookup,

1821 obelisk-frontend,

1922 obelisk-route,

2023 obelisk-snap-extras,

lib/backend/src/Obelisk/Backend.hs+52−21

@@ -11,6 +11,7 @@ module Obelisk.Backend

1111 ( Backend (..)

1212 -- * Re-exports

1313 , Default (def)

14+ , ComponentConfigs(..)

1415 , getPageName

1516 , getRouteWith

1617 , runSnapWithCommandLineArgs

@@ -19,6 +20,7 @@ module Obelisk.Backend

1920 , runBackend

2021 , staticRenderContentType

2122 , mkRouteToUrl

23+ , getComponentConfigs

2224 ) where

2325

2426import Prelude hiding (id, (.))

@@ -32,11 +34,15 @@ import Data.Default (Default (..))

3234import Data.Dependent.Sum

3335import Data.Functor.Sum

3436import Data.Functor.Identity

37+import Data.Map (Map)

38+import qualified Data.Map as Map

3539import Data.Monoid ((<>))

3640import Data.Text (Text)

3741import qualified Data.Text as T

3842import Data.Text.Encoding

3943import Obelisk.Asset.Serve.Snap (serveAsset)

44+import Obelisk.ExecutableConfig.Backend

45+import Obelisk.ExecutableConfig.Lookup

4046import Obelisk.Frontend

4147import Obelisk.Route

4248import Obelisk.Snap.Extras (doNotCache, serveFileIfExistsAs)

@@ -49,7 +55,14 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)

4955

5056data Backend backendRoute frontendRoute = Backend

5157 { _backend_routeEncoder :: Encoder (Either Text) Identity (R (Sum backendRoute (ObeliskRoute frontendRoute))) PageName

52− , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()

58+ , _backend_run :: ((R backendRoute -> BackendConfigsT Snap ()) -> BackendConfigsT IO ()) -> BackendConfigsT IO ()

59+ }

60+

61+-- | All the configs separated by which context they are accessible in. (Common

62+-- configs are present in both.)

63+data ComponentConfigs = ComponentConfigs

64+ { _componentConfigs_backend :: Map Text Text

65+ , _componentConfigs_frontend :: Map Text Text

5366 }

5467

5568-- | The static assets provided must contain a compiled GHCJS app that corresponds exactly to the Frontend provided

@@ -67,9 +80,10 @@ serveDefaultObeliskApp

6780 -> ([Text]

6881 -> m ())

6982 -> Frontend (R appRoute)

83+ -> Map Text Text

7084 -> R (ObeliskRoute appRoute)

7185 -> m ()

72−serveDefaultObeliskApp urlEnc serveStaticAsset frontend = serveObeliskApp urlEnc serveStaticAsset frontendApp

86+serveDefaultObeliskApp urlEnc serveStaticAsset frontend configs = serveObeliskApp urlEnc serveStaticAsset frontendApp configs

7387 where frontendApp = GhcjsApp

7488 { _ghcjsApp_compiled = defaultFrontendGhcjsAssets

7589 , _ghcjsApp_value = frontend

@@ -94,16 +108,16 @@ defaultFrontendGhcjsAssets = StaticAssets

94108 , _staticAssets_unprocessed = "frontend.jsexe"

95109 }

96110

97−runSnapWithCommandLineArgs :: Snap () -> IO ()

111+runSnapWithCommandLineArgs :: MonadIO m => Snap () -> m ()

98112runSnapWithCommandLineArgs a = do

99113 -- Get the web server configuration from the command line

100− cmdLineConf <- commandLineConfig defaultConfig

114+ cmdLineConf <- liftIO $ commandLineConfig defaultConfig

101115 let httpConf = cmdLineConf

102116 { accessLog = Just $ ConfigIoLog BSC8.putStrLn

103117 , errorLog = Just $ ConfigIoLog BSC8.putStrLn

104118 }

105119 -- Start the web server

106− httpServe httpConf a

120+ liftIO $ httpServe httpConf a

107121

108122getPageName :: (MonadSnap m) => m PageName

109123getPageName = do

@@ -125,13 +139,14 @@ serveObeliskApp

125139 => (R appRoute -> Text)

126140 -> ([Text] -> m ())

127141 -> GhcjsApp (R appRoute)

142+ -> Map Text Text

128143 -> R (ObeliskRoute appRoute)

129144 -> m ()

130−serveObeliskApp urlEnc serveStaticAsset frontendApp = \case

131− ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc frontendApp $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest

145+serveObeliskApp urlEnc serveStaticAsset frontendApp config = \case

146+ ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc frontendApp config $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest

132147 ObeliskRoute_Resource resComponent :=> Identity resRest -> case resComponent :=> Identity resRest of

133148 ResourceRoute_Static :=> Identity pathSegments -> serveStaticAsset pathSegments

134− ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc frontendApp $ GhcjsAppRoute_Resource :/ pathSegments

149+ ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc frontendApp config $ GhcjsAppRoute_Resource :/ pathSegments

135150 ResourceRoute_JSaddleWarp :=> Identity _ -> do

136151 let msg = "Error: Obelisk.Backend received jsaddle request"

137152 liftIO $ putStrLn $ T.unpack msg

@@ -159,24 +174,30 @@ serveGhcjsApp

159174 :: (MonadSnap m, HasCookies m)

160175 => (R appRouteComponent -> Text)

161176 -> GhcjsApp (R appRouteComponent)

177+ -> Map Text Text

162178 -> R (GhcjsAppRoute appRouteComponent)

163179 -> m ()

164−serveGhcjsApp urlEnc app = \case

180+serveGhcjsApp urlEnc app config = \case

165181 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do

166182 modifyResponse $ setContentType staticRenderContentType

167− writeBS <=< renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) $ _ghcjsApp_value app

183+ writeBS <=< renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app

168184 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments

169185

170186runBackend :: Backend fullRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()

171187runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

172188 Left e -> fail $ "backend error:\n" <> T.unpack e

173− Right validFullEncoder -> _backend_run backend $ \serveRoute -> do

174− runSnapWithCommandLineArgs $ do

175− getRouteWith validFullEncoder >>= \case

176− Identity r -> case r of

177− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

178− InR obeliskRoute :=> Identity a ->

179− serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend $ obeliskRoute :/ a

189+ Right validFullEncoder -> do

190+ configs <- getComponentConfigs

191+ runBackendConfigsT (_componentConfigs_backend configs) $

192+ _backend_run backend $ \serveRoute -> do

193+ runSnapWithCommandLineArgs $ do

194+ getRouteWith validFullEncoder >>= \case

195+ Identity r -> case r of

196+ InL backendRoute :=> Identity a ->

197+ runBackendConfigsT (_componentConfigs_backend configs) $

198+ serveRoute $ backendRoute :/ a

199+ InR obeliskRoute :=> Identity a ->

200+ serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend (_componentConfigs_frontend configs) $ obeliskRoute :/ a

180201

181202mkRouteToUrl :: Encoder Identity parse (R (Sum f (ObeliskRoute r))) PageName -> R r -> Text

182203mkRouteToUrl validFullEncoder =

@@ -187,15 +208,25 @@ renderGhcjsFrontend

187208 :: (MonadSnap m, HasCookies m)

188209 => (route -> Text)

189210 -> route

211+ -> Map Text Text

190212 -> Frontend route

191213 -> m ByteString

192−renderGhcjsFrontend urlEnc route f = do

214+renderGhcjsFrontend urlEnc route configs f = do

193215 let ghcjsPreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: "ghcjs/all.js") blank

194216 ghcjsScript = elAttr "script" ("language" =: "javascript" <> "src" =: "ghcjs/all.js" <> "defer" =: "defer") blank

195217 cookies <- askCookies

196− renderFrontendHtml cookies urlEnc route

197− (_frontend_head f >> ghcjsPreload)

198− (_frontend_body f >> ghcjsScript)

218+ renderFrontendHtml configs cookies urlEnc route f ghcjsPreload ghcjsScript

199219

200220instance HasCookies Snap where

201221 askCookies = map (\c -> (cookieName c, cookieValue c)) <$> getsRequest rqCookies

222+

223+getComponentConfigs :: IO ComponentConfigs

224+getComponentConfigs = do

225+ allConfigs <- getConfigs

226+ return $ ComponentConfigs

227+ { _componentConfigs_backend =

228+ Map.filterWithKey (\k _ -> isMemberOf k ["common", "backend"]) allConfigs

229+ , _componentConfigs_frontend =

230+ Map.filterWithKey (\k _ -> isMemberOf k ["common", "frontend"]) allConfigs

231+ }

232+ where isMemberOf k dirs = or $ map (\dir -> ("config/" <> dir) `T.isPrefixOf` k) dirs

lib/executable-config/backend/obelisk-executable-config-backend.cabalnew file+20

@@ -0,0 +1,20 @@

1+name: obelisk-executable-config-backend

2+version: 0.1

3+cabal-version: >= 1.2

4+build-type: Simple

6+library

7+ hs-source-dirs: src

8+ build-depends: base,

9+ containers,

10+ monad-control,

11+ mtl,

12+ primitive,

13+ ref-tf,

14+ snap-core,

15+ text,

16+ transformers,

17+ transformers-base

18+ exposed-modules:

19+ Obelisk.ExecutableConfig.Backend

20+ ghc-options: -Wall

lib/executable-config/backend/src/Obelisk/ExecutableConfig/Backend.hsnew file+77

@@ -0,0 +1,77 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DefaultSignatures #-}

4+{-# LANGUAGE DeriveFunctor #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE OverloadedStrings #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+module Obelisk.ExecutableConfig.Backend

14+ ( HasBackendConfigs(..)

15+ , BackendConfigsT

16+ , runBackendConfigsT

17+ , mapBackendConfigsT

18+ ) where

19+

20+import Control.Applicative

21+import Control.Monad

22+import Control.Monad.Base

23+import Control.Monad.Fix

24+import Control.Monad.Primitive

25+import Control.Monad.Ref

26+import Control.Monad.IO.Class

27+import Control.Monad.Trans.Class

28+import Control.Monad.Trans.Control

29+import Control.Monad.Trans.Reader

30+import Data.Map (Map)

31+import qualified Data.Map as Map

32+import Data.Text (Text)

33+import Snap.Core (MonadSnap)

34+

35+class Monad m => HasBackendConfigs m where

36+ getBackendConfig :: Text -> m (Maybe Text)

37+ default getBackendConfig :: (HasBackendConfigs m', m ~ t m', MonadTrans t) => Text -> m (Maybe Text)

38+ getBackendConfig = lift . getBackendConfig

39+ getCommonConfig :: Text -> m (Maybe Text)

40+ default getCommonConfig :: (HasBackendConfigs m', m ~ t m', MonadTrans t) => Text -> m (Maybe Text)

41+ getCommonConfig = lift . getCommonConfig

42+

43+newtype BackendConfigsT m a = BackendConfigsT { unBackendConfigsT :: ReaderT (Map Text Text) m a }

44+ deriving

45+ ( Functor

46+ , Applicative

47+ , Monad

48+ , MonadPlus

49+ , Alternative

50+ , MonadFix

51+ , MonadIO

52+ , MonadBase m'

53+ , MonadBaseControl m'

54+ , MonadRef

55+ , MonadTrans

56+ , MonadSnap

57+ )

58+

59+instance PrimMonad m => PrimMonad (BackendConfigsT m) where

60+ type PrimState (BackendConfigsT m) = PrimState m

61+ primitive = lift . primitive

62+

63+runBackendConfigsT

64+ :: Map Text Text

65+ -> BackendConfigsT m a

66+ -> m a

67+runBackendConfigsT cs child = runReaderT (unBackendConfigsT child) cs

68+

69+instance Monad m => HasBackendConfigs (BackendConfigsT m) where

70+ getBackendConfig k = BackendConfigsT $ Map.lookup ("config/backend/" <> k) <$> ask

71+ getCommonConfig k = BackendConfigsT $ Map.lookup ("config/common/" <> k) <$> ask

72+

73+mapBackendConfigsT

74+ :: (forall x. m x -> n x)

75+ -> BackendConfigsT m a

76+ -> BackendConfigsT n a

77+mapBackendConfigsT f (BackendConfigsT x) = BackendConfigsT $ mapReaderT f x

lib/executable-config/default.nix+6−1

@@ -16,9 +16,14 @@ let injectConfig = config: assets: nixpkgs.runCommand "inject-config" {} (''

1616 exit 1

1717 fi

1818 cp -a "${config}"/* "$out/config"

19+ (cd $out && find config -type f -print0 >config.files)

1920 '');

2021in with nixpkgs.haskell.lib; {

21− haskellPackage = self: self.callPackage (filterGitSource ./lookup) {};

22+ haskellOverlay = self: super: {

23+ obelisk-executable-config-backend = self.callCabal2nix "obelisk-executable-config-backend" (filterGitSource ./backend) {};

24+ obelisk-executable-config-frontend = self.callCabal2nix "obelisk-executable-config-frontend" (filterGitSource ./frontend) {};

25+ obelisk-executable-config-lookup = self.callPackage (filterGitSource ./lookup) {};

26+ };

2227 platforms = {

2328 android = {

2429 # Inject the given config directory into an android assets folder

lib/executable-config/frontend/obelisk-executable-config-frontend.cabalnew file+21

@@ -0,0 +1,21 @@

1+name: obelisk-executable-config-frontend

2+version: 0.1

3+cabal-version: >= 1.2

4+build-type: Simple

6+library

7+ hs-source-dirs: src

8+ build-depends: base,

9+ containers,

10+ ghcjs-dom,

11+ jsaddle,

12+ mtl,

13+ primitive,

14+ ref-tf,

15+ reflex,

16+ reflex-dom-core,

17+ text,

18+ transformers

19+ exposed-modules:

20+ Obelisk.ExecutableConfig.Frontend

21+ ghc-options: -Wall

lib/executable-config/frontend/src/Obelisk/ExecutableConfig/Frontend.hsnew file+115

@@ -0,0 +1,115 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DefaultSignatures #-}

4+{-# LANGUAGE DeriveFunctor #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE OverloadedStrings #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+module Obelisk.ExecutableConfig.Frontend

14+ ( HasFrontendConfigs(..)

15+ , FrontendConfigsT

16+ , runFrontendConfigsT

17+ , mapFrontendConfigsT

18+ ) where

19+

20+import Control.Monad.Fix

21+import Control.Monad.Primitive

22+import Control.Monad.Ref

23+import Control.Monad.IO.Class

24+import Control.Monad.Trans.Class

25+import Control.Monad.Trans.Reader

26+import Data.Map (Map)

27+import qualified Data.Map as Map

28+import Data.Text (Text)

29+import Reflex

30+import Reflex.Host.Class

31+import Reflex.Dom.Core

32+#ifndef ghcjs_HOST_OS

33+import GHCJS.DOM.Types (MonadJSM)

34+#endif

35+

36+class Monad m => HasFrontendConfigs m where

37+ getFrontendConfig :: Text -> m (Maybe Text)

38+ default getFrontendConfig :: (HasFrontendConfigs m', m ~ t m', MonadTrans t) => Text -> m (Maybe Text)

39+ getFrontendConfig = lift . getFrontendConfig

40+ getCommonConfig :: Text -> m (Maybe Text)

41+ default getCommonConfig :: (HasFrontendConfigs m', m ~ t m', MonadTrans t) => Text -> m (Maybe Text)

42+ getCommonConfig = lift . getCommonConfig

43+

44+instance HasFrontendConfigs m => HasFrontendConfigs (BehaviorWriterT t w m)

45+instance HasFrontendConfigs m => HasFrontendConfigs (DynamicWriterT t w m)

46+instance HasFrontendConfigs m => HasFrontendConfigs (EventWriterT t w m)

47+instance HasFrontendConfigs m => HasFrontendConfigs (PostBuildT t m)

48+instance HasFrontendConfigs m => HasFrontendConfigs (QueryT t q m)

49+instance HasFrontendConfigs m => HasFrontendConfigs (ReaderT r m)

50+instance HasFrontendConfigs m => HasFrontendConfigs (RequesterT t request response m)

51+instance HasFrontendConfigs m => HasFrontendConfigs (StaticDomBuilderT t m)

52+instance HasFrontendConfigs m => HasFrontendConfigs (TriggerEventT t m)

53+

54+newtype FrontendConfigsT m a = FrontendConfigsT { unFrontendConfigsT :: ReaderT (Map Text Text) m a }

55+ deriving

56+ ( Functor

57+ , Applicative

58+ , DomBuilder t

59+ , Monad

60+ , MonadFix

61+ , MonadHold t

62+ , MonadIO

63+#ifndef ghcjs_HOST_OS

64+ , MonadJSM

65+#endif

66+ , MonadRef

67+ , MonadReflexCreateTrigger t

68+ , MonadSample t

69+ , MonadTrans

70+ , NotReady t

71+ , PostBuild t

72+ , TriggerEvent t

73+ , HasDocument

74+ , DomRenderHook t

75+ , HasJSContext

76+ , HasJS js

77+ )

78+

79+instance PerformEvent t m => PerformEvent t (FrontendConfigsT m) where

80+ type Performable (FrontendConfigsT m) = FrontendConfigsT (Performable m)

81+ performEvent e = FrontendConfigsT $ ReaderT $ \configs ->

82+ performEvent $ runFrontendConfigsT configs <$> e

83+ performEvent_ e = FrontendConfigsT $ ReaderT $ \configs ->

84+ performEvent_ $ runFrontendConfigsT configs <$> e

85+

86+instance Adjustable t m => Adjustable t (FrontendConfigsT m) where

87+ runWithReplace a e = FrontendConfigsT $ runWithReplace (unFrontendConfigsT a) (unFrontendConfigsT <$> e)

88+ traverseDMapWithKeyWithAdjust f m e = FrontendConfigsT $ traverseDMapWithKeyWithAdjust (\k v -> unFrontendConfigsT $ f k v) m e

89+ traverseIntMapWithKeyWithAdjust f m e = FrontendConfigsT $ traverseIntMapWithKeyWithAdjust (\k v -> unFrontendConfigsT $ f k v) m e

90+ traverseDMapWithKeyWithAdjustWithMove f m e = FrontendConfigsT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFrontendConfigsT $ f k v) m e

91+

92+instance Prerender js t m => Prerender js t (FrontendConfigsT m) where

93+ type Client (FrontendConfigsT m) = FrontendConfigsT (Client m)

94+ prerender server client = FrontendConfigsT $ ReaderT $ \configs ->

95+ prerender (runFrontendConfigsT configs server) (runFrontendConfigsT configs client)

96+

97+instance PrimMonad m => PrimMonad (FrontendConfigsT m) where

98+ type PrimState (FrontendConfigsT m) = PrimState m

99+ primitive = lift . primitive

100+

101+runFrontendConfigsT

102+ :: Map Text Text

103+ -> FrontendConfigsT m a

104+ -> m a

105+runFrontendConfigsT cs child = runReaderT (unFrontendConfigsT child) cs

106+

107+instance Monad m => HasFrontendConfigs (FrontendConfigsT m) where

108+ getFrontendConfig k = FrontendConfigsT $ Map.lookup ("config/frontend/" <> k) <$> ask

109+ getCommonConfig k = FrontendConfigsT $ Map.lookup ("config/common/" <> k) <$> ask

110+

111+mapFrontendConfigsT

112+ :: (forall x. m x -> n x)

113+ -> FrontendConfigsT m a

114+ -> FrontendConfigsT n a

115+mapFrontendConfigsT f (FrontendConfigsT x) = FrontendConfigsT $ mapReaderT f x

lib/executable-config/inject/obelisk-executable-config-inject.cabal+1−3

@@ -8,9 +8,7 @@ library

99 build-depends:

1010 base,

11− bytestring,

12− directory,

13− filepath,

11+ containers,

1412 reflex-dom-core,

1513 text

1614

lib/executable-config/inject/src/Obelisk/ExecutableConfig/Inject.hs+8−37

@@ -2,50 +2,21 @@

22module Obelisk.ExecutableConfig.Inject where

44import Control.Monad (mapM_)

5−import Control.Monad.IO.Class (MonadIO, liftIO)

5+import Control.Monad.IO.Class (MonadIO)

6+import Data.Map (Map)

7+import qualified Data.Map as Map

68import Data.Semigroup ((<>))

7−import Data.ByteString (ByteString)

89import Data.Text (Text)

9−import qualified Data.Text as T

10−import qualified Data.Text.IO as T

1110import Reflex.Dom.Core hiding (value)

12−import System.Directory

13−import System.FilePath ((</>))

14−

15−-- | Produces a @<script>@ tag containing the contents of the config item,

16−-- rendered as a 'ByteString'.

17−inject :: FilePath -> IO ByteString

18−inject key = do

19− value <- T.readFile key

20− fmap snd $ renderStatic $ injectPure (T.pack key) value

2111

2212-- | Produces a @<script>@ tag with an @id@ attribute containing the key and

2313-- whose value is the provided configuration

2414injectPure :: DomBuilder t m => Text -> Text -> m ()

2515injectPure key value =

26− let attrs = ("type" =: "text/plain" <> "id" =: ("config-" <> key))

16+ let attrs = ("type" =: "text/plain" <> "data-obelisk-executable-config-inject-key" =: key)

2717 in elAttr "script" attrs $ text value

2818

29−-- | Scans the "common" and "frontend" configuration folders and produces

30−-- injectable @<script>@ tags containing the configuration keys (filepaths) and

31−-- values.

32−injectExecutableConfigs :: (MonadIO m, DomBuilder t m) => m ()

33−injectExecutableConfigs = do

34− cfgC <- getConfigs "config/common"

35− cfgF <- getConfigs "config/frontend"

36− mapM_ (uncurry injectPure) (cfgC <> cfgF)

37−

38−getConfigs :: MonadIO m => FilePath -> m [(Text, Text)]

39−getConfigs fp = liftIO $ do

40− dir <- doesDirectoryExist fp

41− if dir

42− then do

43− ps <- listDirectory fp

44− fmap concat $ mapM (\p -> getConfigs $ fp </> p) ps

45− else do

46− file <- doesFileExist fp

47− if file

48− then do

49− f <- T.readFile fp

50− return [(T.pack fp, f)]

51− else return []

19+-- | Produces injectable @<script>@ tags containing the configuration keys

20+-- (filepaths) and values.

21+injectExecutableConfigs :: (MonadIO m, DomBuilder t m) => Map Text Text -> m ()

22+injectExecutableConfigs = mapM_ (uncurry injectPure) . Map.toList

lib/executable-config/lookup/default.nix+1−1

@@ -6,7 +6,7 @@ let isAndroid = hostPlatform.libc == "bionic";

66 isIOS = hostPlatform.isDarwin && hostPlatform.isAarch64;

77 isGhcjs = ghc.isGhcjs or false;

88in mkDerivation {

9− pname = "obelisk-executable-config";

9+ pname = "obelisk-executable-config-lookup";

1010 version = "0.1";

1111 src = ./.;

1212 libraryHaskellDepends = [

lib/executable-config/lookup/obelisk-executable-config.cabal → lib/executable-config/lookup/obelisk-executable-config-lookup.cabalrenamed+11−4

@@ -1,13 +1,15 @@

1−name: obelisk-executable-config

1+name: obelisk-executable-config-lookup

22version: 0.1.1

33cabal-version: >= 1.2

44build-type: Simple

66library

7− exposed-modules: Obelisk.ExecutableConfig

7+ exposed-modules: Obelisk.ExecutableConfig.Lookup

88 if os(ios)

9− hs-source-dirs: src-ios

9+ hs-source-dirs: src-ios, src-directory

10+ other-modules: Obelisk.ExecutableConfig.Internal.ConfigDirectory

1011 build-depends: jsaddle-wkwebview

12+ build-depends: directory

1113 else

1214 if os(linux-android)

1315 hs-source-dirs: src-android

@@ -20,11 +22,16 @@ library

2022 hs-source-dirs: src-ghcjs

2123 build-depends: ghcjs-dom

2224 else

23− hs-source-dirs: src

25+ hs-source-dirs: src, src-directory

26+ other-modules: Obelisk.ExecutableConfig.Internal.ConfigDirectory

27+ build-depends: directory

2428

2529 build-depends:

2630 base,

2731 bytestring,

32+ containers,

2833 filepath,

2934 text,

3035 transformers

36+

37+ ghc-options: -Wall

lib/executable-config/lookup/src-android/Obelisk/ExecutableConfig.hsdeleted−27

@@ -1,27 +0,0 @@

1−module Obelisk.ExecutableConfig (get) where

2−

3−import Control.Exception (bracket)

4−import qualified Data.ByteString as BS

5−import Data.Text (Text)

6−import qualified Data.Text as T

7−import qualified Data.Text.Encoding as T

8−import Foreign.C.String (withCString)

9−import Foreign.Ptr (nullPtr)

10−import System.FilePath.Posix ((</>))

11−

12−import Obelisk.ExecutableConfig.Internal.AssetManager

13−

14−get :: Text -> IO (Maybe Text)

15−get name = bracket getAssets freeAssetManager $ \mgrObj -> do

16− mgr <- assetManagerFromJava mgrObj

17− let open = do

18− a <- withCString (T.unpack name) $ \fn ->

19− assetManager_open mgr fn 3

20− return $ if unAAsset a == nullPtr

21− then Nothing

22− else Just a

23− close = mapM_ asset_close

24− bracket open close $ mapM $ \asset -> do

25− b <- asset_getBuffer asset

26− l <- asset_getLength asset

27− fmap T.decodeUtf8 $ BS.packCStringLen (b, fromIntegral l)

lib/executable-config/lookup/src-android/Obelisk/ExecutableConfig/Lookup.hsnew file+56

@@ -0,0 +1,56 @@

1+{-# LANGUAGE LambdaCase #-}

2+module Obelisk.ExecutableConfig.Lookup where

4+import Control.Exception (bracket)

5+import Control.Monad (forM)

6+import qualified Data.ByteString as BS

7+import Data.Map (Map)

8+import qualified Data.Map as Map

9+import Data.Text (Text)

10+import qualified Data.Text.Encoding as T

11+import Foreign.C.String (withCString)

12+import Foreign.Ptr (nullPtr)

13+

14+import Obelisk.ExecutableConfig.Internal.AssetManager

15+

16+getFromMgr :: AAssetManager -> BS.ByteString -> IO (Maybe Text)

17+getFromMgr mgr name = do

18+ let open = do

19+ a <- BS.useAsCString name $ \fn ->

20+ assetManager_open mgr fn 3

21+ return $ if unAAsset a == nullPtr

22+ then Nothing

23+ else Just a

24+ close = mapM_ asset_close

25+ bracket open close $ mapM $ \asset -> do

26+ b <- asset_getBuffer asset

27+ l <- asset_getLength asset

28+ fmap T.decodeUtf8 $ BS.packCStringLen (b, fromIntegral l)

29+

30+getConfigs :: IO (Map Text Text)

31+getConfigs = bracket getAssets freeAssetManager $ \mgrObj -> do

32+ mgr <- assetManagerFromJava mgrObj

33+ let openDir = do

34+ d <- withCString "config.files" $ \fn ->

35+ assetManager_open mgr fn 3

36+ return $ if unAAsset d == nullPtr

37+ then Nothing

38+ else Just d

39+ closeDir = mapM_ asset_close

40+ configPaths <- bracket openDir closeDir $ \case

41+ Just asset -> do

42+ b <- asset_getBuffer asset

43+ l <- asset_getLength asset

44+ lines0 <$> BS.packCStringLen (b, fromIntegral l)

45+ Nothing -> error "could not open configuration manifest 'config.files'"

46+ fmap Map.fromList $ forM configPaths $ \fp ->

47+ getFromMgr mgr fp >>= \case

48+ Just v -> return (T.decodeUtf8 fp, v)

49+ Nothing -> error $ "Config present in config.files but not in assets: " <> show fp

50+

51+lines0 :: BS.ByteString -> [BS.ByteString]

52+lines0 ps

53+ | BS.null ps = []

54+ | otherwise = case BS.elemIndex 0 ps of

55+ Nothing -> [ps]

56+ Just n -> BS.take n ps : lines0 (BS.drop (n+1) ps)

lib/executable-config/lookup/src-directory/Obelisk/ExecutableConfig/Internal/ConfigDirectory.hsnew file+24

@@ -0,0 +1,24 @@

1+module Obelisk.ExecutableConfig.Internal.ConfigDirectory where

3+import Data.Map (Map)

4+import qualified Data.Map as Map

5+import Data.Text (Text)

6+import Data.Text as T

7+import Data.Text.IO as T

8+import System.Directory

9+import System.FilePath.Posix ((</>))

10+

11+getConfigsFromDirectory :: FilePath -> FilePath -> IO (Map Text Text)

12+getConfigsFromDirectory base fp = do

13+ dir <- doesDirectoryExist (base </> fp)

14+ if dir

15+ then do

16+ ps <- listDirectory (base </> fp)

17+ fmap mconcat $ mapM (\p -> getConfigsFromDirectory base $ fp </> p) ps

18+ else do

19+ file <- doesFileExist (base </> fp)

20+ if file

21+ then do

22+ f <- T.readFile (base </> fp)

23+ return $ Map.singleton (T.pack fp) f

24+ else return mempty

lib/executable-config/lookup/src-ghcjs/Obelisk/ExecutableConfig.hsdeleted−17

@@ -1,17 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Obelisk.ExecutableConfig where

3−

4−import Control.Monad.Trans.Maybe

5−import Data.Semigroup ((<>))

6−import Data.Text (Text)

7−import GHCJS.DOM

8−import GHCJS.DOM.Document

9−import GHCJS.DOM.Element

10−import GHCJS.DOM.NonElementParentNode

11−

12−get :: Text -> IO (Maybe Text)

13−get item = runMaybeT $ do

14− doc <- MaybeT currentDocument

15− e <- MaybeT $ getElementById doc $ "config-" <> item

16− getInnerHTML e

17−

lib/executable-config/lookup/src-ghcjs/Obelisk/ExecutableConfig/Lookup.hsnew file+36

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

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Obelisk.ExecutableConfig.Lookup where

5+import Data.Map (Map)

6+import qualified Data.Map as Map

7+import Data.Maybe (catMaybes)

8+import Data.Text (Text)

9+import Data.Traversable (for)

10+import GHCJS.DOM

11+import GHCJS.DOM.Document (getHead)

12+import GHCJS.DOM.DOMStringMap (get)

13+import GHCJS.DOM.Element (getInnerHTML)

14+import GHCJS.DOM.HTMLElement (HTMLElement(HTMLElement), getDataset)

15+import GHCJS.DOM.NodeList (item, getLength)

16+import GHCJS.DOM.ParentNode (querySelectorAll)

17+import GHCJS.DOM.Types (Node(Node), castTo)

18+

19+getConfigs :: IO (Map Text Text)

20+getConfigs = do

21+ Just doc <- currentDocument

22+ Just hd <- getHead doc

23+ nodes <- collToList =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)

24+ fmap Map.fromList $ for nodes $ \node -> do

25+ e <- castTo HTMLElement node >>= \case

26+ Nothing -> error "Found node with data attribute obelisk-executable-config-inject-key that is not an HTMLElement."

27+ Just htmlE -> return htmlE

28+ dataset <- getDataset e

29+ (,)

30+ <$> get dataset ("obelisk-executable-config-inject-key" :: Text)

31+ <*> getInnerHTML e

32+ where

33+ collToList es = do

34+ len <- getLength es

35+ list <- traverse (item es) [0..len-1]

36+ pure $ catMaybes list

lib/executable-config/lookup/src-ios/Obelisk/ExecutableConfig.hsdeleted−22

@@ -1,22 +0,0 @@

1−module Obelisk.ExecutableConfig (get) where

2−

3−import Control.Exception

4−import Control.Monad

5−import Control.Monad.Trans.Maybe

6−import Data.ByteString as BS

7−import Data.Text (Text)

8−import qualified Data.Text as T

9−import qualified Data.Text.IO as T

10−import qualified Data.Text.Encoding as T

11−import Language.Javascript.JSaddle.WKWebView

12−import System.FilePath.Posix ((</>))

13−import System.IO.Error

14−

15−get :: Text -> IO (Maybe Text)

16−get name = fmap join $ mainBundleResourcePath >>= \mp -> forM mp $ \p ->

17− catchDoesNotExist $ T.readFile $ T.unpack (T.decodeUtf8 p) </> T.unpack name

18−

19−catchDoesNotExist :: IO a -> IO (Maybe a)

20−catchDoesNotExist f = catchJust doesNotExist (Just <$> f) $ const $ return Nothing

21− where

22− doesNotExist e = if isDoesNotExistError e then Just () else Nothing

lib/executable-config/lookup/src-ios/Obelisk/ExecutableConfig/Lookup.hsnew file+15

@@ -0,0 +1,15 @@

1+{-# LANGUAGE LambdaCase #-}

2+module Obelisk.ExecutableConfig.Lookup where

4+import Data.Map (Map)

5+import Data.Text (Text)

6+import qualified Data.Text as T

7+import qualified Data.Text.Encoding as T

8+import Language.Javascript.JSaddle.WKWebView

10+import Obelisk.ExecutableConfig.Internal.ConfigDirectory

11+

12+getConfigs :: IO (Map Text Text)

13+getConfigs = mainBundleResourcePath >>= \case

14+ Nothing -> error "Could not get bundle resource path."

15+ Just p -> getConfigsFromDirectory (T.unpack (T.decodeUtf8 p)) "config"

lib/executable-config/lookup/src/Obelisk/ExecutableConfig.hsdeleted−13

@@ -1,13 +0,0 @@

1−module Obelisk.ExecutableConfig (get) where

2−

3−import Control.Exception

4−import Data.Text (Text)

5−import Data.Text as T

6−import Data.Text.IO as T

7−import System.FilePath.Posix ((</>))

8−import System.IO.Error

9−

10−get :: Text -> IO (Maybe Text)

11−get path = do

12− let doesNotExist = \e -> if isDoesNotExistError e then Just () else Nothing

13− catchJust doesNotExist (fmap Just $ T.readFile $ T.unpack path) (\_ -> pure Nothing)

lib/executable-config/lookup/src/Obelisk/ExecutableConfig/Lookup.hsnew file+9

@@ -0,0 +1,9 @@

1+module Obelisk.ExecutableConfig.Lookup where

3+import Data.Map (Map)

4+import Data.Text (Text)

6+import Obelisk.ExecutableConfig.Internal.ConfigDirectory

8+getConfigs :: IO (Map Text Text)

9+getConfigs = getConfigsFromDirectory "." "config"

lib/frontend/obelisk-frontend.cabal+3

@@ -7,13 +7,16 @@ library

77 hs-source-dirs: src

88 build-depends: base,

99 bytestring,

10+ containers,

1011 cookie,

1112 dependent-sum,

1213 ghcjs-dom,

1314 jsaddle,

1415 lens,

1516 mtl,

17+ obelisk-executable-config-frontend,

1618 obelisk-executable-config-inject,

19+ obelisk-executable-config-lookup,

1720 obelisk-route,

1821 primitive,

1922 ref-tf,

lib/frontend/src/Obelisk/Frontend.hs+64−15

@@ -1,4 +1,5 @@

11{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE LambdaCase #-}

@@ -14,7 +15,9 @@ module Obelisk.Frontend

1415 ( ObeliskWidget

1516 , Frontend (..)

1617 , runFrontend

18+ , runFrontendWithConfigs

1719 , renderFrontendHtml

20+ , removeHTMLConfigs

1821 , module Obelisk.Frontend.Cookie

1922 ) where

2023

@@ -27,16 +30,27 @@ import Control.Monad.IO.Class

2730import Control.Monad.Primitive

2831import Control.Monad.Reader

2932import Control.Monad.Ref

33+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

3034import Data.ByteString (ByteString)

35+import Data.Foldable (for_)

3136import Data.Functor.Sum

37+import Data.Map (Map)

38+import Data.Maybe (catMaybes)

3239import Data.Monoid ((<>))

3340import Data.Text (Text)

41+import GHCJS.DOM (currentDocument)

42+import GHCJS.DOM.Document (getHead)

43+import GHCJS.DOM.Node (removeChild_)

44+import GHCJS.DOM.NodeList (item, getLength)

45+import GHCJS.DOM.ParentNode (querySelectorAll)

3446import Language.Javascript.JSaddle (JSM)

3547import Obelisk.Frontend.Cookie

3648import Obelisk.Route.Frontend

3749import Reflex.Dom.Core

3850import Reflex.Host.Class

51+import Obelisk.ExecutableConfig.Frontend

3952import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)

53+import Obelisk.ExecutableConfig.Lookup (getConfigs)

4054import Web.Cookie

4155

4256makePrisms ''Sum

@@ -60,16 +74,16 @@ type ObeliskWidget js t route m =

6074 , Prerender js t m

6175 , PrebuildAgnostic t route m

6276 , PrebuildAgnostic t route (Client m)

77+ , HasFrontendConfigs m

6378 , HasCookies m

64− -- TODO Remove these. Probably requires a new class to allow executable-configs to work without being inside a `prerender`

65− , MonadIO m

66− , MonadIO (Performable m)

6779 )

6880

6981type PrebuildAgnostic t route m =

7082 ( SetRoute t route m

7183 , RouteToUrl route m

7284 , MonadFix m

85+ , HasFrontendConfigs m

86+ , HasFrontendConfigs (Performable m)

7387 )

7488

7589data Frontend route = Frontend

@@ -77,12 +91,40 @@ data Frontend route = Frontend

7791 , _frontend_body :: !(forall js t m. ObeliskWidget js t route m => RoutedT t route m ())

7892 }

7993

94+baseTag :: forall route js t m. ObeliskWidget js t route m => RoutedT t route m ()

95+baseTag = elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes

96+

97+removeHTMLConfigs :: JSM ()

98+removeHTMLConfigs = void $ runMaybeT $ do

99+ doc <- MaybeT currentDocument

100+ hd <- MaybeT $ getHead doc

101+ es <- collToList =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)

102+ for_ es $ removeChild_ hd

103+ where

104+ collToList es = do

105+ len <- getLength es

106+ lst <- traverse (item es) $ take (fromIntegral len) $ [0..] -- fun with unsigned types ...

107+ pure $ catMaybes lst

108+

80109runFrontend

81110 :: forall backendRoute route

82111 . Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

83112 -> Frontend (R route)

84113 -> JSM ()

85114runFrontend validFullEncoder frontend = do

115+ configs <- liftIO getConfigs

116+#ifdef ghcjs_HOST_OS

117+ removeHTMLConfigs

118+#endif

119+ runFrontendWithConfigs configs validFullEncoder frontend

120+

121+runFrontendWithConfigs

122+ :: forall backendRoute route

123+ . Map Text Text

124+ -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

125+ -> Frontend (R route)

126+ -> JSM ()

127+runFrontendWithConfigs configs validFullEncoder frontend = do

86128 let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _InR . _ObeliskRoute_App))

87129 errorLeft = \case

88130 Left _ -> error "runFrontend: Unexpected non-app ObeliskRoute reached the frontend. This shouldn't happen."

@@ -90,11 +132,13 @@ runFrontend validFullEncoder frontend = do

90132 runHydrationWidgetWithHeadAndBody (pure ()) $ \appendHead appendBody -> do

91133 rec switchover <- runRouteViewT ve switchover $ do

92134 (switchover'', fire) <- newTriggerEvent

93− mapRoutedT (mapSetRouteT (mapRouteToUrlT appendHead)) $ do

135+ mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendHead . runFrontendConfigsT configs))) $ do

136+ -- The order here is important - baseTag has to be before headWidget!

137+ baseTag

94138 _frontend_head frontend

95− mapRoutedT (mapSetRouteT (mapRouteToUrlT appendBody)) $ do

139+ mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendBody . runFrontendConfigsT configs))) $ do

96140 _frontend_body frontend

97− switchover' <- lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

141+ switchover' <- lift $ lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

98142 performEvent_ $ liftIO (fire ()) <$ switchover'

99143 pure switchover''

100144 pure ()

@@ -102,21 +146,26 @@ runFrontend validFullEncoder frontend = do

102146renderFrontendHtml

103147 :: ( t ~ DomTimeline

104148 , MonadIO m

105− , widget ~ RoutedT t r (SetRouteT t r' (RouteToUrlT r' (CookiesT (PostBuildT t (StaticDomBuilderT t (PerformEventT t DomHost))))))

149+ , widget ~ RoutedT t r (SetRouteT t r (RouteToUrlT r (FrontendConfigsT (CookiesT (PostBuildT t (StaticDomBuilderT t (PerformEventT t DomHost)))))))

106150 )

107− => Cookies

108− -> (r' -> Text)

151+ => Map Text Text

152+ -> Cookies

153+ -> (r -> Text)

109154 -> r

155+ -> Frontend r

110156 -> widget ()

111157 -> widget ()

112158 -> m ByteString

113−renderFrontendHtml cookies urlEnc route headWidget bodyWidget = do

159+renderFrontendHtml configs cookies urlEnc route frontend headExtra bodyExtra = do

114160 --TODO: We should probably have a "NullEventWriterT" or a frozen reflex timeline

115− html <- fmap snd $ liftIO $ renderStatic $ fmap fst $ runCookiesT cookies $ flip runRouteToUrlT urlEnc $ runSetRouteT $ flip runRoutedT (pure route) $

161+ html <- fmap snd $ liftIO $ renderStatic $ fmap fst $ runCookiesT cookies $ runFrontendConfigsT configs $ flip runRouteToUrlT urlEnc $ runSetRouteT $ flip runRoutedT (pure route) $

116162 el "html" $ do

117163 el "head" $ do

118− let baseTag = elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes

119− -- The order here is important - baseTag has to be before headWidget!

120− baseTag >> injectExecutableConfigs >> headWidget

121− el "body" bodyWidget

164+ baseTag

165+ injectExecutableConfigs configs

166+ _frontend_head frontend

167+ headExtra

168+ el "body" $ do

169+ _frontend_body frontend

170+ bodyExtra

122171 return $ "<!DOCTYPE html>" <> html

lib/frontend/src/Obelisk/Frontend/Cookie.hs+3

@@ -26,6 +26,7 @@ import GHCJS.DOM.Document (getCookie, Document)

2626import GHCJS.DOM.Types (MonadJSM)

2727import Web.Cookie

2828

29+import Obelisk.ExecutableConfig.Frontend

2930import Obelisk.Route.Frontend

3031

3132class Monad m => HasCookies m where

@@ -45,6 +46,8 @@ instance HasCookies m => HasCookies (SetRouteT t r m)

4546instance HasCookies m => HasCookies (StaticDomBuilderT t m)

4647instance HasCookies m => HasCookies (TriggerEventT t m)

4748instance HasCookies m => HasCookies (RoutedT t r m)

49+instance HasCookies m => HasCookies (FrontendConfigsT m)

50+instance HasFrontendConfigs m => HasFrontendConfigs (CookiesT m)

4851

4952newtype CookiesT m a = CookiesT { unCookiesT :: ReaderT Cookies m a }

5053 deriving

lib/route/obelisk-route.cabal+1

@@ -21,6 +21,7 @@ library

2121 monad-control,

2222 mtl,

2323 network-uri,

24+ obelisk-executable-config-frontend,

2425 primitive,

2526 ref-tf,

2627 reflex,

lib/route/src/Obelisk/Route/Frontend.hs+7

@@ -56,6 +56,7 @@ module Obelisk.Route.Frontend

5656

5757import Prelude hiding ((.), id)

5858

59+import Obelisk.ExecutableConfig.Frontend

5960import Obelisk.Route

6061

6162import Control.Category (Category (..), (.))

@@ -177,6 +178,8 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RoutedT t r m) where

177178 askQueryResult = lift askQueryResult

178179 queryIncremental = lift . queryIncremental

179180

181+instance HasFrontendConfigs m => HasFrontendConfigs (RoutedT t r m)

182+

180183instance (Monad m, RouteToUrl r m) => RouteToUrl r (QueryT t q m)

181184

182185instance (Monad m, SetRoute t r m) => SetRoute t r (QueryT t q m)

@@ -339,6 +342,8 @@ instance PrimMonad m => PrimMonad (SetRouteT t r m ) where

339342 type PrimState (SetRouteT t r m) = PrimState m

340343 primitive = lift . primitive

341344

345+instance HasFrontendConfigs m => HasFrontendConfigs (SetRouteT t r m)

346+

342347instance (MonadHold t m, Adjustable t m) => Adjustable t (SetRouteT t r m) where

343348 runWithReplace a0 a' = SetRouteT $ runWithReplace (coerce a0) $ coerceEvent a'

344349 traverseIntMapWithKeyWithAdjust f a0 a' = SetRouteT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'

@@ -436,6 +441,8 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RouteToUrlT r m) where

436441 askQueryResult = lift askQueryResult

437442 queryIncremental = lift . queryIncremental

438443

444+instance HasFrontendConfigs m => HasFrontendConfigs (RouteToUrlT t m)

445+

439446runRouteViewT

440447 :: forall t m r a.

441448 ( TriggerEvent t m

lib/run/obelisk-run.cabal+2−1

@@ -10,6 +10,7 @@ library

1010 attoparsec

1111 , base

1212 , bytestring

13+ , containers

1314 , cookie

1415 , dependent-sum

1516 , dependent-sum-template

@@ -25,7 +26,7 @@ library

2526 , network

2627 , obelisk-asset-serve-snap

2728 , obelisk-backend

28− , obelisk-executable-config

29+ , obelisk-executable-config-backend

2930 , obelisk-frontend

3031 , obelisk-route

3132 , process

lib/run/src/Obelisk/Run.hs+42−22

@@ -26,6 +26,8 @@ import Data.Dependent.Sum (DSum (..))

2626import Data.Functor.Identity

2727import Data.Functor.Sum

2828import Data.List (uncons)

29+import Data.Map (Map)

30+import qualified Data.Map as Map

2931import Data.Maybe

3032import Data.Semigroup ((<>))

3133import Data.Streaming.Network (bindPortTCP)

@@ -46,7 +48,7 @@ import Network.WebSockets (ConnectionOptions)

4648import Network.WebSockets.Connection (defaultConnectionOptions)

4749import qualified Obelisk.Asset.Serve.Snap as Snap

4850import Obelisk.Backend

49−import Obelisk.ExecutableConfig (get)

51+import Obelisk.ExecutableConfig.Backend

5052import Obelisk.Frontend

5153import Obelisk.Route.Frontend

5254import Reflex.Dom.Core

@@ -73,23 +75,27 @@ run port serveStaticAsset backend frontend = do

7375 case checkEncoder $ _backend_routeEncoder backend of

7476 Left e -> hPutStrLn stderr $ "backend error:\n" <> T.unpack e

7577 Right validFullEncoder -> do

78+ configs <- getComponentConfigs

7679 backendTid <- forkIO $ handle handleBackendErr $ withArgs ["--quiet", "--port", show port] $ do

77− _backend_run backend $ \serveRoute -> do

78− runSnapWithCommandLineArgs $ do

79− getRouteWith validFullEncoder >>= \case

80− Identity r -> case r of

81− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

82− InR obeliskRoute :=> Identity a ->

83− serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend $ obeliskRoute :/ a

80+ runBackendConfigsT (_componentConfigs_backend configs) $

81+ _backend_run backend $ \serveRoute -> do

82+ runSnapWithCommandLineArgs $ do

83+ getRouteWith validFullEncoder >>= \case

84+ Identity r -> case r of

85+ InL backendRoute :=> Identity a ->

86+ runBackendConfigsT (_componentConfigs_backend configs) $

87+ serveRoute $ backendRoute :/ a

88+ InR obeliskRoute :=> Identity a ->

89+ serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend (_componentConfigs_frontend configs) $ obeliskRoute :/ a

8490 let conf = defRunConfig { _runConfig_redirectPort = port }

85− runWidget conf frontend validFullEncoder `finally` killThread backendTid

91+ runWidget conf (_componentConfigs_frontend configs) frontend validFullEncoder `finally` killThread backendTid

8692

8793-- Convenience wrapper to handle path segments for 'Snap.serveAsset'

8894runServeAsset :: FilePath -> [Text] -> Snap ()

8995runServeAsset rootPath = Snap.serveAsset "" rootPath . T.unpack . T.intercalate "/"

9096

91−getConfigRoute :: IO (Maybe URI)

92−getConfigRoute = get "config/common/route" >>= \case

97+getConfigRoute :: Map Text Text -> IO (Maybe URI)

98+getConfigRoute configs = case Map.lookup "common/route" configs of

9399 Just r -> case URI.mkURI $ T.strip r of

94100 Just route -> pure $ Just route

95101 Nothing -> do

@@ -100,9 +106,14 @@ getConfigRoute = get "config/common/route" >>= \case

100106defAppUri :: URI

101107defAppUri = fromMaybe (error "defAppUri") $ URI.mkURI "http://127.0.0.1:8000"

102108

103−runWidget :: RunConfig -> Frontend (R route) -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName -> IO ()

104−runWidget conf frontend validFullEncoder = do

105− uri <- fromMaybe defAppUri <$> getConfigRoute

109+runWidget

110+ :: RunConfig

111+ -> Map Text Text

112+ -> Frontend (R route)

113+ -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

114+ -> IO ()

115+runWidget conf configs frontend validFullEncoder = do

116+ uri <- fromMaybe defAppUri <$> getConfigRoute configs

106117 let port = fromIntegral $ fromMaybe 80 $ uri ^? uriAuthority . _Right . authPort . _Just

107118 redirectHost = _runConfig_redirectHost conf

108119 redirectPort = _runConfig_redirectPort conf

@@ -114,19 +125,22 @@ runWidget conf frontend validFullEncoder = do

114125 close

115126 (\skt -> do

116127 man <- newManager defaultManagerSettings

117− app <- obeliskApp defaultConnectionOptions frontend validFullEncoder uri $ fallbackProxy redirectHost redirectPort man

128+ app <- obeliskApp configs defaultConnectionOptions frontend validFullEncoder uri $ fallbackProxy redirectHost redirectPort man

118129 runSettingsSocket settings skt app)

119130

120131obeliskApp

121− :: forall route backendRoute. ConnectionOptions

132+ :: forall route backendRoute

133+ . Map Text Text

134+ -> ConnectionOptions

122135 -> Frontend (R route)

123136 -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

124137 -> URI

125138 -> Application

126139 -> IO Application

127−obeliskApp opts frontend validFullEncoder uri backend = do

140+obeliskApp configs opts frontend validFullEncoder uri backend = do

128141 let entryPoint = do

129− runFrontend validFullEncoder frontend

142+ removeHTMLConfigs

143+ runFrontendWithConfigs configs validFullEncoder frontend

130144 syncPoint

131145 jsaddlePath <- URI.mkPathPiece "jsaddle"

132146 let jsaddleUri = BSLC.fromStrict $ URI.renderBs $ uri & uriPath %~ (<>[jsaddlePath])

@@ -141,15 +155,21 @@ obeliskApp opts frontend validFullEncoder uri backend = do

141155 }

142156 InR (ObeliskRoute_App appRouteComponent) :=> Identity appRouteRest -> do

143157 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)

144− html <- renderJsaddleFrontend cookies (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend

158+ html <- renderJsaddleFrontend configs cookies (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend

145159 sendResponse $ W.responseLBS H.status200 [("Content-Type", staticRenderContentType)] $ BSLC.fromStrict html

146160 _ -> backend req sendResponse

147161

148−renderJsaddleFrontend :: Cookies -> (route -> Text) -> route -> Frontend route -> IO ByteString

149−renderJsaddleFrontend cookies urlEnc r f =

162+renderJsaddleFrontend

163+ :: Map Text Text

164+ -> Cookies

165+ -> (route -> Text)

166+ -> route

167+ -> Frontend route

168+ -> IO ByteString

169+renderJsaddleFrontend configs cookies urlEnc r f =

150170 let jsaddleScript = elAttr "script" ("src" =: "/jsaddle/jsaddle.js") blank

151171 jsaddlePreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: "/jsaddle/jsaddle.js") blank

152− in renderFrontendHtml cookies urlEnc r (_frontend_head f >> jsaddlePreload) (_frontend_body f >> jsaddleScript)

172+ in renderFrontendHtml configs cookies urlEnc r f jsaddlePreload jsaddleScript

153173

154174-- | like 'bindPortTCP' but reconnects on exception

155175bindPortTCPRetry :: Settings

lib/selftest/obelisk-selftest.cabal+1

@@ -16,6 +16,7 @@ library

1616 , http-types

1717 , HUnit

1818 , obelisk-cliapp

19+ , obelisk-executable-config-lookup

1920 , obelisk-run

2021 , process

2122 , network

lib/selftest/src/Obelisk/SelfTest.hs+4−2

@@ -34,6 +34,7 @@ import Test.HUnit.Base

3434

3535import Obelisk.CliApp hiding (runCli, readCreateProcessWithExitCode)

3636import qualified Obelisk.CliApp as CliApp

37+import Obelisk.ExecutableConfig.Lookup (getConfigs)

3738import Obelisk.Run (getConfigRoute)

3839

3940data ObRunState

@@ -126,8 +127,9 @@ main = do

126127 void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]

127128 ls tmp >>= liftIO . assertEqual "" []

128129

129− it "produces a valid route config" $ inTmpObInit $ \tmp -> do

130− liftIO $ withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ getConfigRoute `shouldNotReturn` Nothing

130+ it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $ do

131+ configs <- getConfigs

132+ withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ getConfigRoute configs `shouldNotReturn` Nothing

131133

132134 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

133135 -- when not run by 'nix-build --attr selftest'