86a9584 · obelisk · git.iko.soy

.gitignore+1−3

compare with master

unifiedsplit

@@ -4,12 +4,10 @@

4result

5*.o

6*.hi

7−

8TAGS

7TAGS

9tags

8tags

10ctags

9ctags

11dist-newstyle

10dist-newstyle

12cabal.project.local

11cabal.project.local

13.ghc.environment.*

12.ghc.environment.*

14−

15−**/ghcid-output.txt

13+**/ghcid-output.txt

ChangeLog.md+4−1

@@ -3,7 +3,10 @@

3This project's release branch is `master`. This log is written from the perspective of the release branch: when changes hit `master`, they are considered released, and the date should reflect that release.

4

5## Unreleased

6−

6+* Configs become ByteStrings.

7+* FrontendConfigsT has been changed into ConfigsT and configs are made available via getConfig/getConfigs

8+ * The frontend will still only have access to configs that are placed in config/frontend and config/common, while the backend has access to the entire contents of the config directory via `Obelisk.ExecutableConfig.Lookup.getConfigs`.

9+* The backend no longer runs in BackendConfigsT.

7* Add tabulation package. See Data.Tabulation for details.

10* Add tabulation package. See Data.Tabulation for details.

8* Add encoders for `DMap`, `HasFields` (cf. Data.Tabulation), and JSON.

11* Add encoders for `DMap`, `HasFields` (cf. Data.Tabulation), and JSON.

9

12

default.nix−8

@@ -39,14 +39,6 @@ let

39 rev = "42afdc21da5d9e076eab57eaa42bfdde938192b8";

40 sha256 = "0psw384dx9bw2dp93xrzw8rd9amvcwgzn64jzzwby7sfspj6k349";

41 }) {});

42− # Need 8.0.2 build support

43− # PR: https://github.com/dmwit/universe/pull/33

44− universe-template = self.callCabal2nix "universe-template" (pkgs.fetchFromGitHub {

45− owner = "obsidiansystems";

46− repo = "universe";

47− rev = "6a71119bfa5db2b9990a2491c941469ff8ef5d13";

48− sha256 = "0z8smyainnlzcglv3dlx6x1n9j6d2jv48aa8f2421iayfkxg3js5";

49− } + /template) {};

50 })

42 })

51

43

52 pkgs.obeliskExecutableConfig.haskellOverlay

44 pkgs.obeliskExecutableConfig.haskellOverlay

dep/reflex-platform/github.json+3−3

@@ -1,7 +1,7 @@

1{

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

4− "branch": "develop",

4+ "branch": "cg-bump-reflex-dom",

5− "rev": "d68ab80e3a92425d4bcbfa2da7c685aded550c16",

5+ "rev": "7ecb4c255bb053a7a4796ffd6331cdbe210de91c",

6− "sha256": "0d5hc4v56pldy65rl0pmdzx2jylh8rjqqg5n0qb48039yy3pp8cq"

6+ "sha256": "1mngxa24cfpvxxq4hgh77nw36vny4abl5wi2xmlwpkk25wzm0h0x"

7}

lib/backend/obelisk-backend.cabal+1−1

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

16 lens,

17 mtl,

18 obelisk-asset-serve-snap,

19− obelisk-executable-config-backend,

19+ obelisk-executable-config-inject,

20 obelisk-executable-config-lookup,

21 obelisk-frontend,

22 obelisk-route,

lib/backend/src/Obelisk/Backend.hs+22−37

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

11 ( Backend (..)

12 -- * Re-exports

13 , Default (def)

14− , ComponentConfigs(..)

15 , getPageName

14 , getPageName

16 , getRouteWith

15 , getRouteWith

17 , runSnapWithCommandLineArgs

16 , runSnapWithCommandLineArgs

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

20 , runBackend

19 , runBackend

21 , staticRenderContentType

20 , staticRenderContentType

22 , mkRouteToUrl

21 , mkRouteToUrl

23− , getComponentConfigs

22+ , getPublicConfigs

24 ) where

23 ) where

25

24

26import Prelude hiding (id, (.))

25import Prelude hiding (id, (.))

@@ -41,8 +40,7 @@ import Data.Text (Text)

41import qualified Data.Text as T

40import qualified Data.Text as T

42import Data.Text.Encoding

41import Data.Text.Encoding

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

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

44−import Obelisk.ExecutableConfig.Backend

43+import qualified Obelisk.ExecutableConfig.Lookup as Lookup

45−import Obelisk.ExecutableConfig.Lookup

46import Obelisk.Frontend

44import Obelisk.Frontend

47import Obelisk.Route

45import Obelisk.Route

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

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

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

55

53

56data Backend backendRoute frontendRoute = Backend

54data Backend backendRoute frontendRoute = Backend

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

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

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

56+ , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> 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

66 }

57 }

67

58

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

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

@@ -80,7 +71,7 @@ serveDefaultObeliskApp

80 -> ([Text]

71 -> ([Text]

81 -> m ())

72 -> m ())

82 -> Frontend (R appRoute)

73 -> Frontend (R appRoute)

83− -> Map Text Text

74+ -> Map Text ByteString

84 -> R (ObeliskRoute appRoute)

75 -> R (ObeliskRoute appRoute)

85 -> m ()

76 -> m ()

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

77serveDefaultObeliskApp urlEnc serveStaticAsset frontend configs = serveObeliskApp urlEnc serveStaticAsset frontendApp configs

@@ -139,7 +130,7 @@ serveObeliskApp

139 => (R appRoute -> Text)

130 => (R appRoute -> Text)

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

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

141 -> GhcjsApp (R appRoute)

132 -> GhcjsApp (R appRoute)

142− -> Map Text Text

133+ -> Map Text ByteString

143 -> R (ObeliskRoute appRoute)

134 -> R (ObeliskRoute appRoute)

144 -> m ()

135 -> m ()

145serveObeliskApp urlEnc serveStaticAsset frontendApp config = \case

136serveObeliskApp urlEnc serveStaticAsset frontendApp config = \case

@@ -174,7 +165,7 @@ serveGhcjsApp

174 :: (MonadSnap m, HasCookies m)

165 :: (MonadSnap m, HasCookies m)

175 => (R appRouteComponent -> Text)

166 => (R appRouteComponent -> Text)

176 -> GhcjsApp (R appRouteComponent)

167 -> GhcjsApp (R appRouteComponent)

177− -> Map Text Text

168+ -> Map Text ByteString

178 -> R (GhcjsAppRoute appRouteComponent)

169 -> R (GhcjsAppRoute appRouteComponent)

179 -> m ()

170 -> m ()

180serveGhcjsApp urlEnc app config = \case

171serveGhcjsApp urlEnc app config = \case

@@ -187,17 +178,15 @@ runBackend :: Backend fullRoute frontendRoute -> Frontend (R frontendRoute) -> I

187runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

178runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

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

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

189 Right validFullEncoder -> do

180 Right validFullEncoder -> do

190− configs <- getComponentConfigs

181+ publicConfigs <- getPublicConfigs

191− runBackendConfigsT (_componentConfigs_backend configs) $

192− _backend_run backend $ \serveRoute -> do

182+ _backend_run backend $ \serveRoute -> do

193− runSnapWithCommandLineArgs $ do

183+ runSnapWithCommandLineArgs $ do

194− getRouteWith validFullEncoder >>= \case

184+ getRouteWith validFullEncoder >>= \case

195− Identity r -> case r of

185+ Identity r -> case r of

196− InL backendRoute :=> Identity a ->

186+ InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

197− runBackendConfigsT (_componentConfigs_backend configs) $

198− serveRoute $ backendRoute :/ a

199− InR obeliskRoute :=> Identity a ->

187+ InR obeliskRoute :=> Identity a ->

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

188+ serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $

189+ obeliskRoute :/ a

201

190

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

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

203mkRouteToUrl validFullEncoder =

192mkRouteToUrl validFullEncoder =

@@ -208,7 +197,7 @@ renderGhcjsFrontend

208 :: (MonadSnap m, HasCookies m)

197 :: (MonadSnap m, HasCookies m)

209 => (route -> Text)

198 => (route -> Text)

210 -> route

199 -> route

211− -> Map Text Text

200+ -> Map Text ByteString

212 -> Frontend route

201 -> Frontend route

213 -> m ByteString

202 -> m ByteString

214renderGhcjsFrontend urlEnc route configs f = do

203renderGhcjsFrontend urlEnc route configs f = do

@@ -220,13 +209,9 @@ renderGhcjsFrontend urlEnc route configs f = do

220instance HasCookies Snap where

209instance HasCookies Snap where

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

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

222

211

223−getComponentConfigs :: IO ComponentConfigs

