abc320a · obelisk · git.iko.soy

git.iko.soy/obelisk

Merge pull request #373 from obsidiansystems/aa-dessicated-cookies

Provide access to cookies pre- and post-hydration

commitabc320a6778a53a079ac7d411d2c5f31c38e0db3 authorAli Abrar <aliabrar@gmail.com> dateMon 18 Mar 2019, 10:31 (8 years ago) parentbfe4b31 c8656ae

8 files changed+180−57

compare with master

unifiedsplit

lib/backend/obelisk-backend.cabal+1 lib/backend/src/Obelisk/Backend.hs+37−9 lib/frontend/obelisk-frontend.cabal+4−1 lib/frontend/src/Obelisk/Frontend.hs+23−37 lib/frontend/src/Obelisk/Frontend/Cookie.hs+99 lib/route/src/Obelisk/Route/Frontend.hs+7 lib/run/obelisk-run.cabal+1 lib/run/src/Obelisk/Run.hs+8−10

lib/backend/obelisk-backend.cabal+1

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

88 build-depends: base,

99 bytestring,

1010 categories,

11+ cookie,

1112 data-default,

1213 dependent-sum,

1314 dependent-sum-template,

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

@@ -6,7 +6,7 @@

66{-# LANGUAGE MultiParamTypeClasses #-}

77{-# LANGUAGE OverloadedStrings #-}

88{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TemplateHaskell #-}

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

1010module Obelisk.Backend

1111 ( Backend (..)

1212 -- * Re-exports

@@ -42,7 +42,8 @@ import Obelisk.Route

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

4343import Reflex.Dom

4444import Snap (MonadSnap, Snap, commandLineConfig, defaultConfig, getsRequest, httpServe, modifyResponse

45− , rqPathInfo, rqQueryString, setContentType, writeBS, writeText)

45+ , rqPathInfo, rqQueryString, setContentType, writeBS, writeText

46+ , rqCookies, Cookie(..))

4647import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog (ConfigIoLog))

4748import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)

4849

@@ -59,7 +60,15 @@ data GhcjsApp route = GhcjsApp

5960

6061-- | Serve a frontend, which must be the same frontend that Obelisk has built and placed in the default location

6162--TODO: The frontend should be provided together with the asset paths so that this isn't so easily breakable; that will probably make this function obsolete

62−serveDefaultObeliskApp :: MonadSnap m => (R appRoute -> Text) -> ([Text] -> m ()) -> Frontend (R appRoute) -> R (ObeliskRoute appRoute) -> m ()

63+serveDefaultObeliskApp

64+ :: (MonadSnap m, HasCookies m)

65+ => (R appRoute

66+ -> Text)

67+ -> ([Text]

68+ -> m ())

69+ -> Frontend (R appRoute)

70+ -> R (ObeliskRoute appRoute)

71+ -> m ()

6372serveDefaultObeliskApp urlEnc serveStaticAsset frontend = serveObeliskApp urlEnc serveStaticAsset frontendApp

6473 where frontendApp = GhcjsApp

6574 { _ghcjsApp_compiled = defaultFrontendGhcjsAssets

@@ -111,7 +120,13 @@ getRouteWith e = do

111120 pageName <- getPageName

112121 return $ tryDecode e pageName

113122

114−serveObeliskApp :: MonadSnap m => (R appRoute -> Text) -> ([Text] -> m ()) -> GhcjsApp (R appRoute) -> R (ObeliskRoute appRoute) -> m ()

123+serveObeliskApp

124+ :: (MonadSnap m, HasCookies m)

125+ => (R appRoute -> Text)

126+ -> ([Text] -> m ())

127+ -> GhcjsApp (R appRoute)

128+ -> R (ObeliskRoute appRoute)

129+ -> m ()

115130serveObeliskApp urlEnc serveStaticAsset frontendApp = \case

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

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

@@ -140,11 +155,16 @@ staticRenderContentType :: ByteString

140155staticRenderContentType = "text/html; charset=utf-8"

141156

142157--TODO: Don't assume we're being served at "/"

143−serveGhcjsApp :: MonadSnap m => (R appRouteComponent -> Text) -> GhcjsApp (R appRouteComponent) -> R (GhcjsAppRoute appRouteComponent) -> m ()

158+serveGhcjsApp

159+ :: (MonadSnap m, HasCookies m)

160+ => (R appRouteComponent -> Text)

161+ -> GhcjsApp (R appRouteComponent)

162+ -> R (GhcjsAppRoute appRouteComponent)

163+ -> m ()

144164serveGhcjsApp urlEnc app = \case

145165 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do

146166 modifyResponse $ setContentType staticRenderContentType

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

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

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

149169

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

@@ -163,11 +183,19 @@ mkRouteToUrl validFullEncoder =

163183 let pageNameEncoder' :: Encoder Identity (Either Text) PageName PathQuery = pageNameEncoder

164184 in \(k :/ v) -> T.pack . uncurry (<>) . encode pageNameEncoder' . encode validFullEncoder $ (InR $ ObeliskRoute_App k) :/ v

165185

166−

167−renderGhcjsFrontend :: MonadIO m => (route -> Text) -> route -> Frontend route -> m ByteString

186+renderGhcjsFrontend

187+ :: (MonadSnap m, HasCookies m)

188+ => (route -> Text)

189+ -> route

190+ -> Frontend route

191+ -> m ByteString

168192renderGhcjsFrontend urlEnc route f = do

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

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

171− liftIO $ renderFrontendHtml urlEnc route

195+ cookies <- askCookies

196+ renderFrontendHtml cookies urlEnc route

172197 (_frontend_head f >> ghcjsPreload)

173198 (_frontend_body f >> ghcjsScript)

199+

200+instance HasCookies Snap where

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

lib/frontend/obelisk-frontend.cabal+4−1

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

77 hs-source-dirs: src

88 build-depends: base,

99 bytestring,

10+ cookie,

1011 dependent-sum,

1112 ghcjs-dom,

1213 jsaddle,

@@ -20,5 +21,7 @@ library

2021 reflex-dom-core,

2122 text,

2223 transformers

23− exposed-modules: Obelisk.Frontend

24+ exposed-modules:

25+ Obelisk.Frontend

26+ Obelisk.Frontend.Cookie

2427 ghc-options: -Wall

lib/frontend/src/Obelisk/Frontend.hs+23−37

@@ -15,39 +15,29 @@ module Obelisk.Frontend

1515 , Frontend (..)

1616 , runFrontend

1717 , renderFrontendHtml

18+ , module Obelisk.Frontend.Cookie

1819 ) where

1920

2021import Prelude hiding ((.))

2122

2223import Control.Category

23−import Control.Concurrent

2424import Control.Lens

25−import Control.Monad hiding (sequence, sequence_)

2625import Control.Monad.Fix

2726import Control.Monad.IO.Class

2827import Control.Monad.Primitive

2928import Control.Monad.Reader

3029import Control.Monad.Ref

31−import Control.Monad.Trans.Class

3230import Data.ByteString (ByteString)

33−import Data.Dependent.Sum (DSum (..))

34−import Data.Foldable (for_)

3531import Data.Functor.Sum

36−import Data.IORef

3732import Data.Monoid ((<>))

3833import Data.Text (Text)

39−import Data.Foldable (sequence_)

40−import Data.Traversable (sequence)

41−import GHCJS.DOM hiding (bracket, catch)

42−import GHCJS.DOM.Document

43−import GHCJS.DOM.Node

44−import qualified GHCJS.DOM.Types as DOM

4534import Language.Javascript.JSaddle (JSM)

35+import Obelisk.Frontend.Cookie

4636import Obelisk.Route.Frontend

4737import Reflex.Dom.Core

4838import Reflex.Host.Class

49−import qualified Reflex.TriggerEvent.Base as TriggerEvent

5039import Obelisk.ExecutableConfig.Inject (injectExecutableConfigs)

40+import Web.Cookie

5141

5242makePrisms ''Sum

5343

@@ -70,6 +60,7 @@ type ObeliskWidget js t route m =

7060 , Prerender js t m

7161 , PrebuildAgnostic t route m

7262 , PrebuildAgnostic t route (Client m)

63+ , HasCookies m

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

7465 , MonadIO m

7566 , MonadIO (Performable m)

@@ -86,47 +77,42 @@ data Frontend route = Frontend

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

8778 }

