b6da186 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Add a FullRoute type to formalise the expected top level structure of obelisk routes.

b6da186Cale Gibbard7 years ago

lib/backend/src/Obelisk/Backend.hs+6−7

compare with master

unifiedsplit

@@ -31,7 +31,6 @@ import Data.ByteString (ByteString)

31import qualified Data.ByteString.Char8 as BSC8

32import Data.Default (Default (..))

33import Data.Dependent.Sum

34−import Data.Functor.Sum

35import Data.Functor.Identity

34import Data.Functor.Identity

36import Data.Map (Map)

35import Data.Map (Map)

37import qualified Data.Map as Map

36import qualified Data.Map as Map

@@ -52,7 +51,7 @@ import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog

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

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

54data Backend backendRoute frontendRoute = Backend

53data Backend backendRoute frontendRoute = Backend

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

54+ { _backend_routeEncoder :: Encoder (Either Text) Identity (R (FullRoute backendRoute frontendRoute)) PageName

56 , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()

55 , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()

57 }

56 }

@@ -174,7 +173,7 @@ serveGhcjsApp urlEnc app config = \case

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

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

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

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

176

175

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

176+runBackend :: Backend backendRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()

178runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

177runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

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

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

180 Right validFullEncoder -> do

179 Right validFullEncoder -> do

@@ -183,15 +182,15 @@ runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend

183 runSnapWithCommandLineArgs $ do

182 runSnapWithCommandLineArgs $ do

184 getRouteWith validFullEncoder >>= \case

183 getRouteWith validFullEncoder >>= \case

185 Identity r -> case r of

184 Identity r -> case r of

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

185+ FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

187− InR obeliskRoute :=> Identity a ->

186+ FullRoute_Frontend obeliskRoute :/ a ->

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

187 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $

189 obeliskRoute :/ a

188 obeliskRoute :/ a

190

189

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

190+mkRouteToUrl :: Encoder Identity parse (R (FullRoute br fr)) PageName -> R fr -> Text

192mkRouteToUrl validFullEncoder =

191mkRouteToUrl validFullEncoder =

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

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

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

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

195

194

196renderGhcjsFrontend

195renderGhcjsFrontend

197 :: (MonadSnap m, HasCookies m)

196 :: (MonadSnap m, HasCookies m)

lib/frontend/src/Obelisk/Frontend.hs+5−5

@@ -137,7 +137,7 @@ data FrontendMode = FrontendMode

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

138runFrontend

139 :: forall backendRoute route

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

140+ . Encoder Identity Identity (R (FullRoute backendRoute route)) PageName

141 -> Frontend (R route)

142 -> JSM ()

143runFrontend validFullEncoder frontend = do

@@ -165,14 +165,14 @@ runFrontend validFullEncoder frontend = do

165 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend

166

167runFrontendWithConfigsAndCurrentRoute

168− :: forall backendRoute route

168+ :: forall backendRoute frontendRoute

169 . FrontendMode

170 -> Map Text ByteString

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

171+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName

172− -> Frontend (R route)

172+ -> Frontend (R frontendRoute)

173 -> JSM ()

174runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do

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

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

176 errorLeft = \case

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

178 Right x -> Identity x

lib/route/src/Obelisk/Route.hs+45−1

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

