07837b8 · obelisk · git.iko.soy

git.iko.soy/obelisk

Use route parsing on the backend

commit07837b8e98ba9d9d4d65adb7ef600c952e49ed1b authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 30 Jun 2018, 00:01 (8 years ago) parentce60288

4 files changed+92−20

compare with master

unifiedsplit

lib/backend/obelisk-backend.cabal+4−1 lib/backend/src/Obelisk/Backend.hs+47−6 lib/route/src/Obelisk/Route.hs+39−11 lib/route/src/Obelisk/Route/Frontend.hs+2−2

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

@@ -8,10 +8,13 @@ library

88 build-depends: base,

99 bytestring,

1010 data-default,

11+ dependent-sum,

1112 lens,

1213 obelisk-asset-serve-snap,

14+ obelisk-route,

1315 obelisk-snap,

1416 reflex-dom,

1517 snap,

16− snap-server

18+ snap-server,

19+ text

1720 exposed-modules: Obelisk.Backend

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

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

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE GADTs #-}

13{-# LANGUAGE OverloadedStrings #-}

24module Obelisk.Backend

35 ( backend

@@ -6,14 +8,24 @@ module Obelisk.Backend

68 , Default (def)

79 ) where

810

9−import Control.Lens

11+import Prelude hiding ((.))

12+

13+import Control.Category

14+import Control.Monad.IO.Class

1015import qualified Data.ByteString.Char8 as BSC8

1116import Data.Default (Default (..))

12−import Obelisk.Asset.Serve.Snap (serveAssets)

17+import Data.Dependent.Sum

18+import Data.Functor.Identity

19+import Data.Monoid

20+import Data.Text (Text)

21+import qualified Data.Text as T

22+import Data.Text.Encoding

23+import Obelisk.Asset.Serve.Snap (serveAsset, serveAssets)

24+import Obelisk.Route

1325import Obelisk.Snap

1426import Reflex.Dom

15−import System.IO (hSetBuffering, stderr, BufferMode (..))

16−import Snap (httpServe, defaultConfig, commandLineConfig, route)

27+import System.IO (hSetBuffering, stdout, stderr, BufferMode (..))

28+import Snap (httpServe, defaultConfig, commandLineConfig, route, getsRequest, rqPathInfo, rqQueryString, writeText, writeBS)

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

1830

1931--TODO: Add a link to a large explanation of the idea of using 'def'

@@ -27,10 +39,11 @@ instance Default BackendConfig where

2739 def = BackendConfig (return ())

2840

2941-- | Start an Obelisk backend

30−backend :: BackendConfig -> IO ()

31−backend cfg = do

42+backend :: ShowTag appRoute Identity => Encoder (Either Text) (Either Text) (R (ObeliskRoute appRoute)) PageName -> BackendConfig -> IO ()

43+backend routeEncoder cfg = do

3244 -- Make output more legible by decreasing the likelihood of output from

3345 -- multiple threads being interleaved

46+ hSetBuffering stdout LineBuffering

3447 hSetBuffering stderr LineBuffering

3548

3649 -- Get the web server configuration from the command line

@@ -41,9 +54,37 @@ backend cfg = do

4154 , errorLog = Just $ ConfigIoLog BSC8.putStrLn

4255 }

4356 appCfg = def & appConfig_initialHead .~ headHtml

57+ let Right routeEncoderValid = checkEncoder routeEncoder --TODO: Report error better

58+ -- Start the web server

59+ httpServe httpConf $ do

60+ p <- getsRequest rqPathInfo

61+ q <- getsRequest rqQueryString

62+ let parsed = _validEncoder_decode (pageNameValidEncoder . routeEncoderValid)

63+ ( "/" <> T.unpack (decodeUtf8 p)

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

65+ )

66+ liftIO $ putStrLn $ "Got route: " <> show parsed

67+ case parsed of

68+ Left e -> writeText e

69+ Right r -> case r of

70+ ObeliskRoute_App _ :/ _ -> do

