75c3b86 · obelisk · git.iko.soy

git.iko.soy/obelisk

More things to make custom routes work

commit75c3b86af8dda2a21c0230d8c7a0dec6d61cc44a authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 11 Jul 2018, 18:23 (8 years ago) parent6061e51

2 files changed+64−16

compare with master

unifiedsplit

lib/backend/src/Obelisk/Backend.hs+25−12 lib/route/src/Obelisk/Route.hs+39−4

lib/backend/src/Obelisk/Backend.hs+25−12

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

1111 , BackendConfig (..)

1212 -- * Re-exports

1313 , Default (def)

14+ , checkGetRequestRoute

15+ , runSnapWithCommandLineArgs

16+ , serveDefaultObeliskApp

17+ , prettifyOutput

1418 ) where

1519

1620import Prelude hiding ((.))

@@ -40,7 +44,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)

4044-- use 'def'.

4145data BackendConfig (route :: * -> *) = BackendConfig

4246 { _backendConfig_frontend :: !(Frontend (R route))

43− , _backendConfig_routeEncoder :: !(Encoder (Either Text) (Either Text) (R (ObeliskRoute route)) PageName)

47+ , _backendConfig_routeEncoder :: !(Encoder (Either Text) (Either Text) (R (ObeliskRoute route)) PageName) --TODO: Factor this out so that it isn't partially redundant with _frontend_routeEncoder

4448 }

4549

4650instance route ~ IndexOnlyRoute => Default (BackendConfig route) where

@@ -74,19 +78,28 @@ backend

7478backend cfg = do

7579 getRequestRoute <- checkGetRequestRoute $ _backendConfig_routeEncoder cfg --TODO: Report error better

7680 return $ do

77− -- Make output more legible by decreasing the likelihood of output from

78− -- multiple threads being interleaved

79− hSetBuffering stdout LineBuffering

80− hSetBuffering stderr LineBuffering

81+ prettifyOutput

8182

8283 runSnapWithCommandLineArgs $ do

83− let frontendApp = GhcjsApp

84− { _ghcjsApp_compiled = defaultFrontendGhcjsAssets

85− , _ghcjsApp_value = _backendConfig_frontend cfg

86− }

8784 getRequestRoute >>= \case

8885 Left e -> writeText e

89− Right r -> serveObeliskRoute defaultStaticAssets frontendApp r

86+ Right r -> serveDefaultObeliskApp (_backendConfig_frontend cfg) r

87+

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

89+--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

90+serveDefaultObeliskApp :: MonadSnap m => Frontend (R appRoute) -> R (ObeliskRoute appRoute) -> m ()

91+serveDefaultObeliskApp frontend = serveObeliskApp defaultStaticAssets frontendApp

92+ where frontendApp = GhcjsApp

93+ { _ghcjsApp_compiled = defaultFrontendGhcjsAssets

94+ , _ghcjsApp_value = frontend

95+ }

96+

97+prettifyOutput :: IO ()

98+prettifyOutput = do

99+ -- Make output more legible by decreasing the likelihood of output from

100+ -- multiple threads being interleaved

101+ hSetBuffering stdout LineBuffering

102+ hSetBuffering stderr LineBuffering

90103

91104defaultStaticAssets :: StaticAssets

92105defaultStaticAssets = StaticAssets

@@ -122,8 +135,8 @@ checkGetRequestRoute routeEncoder = do

122135 , "?" <> T.unpack (decodeUtf8 q)

123136 )

124137

125−serveObeliskRoute :: MonadSnap m => StaticAssets -> GhcjsApp (R appRoute) -> R (ObeliskRoute appRoute) -> m ()

126−serveObeliskRoute staticAssets frontendApp = \case

138+serveObeliskApp :: MonadSnap m => StaticAssets -> GhcjsApp (R appRoute) -> R (ObeliskRoute appRoute) -> m ()

139+serveObeliskApp staticAssets frontendApp = \case

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

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

129142 ResourceRoute_Static :=> Identity pathSegments -> serveStaticAssets staticAssets pathSegments

lib/route/src/Obelisk/Route.hs+39−4

@@ -21,6 +21,7 @@ module Obelisk.Route

2121 , Encoder (..) --TODO: unsafe

2222 , checkEncoder

2323 , ValidEncoder (..) --TODO: unsafe

24+ , ValidEncoderFunc (..)

2425 , mapSome

2526 , pathComponentEncoder

2627 , enumEncoder

@@ -39,6 +40,8 @@ module Obelisk.Route

3940 , prismValidEncoder

4041 , rPrism

4142 , obeliskRouteEncoder

43+ , obeliskRouteComponentEncoder

44+ , checkObeliskRouteRestEncoder

4245 , pageNameValidEncoder

4346 , catchValidEncoder