8879

89−runFrontend :: forall backendRoute route. Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName -> Frontend (R route) -> JSM ()

80+runFrontend

81+ :: forall backendRoute route

82+ . Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

83+ -> Frontend (R route)

84+ -> JSM ()

9085runFrontend validFullEncoder frontend = do

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

9287 errorLeft = \case

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

9489 Right x -> Identity x

95− runMyRouteViewT

96− :: ( TriggerEvent t m

97− , PerformEvent t m

98− , MonadHold t m

99− , DOM.MonadJSM m

100− , DOM.MonadJSM (Performable m)

101− , MonadFix m

102− , MonadFix (Performable m)

103− )

104− => Event t ()

105− -> RoutedT t (R route) (SetRouteT t (R route) (RouteToUrlT (R route) m)) a

106− -> m a

107− runMyRouteViewT = runRouteViewT ve

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

109− rec switchover <- runMyRouteViewT switchover $ do

110− (switchover, fire) <- newTriggerEvent

91+ rec switchover <- runRouteViewT ve switchover $ do

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

11193 mapRoutedT (mapSetRouteT (mapRouteToUrlT appendHead)) $ do

11294 _frontend_head frontend

11395 mapRoutedT (mapSetRouteT (mapRouteToUrlT appendBody)) $ do

11496 _frontend_body frontend