71+ (_, index) <- liftIO $ renderStatic blankLoader --TODO: Render to a Builder instead; don't allow IO

72+ writeBS $ "<!DOCTYPE html>\n" <> index

73+ ObeliskRoute_Resource ResourceRoute_Static :=> Identity pathSegments -> serveAsset "static.assets" "static" $ T.unpack $ T.intercalate "/" pathSegments

74+ ObeliskRoute_Resource ResourceRoute_Ghcjs :=> Identity ghcjsRoute -> case ghcjsRoute of

75+ GhcjsRoute_AllJs :=> Identity () -> serveAsset "frontend.jsexe.assets" "frontend.jsexe" "all.js"

76+ ObeliskRoute_Resource ResourceRoute_JSaddleWarp :=> Identity _ -> error "asdf"

4477 -- Start the web server

4578 httpServe httpConf $ route

4679 [ ("", serveApp "" appCfg)

4780 , ("", serveAssets "frontend.jsexe.assets" "frontend.jsexe") --TODO: Can we prevent naming conflicts between frontend.jsexe and static?

4881 , ("static", serveAssets "static.assets" "static")

4982 ]

83+

84+blankLoader :: DomBuilder t m => m ()

85+blankLoader = el "html" $ do

86+ el "head" $ do

87+ elAttr "base" ("href" =: "/") blank --TODO: Figure out the base URL from the routes

88+ el "body" $ do

89+ --TODO: Hash the all.js path

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

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

@@ -39,7 +39,7 @@ module Obelisk.Route

3939 , prismValidEncoder

4040 , rPrism

4141 , obeliskRouteEncoder

42− , pageNameEncoder

42+ , pageNameValidEncoder

4343 , catchValidEncoder

4444 , ObeliskRoute (..)

4545 , _ObeliskRoute_App

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

4747 , ResourceRoute (..)

4848 , JSaddleWarpRoute (..)

4949 , jsaddleWarpRouteEncoder

50+ , GhcjsRoute (..)

5051 ) where

5152

5253import Prelude hiding ((.), id)

@@ -275,15 +276,15 @@ enumEncoder f = Encoder $ do

275276 [e] -> Success e

276277 _ -> Failure $ Map.singleton k vs

277278 showRedundant :: r -> Set p -> [Text]

278− showRedundant k vs = (" " <> T.pack (show k) <> " can decode to any of:")

279− : fmap ((" "<>) . T.pack . show) (Set.toList vs)

279+ showRedundant k vs = (" " <> tshow k <> " can decode to any of:")

280+ : fmap ((" "<>) . tshow) (Set.toList vs)

280281 case itraverse checkSingleton reversed :: Validation (Map r (Set p)) (Map r p) of

281282 Failure ambiguousEntries -> throwError $ T.unlines $

282283 "enumEncoder: ambiguous encodings detected:" : concat (Map.elems $ imap showRedundant ambiguousEntries)

283284 Success m -> pure $ ValidEncoder

284285 { _validEncoder_decode = \r -> case Map.lookup r m of

285286 Just a -> pure a

286− Nothing -> throwError $ "enumEncoder: not recognized: " <> T.pack (show r) --TODO: Report this as a better type

287+ Nothing -> throwError $ "enumEncoder: not recognized: " <> tshow r --TODO: Report this as a better type

287288 , _validEncoder_encode = f

288289 }

289290

@@ -292,7 +293,7 @@ endValidEncoder expected = ValidEncoder

292293 { _validEncoder_decode = \obtained ->

293294 if obtained == expected

294295 then pure ()

295− else throwError $ "endValidEncoder: expected " <> T.pack (show expected) <> ", got " <> T.pack (show obtained)

296+ else throwError $ "endValidEncoder: expected " <> tshow expected <> ", got " <> tshow obtained

296297 , _validEncoder_encode = \_ -> expected

297298 }

298299

@@ -309,7 +310,7 @@ singletonListValidEncoder :: (MonadError Text parse) => ValidEncoder parse a [a]

309310singletonListValidEncoder = ValidEncoder

