git.iko.soy/obelisk
on master help sign in
Add a FullRoute type to formalise the expected top level structure of obelisk routes.
commitb6da186353c525aaf674e16933b48311dca5a1d3 authorCale Gibbard <cgibbard@gmail.com> dateMon 24 Jun 2019, 11:50 (7 years ago) parent86a9584
7 files changed+75−38
compare with master
unifiedsplit
lib/backend/src/Obelisk/Backend.hs+6−7 lib/frontend/src/Obelisk/Frontend.hs+5−5 lib/route/src/Obelisk/Route.hs+45−1 lib/run/src/Obelisk/Run.hs+9−11 skeleton/backend/src/Backend.hs+1−1 skeleton/common/src/Common/Route.hs+8−12 skeleton/frontend/src-bin/main.hs+1−1
lib/backend/src/Obelisk/Backend.hs+6−7
@@ -31,7 +31,6 @@ import Data.ByteString (ByteString)
3131import qualified Data.ByteString.Char8 as BSC8
3232import Data.Default (Default (..))
3333import Data.Dependent.Sum
34−import Data.Functor.Sum
3534import Data.Functor.Identity
3635import Data.Map (Map)
3736import qualified Data.Map as Map
@@ -52,7 +51,7 @@ import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog
5251import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
5352
5453data 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
5655 , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()
5756 }
5857
@@ -174,7 +173,7 @@ serveGhcjsApp urlEnc app config = \case
174173 writeBS <=< renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app
175174 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments
176175
177−runBackend :: Backend fullRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
176+runBackend :: Backend backendRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
178177runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of
179178 Left e -> fail $ "backend error:\n" <> T.unpack e
180179 Right validFullEncoder -> do
@@ -183,15 +182,15 @@ runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend
183182 runSnapWithCommandLineArgs $ do
184183 getRouteWith validFullEncoder >>= \case
185184 Identity r -> case r of
186− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a
187− InR obeliskRoute :=> Identity a ->
185+ FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a
186+ FullRoute_Frontend obeliskRoute :/ a ->
188187 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $
189188 obeliskRoute :/ a
190189
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
192191mkRouteToUrl validFullEncoder =
193192 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
195194
196195renderGhcjsFrontend
197196 :: (MonadSnap m, HasCookies m)
lib/frontend/src/Obelisk/Frontend.hs+5−5
@@ -137,7 +137,7 @@ data FrontendMode = FrontendMode
137137-- Selects FrontendMode based on platform; this doesn't work for jsaddle-warp
138138runFrontend
139139 :: forall backendRoute route
140− . Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
140+ . Encoder Identity Identity (R (FullRoute backendRoute route)) PageName
141141 -> Frontend (R route)
142142 -> JSM ()
143143runFrontend validFullEncoder frontend = do
@@ -165,14 +165,14 @@ runFrontend validFullEncoder frontend = do
165165 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend
166166
167167runFrontendWithConfigsAndCurrentRoute
168− :: forall backendRoute route
168+ :: forall backendRoute frontendRoute
169169 . FrontendMode
170170 -> Map Text ByteString
171− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
172− -> Frontend (R route)
171+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName
172+ -> Frontend (R frontendRoute)
173173 -> JSM ()
174174runFrontendWithConfigsAndCurrentRoute 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))
176176 errorLeft = \case
177177 Left _ -> error "runFrontend: Unexpected non-app ObeliskRoute reached the frontend. This shouldn't happen."
178178 Right x -> Identity x
lib/route/src/Obelisk/Route.hs+45−1
@@ -12,6 +12,7 @@
1212{-# LANGUAGE PatternSynonyms #-}
1313{-# LANGUAGE RankNTypes #-}
1414{-# LANGUAGE ScopedTypeVariables #-}
15+{-# LANGUAGE StandaloneDeriving #-}
1516{-# LANGUAGE TemplateHaskell #-}
1617{-# LANGUAGE TypeApplications #-}
1718{-# LANGUAGE TypeFamilies #-}
@@ -66,6 +67,10 @@ module Obelisk.Route
6667 , obeliskRouteSegment
6768 , pageNameEncoder
6869 , handleEncoder
70+ , FullRoute (..)
71+ , _FullRoute_Frontend
72+ , _FullRoute_Backend
73+ , mkFullRouteEncoder
6974 , ObeliskRoute (..)
7075 , _ObeliskRoute_App
7176 , _ObeliskRoute_Resource
@@ -710,6 +715,45 @@ handleEncoder recover e = Encoder $ do
710715-- Actual obelisk route info
711716--------------------------------------------------------------------------------
712717
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+
713757-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
714758-- frontend.
715759data ObeliskRoute :: (* -> *) -> * -> * where
@@ -839,7 +883,7 @@ concat <$> mapM deriveRouteComponent
839883 ]
840884
841885makePrisms ''ObeliskRoute
842−
886+makePrisms ''FullRoute
843887deriveGEq ''Void1
844888deriveGCompare ''Void1
845889
lib/run/src/Obelisk/Run.hs+9−11
@@ -22,9 +22,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
2222import Data.ByteString (ByteString)
2323import qualified Data.ByteString.Char8 as BSC
2424import qualified Data.ByteString.Lazy.Char8 as BSLC
25−import Data.Dependent.Sum (DSum (..))
2625import Data.Functor.Identity
27−import Data.Functor.Sum
2826import Data.List (uncons)
2927import Data.Map (Map)
3028import qualified Data.Map as Map
@@ -81,8 +79,8 @@ run port serveStaticAsset backend frontend = do
8179 runSnapWithCommandLineArgs $ do
8280 getRouteWith validFullEncoder >>= \case
8381 Identity r -> case r of
84− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a
85− InR obeliskRoute :=> Identity a ->
82+ FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a
83+ FullRoute_Frontend obeliskRoute :/ a ->
8684 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a
8785 let conf = defRunConfig { _runConfig_redirectPort = port }
8886 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid
@@ -103,8 +101,8 @@ getConfigRoute configs = case Map.lookup "common/route" configs of
103101runWidget
104102 :: RunConfig
105103 -> Map Text ByteString
106− -> Frontend (R route)
107− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
104+ -> Frontend (R frontendRoute)
105+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName
108106 -> IO ()
109107runWidget conf configs frontend validFullEncoder = do
110108 uri <- either (fail . T.unpack) pure $ getConfigRoute configs
@@ -123,11 +121,11 @@ runWidget conf configs frontend validFullEncoder = do
123121 runSettingsSocket settings skt app)
124122
125123obeliskApp
126− :: forall route backendRoute
124+ :: forall frontendRoute backendRoute
127125 . Map Text ByteString
128126 -> ConnectionOptions
129− -> Frontend (R route)
130− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
127+ -> Frontend (R frontendRoute)
128+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName
131129 -> URI
132130 -> Application
133131 -> IO Application
@@ -145,12 +143,12 @@ obeliskApp configs opts frontend validFullEncoder uri backend = do
145143 jsaddle <- jsaddleWithAppOr opts entryPoint $ \_ sendResponse -> sendResponse $ W.responseLBS H.status500 [("Content-Type", "text/plain")] "obeliskApp: jsaddle got a bad URL"
146144 return $ \req sendResponse -> case tryDecode validFullEncoder (W.pathInfo req, mempty) of --TODO: Query strings
147145 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
149147 JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False
150148 _ -> flip jsaddle sendResponse $ req
151149 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute
152150 }
153− InR (ObeliskRoute_App appRouteComponent) :=> Identity appRouteRest -> do
151+ FullRoute_Frontend (ObeliskRoute_App appRouteComponent) :/ appRouteRest -> do
154152 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)
155153 html <- renderJsaddleFrontend configs cookies (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend
156154 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
1111backend :: Backend BackendRoute FrontendRoute
1212backend = Backend
1313 { _backend_run = \serve -> serve $ const $ return ()
14− , _backend_routeEncoder = backendRouteEncoder
14+ , _backend_routeEncoder = fullRouteEncoder
1515 }
skeleton/common/src/Common/Route.hs+8−12
@@ -19,7 +19,6 @@ import Control.Category
1919
2020import Data.Text (Text)
2121import Data.Functor.Identity
22−import Data.Functor.Sum
2322
2423import Obelisk.Route
2524import Obelisk.Route.TH
@@ -34,17 +33,14 @@ data FrontendRoute :: * -> * where
3433 FrontendRoute_Main :: FrontendRoute ()
3534 -- This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend.
3635
37−backendRouteEncoder
38− :: Encoder (Either Text) Identity (R (Sum BackendRoute (ObeliskRoute FrontendRoute))) PageName
39−backendRouteEncoder = handleEncoder (const (InL BackendRoute_Missing :/ ())) $
40− pathComponentEncoder $ \case
41− InL backendRoute -> case backendRoute of
42− BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty
43− InR obeliskRoute -> obeliskRouteSegment obeliskRoute $ \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
47−
36+fullRouteEncoder
37+ :: Encoder (Either Text) Identity (R (FullRoute BackendRoute FrontendRoute)) PageName
38+fullRouteEncoder = mkFullRouteEncoder
39+ (FullRoute_Backend BackendRoute_Missing :/ ())
40+ (\case
41+ BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty)
42+ (\case
43+ FrontendRoute_Main -> PathEnd $ unitEncoder mempty)
4844
4945concat <$> mapM deriveRouteComponent
5046 [ ''BackendRoute
skeleton/frontend/src-bin/main.hs+1−1
@@ -6,5 +6,5 @@ import Reflex.Dom
66
77main :: IO ()
88main = do
9− let Right validFullEncoder = checkEncoder backendRouteEncoder
9+ let Right validFullEncoder = checkEncoder fullRouteEncoder
1010 run $ runFrontend validFullEncoder frontend