11597 switchover' <- lift $ lift $ lift $ HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover

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

117− pure switchover

99+ pure switchover''

118100 pure ()

119101

120102renderFrontendHtml

121− :: (t ~ DomTimeline)

122− => (r' -> Text)

103+ :: ( t ~ DomTimeline

104+ , MonadIO m

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

106+ )

107+ => Cookies

108+ -> (r' -> Text)

123109 -> r

124− -> RoutedT t r (SetRouteT t r' (RouteToUrlT r' (PostBuildT DomTimeline (StaticDomBuilderT DomTimeline (PerformEventT DomTimeline DomHost))))) ()

125− -> RoutedT t r (SetRouteT t r' (RouteToUrlT r' (PostBuildT DomTimeline (StaticDomBuilderT DomTimeline (PerformEventT DomTimeline DomHost))))) ()

126− -> IO ByteString

127−renderFrontendHtml urlEnc route headWidget bodyWidget = do

110+ -> widget ()

111+ -> widget ()

112+ -> m ByteString

113+renderFrontendHtml cookies urlEnc route headWidget bodyWidget = do

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

129− html <- fmap snd $ renderStatic $ fmap fst $ flip runRouteToUrlT urlEnc $ runSetRouteT $ flip runRoutedT (pure route) $

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

130116 el "html" $ do

131117 el "head" $ do

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

lib/frontend/src/Obelisk/Frontend/Cookie.hsnew file+99

@@ -0,0 +1,99 @@

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 RankNTypes #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+

13+module Obelisk.Frontend.Cookie where

14+

15+import Control.Monad.Fix

16+import Control.Monad.Primitive

17+import Control.Monad.Ref

18+import Control.Monad.IO.Class

19+import Control.Monad.Trans.Class

20+import Control.Monad.Trans.Reader

21+import Data.Text.Encoding (encodeUtf8)

22+import Reflex

23+import Reflex.Host.Class

24+import Reflex.Dom.Core

25+import GHCJS.DOM.Document (getCookie, Document)

26+import GHCJS.DOM.Types (MonadJSM)

27+import Web.Cookie

28+

29+import Obelisk.Route.Frontend

30+

31+class Monad m => HasCookies m where

32+ askCookies :: m Cookies

33+ default askCookies :: (HasCookies m', m ~ t m', MonadTrans t) => m Cookies

34+ askCookies = lift askCookies

35+

36+instance HasCookies m => HasCookies (BehaviorWriterT t w m)

37+instance HasCookies m => HasCookies (DynamicWriterT t w m)

38+instance HasCookies m => HasCookies (EventWriterT t w m)

39+instance HasCookies m => HasCookies (PostBuildT t m)

40+instance HasCookies m => HasCookies (QueryT t q m)

41+instance HasCookies m => HasCookies (ReaderT r m)

42+instance HasCookies m => HasCookies (RequesterT t request response m)

43+instance HasCookies m => HasCookies (RouteToUrlT t m)

44+instance HasCookies m => HasCookies (SetRouteT t r m)

45+instance HasCookies m => HasCookies (StaticDomBuilderT t m)

46+instance HasCookies m => HasCookies (TriggerEventT t m)

47+instance HasCookies m => HasCookies (RoutedT t r m)

48+

49+newtype CookiesT m a = CookiesT { unCookiesT :: ReaderT Cookies m a }

50+ deriving

51+ ( Functor

52+ , Applicative

53+ , DomBuilder t

54+ , Monad

55+ , MonadFix

56+ , MonadHold t

57+ , MonadIO

58+#ifndef ghcjs_HOST_OS

59+ , MonadJSM

60+#endif

61+ , MonadRef

62+ , MonadReflexCreateTrigger t

63+ , MonadSample t

64+ , MonadTrans

65+ , NotReady t

66+ , PerformEvent t

67+ , PostBuild t

68+ , Prerender js t

69+ , TriggerEvent t

70+ , HasDocument

71+ )

72+

73+instance Adjustable t m => Adjustable t (CookiesT m) where

74+ runWithReplace a e = CookiesT $ runWithReplace (unCookiesT a) (unCookiesT <$> e)

75+ traverseDMapWithKeyWithAdjust f m e = CookiesT $ traverseDMapWithKeyWithAdjust (\k v -> unCookiesT $ f k v) m e

76+ traverseIntMapWithKeyWithAdjust f m e = CookiesT $ traverseIntMapWithKeyWithAdjust (\k v -> unCookiesT $ f k v) m e

77+ traverseDMapWithKeyWithAdjustWithMove f m e = CookiesT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unCookiesT $ f k v) m e