4447 , ObeliskRoute (..)

@@ -50,6 +53,7 @@ module Obelisk.Route

5053 , IndexOnlyRoute (..)

5154 , indexOnlyRouteComponentEncoder

5255 , indexOnlyRouteRestEncoder

56+ , someSumEncoder

5357 ) where

5458

5559import Prelude hiding ((.), id)

@@ -63,7 +67,9 @@ import Control.Monad.Except

6367import Data.Dependent.Sum (DSum (..), ShowTag (..))

6468import Data.Dependent.Map (DMap)

6569import qualified Data.Dependent.Map as DMap

70+import Data.Either.Validation (Validation (..))

6671import Data.Foldable

72+import Data.Functor.Sum

6773import Data.GADT.Compare

6874import Data.GADT.Compare.TH

6975import Data.GADT.Show

@@ -78,7 +84,6 @@ import Data.Some (Some)

7884import qualified Data.Some as Some

7985import Data.Text (Text)

8086import qualified Data.Text as T

81−import Data.Either.Validation (Validation (..))

8287import Data.Universe

8388

8489-- Design goals:

@@ -232,7 +237,7 @@ shadowEncoder

232237 , Show c

233238 , check ~ parse --TODO: Get rid of this

234239 )

235− => Encoder check parse a c -- ^ Overlaps

240+ => Encoder check parse a c -- ^ Overlaps; should have a small number of possible routes

236241 -> Encoder check parse b c -- ^ Gets overlapped

237242 -> Encoder check parse (Either a b) c

238243shadowEncoder f g = Encoder $ do

@@ -471,13 +476,33 @@ obeliskRouteEncoder

471476 -> (forall a. appRoute a -> Encoder check parse a PageName)

472477 -> Encoder check parse (R (ObeliskRoute appRoute)) PageName

473478obeliskRouteEncoder appComponentEncoder appRouteEncoder = Encoder $ do

474− let componentEncoder = (resourceComponentEncoder `shadowEncoder` appComponentEncoder) . obeliskComponentEncoder

479+ let componentEncoder = obeliskRouteComponentEncoder appComponentEncoder

480+ restEncoder <- checkObeliskRouteRestEncoder appRouteEncoder

481+ checkEncoder $ pathComponentEncoder componentEncoder $ runValidEncoderFunc restEncoder

482+

483+checkObeliskRouteRestEncoder

484+ :: ( MonadError Text check

485+ , MonadError Text parse

486+ , Universe (Some appRoute)

487+ , GCompare appRoute

488+ )

489+ => (forall a. appRoute a -> Encoder check parse a PageName)

490+ -> check (ValidEncoderFunc parse (ObeliskRoute appRoute) PageName)

491+checkObeliskRouteRestEncoder appRouteEncoder = do

475492 appRouteValidEncoder <- checkSomeUniverseEncoder appRouteEncoder

476493 resourceRouteValidEncoder <- checkSomeUniverseEncoder resourceRouteEncoder

477− checkEncoder $ pathComponentEncoder componentEncoder $ \case

494+ return $ ValidEncoderFunc $ \case

478495 ObeliskRoute_App appRoute -> runValidEncoderFunc appRouteValidEncoder appRoute

479496 ObeliskRoute_Resource resRoute -> runValidEncoderFunc resourceRouteValidEncoder resRoute

480497

498+obeliskRouteComponentEncoder

499+ :: ( MonadError Text parse

500+ , GShow appRoute

501+ , check ~ parse

502+ )

503+ => Encoder check parse (Some appRoute) (Maybe Text) -> Encoder check parse (Some (ObeliskRoute appRoute)) (Maybe Text)

504+obeliskRouteComponentEncoder appComponentEncoder = (resourceComponentEncoder `shadowEncoder` appComponentEncoder) . obeliskComponentEncoder

505+

481506resourceComponentEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (Some ResourceRoute) (Maybe Text)

482507resourceComponentEncoder = enum1Encoder $ \case

483508 ResourceRoute_Static -> Just "static"

@@ -563,6 +588,16 @@ instance ShowTag IndexOnlyRoute Identity where

563588 showTaggedPrec = \case

564589 IndexOnlyRoute -> showsPrec

565590

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

592+someSumEncoder = Encoder $ pure $ ValidEncoder

593+ { _validEncoder_encode = \(Some.This t) -> case t of

594+ InL l -> Left $ Some.This l

595+ InR r -> Right $ Some.This r

596+ , _validEncoder_decode = pure . \case

597+ Left (Some.This l) -> Some.This (InL l)

598+ Right (Some.This r) -> Some.This (InR r)

599+ }

600+

566601makePrisms ''ObeliskRoute

567602--TODO: Prevent deriveGShow from creating this warning:

568603-- Defined but not used: ‘p’