212+-- | Get configs from the canonical "public" locations (i.e., locations that obelisk expects to make available

224−getComponentConfigs = do

213+-- to frontend applications, and hence visible to end users).

225− allConfigs <- getConfigs

214+getPublicConfigs :: IO (Map Text ByteString)

226− return $ ComponentConfigs

215+getPublicConfigs = Map.filterWithKey (\k _ -> isMemberOf k ["common", "frontend"]) <$> Lookup.getConfigs

227− { _componentConfigs_backend =

216+ where

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 (`T.isPrefixOf` k) dirs

217+ isMemberOf k = any (`T.isPrefixOf` k)

lib/executable-config/backend/obelisk-executable-config-backend.cabaldeleted−20

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

1−name: obelisk-executable-config-backend

2−version: 0.1

3−cabal-version: >= 1.2

4−build-type: Simple

5−

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.hsdeleted−77

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

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 ("backend/" <> k) <$> ask

71− getCommonConfig k = BackendConfigsT $ Map.lookup ("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+1−3

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

16 exit 1

17 fi

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

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

19+ find "$out/config" -type f -printf '%P\0' >"$out/config.files"

20 '');

21in with nixpkgs.haskell.lib; {

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) {};

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

26 };

24 };

27 platforms = {

25 platforms = {

lib/executable-config/frontend/obelisk-executable-config-frontend.cabaldeleted−21

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

1−name: obelisk-executable-config-frontend

2−version: 0.1

3−cabal-version: >= 1.2

4−build-type: Simple

5−

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.hsdeleted−115

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

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 ("frontend/" <> k) <$> ask

109− getCommonConfig k = FrontendConfigsT $ Map.lookup ("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+2

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

8

9 build-depends:

10 base,

11+ bytestring,

12+ base64-bytestring,

11 containers,

13 containers,

12 reflex-dom-core,

14 reflex-dom-core,

13 text

15 text

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

@@ -3,20 +3,23 @@ module Obelisk.ExecutableConfig.Inject where

3

4import Control.Monad (mapM_)

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

6+import Data.ByteString (ByteString)

7+import qualified Data.ByteString.Base64 as B64

6import Data.Map (Map)

8import Data.Map (Map)

7import qualified Data.Map as Map

9import qualified Data.Map as Map

8import Data.Semigroup ((<>))

10import Data.Semigroup ((<>))

9import Data.Text (Text)

11import Data.Text (Text)

12+import qualified Data.Text.Encoding as T

10import Reflex.Dom.Core hiding (value)

13import Reflex.Dom.Core hiding (value)

11

14

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

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

13−-- whose value is the provided configuration

16+-- whose value is the provided configuration, encoded in base64.

14−injectPure :: DomBuilder t m => Text -> Text -> m ()

17+injectPure :: DomBuilder t m => Text -> ByteString -> m ()

15injectPure key value =

18injectPure key value =

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

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

17− in elAttr "script" attrs $ text value

20+ in elAttr "script" attrs $ text (T.decodeUtf8 (B64.encode value))

18

21

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

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

20-- (filepaths) and values.

23-- (filepaths) and values.

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

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

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

25injectExecutableConfigs = mapM_ (uncurry injectPure) . Map.toList

lib/executable-config/lookup/default.nix+4−2

@@ -1,5 +1,7 @@

1{ hostPlatform, ghc

2−, mkDerivation, base, bytestring, filepath, stdenv, text, transformers

2+, mkDerivation, base, base64-bytestring, bytestring, filepath, stdenv, text, transformers

3+, transformers-base, ref-tf, primitive, monad-control, reflex, reflex-dom

4+, jsaddle

3, android-activity ? null, jsaddle-wkwebview ? null, ghcjs-dom ? null

5, android-activity ? null, jsaddle-wkwebview ? null, ghcjs-dom ? null

4}:

6}:

5let isAndroid = hostPlatform.libc == "bionic";

7let isAndroid = hostPlatform.libc == "bionic";

@@ -10,7 +12,7 @@ in mkDerivation {

10 version = "0.1";

12 version = "0.1";

11 src = ./.;

13 src = ./.;

12 libraryHaskellDepends = [

14 libraryHaskellDepends = [

13− base bytestring filepath text transformers

15+ base bytestring filepath text transformers transformers-base ref-tf primitive monad-control reflex reflex-dom jsaddle

14 ] ++ (if isAndroid then [

16 ] ++ (if isAndroid then [

15 android-activity

17 android-activity

16 ] else if isIOS then [

18 ] else if isIOS then [

lib/executable-config/lookup/obelisk-executable-config-lookup.cabal+16−8

@@ -4,34 +4,42 @@ cabal-version: >= 1.2

4build-type: Simple

5

6library

7− exposed-modules: Obelisk.ExecutableConfig.Lookup

7+ exposed-modules: Obelisk.ExecutableConfig.Lookup, Obelisk.Configs

8 if os(ios)

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

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

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

10+ other-modules: Obelisk.Configs.Internal.Directory

11 build-depends: jsaddle-wkwebview

12 build-depends: directory

13 else

14 if os(linux-android)

15− hs-source-dirs: src-android

15+ hs-source-dirs: src-android, src

16 c-sources: cbits/ExecutableConfig.c

17 other-modules: Obelisk.ExecutableConfig.Internal.AssetManager

18 build-depends: android-activity

19 ld-options: -landroid

20 else

21 if impl(ghcjs)

22− hs-source-dirs: src-ghcjs

22+ hs-source-dirs: src-ghcjs, src

23 build-depends: ghcjs-dom

24 else

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

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

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

26+ other-modules: Obelisk.Configs.Internal.Directory

27 build-depends: directory

28

29 build-depends:

30 base,

31+ base64-bytestring,

31 bytestring,

32 bytestring,

32 containers,

33 containers,

33 filepath,

34 filepath,

34 text,

35 text,

35− transformers

36+ transformers,

37+ transformers-base,

38+ ref-tf,

39+ primitive,

40+ monad-control,

41+ reflex,

42+ reflex-dom,

43+ jsaddle

36

44

37 ghc-options: -Wall

45 ghc-options: -Wall

lib/executable-config/lookup/src-android/Obelisk/ExecutableConfig/Lookup.hs+11−7

@@ -1,8 +1,10 @@

1{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module Obelisk.ExecutableConfig.Lookup where

3module Obelisk.ExecutableConfig.Lookup where

3

4

4import Control.Exception (bracket)

5import Control.Exception (bracket)

5import Control.Monad (forM)

6import Control.Monad (forM)

7+import Data.ByteString (ByteString)

6import qualified Data.ByteString as BS

8import qualified Data.ByteString as BS

7import Data.Map (Map)

9import Data.Map (Map)

8import qualified Data.Map as Map

10import qualified Data.Map as Map

@@ -13,7 +15,7 @@ import Foreign.Ptr (nullPtr)

13

15

14import Obelisk.ExecutableConfig.Internal.AssetManager

16import Obelisk.ExecutableConfig.Internal.AssetManager

15

17

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

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

17getFromMgr mgr name = do

19getFromMgr mgr name = do

18 let open = do

20 let open = do

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

21 a <- BS.useAsCString name $ \fn ->

@@ -25,10 +27,10 @@ getFromMgr mgr name = do

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

27 bracket open close $ mapM $ \asset -> do

26 b <- asset_getBuffer asset

28 b <- asset_getBuffer asset

27 l <- asset_getLength asset

29 l <- asset_getLength asset

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

30+ BS.packCStringLen (b, fromIntegral l)

29

31

30−getConfigs :: IO (Map Text Text)

32+getConfigs :: IO (Map Text ByteString)

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

33+getConfigs = fmap (Map.mapKeys T.decodeUtf8) $ bracket getAssets freeAssetManager $ \mgrObj -> do

32 mgr <- assetManagerFromJava mgrObj

34 mgr <- assetManagerFromJava mgrObj

33 let openDir = do

35 let openDir = do

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

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

@@ -43,10 +45,12 @@ getConfigs = bracket getAssets freeAssetManager $ \mgrObj -> do

43 l <- asset_getLength asset

45 l <- asset_getLength asset

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

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

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

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

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

48+ result <- fmap Map.fromList $ forM configPaths $ \fp ->

47− getFromMgr mgr fp >>= \case

49+ getFromMgr mgr ("config/" <> fp) >>= \case

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

50+ Just v -> return (fp, v)

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

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

52+ putStrLn $ "getConfigs: found " <> show result

53+ pure result

50

54

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

55lines0 :: BS.ByteString -> [BS.ByteString]

52lines0 ps

56lines0 ps

lib/executable-config/lookup/src-directory/Obelisk/ExecutableConfig/Internal/ConfigDirectory.hsdeleted−28

@@ -1,28 +0,0 @@

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Obelisk.ExecutableConfig.Internal.ConfigDirectory where

4−

5−import Control.Monad

6−import Data.Map (Map)

7−import qualified Data.Map as Map

8−import Data.Text (Text)

9−import Data.Text as T

10−import Data.Text.IO as T

11−import System.Directory

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

13−

14−getConfigsFromDirectory :: FilePath -> IO (Map Text Text)

15−getConfigsFromDirectory base = do

16− doesDirectoryExist base >>= \case

17− True -> do

18− ps <- listDirectory base

19− fmap mconcat $ forM ps $ \p -> do

20− subdirConfigs <- getConfigsFromDirectory $ base </> p

21− pure $ Map.mapKeys (T.pack . (p </>) . T.unpack) subdirConfigs

22− False -> do

23− doesFileExist base >>= \case

24− True -> do

25− f <- T.readFile base

26− pure $ Map.singleton "" f

27− False -> do

28− pure mempty

lib/executable-config/lookup/src-ghcjs/Obelisk/ExecutableConfig/Lookup.hs+8−2

@@ -2,10 +2,13 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Obelisk.ExecutableConfig.Lookup where

4

5+import Data.ByteString (ByteString)

6+import qualified Data.ByteString.Base64 as B64

5import Data.Map (Map)

7import Data.Map (Map)

6import qualified Data.Map as Map

8import qualified Data.Map as Map

7import Data.Maybe (catMaybes)

9import Data.Maybe (catMaybes)

8import Data.Text (Text)

10import Data.Text (Text)

11+import qualified Data.Text.Encoding as T

9import Data.Traversable (for)

12import Data.Traversable (for)

10import GHCJS.DOM

13import GHCJS.DOM

11import GHCJS.DOM.Document (getHead)

14import GHCJS.DOM.Document (getHead)

@@ -16,7 +19,7 @@ import GHCJS.DOM.NodeList (item, getLength)

16import GHCJS.DOM.ParentNode (querySelectorAll)

19import GHCJS.DOM.ParentNode (querySelectorAll)

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

20import GHCJS.DOM.Types (Node(Node), castTo)

18

21

19−getConfigs :: IO (Map Text Text)

22+getConfigs :: IO (Map Text ByteString)

20getConfigs = do

23getConfigs = do

21 Just doc <- currentDocument

24 Just doc <- currentDocument

22 Just hd <- getHead doc

25 Just hd <- getHead doc

@@ -28,9 +31,12 @@ getConfigs = do

28 dataset <- getDataset e

31 dataset <- getDataset e

29 (,)

32 (,)

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

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

31− <*> getInnerHTML e

34+ <*> (fmap decodeOrFail (getInnerHTML e))

32 where

35 where

33 collToList es = do

36 collToList es = do

34 len <- getLength es

37 len <- getLength es

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

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

36 pure $ catMaybes list

39 pure $ catMaybes list

40+ decodeOrFail x = case B64.decode (T.encodeUtf8 x) of

41+ Left e -> error ("Obelisk.ExecutableConfig.Lookup.getConfigs: error when decoding base64: " ++ e)

42+ Right x' -> x'

lib/executable-config/lookup/src-ios/Obelisk/ExecutableConfig/Lookup.hs+5−3

@@ -1,15 +1,17 @@

1{-# LANGUAGE LambdaCase #-}

2module Obelisk.ExecutableConfig.Lookup where

3

4+import Data.ByteString (ByteString)

4import Data.Map (Map)

5import Data.Map (Map)

5import Data.Text (Text)

6import Data.Text (Text)

6import qualified Data.Text as T

7import qualified Data.Text as T

7import qualified Data.Text.Encoding as T

8import qualified Data.Text.Encoding as T

8import Language.Javascript.JSaddle.WKWebView

9import Language.Javascript.JSaddle.WKWebView

10+import System.FilePath.Posix

9

11

10−import Obelisk.ExecutableConfig.Internal.ConfigDirectory

12+import Obelisk.Configs.Internal.Directory

11

13

12−getConfigs :: IO (Map Text Text)

14+getConfigs :: IO (Map Text ByteString)

13getConfigs = mainBundleResourcePath >>= \case

15getConfigs = mainBundleResourcePath >>= \case

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

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

15− Just _ -> getConfigsFromDirectory "config"

17+ Just p -> getConfigsFromDirectory $ T.unpack (T.decodeUtf8 p) </> "config"

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

@@ -0,0 +1,18 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Obelisk.ExecutableConfig.Lookup where

4+

5+import Data.Map (Map)

6+import qualified Data.Map as Map

7+import Data.Text (Text)

8+import qualified Data.Text as T

9+import Data.ByteString (ByteString)

10+import qualified Data.ByteString as BS

11+import System.Directory

12+import System.FilePath

13+import Control.Monad

14+

15+import Obelisk.Configs.Internal.Directory

16+

17+getConfigs :: IO (Map Text ByteString)

18+getConfigs = getConfigsFromDirectory "config"

lib/executable-config/lookup/src/Obelisk/Configs.hsnew file+124

@@ -0,0 +1,124 @@

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.Configs

14+ ( HasConfigs(..)

15+ , ConfigsT

16+ , runConfigsT

17+ , mapConfigsT

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.ByteString (ByteString)

31+import Data.Map (Map)

32+import qualified Data.Map as Map

33+import Data.Text (Text)

34+import Reflex

35+import Reflex.Host.Class

36+import Reflex.Dom

37+#ifndef ghcjs_HOST_OS

38+import Language.Javascript.JSaddle (MonadJSM)

39+#endif

40+

41+class Monad m => HasConfigs m where

42+ getConfigs :: m (Map Text ByteString)

43+ default getConfigs :: (HasConfigs m', m ~ t m', MonadTrans t) => m (Map Text ByteString)

44+ getConfigs = lift getConfigs

45+ getConfig :: Text -> m (Maybe ByteString)

46+ getConfig k = do

47+ configs <- getConfigs

48+ return $ Map.lookup k configs

49+

50+instance Monad m => HasConfigs (ConfigsT m) where

51+ getConfigs = ConfigsT ask

52+

53+instance HasConfigs m => HasConfigs (BehaviorWriterT t w m)

54+instance HasConfigs m => HasConfigs (DynamicWriterT t w m)

55+instance HasConfigs m => HasConfigs (EventWriterT t w m)

56+instance HasConfigs m => HasConfigs (PostBuildT t m)

57+instance HasConfigs m => HasConfigs (QueryT t q m)

58+instance HasConfigs m => HasConfigs (ReaderT r m)

59+instance HasConfigs m => HasConfigs (RequesterT t request response m)

60+instance HasConfigs m => HasConfigs (StaticDomBuilderT t m)

61+instance HasConfigs m => HasConfigs (TriggerEventT t m)

62+

63+newtype ConfigsT m a = ConfigsT { unConfigsT :: ReaderT (Map Text ByteString) m a }

64+ deriving

65+ ( Functor

66+ , Applicative

67+ , Monad

68+ , MonadPlus

69+ , Alternative

70+ , MonadFix

71+ , MonadIO

72+ , MonadBase m'

73+ , MonadBaseControl m'

74+ , MonadRef

75+ , MonadTrans

76+ , DomBuilder t

77+ , MonadHold t

78+ , MonadReflexCreateTrigger t

79+ , MonadSample t

80+ , NotReady t

81+ , PostBuild t

82+ , TriggerEvent t

83+ , HasDocument

84+ , DomRenderHook t

85+ , HasJSContext

86+ , HasJS js

87+#ifndef ghcjs_HOST_OS

88+ , MonadJSM

89+#endif

90+ )

91+

92+instance PerformEvent t m => PerformEvent t (ConfigsT m) where

93+ type Performable (ConfigsT m) = ConfigsT (Performable m)

94+ performEvent e = ConfigsT $ ReaderT $ \configs ->

95+ performEvent $ runConfigsT configs <$> e

96+ performEvent_ e = ConfigsT $ ReaderT $ \configs ->

97+ performEvent_ $ runConfigsT configs <$> e

98+

99+instance Adjustable t m => Adjustable t (ConfigsT m) where

100+ runWithReplace a e = ConfigsT $ runWithReplace (unConfigsT a) (unConfigsT <$> e)

101+ traverseDMapWithKeyWithAdjust f m e = ConfigsT $ traverseDMapWithKeyWithAdjust (\k v -> unConfigsT $ f k v) m e

102+ traverseIntMapWithKeyWithAdjust f m e = ConfigsT $ traverseIntMapWithKeyWithAdjust (\k v -> unConfigsT $ f k v) m e

103+ traverseDMapWithKeyWithAdjustWithMove f m e = ConfigsT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unConfigsT $ f k v) m e

104+

105+instance Prerender js t m => Prerender js t (ConfigsT m) where

106+ type Client (ConfigsT m) = ConfigsT (Client m)

107+ prerender server client = ConfigsT $ ReaderT $ \configs ->

108+ prerender (runConfigsT configs server) (runConfigsT configs client)

109+

110+instance PrimMonad m => PrimMonad (ConfigsT m) where

111+ type PrimState (ConfigsT m) = PrimState m

112+ primitive = lift . primitive

113+

114+runConfigsT

115+ :: Map Text ByteString

116+ -> ConfigsT m a

117+ -> m a

118+runConfigsT cs child = runReaderT (unConfigsT child) cs

119+

120+mapConfigsT

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

122+ -> ConfigsT m a

123+ -> ConfigsT n a

124+mapConfigsT f (ConfigsT x) = ConfigsT $ mapReaderT f x

lib/executable-config/lookup/src/Obelisk/Configs/Internal/Directory.hsnew file+24

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

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Obelisk.Configs.Internal.Directory where

4+

5+import Control.Monad

6+import Data.ByteString (ByteString)

7+import qualified Data.ByteString as BS

8+import Data.Map (Map)

9+import qualified Data.Map as Map

10+import Data.Text (Text)

11+import qualified Data.Text as T

12+import System.Directory

13+import System.FilePath.Posix

14+

15+getConfigsFromDirectory :: FilePath -> IO (Map Text ByteString)

16+getConfigsFromDirectory base = doesDirectoryExist base >>= \case

17+ True -> do

18+ ps <- listDirectory base

19+ fmap mconcat $ forM ps $ \p -> do

20+ subdirConfigs <- getConfigsFromDirectory $ base </> p

21+ pure $ Map.mapKeys (T.pack . (p </>) . T.unpack) subdirConfigs

22+ False -> doesFileExist base >>= \case

23+ True -> Map.singleton "" <$> BS.readFile base

24+ False -> pure mempty

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

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

1−module Obelisk.ExecutableConfig.Lookup where

2−

3−import Data.Map (Map)

4−import Data.Text (Text)

5−

6−import Obelisk.ExecutableConfig.Internal.ConfigDirectory

7−

8−getConfigs :: IO (Map Text Text)

9−getConfigs = getConfigsFromDirectory "config"

lib/frontend/obelisk-frontend.cabal−1

@@ -14,7 +14,6 @@ library

14 jsaddle,

15 lens,

16 mtl,

17− obelisk-executable-config-frontend,

18 obelisk-executable-config-inject,

17 obelisk-executable-config-inject,

19 obelisk-executable-config-lookup,

18 obelisk-executable-config-lookup,

20 obelisk-route,

19 obelisk-route,

lib/frontend/src/Obelisk/Frontend.hs+105−30

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

1−{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE LambdaCase #-}

@@ -15,9 +15,10 @@ module Obelisk.Frontend

15 ( ObeliskWidget

16 , Frontend (..)

17 , runFrontend

18− , runFrontendWithConfigs

18+ , runFrontendWithConfigsAndCurrentRoute

19 , renderFrontendHtml

20 , removeHTMLConfigs

21+ , FrontendMode (..)

21 , module Obelisk.Frontend.Cookie

22 , module Obelisk.Frontend.Cookie

22 ) where

23 ) where

23

24

@@ -38,21 +39,27 @@ import Data.Map (Map)

38import Data.Maybe (catMaybes)

39import Data.Maybe (catMaybes)

39import Data.Monoid ((<>))

40import Data.Monoid ((<>))

40import Data.Text (Text)

41import Data.Text (Text)

42+import qualified GHCJS.DOM as DOM

43+import qualified GHCJS.DOM.Types as DOM

44+import qualified GHCJS.DOM.History as DOM

45+import qualified GHCJS.DOM.Window as DOM

46+import Language.Javascript.JSaddle (JSM, jsNull)

41import GHCJS.DOM (currentDocument)

47import GHCJS.DOM (currentDocument)

42import GHCJS.DOM.Document (getHead)

48import GHCJS.DOM.Document (getHead)

43import GHCJS.DOM.Node (removeChild_)

49import GHCJS.DOM.Node (removeChild_)

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

50import GHCJS.DOM.NodeList (item, getLength)

45import GHCJS.DOM.ParentNode (querySelectorAll)

51import GHCJS.DOM.ParentNode (querySelectorAll)

46−import Language.Javascript.JSaddle (JSM)

47import Obelisk.Frontend.Cookie

52import Obelisk.Frontend.Cookie

48import Obelisk.Route.Frontend

53import Obelisk.Route.Frontend

49import Reflex.Dom.Core

54import Reflex.Dom.Core

50import Reflex.Host.Class

55import Reflex.Host.Class

51−import Obelisk.ExecutableConfig.Frontend

56+import Obelisk.Configs

52import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)

57import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)

53−import Obelisk.ExecutableConfig.Lookup (getConfigs)

58+import qualified Obelisk.ExecutableConfig.Lookup as Lookup

54import Web.Cookie

59import Web.Cookie

55

60

61+import Debug.Trace

62+

56makePrisms ''Sum

63makePrisms ''Sum

57

64

58type ObeliskWidget js t route m =

65type ObeliskWidget js t route m =

@@ -74,7 +81,7 @@ type ObeliskWidget js t route m =

74 , Prerender js t m

81 , Prerender js t m

75 , PrebuildAgnostic t route m

82 , PrebuildAgnostic t route m

76 , PrebuildAgnostic t route (Client m)

83 , PrebuildAgnostic t route (Client m)

77− , HasFrontendConfigs m

84+ , HasConfigs m

78 , HasCookies m

85 , HasCookies m

79 )

86 )

80

87

@@ -82,8 +89,8 @@ type PrebuildAgnostic t route m =

82 ( SetRoute t route m

89 ( SetRoute t route m

83 , RouteToUrl route m

90 , RouteToUrl route m

84 , MonadFix m

91 , MonadFix m

85− , HasFrontendConfigs m

92+ , HasConfigs m

86− , HasFrontendConfigs (Performable m)

93+ , HasConfigs (Performable m)

87 )

94 )

88

95

89data Frontend route = Frontend

96data Frontend route = Frontend

@@ -106,49 +113,117 @@ removeHTMLConfigs = void $ runMaybeT $ do

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

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

107 pure $ catMaybes lst

114 pure $ catMaybes lst

108

115

116+setInitialRoute :: Bool -> JSM ()

117+setInitialRoute useHash = do

118+ traceM "setInitialRoute"

119+ window <- DOM.currentWindowUnchecked

120+ initialLocation <- DOM.getLocation window

121+ initialUri <- getLocationUri initialLocation

122+ history <- DOM.getHistory window

123+ DOM.replaceState history jsNull ("" :: Text) $ Just $

124+ show $ setAdaptedUriPath useHash "/" initialUri

125+

126+data FrontendMode = FrontendMode

127+ { _frontendMode_hydrate :: Bool

128+ -- ^ There is already a rendering of the DOM in place; hydrate it rather

129+ -- than building new DOM

130+ , _frontendMode_adjustRoute :: Bool

131+ -- ^ The page can't use regular routes, so encode routes into the hash

132+ -- instead

133+ }

134+

135+-- | Run the frontend, setting the initial route to "/" on platforms where no

136+-- route exists ambiently in the context (e.g. anything but web).

137+-- Selects FrontendMode based on platform; this doesn't work for jsaddle-warp

109runFrontend

138runFrontend

110 :: forall backendRoute route

139 :: forall backendRoute route

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

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

112 -> Frontend (R route)

141 -> Frontend (R route)

113 -> JSM ()

142 -> JSM ()

114runFrontend validFullEncoder frontend = do

143runFrontend validFullEncoder frontend = do

115− configs <- liftIO getConfigs

144+ let mode = FrontendMode

145+ { _frontendMode_hydrate =

146+#ifdef ghcjs_HOST_OS

147+ True

148+#else

149+ False

150+#endif

151+ , _frontendMode_adjustRoute =

116#ifdef ghcjs_HOST_OS

152#ifdef ghcjs_HOST_OS

117− removeHTMLConfigs

153+ False

154+#else

155+ True

118#endif

156#endif

157+ }

158+ configs <- liftIO Lookup.getConfigs

159+ when (_frontendMode_hydrate mode) removeHTMLConfigs

160+ -- There's no fundamental reason that adjustRoute needs to control setting the

161+ -- initial route and *also* the useHash parameter; that's why these are

162+ -- separate here. However, currently, they are always the same.

163+ when (_frontendMode_adjustRoute mode) $ do

164+ setInitialRoute $ _frontendMode_adjustRoute mode

119− runFrontendWithConfigs configs validFullEncoder frontend

165+ runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend

120

166

121−runFrontendWithConfigs

167+runFrontendWithConfigsAndCurrentRoute

122 :: forall backendRoute route

168 :: forall backendRoute route

169+ . FrontendMode

123− . Map Text Text

170+ -> Map Text ByteString

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

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

125 -> Frontend (R route)

172 -> Frontend (R route)

126 -> JSM ()

173 -> JSM ()

127−runFrontendWithConfigs configs validFullEncoder frontend = do

174+runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do

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

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

129 errorLeft = \case

176 errorLeft = \case

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

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

131 Right x -> Identity x

178 Right x -> Identity x

179+ w :: ( RawDocument (DomBuilderSpace (HydrationDomBuilderT s DomTimeline m)) ~ DOM.Document

180+ , Ref (Performable m) ~ Ref IO

181+ , Ref m ~ Ref IO

182+ , DomBuilder DomTimeline (HydrationDomBuilderT s DomTimeline m)

183+ , MonadHold DomTimeline m

184+ , MonadRef m

185+ , MonadRef (Performable m)

186+ , MonadReflexCreateTrigger DomTimeline m

187+ , PerformEvent DomTimeline m

188+ , PostBuild DomTimeline m

189+ , PrimMonad m

190+ , MonadSample DomTimeline (Performable m)

191+ , DOM.MonadJSM m

192+ , Monad (Performable (Client (HydrationDomBuilderT s DomTimeline m)))

193+ , MonadFix (Client (HydrationDomBuilderT s DomTimeline m))

194+ , MonadFix (Performable m)

195+ , MonadFix m

196+ , Prerender js DomTimeline (HydrationDomBuilderT s DomTimeline m)

197+ , MonadIO (Performable m)

198+ )

199+ => (forall c. HydrationDomBuilderT s DomTimeline m c -> FloatingWidget () c)

200+ -> (forall c. HydrationDomBuilderT s DomTimeline m c -> FloatingWidget () c)

201+ -> FloatingWidget () ()

132− runHydrationWidgetWithHeadAndBody (pure ()) $ \appendHead appendBody -> do

202+ w appendHead appendBody = do

133− rec switchover <- runRouteViewT ve switchover $ do

203+ rec switchover <- runRouteViewT ve switchover (_frontendMode_adjustRoute mode) $ do

134− (switchover'', fire) <- newTriggerEvent

204+ (switchover'', fire) <- newTriggerEvent

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

205+ mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendHead . runConfigsT configs))) $ do

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

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

137− baseTag

207+ baseTag

138− _frontend_head frontend

208+ _frontend_head frontend

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

209+ mapRoutedT (mapSetRouteT (mapRouteToUrlT (appendBody . runConfigsT configs))) $ do

140− _frontend_body frontend

210+ _frontend_body frontend

211+ switchover' <- case _frontendMode_hydrate mode of

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

212+ True -> lift $ lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

213+ False -> getPostBuild

142− performEvent_ $ liftIO (fire ()) <$ switchover'

214+ performEvent_ $ liftIO (fire ()) <$ switchover'

143− pure switchover''

215+ pure switchover''

144− pure ()

216+ pure ()

217+ if _frontendMode_hydrate mode

218+ then runHydrationWidgetWithHeadAndBody (pure ()) w

219+ else runImmediateWidgetWithHeadAndBody w

145

220

146renderFrontendHtml

221renderFrontendHtml

147 :: ( t ~ DomTimeline

222 :: ( t ~ DomTimeline

148 , MonadIO m

223 , MonadIO m

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

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

150 )

225 )

151− => Map Text Text

226+ => Map Text ByteString

152 -> Cookies

227 -> Cookies

153 -> (r -> Text)

228 -> (r -> Text)

154 -> r

229 -> r

@@ -158,7 +233,7 @@ renderFrontendHtml

158 -> m ByteString

233 -> m ByteString

159renderFrontendHtml configs cookies urlEnc route frontend headExtra bodyExtra = do

234renderFrontendHtml configs cookies urlEnc route frontend headExtra bodyExtra = do

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

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

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

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

162 el "html" $ do

237 el "html" $ do

163 el "head" $ do

238 el "head" $ do

164 baseTag

239 baseTag

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

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

26import GHCJS.DOM.Types (MonadJSM)

27import Web.Cookie

28

29−import Obelisk.ExecutableConfig.Frontend

29+import Obelisk.Configs

30import Obelisk.Route.Frontend

31

32class Monad m => HasCookies m where

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

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

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

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

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

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

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

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

51

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

53 deriving

lib/route/obelisk-route.cabal+3−3

@@ -14,7 +14,6 @@ library

14 containers,

15 dependent-map,

16 dependent-sum,

17− dependent-sum-universe-orphans,

18 dependent-sum-template,

17 dependent-sum-template,

19 either,

18 either,

20 ghcjs-dom,

19 ghcjs-dom,

@@ -24,7 +23,7 @@ library

24 monad-control,

23 monad-control,

25 mtl,

24 mtl,

26 network-uri,

25 network-uri,

27− obelisk-executable-config-frontend,

26+ obelisk-executable-config-lookup,

28 primitive,

27 primitive,

29 ref-tf,

28 ref-tf,

30 reflex,

29 reflex,

@@ -32,9 +31,10 @@ library

32 template-haskell,

31 template-haskell,

33 tabulation,

32 tabulation,

34 text,

33 text,

34+ th-extras,

35 transformers,

36 universe,

37− universe-template

37+ universe-dependent-sum

38 exposed-modules: Obelisk.Route

39 Obelisk.Route.TH

40 Obelisk.Route.Frontend

lib/route/src/Obelisk/Route.hs+29−28

@@ -120,13 +120,12 @@ import Data.Maybe

120import Data.Monoid ((<>))

121import Data.Set (Set)

122import qualified Data.Set as Set

123−import Data.Some (Some)

123+import Data.Some (Some(Some))

124−import qualified Data.Some as Some

125−import Data.Some.Universe.Orphans ()

126import Data.Text (Text)

124import Data.Text (Text)

127import qualified Data.Text as T

125import qualified Data.Text as T

128−import Data.Text.Encoding

126+import qualified Data.Text.Encoding as T

129import Data.Universe

127import Data.Universe

128+import Data.Universe.Some

130import Network.HTTP.Types.URI

129import Network.HTTP.Types.URI

131import qualified Numeric.Lens

130import qualified Numeric.Lens

132import Obelisk.Route.TH

131import Obelisk.Route.TH

@@ -165,7 +164,7 @@ pattern (:/) :: f a -> a -> R f

165pattern a :/ b = a :=> Identity b

164pattern a :/ b = a :=> Identity b

166

165

167mapSome :: (forall a. f a -> g a) -> Some f -> Some g

166mapSome :: (forall a. f a -> g a) -> Some f -> Some g

168−mapSome f (Some.This a) = Some.This $ f a

167+mapSome f (Some a) = Some $ f a

169

168

170hoistR :: (forall x. f x -> g x) -> R f -> R g

169hoistR :: (forall x. f x -> g x) -> R f -> R g

171hoistR f (x :=> Identity y) = f x :/ y

170hoistR f (x :=> Identity y) = f x :/ y

@@ -359,8 +358,8 @@ nothingEncoder = prismEncoder _Nothing

359

358

360someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a

359someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a

361someConstEncoder = unsafeMkEncoder $ EncoderImpl

360someConstEncoder = unsafeMkEncoder $ EncoderImpl

362− { _encoderImpl_encode = \(Some.This (Const a)) -> a

361+ { _encoderImpl_encode = \(Some (Const a)) -> a

363− , _encoderImpl_decode = pure . Some.This . Const

362+ , _encoderImpl_decode = pure . Some . Const

364 }

363 }

365

364

366-- | WARNING: This is only safe if the Show and Read instances for 'a' are

365-- | WARNING: This is only safe if the Show and Read instances for 'a' are

@@ -388,7 +387,7 @@ checkEnum1EncoderFunc

388 -> check (EncoderFunc check' parse p r)

387 -> check (EncoderFunc check' parse p r)

389checkEnum1EncoderFunc f = do

388checkEnum1EncoderFunc f = do

390 (encoderImpls :: DMap p (Flip (EncoderImpl parse) r)) <- DMap.fromList <$>

389 (encoderImpls :: DMap p (Flip (EncoderImpl parse) r)) <- DMap.fromList <$>

391− traverse (\(Some.This p) -> (p :=>) . Flip <$> unEncoder (f p)) universe

390+ traverse (\(Some p) -> (p :=>) . Flip <$> unEncoder (f p)) universe

392 pure $ EncoderFunc $ \p -> unsafeMkEncoder . unFlip $

391 pure $ EncoderFunc $ \p -> unsafeMkEncoder . unFlip $

393 DMap.findWithDefault (error "checkEnum1EncoderFunc: EncoderImpl not found (should be impossible)") p encoderImpls

392 DMap.findWithDefault (error "checkEnum1EncoderFunc: EncoderImpl not found (should be impossible)") p encoderImpls

394

393

@@ -443,11 +442,11 @@ chainEncoder cons this rest = Encoder $ do

443 pure $ EncoderImpl

442 pure $ EncoderImpl

444 { _encoderImpl_decode = \v -> do

443 { _encoderImpl_decode = \v -> do

445 (here, following) <- _encoderImpl_decode consValid v

444 (here, following) <- _encoderImpl_decode consValid v

446− Some.This r <- _encoderImpl_decode thisValid here

445+ Some r <- _encoderImpl_decode thisValid here

447 (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following

446 (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following

448 , _encoderImpl_encode = \(r :/ s) ->

447 , _encoderImpl_encode = \(r :/ s) ->

449 _encoderImpl_encode consValid

448 _encoderImpl_encode consValid

450− ( _encoderImpl_encode thisValid $ Some.This r

449+ ( _encoderImpl_encode thisValid $ Some r

451 , _encoderImpl_encode (runIdentity . unEncoder $ rest r) s)

450 , _encoderImpl_encode (runIdentity . unEncoder $ rest r) s)

452 }

451 }

453

452

@@ -514,7 +513,7 @@ enum1Encoder

514 , Show r

513 , Show r

515 )

514 )

516 => (forall a. p a -> r) -> Encoder check parse (Some p) r

515 => (forall a. p a -> r) -> Encoder check parse (Some p) r

517−enum1Encoder f = enumEncoder $ \(Some.This p) -> f p

516+enum1Encoder f = enumEncoder $ \(Some p) -> f p

518

517

519-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that

518-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that

520-- have a large number of values - it will use a lot of memory.

519-- have a large number of values - it will use a lot of memory.

@@ -603,10 +602,10 @@ queryParametersTextEncoder = Encoder $ pure $ EncoderImpl

603 in (urlDecodeText True k, urlDecodeText True <$> mv)

602 in (urlDecodeText True k, urlDecodeText True <$> mv)

604

603

605urlEncodeText :: Bool -> Text -> Text

604urlEncodeText :: Bool -> Text -> Text

606−urlEncodeText q = decodeUtf8 . urlEncode q . encodeUtf8

605+urlEncodeText q = T.decodeUtf8 . urlEncode q . T.encodeUtf8

607

606

608urlDecodeText :: Bool -> Text -> Text

607urlDecodeText :: Bool -> Text -> Text

609−urlDecodeText q = decodeUtf8 . urlDecode q . encodeUtf8

608+urlDecodeText q = T.decodeUtf8 . urlDecode q . T.encodeUtf8

610

609

611listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)

610listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)

612listToNonEmptyEncoder = Encoder $ pure $ EncoderImpl

611listToNonEmptyEncoder = Encoder $ pure $ EncoderImpl

@@ -718,9 +717,11 @@ data ObeliskRoute :: (* -> *) -> * -> * where

718 ObeliskRoute_App :: f a -> ObeliskRoute f a

717 ObeliskRoute_App :: f a -> ObeliskRoute f a

719 ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a

718 ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a

720

719

721−instance Universe (Some f) => Universe (Some (ObeliskRoute f)) where

720+instance UniverseSome f => UniverseSome (ObeliskRoute f) where

721+ universeSome = concat

722− universe = fmap (\(Some.This x) -> Some.This (ObeliskRoute_App x)) universe

722+ [ (\(Some x) -> Some (ObeliskRoute_App x)) <$> universe

723− ++ fmap (\(Some.This x) -> Some.This (ObeliskRoute_Resource x)) universe

723+ , (\(Some x) -> Some (ObeliskRoute_Resource x)) <$> universe

724+ ]

724

725

725instance GEq f => GEq (ObeliskRoute f) where

726instance GEq f => GEq (ObeliskRoute f) where

726 geq (ObeliskRoute_App x) (ObeliskRoute_App y) = geq x y

727 geq (ObeliskRoute_App x) (ObeliskRoute_App y) = geq x y

@@ -808,12 +809,12 @@ indexOnlyRouteEncoder = pathComponentEncoder indexOnlyRouteSegment

808

809

809someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))

810someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))

810someSumEncoder = Encoder $ pure $ EncoderImpl

811someSumEncoder = Encoder $ pure $ EncoderImpl

811− { _encoderImpl_encode = \(Some.This t) -> case t of

812+ { _encoderImpl_encode = \(Some t) -> case t of

812− InL l -> Left $ Some.This l

813+ InL l -> Left $ Some l

813− InR r -> Right $ Some.This r

814+ InR r -> Right $ Some r

814 , _encoderImpl_decode = pure . \case

815 , _encoderImpl_decode = pure . \case

815− Left (Some.This l) -> Some.This (InL l)

816+ Left (Some l) -> Some (InL l)

816− Right (Some.This r) -> Some.This (InR r)

817+ Right (Some r) -> Some (InR r)

817 }

818 }

818

819

819data Void1 :: * -> * where {}

820data Void1 :: * -> * where {}

@@ -824,7 +825,7 @@ instance Universe (Some Void1) where

824void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a

825void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a

825void1Encoder = Encoder $ pure $ EncoderImpl

826void1Encoder = Encoder $ pure $ EncoderImpl

826 { _encoderImpl_encode = \case

827 { _encoderImpl_encode = \case

827− Some.This f -> case f of {}

828+ Some f -> case f of {}

828 , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"

829 , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"

829 }

830 }