78+

79+instance PrimMonad m => PrimMonad (CookiesT m) where

80+ type PrimState (CookiesT m) = PrimState m

81+ primitive = lift . primitive

82+

83+runCookiesT

84+ :: Cookies

85+ -> CookiesT m a

86+ -> m a

87+runCookiesT cs child = runReaderT (unCookiesT child) cs

88+

89+instance Monad m => HasCookies (CookiesT m) where

90+ askCookies = CookiesT ask

91+

92+mapCookiesT

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

94+ -> CookiesT m a

95+ -> CookiesT n a

96+mapCookiesT f (CookiesT x) = CookiesT $ mapReaderT f x

97+

98+instance (MonadJSM m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HasCookies (HydrationDomBuilderT s t m) where

99+ askCookies = fmap (parseCookies . encodeUtf8) $ getCookie =<< askDocument

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

@@ -300,6 +300,10 @@ instance Requester t m => Requester t (SetRouteT t r m) where

300300 requesting = SetRouteT . requesting

301301 requesting_ = SetRouteT . requesting_

302302

303+instance (Monad m, SetRoute t r m) => SetRoute t r (RequesterT t req rsp m) where

304+ setRoute = lift . setRoute

305+ modifyRoute = lift . modifyRoute

306+

303307#ifndef ghcjs_HOST_OS

304308deriving instance MonadJSM m => MonadJSM (SetRouteT t r m)

305309#endif

@@ -358,6 +362,9 @@ instance (Monad m, RouteToUrl r m) => RouteToUrl r (SetRouteT t r' m) where

358362instance (Monad m, RouteToUrl r m) => RouteToUrl r (RoutedT t r' m) where

359363 askRouteToUrl = lift askRouteToUrl

360364

365+instance (Monad m, RouteToUrl r m) => RouteToUrl r (RequesterT t req rsp m) where

366+ askRouteToUrl = lift askRouteToUrl

367+

361368instance HasJSContext m => HasJSContext (RouteToUrlT r m) where

362369 type JSContextPhantom (RouteToUrlT r m) = JSContextPhantom m

363370 askJSContext = lift askJSContext

lib/run/obelisk-run.cabal+1

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

1010 attoparsec

1111 , base

1212 , bytestring

13+ , cookie

1314 , dependent-sum

1415 , dependent-sum-template

1516 , ghcjs-dom

lib/run/src/Obelisk/Run.hs+8−10

@@ -1,17 +1,12 @@

11{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE EmptyCase #-}

3−{-# LANGUAGE EmptyDataDecls #-}

42{-# LANGUAGE FlexibleContexts #-}

53{-# LANGUAGE FlexibleInstances #-}

64{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE KindSignatures #-}

85{-# LANGUAGE LambdaCase #-}

96{-# LANGUAGE MultiParamTypeClasses #-}

107{-# LANGUAGE OverloadedStrings #-}

118{-# LANGUAGE Rank2Types #-}

12−{-# LANGUAGE RecursiveDo #-}

139{-# LANGUAGE ScopedTypeVariables #-}

14−{-# LANGUAGE TemplateHaskell #-}

1510{-# LANGUAGE TypeFamilies #-}

1611{-# LANGUAGE UndecidableInstances #-}

1712{-# OPTIONS_GHC -fno-warn-orphans #-} -- Due to instance HasJS x (EventWriterT t w m)

@@ -34,6 +29,7 @@ import Data.List (uncons)

3429import Data.Maybe

3530import Data.Semigroup ((<>))

3631import Data.Streaming.Network (bindPortTCP)

32+import Data.String (fromString)

3733import Data.Text (Text)

3834import qualified Data.Text as T

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

@@ -49,6 +45,7 @@ import Network.Wai.Handler.Warp.Internal (settingsHost, settingsPort)

4945import Network.WebSockets (ConnectionOptions)

5046import Network.WebSockets.Connection (defaultConnectionOptions)

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

48+import Obelisk.Backend

5249import Obelisk.ExecutableConfig (get)

5350import Obelisk.Frontend

5451import Obelisk.Route.Frontend

@@ -61,7 +58,7 @@ import System.Exit (ExitCode(..))

6158import Text.URI (URI)

6259import qualified Text.URI as URI

6360import Text.URI.Lens

64−import Obelisk.Backend

61+import Web.Cookie

6562

6663run

6764 :: Int -- ^ Port to run the backend

@@ -143,15 +140,16 @@ obeliskApp opts frontend validFullEncoder uri backend = do

143140 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

144141 }

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

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

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

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

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

148146 _ -> backend req sendResponse

149147

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

151−renderJsaddleFrontend urlEnc r f =

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

149+renderJsaddleFrontend cookies urlEnc r f =

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

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

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

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

155153

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

157155bindPortTCPRetry :: Settings