310311 { _validEncoder_decode = \case

311312 [a] -> pure a

312− l -> throwError $ "singletonListValidEncoder: expected one item, got " <> T.pack (show $ length l)

313+ l -> throwError $ "singletonListValidEncoder: expected one item, got " <> tshow (length l)

313314 , _validEncoder_encode = (:[])

314315 }

315316

@@ -339,7 +340,7 @@ prefixTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encod

339340prefixTextEncoder p = Encoder $ pure $ ValidEncoder

340341 { _validEncoder_encode = mappend p

341342 , _validEncoder_decode = \v -> case T.stripPrefix p v of

342− Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> T.pack (show p)

343+ Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> tshow p <> ", got " <> tshow (T.take (T.length p) v)

343344 Just stripped -> pure stripped

344345 }

345346

@@ -351,7 +352,7 @@ prefixNonemptyTextEncoder p = Encoder $ pure $ ValidEncoder

351352 , _validEncoder_decode = \case

352353 "" -> pure ""

353354 v -> case T.stripPrefix p v of

354− Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> T.pack (show p)

355+ Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> tshow p

355356 Just stripped -> pure stripped

356357 }

357358

@@ -376,7 +377,7 @@ joinPairTextEncoder = Encoder . \case

376377 let (kt, vt) = T.breakOn separator r

377378 in case vt of

378379 -- The separator was not found

379− "" -> throwError $ "joinPairTextEncoder: separator not found; expected " <> T.pack (show separator)

380+ "" -> throwError $ "joinPairTextEncoder: separator not found; expected " <> tshow separator

380381 _ -> return (kt, T.drop (T.length separator) vt)

381382 }

382383

@@ -397,8 +398,8 @@ prismValidEncoder p = ValidEncoder

397398

398399-- | Encode a PageName into a path and query string, suitable for use in the

399400-- 'URI' type

400−pageNameEncoder :: MonadError Text parse => ValidEncoder parse PageName (String, String)

401−pageNameEncoder = ve

401+pageNameValidEncoder :: MonadError Text parse => ValidEncoder parse PageName (String, String)

402+pageNameValidEncoder = ve

402403 where Right ve = checkEncoder $ bimap

403404 (unpackTextEncoder . prefixTextEncoder "/" . intercalateTextEncoder "/" . listToNonEmptyEncoder)

404405 (unpackTextEncoder . prefixNonemptyTextEncoder "?" . intercalateTextEncoder "&" . listToNonEmptyEncoder . Cat.fmap (joinPairTextEncoder "=") . toListMapEncoder)

@@ -421,12 +422,14 @@ data ObeliskRoute :: (* -> *) -> * -> * where

421422

422423data ResourceRoute :: * -> * where

423424 ResourceRoute_Static :: ResourceRoute [Text] -- This [Text] represents the *path in our static files directory*, not necessarily the URL path that the asset gets served at (although that will often be "/static/this/text/thing")

425+ ResourceRoute_Ghcjs :: ResourceRoute (R GhcjsRoute)

424426 ResourceRoute_JSaddleWarp :: ResourceRoute (R JSaddleWarpRoute)

425427

426428--TODO: Generate this

427429instance Universe (Some ResourceRoute) where

428430 universe =

429431 [ Some.This ResourceRoute_Static

432+ , Some.This ResourceRoute_Ghcjs

430433 , Some.This ResourceRoute_JSaddleWarp

431434 ]

432435

@@ -478,11 +481,13 @@ obeliskRouteEncoder appComponentEncoder appRouteEncoder = Encoder $ do

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

479482resourceComponentEncoder = enum1Encoder $ \case

480483 ResourceRoute_Static -> Just "static"

484+ ResourceRoute_Ghcjs -> Just "ghcjs"

481485 ResourceRoute_JSaddleWarp -> Just "jsaddle"

482486

483487resourceRouteEncoder :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> Encoder check parse a PageName

484488resourceRouteEncoder = \case

485489 ResourceRoute_Static -> Encoder $ pure pathOnlyValidEncoder