830

831

@@ -900,18 +901,18 @@ dmapEncoder :: forall check parse k k' v.

900 -> Encoder check parse (DMap k' Identity) (Map k v)

901 -> Encoder check parse (DMap k' Identity) (Map k v)

901dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do

902dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do

902 keyEncoder :: Encoder Identity parse (Some k') k <- checkEncoder keyEncoder'

903 keyEncoder :: Encoder Identity parse (Some k') k <- checkEncoder keyEncoder'

903− valueDecoders :: DMap k' (Decoder Identity parse v) <- fmap DMap.fromList . forM universe $ \(Some.This (k' :: k' t)) -> do

904+ valueDecoders :: DMap k' (Decoder Identity parse v) <- fmap DMap.fromList . forM universe $ \(Some (k' :: k' t)) -> do

904 ve :: Encoder Identity parse t v <- checkEncoder (valueEncoderFor k')

905 ve :: Encoder Identity parse t v <- checkEncoder (valueEncoderFor k')

905 return $ (k' :: k' t) :=> (Decoder ve :: Decoder Identity parse v t)

906 return $ (k' :: k' t) :=> (Decoder ve :: Decoder Identity parse v t)

906 let keyError k = "dmapEncoder: key `" <> k <> "' was missing from the Universe instance for its type."

907 let keyError k = "dmapEncoder: key `" <> k <> "' was missing from the Universe instance for its type."

907 return $ EncoderImpl

908 return $ EncoderImpl

908 { _encoderImpl_encode = \dm -> Map.fromList $ do

909 { _encoderImpl_encode = \dm -> Map.fromList $ do

909 ((k' :: k' t) :=> Identity v') <- DMap.toList dm

910 ((k' :: k' t) :=> Identity v') <- DMap.toList dm

910− return ( encode keyEncoder (Some.This k')

911+ return ( encode keyEncoder (Some k')

911 , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'

912 , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'

912 )

913 )

913 , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do

914 , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do

914− Some.This (k' :: k' t) <- tryDecode keyEncoder k

915+ Some (k' :: k' t) <- tryDecode keyEncoder k

915 case DMap.lookup k' valueDecoders of

916 case DMap.lookup k' valueDecoders of

916 Nothing -> throwError . T.pack . keyError $ gshow k'

917 Nothing -> throwError . T.pack . keyError $ gshow k'

917 Just (Decoder e) -> do

918 Just (Decoder e) -> do

@@ -930,7 +931,7 @@ fieldMapEncoder :: forall check parse r.

930 => Encoder check parse r (DMap (Field r) Identity)

931 => Encoder check parse r (DMap (Field r) Identity)

931fieldMapEncoder = unsafeEncoder $ do

932fieldMapEncoder = unsafeEncoder $ do

932 pure $ EncoderImpl

933 pure $ EncoderImpl

933− { _encoderImpl_encode = \r -> DMap.fromList [ f :=> Identity (indexField r f) | Some.This f <- universe ]

934+ { _encoderImpl_encode = \r -> DMap.fromList [ f :=> Identity (indexField r f) | Some f <- universe ]

934 , _encoderImpl_decode = \dm -> tabulateFieldsA $ \f -> do

935 , _encoderImpl_decode = \dm -> tabulateFieldsA $ \f -> do

935 case DMap.lookup f dm of

936 case DMap.lookup f dm of

936 Nothing -> throwError $ "fieldMapEncoder: Couldn't find key for `" <> T.pack (gshow f) <> "' in DMap."

937 Nothing -> throwError $ "fieldMapEncoder: Couldn't find key for `" <> T.pack (gshow f) <> "' in DMap."

@@ -947,8 +948,8 @@ jsonEncoder :: forall check parse r.

947 => Encoder check parse r Text

948 => Encoder check parse r Text

948jsonEncoder = unsafeEncoder $ do

949jsonEncoder = unsafeEncoder $ do

949 pure $ EncoderImpl

950 pure $ EncoderImpl

950− { _encoderImpl_encode = \r -> decodeUtf8 . BSL.toStrict $ Aeson.encode r

951+ { _encoderImpl_encode = \r -> T.decodeUtf8 . BSL.toStrict $ Aeson.encode r

951− , _encoderImpl_decode = \t -> case Aeson.eitherDecodeStrict $ encodeUtf8 t of

952+ , _encoderImpl_decode = \t -> case Aeson.eitherDecodeStrict $ T.encodeUtf8 t of

952 Left err -> throwError ("jsonEncoder: " <> T.pack err)

953 Left err -> throwError ("jsonEncoder: " <> T.pack err)

953 Right x -> return x

954 Right x -> return x

954 }

955 }

lib/route/src/Obelisk/Route/Frontend.hs+24−24

@@ -52,11 +52,12 @@ module Obelisk.Route.Frontend

52 , mapRouteToUrlT

53 , routeLink

54 , dynRouteLink

55+ , adaptedUriPath

56+ , setAdaptedUriPath

55 ) where

57 ) where

56

58

57import Prelude hiding ((.), id)

59import Prelude hiding ((.), id)

58

60

59−import Obelisk.ExecutableConfig.Frontend

60import Obelisk.Route

61import Obelisk.Route

61

62

62import Control.Category (Category (..), (.))

63import Control.Category (Category (..), (.))

@@ -90,13 +91,13 @@ import Language.Javascript.JSaddle --TODO: Get rid of this - other platforms can

90import Reflex.Dom.Core

91import Reflex.Dom.Core

91import qualified GHCJS.DOM.Types as DOM

92import qualified GHCJS.DOM.Types as DOM

92import Network.URI

93import Network.URI

93−#if defined(ios_HOST_OS)

94import Data.Maybe (fromMaybe)

95import qualified Data.List as L

96−#endif

97

96

98import Unsafe.Coerce

97import Unsafe.Coerce

99

98

99+import Obelisk.Configs

100+

100infixr 5 :~

101infixr 5 :~

101pattern (:~) :: Reflex t => f a -> Dynamic t a -> DSum f (Compose (Dynamic t) Identity)

102pattern (:~) :: Reflex t => f a -> Dynamic t a -> DSum f (Compose (Dynamic t) Identity)

102pattern a :~ b <- a :=> (coerceDynamic . getCompose -> b)

103pattern a :~ b <- a :=> (coerceDynamic . getCompose -> b)

@@ -178,7 +179,7 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RoutedT t r m) where

178 askQueryResult = lift askQueryResult

179 askQueryResult = lift askQueryResult

179 queryIncremental = lift . queryIncremental

180 queryIncremental = lift . queryIncremental

180

181

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

182+instance HasConfigs m => HasConfigs (RoutedT t r m)

182

183

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

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

184

185

@@ -342,7 +343,7 @@ instance PrimMonad m => PrimMonad (SetRouteT t r m ) where

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

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

343 primitive = lift . primitive

344 primitive = lift . primitive

344

345

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

346+instance HasConfigs m => HasConfigs (SetRouteT t r m)

346

347

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

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

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

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

@@ -441,7 +442,7 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RouteToUrlT r m) where

441 askQueryResult = lift askQueryResult

442 askQueryResult = lift askQueryResult

442 queryIncremental = lift . queryIncremental

443 queryIncremental = lift . queryIncremental

443

444

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

445+instance HasConfigs m => HasConfigs (RouteToUrlT t m)

445

446

446runRouteViewT

447runRouteViewT

447 :: forall t m r a.

448 :: forall t m r a.

@@ -453,17 +454,20 @@ runRouteViewT

453 , MonadFix m

454 , MonadFix m

454 )

455 )

455 => (Encoder Identity Identity r PageName)

456 => (Encoder Identity Identity r PageName)

457+ --TODO: Get rid of the switchover and useHash arguments

458+ -- useHash can probably be baked into the encoder

456 -> Event t () -- ^ Switchover event, nothing is done until this event fires. Used to prevent incorrect DOM expectations at hydration switchover time

459 -> Event t () -- ^ Switchover event, nothing is done until this event fires. Used to prevent incorrect DOM expectations at hydration switchover time

460+ -> Bool

457 -> RoutedT t r (SetRouteT t r (RouteToUrlT r m)) a

461 -> RoutedT t r (SetRouteT t r (RouteToUrlT r m)) a

458 -> m a

462 -> m a

459−runRouteViewT routeEncoder switchover a = do

463+runRouteViewT routeEncoder switchover useHash a = do

460 rec historyState <- manageHistory' switchover $ HistoryCommand_PushState <$> setState

464 rec historyState <- manageHistory' switchover $ HistoryCommand_PushState <$> setState

461 let theEncoder = pageNameEncoder . hoistParse (pure . runIdentity) routeEncoder

465 let theEncoder = pageNameEncoder . hoistParse (pure . runIdentity) routeEncoder

462 -- NB: The can only fail if the uriPath doesn't begin with a '/' or if the uriQuery

466 -- NB: The can only fail if the uriPath doesn't begin with a '/' or if the uriQuery

463 -- is nonempty, but begins with a character that isn't '?'. Since we don't expect

467 -- is nonempty, but begins with a character that isn't '?'. Since we don't expect

464 -- this ever to happen, we'll just handle it by failing completely with 'error'.

468 -- this ever to happen, we'll just handle it by failing completely with 'error'.

465 route :: Dynamic t r

469 route :: Dynamic t r

466− route = fmap (errorLeft . tryDecode theEncoder . (adaptedUriPath &&& uriQuery) . _historyItem_uri) historyState

470+ route = fmap (errorLeft . tryDecode theEncoder . (adaptedUriPath useHash &&& uriQuery) . _historyItem_uri) historyState

467 where

471 where

468 errorLeft (Left e) = error (T.unpack e)

472 errorLeft (Left e) = error (T.unpack e)

469 errorLeft (Right x) = x

473 errorLeft (Right x) = x

@@ -484,7 +488,7 @@ runRouteViewT routeEncoder switchover a = do

484 -- we can change this function later to accommodate.

488 -- we can change this function later to accommodate.

485 -- See: https://github.com/whatwg/html/issues/2174

489 -- See: https://github.com/whatwg/html/issues/2174

486 , _historyStateUpdate_title = ""

490 , _historyStateUpdate_title = ""

487− , _historyStateUpdate_uri = Just $ setAdaptedUriPath newPath $ (_historyItem_uri currentHistoryState)

491+ , _historyStateUpdate_uri = Just $ setAdaptedUriPath useHash newPath $ (_historyItem_uri currentHistoryState)

488 { uriQuery = newQuery

492 { uriQuery = newQuery

489 }

493 }

490 }

494 }

@@ -537,22 +541,18 @@ dynRouteLink dr w = do

537-- On ios due to sandboxing when loading the page from a file adapt the

541-- On ios due to sandboxing when loading the page from a file adapt the

538-- path to be based on the hash.

542-- path to be based on the hash.

539

543

540−adaptedUriPath :: URI -> String

544+adaptedUriPath :: Bool -> URI -> String

541−#if defined(ios_HOST_OS)

545+adaptedUriPath = \case

542−adaptedUriPath = hashToPath . uriFragment

546+ True -> hashToPath . uriFragment

543−

544−hashToPath :: String -> String

545−hashToPath = ('/' :) . fromMaybe "" . L.stripPrefix "#"

546−#else

547−adaptedUriPath = uriPath

547+ False -> uriPath

548−#endif

549

548

550−setAdaptedUriPath :: String -> URI -> URI

549+setAdaptedUriPath :: Bool -> String -> URI -> URI

551−#if defined(ios_HOST_OS)

550+setAdaptedUriPath useHash s u = case useHash of

552−setAdaptedUriPath s u = u { uriFragment = pathToHash s }

551+ True -> u { uriFragment = pathToHash s }

552+ False -> u { uriPath = s }

553

554pathToHash :: String -> String

555pathToHash = ('#' :) . fromMaybe "" . L.stripPrefix "/"

556−#else

556+

557−setAdaptedUriPath s u = u { uriPath = s }

557+hashToPath :: String -> String

558−#endif

558+hashToPath = ('/' :) . fromMaybe "" . L.stripPrefix "#"

lib/route/src/Obelisk/Route/TH.hs+4−5

@@ -1,8 +1,9 @@

1module Obelisk.Route.TH (deriveRouteComponent) where

2

3+import Data.Constraint.Extras.TH

3import Data.GADT.Show.TH

4import Data.GADT.Show.TH

4import Data.GADT.Compare.TH

5import Data.GADT.Compare.TH

5−import Data.Universe.TH

6+import Data.Universe.Some.TH

6import Language.Haskell.TH

7import Language.Haskell.TH

7

8

8-- | Derive all the typeclasses needed for a RouteComponent type. The argument should be the name of a type of kind @k -> *@

9-- | Derive all the typeclasses needed for a RouteComponent type. The argument should be the name of a type of kind @k -> *@

@@ -11,8 +12,6 @@ deriveRouteComponent x = concat <$> traverse ($ x)

11 [ deriveGShow

12 [ deriveGShow

12 , deriveGEq

13 , deriveGEq

13 , deriveGCompare

14 , deriveGCompare

14− , deriveShowTagIdentity

15+ , deriveUniverseSome

15− , deriveEqTagIdentity

16+ , deriveArgDict

16− , deriveOrdTagIdentity

17− , deriveSomeUniverse

18 ]

17 ]

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

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

26 , network

27 , obelisk-asset-serve-snap

28 , obelisk-backend

29− , obelisk-executable-config-backend

29+ , obelisk-executable-config-lookup

30 , obelisk-frontend

31 , obelisk-route

32 , process

lib/run/src/Obelisk/Run.hs+26−24

@@ -34,6 +34,7 @@ import Data.Streaming.Network (bindPortTCP)

34import Data.String (fromString)

35import Data.Text (Text)

36import qualified Data.Text as T

37+import qualified Data.Text.Encoding as T

37import Language.Javascript.JSaddle.Run (syncPoint)

38import Language.Javascript.JSaddle.Run (syncPoint)

38import Language.Javascript.JSaddle.WebSockets

39import Language.Javascript.JSaddle.WebSockets

39import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)

40import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)

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

48import Network.WebSockets.Connection (defaultConnectionOptions)

49import Network.WebSockets.Connection (defaultConnectionOptions)

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

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

50import Obelisk.Backend

51import Obelisk.Backend

51−import Obelisk.ExecutableConfig.Backend

52import Obelisk.Frontend

53import Obelisk.Route.Frontend

54import Reflex.Dom.Core

@@ -75,35 +75,34 @@ run port serveStaticAsset backend frontend = do

75 case checkEncoder $ _backend_routeEncoder backend of

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

77 Right validFullEncoder -> do

78− configs <- getComponentConfigs

78+ publicConfigs <- getPublicConfigs

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

80− runBackendConfigsT (_componentConfigs_backend configs) $

81− _backend_run backend $ \serveRoute -> do

80+ _backend_run backend $ \serveRoute -> do

82− runSnapWithCommandLineArgs $ do

81+ runSnapWithCommandLineArgs $ do

83− getRouteWith validFullEncoder >>= \case

82+ getRouteWith validFullEncoder >>= \case

84− Identity r -> case r of

83+ Identity r -> case r of

85− InL backendRoute :=> Identity a ->

84+ InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

86− runBackendConfigsT (_componentConfigs_backend configs) $

87− serveRoute $ backendRoute :/ a

88− InR obeliskRoute :=> Identity a ->

85+ InR obeliskRoute :=> Identity a ->

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

86+ serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a

90 let conf = defRunConfig { _runConfig_redirectPort = port }

87 let conf = defRunConfig { _runConfig_redirectPort = port }

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

88+ runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

92

89

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

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

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

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

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

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

96

93

97−getConfigRoute :: Map Text Text -> Either Text URI

94+getConfigRoute :: Map Text ByteString -> Either Text URI

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

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

96+ Just r ->

97+ let stripped = T.strip (T.decodeUtf8 r)

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

98+ in case URI.mkURI stripped of

100− Just route -> Right route

99+ Just route -> Right route

101− Nothing -> Left $ "Couldn't parse route as URI; value read was: " <> T.pack (show r)

100+ Nothing -> Left $ "Couldn't parse route as URI; value read was: " <> T.pack (show stripped)

102− Nothing -> Left $ "Couldn't find config file common/route; it should contain the site's canonical root URI" <> T.pack (show $ Map.keys configs)

101+ Nothing -> Left $ "Couldn't find config file common/route; it should contain the site's canonical root URI" <> T.pack (show $ Map.keys configs)

103

102

104runWidget

103runWidget

105 :: RunConfig

104 :: RunConfig

106− -> Map Text Text

105+ -> Map Text ByteString

107 -> Frontend (R route)

106 -> Frontend (R route)

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

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

109 -> IO ()

108 -> IO ()

@@ -125,7 +124,7 @@ runWidget conf configs frontend validFullEncoder = do

125

124

126obeliskApp

125obeliskApp

127 :: forall route backendRoute

126 :: forall route backendRoute

128− . Map Text Text

127+ . Map Text ByteString

129 -> ConnectionOptions

128 -> ConnectionOptions

130 -> Frontend (R route)

129 -> Frontend (R route)

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

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

@@ -133,9 +132,12 @@ obeliskApp

133 -> Application

132 -> Application

134 -> IO Application

133 -> IO Application

135obeliskApp configs opts frontend validFullEncoder uri backend = do

134obeliskApp configs opts frontend validFullEncoder uri backend = do

135+ let mode = FrontendMode

136+ { _frontendMode_hydrate = True

137+ , _frontendMode_adjustRoute = False

138+ }

136− let entryPoint = do

139+ entryPoint = do

137− removeHTMLConfigs

138− runFrontendWithConfigs configs validFullEncoder frontend

140+ runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend

139 syncPoint

141 syncPoint

140 jsaddlePath <- URI.mkPathPiece "jsaddle"

142 jsaddlePath <- URI.mkPathPiece "jsaddle"

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

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

@@ -155,7 +157,7 @@ obeliskApp configs opts frontend validFullEncoder uri backend = do

155 _ -> backend req sendResponse

157 _ -> backend req sendResponse

156

158

157renderJsaddleFrontend

159renderJsaddleFrontend

158− :: Map Text Text

160+ :: Map Text ByteString

159 -> Cookies

161 -> Cookies

160 -> (route -> Text)

162 -> (route -> Text)

161 -> route

163 -> route

skeleton/common/src/Common/Api.hs+1−1

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

1module Common.Api where

2

3commonStuff :: String

4−commonStuff = "Here is a string defined in code common to the frontend and backend."

4+commonStuff = "Here is a string defined in Common.Api"

skeleton/config/common/examplenew file+1

@@ -0,0 +1 @@

1+This string comes from config/common/example

skeleton/frontend/frontend.cabal+1

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

10 , obelisk-frontend

11 , obelisk-route

12 , reflex-dom

13+ , obelisk-executable-config-lookup

13 , obelisk-generated-static

14 , obelisk-generated-static

14 , text

15 , text

15 exposed-modules:

16 exposed-modules:

skeleton/frontend/src/Frontend.hs+8−1

@@ -4,7 +4,9 @@

4module Frontend where

5

6import qualified Data.Text as T

7+import qualified Data.Text.Encoding as T

7import Obelisk.Frontend

8import Obelisk.Frontend

9+import Obelisk.Configs

8import Obelisk.Route

10import Obelisk.Route

9import Reflex.Dom.Core

11import Reflex.Dom.Core

10

12

@@ -12,7 +14,6 @@ import Common.Api

12import Common.Route

14import Common.Route

13import Obelisk.Generated.Static

15import Obelisk.Generated.Static

14

16

15−

16frontend :: Frontend (R FrontendRoute)

17frontend :: Frontend (R FrontendRoute)

17frontend = Frontend

18frontend = Frontend

18 { _frontend_head = el "title" $ text "Obelisk Minimal Example"

19 { _frontend_head = el "title" $ text "Obelisk Minimal Example"

@@ -20,4 +21,10 @@ frontend = Frontend

20 text "Welcome to Obelisk!"

21 text "Welcome to Obelisk!"

21 el "p" $ text $ T.pack commonStuff

22 el "p" $ text $ T.pack commonStuff

22 elAttr "img" ("src" =: static @"obelisk.jpg") blank

23 elAttr "img" ("src" =: static @"obelisk.jpg") blank

24+ el "div" $ do

25+ exampleConfig <- getConfig "common/example"

26+ case exampleConfig of

27+ Nothing -> text "No config file found in config/common/example"

28+ Just s -> text (T.decodeUtf8 s)

29+ return ()

23 }

30 }