12{-# LANGUAGE PatternSynonyms #-}

13{-# LANGUAGE RankNTypes #-}

14{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE StandaloneDeriving #-}

15{-# LANGUAGE TemplateHaskell #-}

16{-# LANGUAGE TemplateHaskell #-}

16{-# LANGUAGE TypeApplications #-}

17{-# LANGUAGE TypeApplications #-}

17{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeFamilies #-}

@@ -66,6 +67,10 @@ module Obelisk.Route

66 , obeliskRouteSegment

67 , obeliskRouteSegment

67 , pageNameEncoder

68 , pageNameEncoder

68 , handleEncoder

69 , handleEncoder

70+ , FullRoute (..)

71+ , _FullRoute_Frontend

72+ , _FullRoute_Backend

73+ , mkFullRouteEncoder

69 , ObeliskRoute (..)

74 , ObeliskRoute (..)

70 , _ObeliskRoute_App

75 , _ObeliskRoute_App

71 , _ObeliskRoute_Resource

76 , _ObeliskRoute_Resource

@@ -710,6 +715,45 @@ handleEncoder recover e = Encoder $ do

710-- Actual obelisk route info

715-- Actual obelisk route info

711--------------------------------------------------------------------------------

716--------------------------------------------------------------------------------

712

717

718+-- | The typical full route type comprising all of an Obelisk application's routes.

719+-- Parameterised by the top level GADTs that define backend and frontend routes, respectively.

720+data FullRoute :: (* -> *) -> (* -> *) -> * -> * where

721+ FullRoute_Backend :: br a -> FullRoute br fr a

722+ FullRoute_Frontend :: ObeliskRoute fr a -> FullRoute br fr a

723+

724+instance (GShow br, GShow fr) => GShow (FullRoute br fr) where

725+ gshowsPrec p = \case

726+ FullRoute_Backend x -> showParen (p > 10) (showString "FullRoute_Backend " . gshowsPrec 11 x)

727+ FullRoute_Frontend x -> showParen (p > 10) (showString "FullRoute_Frontend " . gshowsPrec 11 x)

728+

729+instance (GEq br, GEq fr) => GEq (FullRoute br fr) where

730+ geq (FullRoute_Backend x) (FullRoute_Backend y) = geq x y

731+ geq (FullRoute_Frontend x) (FullRoute_Frontend y) = geq x y

732+ geq _ _ = Nothing

733+

734+instance (GCompare br, GCompare fr) => GCompare (FullRoute br fr) where

735+ gcompare (FullRoute_Backend _) (FullRoute_Frontend _) = GLT

736+ gcompare (FullRoute_Frontend _) (FullRoute_Backend _) = GGT

737+ gcompare (FullRoute_Backend x) (FullRoute_Backend y) = gcompare x y

738+ gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y

739+

740+instance (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) where

741+ universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]

742+ ++ [Some (FullRoute_Frontend x) | Some x <- universeSome]

743+

744+-- | Build the typical top level application route encoder from a route for handling 404's,

745+-- and segment encoders for backend and frontend routes.

746+mkFullRouteEncoder

747+ :: (GCompare br, GCompare fr, GShow br, GShow fr, UniverseSome br, UniverseSome fr)

748+ => R (FullRoute br fr) -- ^ 404 handler

749+ -> (forall a. br a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single backend route segment

750+ -> (forall a. fr a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single frontend route segment

751+ -> Encoder (Either Text) Identity (R (FullRoute br fr)) PageName

752+mkFullRouteEncoder missing backendSegment frontendSegment = handleEncoder (const missing) $

753+ pathComponentEncoder $ \case

754+ FullRoute_Backend backendRoute -> backendSegment backendRoute

755+ FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute frontendSegment

756+

713-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your

757-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your

714-- frontend.

758-- frontend.

715data ObeliskRoute :: (* -> *) -> * -> * where

759data ObeliskRoute :: (* -> *) -> * -> * where

@@ -839,7 +883,7 @@ concat <$> mapM deriveRouteComponent

839 ]

883 ]

840

884

841makePrisms ''ObeliskRoute

885makePrisms ''ObeliskRoute

842−

886+makePrisms ''FullRoute

843deriveGEq ''Void1

887deriveGEq ''Void1

844deriveGCompare ''Void1

888deriveGCompare ''Void1

845

889

lib/run/src/Obelisk/Run.hs+9−11

@@ -22,9 +22,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A

22import Data.ByteString (ByteString)

23import qualified Data.ByteString.Char8 as BSC

24import qualified Data.ByteString.Lazy.Char8 as BSLC

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

26import Data.Functor.Identity

25import Data.Functor.Identity

27−import Data.Functor.Sum

28import Data.List (uncons)

26import Data.List (uncons)

29import Data.Map (Map)

27import Data.Map (Map)

30import qualified Data.Map as Map

28import qualified Data.Map as Map

@@ -81,8 +79,8 @@ run port serveStaticAsset backend frontend = do

81 runSnapWithCommandLineArgs $ do

79 runSnapWithCommandLineArgs $ do

82 getRouteWith validFullEncoder >>= \case

80 getRouteWith validFullEncoder >>= \case

83 Identity r -> case r of

81 Identity r -> case r of

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

82+ FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

85− InR obeliskRoute :=> Identity a ->

83+ FullRoute_Frontend obeliskRoute :/ a ->

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

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

87 let conf = defRunConfig { _runConfig_redirectPort = port }

85 let conf = defRunConfig { _runConfig_redirectPort = port }

88 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

86 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

@@ -103,8 +101,8 @@ getConfigRoute configs = case Map.lookup "common/route" configs of

103runWidget

101runWidget

104 :: RunConfig

102 :: RunConfig

105 -> Map Text ByteString

103 -> Map Text ByteString

106− -> Frontend (R route)

104+ -> Frontend (R frontendRoute)

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

105+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName

108 -> IO ()

106 -> IO ()

109runWidget conf configs frontend validFullEncoder = do

107runWidget conf configs frontend validFullEncoder = do

110 uri <- either (fail . T.unpack) pure $ getConfigRoute configs

108 uri <- either (fail . T.unpack) pure $ getConfigRoute configs

@@ -123,11 +121,11 @@ runWidget conf configs frontend validFullEncoder = do

123 runSettingsSocket settings skt app)

121 runSettingsSocket settings skt app)

124

122

125obeliskApp

123obeliskApp

126− :: forall route backendRoute

124+ :: forall frontendRoute backendRoute

127 . Map Text ByteString

125 . Map Text ByteString

128 -> ConnectionOptions

126 -> ConnectionOptions

129− -> Frontend (R route)

127+ -> Frontend (R frontendRoute)

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

128+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName

131 -> URI

129 -> URI

132 -> Application

130 -> Application

133 -> IO Application

131 -> IO Application

@@ -145,12 +143,12 @@ obeliskApp configs opts frontend validFullEncoder uri backend = do

145 jsaddle <- jsaddleWithAppOr opts entryPoint $ \_ sendResponse -> sendResponse $ W.responseLBS H.status500 [("Content-Type", "text/plain")] "obeliskApp: jsaddle got a bad URL"

143 jsaddle <- jsaddleWithAppOr opts entryPoint $ \_ sendResponse -> sendResponse $ W.responseLBS H.status500 [("Content-Type", "text/plain")] "obeliskApp: jsaddle got a bad URL"

146 return $ \req sendResponse -> case tryDecode validFullEncoder (W.pathInfo req, mempty) of --TODO: Query strings

144 return $ \req sendResponse -> case tryDecode validFullEncoder (W.pathInfo req, mempty) of --TODO: Query strings

147 Identity r -> case r of

145 Identity r -> case r of

148− InR (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :=> Identity jsaddleRoute -> case jsaddleRoute of

146+ FullRoute_Frontend (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :/ jsaddleRoute -> case jsaddleRoute of

149 JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False

147 JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False

150 _ -> flip jsaddle sendResponse $ req

148 _ -> flip jsaddle sendResponse $ req

151 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

149 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

152 }

150 }

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

151+ FullRoute_Frontend (ObeliskRoute_App appRouteComponent) :/ appRouteRest -> do

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

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

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

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

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

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

skeleton/backend/src/Backend.hs+1−1

@@ -11,5 +11,5 @@ import Obelisk.Backend

11backend :: Backend BackendRoute FrontendRoute

12backend = Backend

13 { _backend_run = \serve -> serve $ const $ return ()

14− , _backend_routeEncoder = backendRouteEncoder

14+ , _backend_routeEncoder = fullRouteEncoder

15 }

skeleton/common/src/Common/Route.hs+8−12

@@ -19,7 +19,6 @@ import Control.Category

20import Data.Text (Text)

21import Data.Functor.Identity

22−import Data.Functor.Sum

24import Obelisk.Route

23import Obelisk.Route

25import Obelisk.Route.TH

24import Obelisk.Route.TH

@@ -34,17 +33,14 @@ data FrontendRoute :: * -> * where

34 FrontendRoute_Main :: FrontendRoute ()

33 FrontendRoute_Main :: FrontendRoute ()

35 -- This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend.

34 -- This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend.

37−backendRouteEncoder

36+fullRouteEncoder

38− :: Encoder (Either Text) Identity (R (Sum BackendRoute (ObeliskRoute FrontendRoute))) PageName

37+ :: Encoder (Either Text) Identity (R (FullRoute BackendRoute FrontendRoute)) PageName

38+fullRouteEncoder = mkFullRouteEncoder

39−backendRouteEncoder = handleEncoder (const (InL BackendRoute_Missing :/ ())) $

39+ (FullRoute_Backend BackendRoute_Missing :/ ())

40− pathComponentEncoder $ \case

40+ (\case

41− InL backendRoute -> case backendRoute of

42− BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty

41+ BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty)

43− InR obeliskRoute -> obeliskRouteSegment obeliskRoute $ \case

42+ (\case

44− -- The encoder given to PathEnd determines how to parse query parameters,

45− -- in this example, we have none, so we insist on it.

46− FrontendRoute_Main -> PathEnd $ unitEncoder mempty

43+ FrontendRoute_Main -> PathEnd $ unitEncoder mempty)

47−

49concat <$> mapM deriveRouteComponent

45concat <$> mapM deriveRouteComponent

50 [ ''BackendRoute

46 [ ''BackendRoute

skeleton/frontend/src-bin/main.hs+1−1

@@ -6,5 +6,5 @@ import Reflex.Dom

7main :: IO ()

8main = do

9− let Right validFullEncoder = checkEncoder backendRouteEncoder

9+ let Right validFullEncoder = checkEncoder fullRouteEncoder

10 run $ runFrontend validFullEncoder frontend