490+ ResourceRoute_Ghcjs -> ghcjsRouteEncoder

486491 ResourceRoute_JSaddleWarp -> jsaddleWarpRouteEncoder

487492

488493data JSaddleWarpRoute :: * -> * where

@@ -517,6 +522,7 @@ instance ShowTag appRoute Identity => ShowTag (ObeliskRoute appRoute) Identity w

517522instance ShowTag ResourceRoute Identity where

518523 showTaggedPrec = \case

519524 ResourceRoute_Static -> showsPrec

525+ ResourceRoute_Ghcjs -> showsPrec

520526 ResourceRoute_JSaddleWarp -> showsPrec

521527

522528instance ShowTag JSaddleWarpRoute Identity where

@@ -525,6 +531,25 @@ instance ShowTag JSaddleWarpRoute Identity where

525531 JSaddleWarpRoute_WebSocket -> showsPrec

526532 JSaddleWarpRoute_Sync -> showsPrec

527533

534+data GhcjsRoute :: * -> * where

535+ GhcjsRoute_AllJs :: GhcjsRoute ()

536+

537+instance Universe (Some GhcjsRoute) where

538+ universe =

539+ [ Some.This GhcjsRoute_AllJs

540+ ]

541+

542+instance ShowTag GhcjsRoute Identity where

543+ showTaggedPrec = \case

544+ GhcjsRoute_AllJs -> showsPrec

545+

546+ghcjsRouteEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (R GhcjsRoute) PageName

547+ghcjsRouteEncoder = pathComponentEncoder ghcjsRouteComponentEncoder $ \case

548+ GhcjsRoute_AllJs -> endValidEncoder mempty

549+

550+ghcjsRouteComponentEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (Some GhcjsRoute) (Maybe Text)

551+ghcjsRouteComponentEncoder = enum1Encoder $ \case

552+ GhcjsRoute_AllJs -> Just "all.js"

528553

529554instance Universe (Some appRoute) => Universe (Some (ObeliskRoute appRoute)) where

530555 universe = mconcat

@@ -548,5 +573,8 @@ deriveGCompare ''ResourceRoute

548573deriveGShow ''JSaddleWarpRoute

549574deriveGEq ''JSaddleWarpRoute

550575deriveGCompare ''JSaddleWarpRoute

576+deriveGShow ''GhcjsRoute

577+deriveGEq ''GhcjsRoute

578+deriveGCompare ''GhcjsRoute

551579

552580--TODO: decodeURIComponent as appropriate

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

@@ -162,11 +162,11 @@ runRouteViewT routeEncoder routeRestEncoder routeToTitle error404 a = do

162162 rec historyState <- manageHistory $ HistoryCommand_PushState <$> setState

163163 let Right myEncoder = checkEncoder $ obeliskRouteEncoder routeEncoder routeRestEncoder . Encoder (pure $ prismValidEncoder $ rPrism _ObeliskRoute_App)

164164 route :: Dynamic t (R r)

165− route = fmap (runIdentity . _validEncoder_decode (catchValidEncoder error404 $ pageNameEncoder . myEncoder) . (uriPath &&& uriQuery) . _historyItem_uri) historyState

165+ route = fmap (runIdentity . _validEncoder_decode (catchValidEncoder error404 $ pageNameValidEncoder . myEncoder) . (uriPath &&& uriQuery) . _historyItem_uri) historyState

166166 (result, changeState) <- runEventWriterT $ runRoutedT a route

167167 let f oldRoute change =

168168 let newRoute = appEndo change oldRoute

169− (newPath, newQuery) = _validEncoder_encode (pageNameEncoder . myEncoder) newRoute

169+ (newPath, newQuery) = _validEncoder_encode (pageNameValidEncoder . myEncoder) newRoute

170170 in HistoryStateUpdate

171171 { _historyStateUpdate_state = DOM.SerializedScriptValue jsNull

172172 , _historyStateUpdate_title = "Reflex FRP - " <> routeToTitle newRoute