git.iko.soy/obelisk
on master help sign in
Merge branch 'cg-fullroute' into aa-ghc865

* cg-fullroute: Add to changelog Use FullRoute in types of render{Backend,Frontend,Obelisk}Route Add a getTextConfig convenience function. Add a FullRoute type to formalise the expected top level structure of obelisk routes. bump reflex-platform, fix warnings, remove a chunk of commented-out code. Add an `_R` prism which is useful with `modifyRoute` Add a few combinators to routes - generalize pageSegmentEncoder about as far as it generalizes - more braided instances for Encoder (,) and Encoder Either - a path style encoder for records using Data.Tabulation Add a few combinators to routes - generalize pageSegmentEncoder about as far as it generalizes - more braided instances for Encoder (,) and Encoder Either - a path style encoder for records using Data.Tabulation Add an `_R` prism which is useful with `modifyRoute` fix route parsing in `ob run` Fiddle with configs so they actually work.

commit5664fca8bcfdf76b149ef4938b8634d3e00afe4d authorAli Abrar <aliabrar@gmail.com> dateWed 28 Aug 2019, 08:20 (7 years ago) parent33ca3d18c2c7b2
10 files changed+238−72
compare with master
unifiedsplit
ChangeLog.md+2 lib/backend/src/Obelisk/Backend.hs+7−12 lib/executable-config/lookup/src/Obelisk/Configs.hs+4 lib/frontend/src/Obelisk/Frontend.hs+6−5 lib/route/src/Obelisk/Route.hs+191−21 lib/run/src/Obelisk/Run.hs+11−12 skeleton/backend/src/Backend.hs+1−1 skeleton/common/src/Common/Route.hs+8−12 skeleton/default.nix+7−8 skeleton/frontend/src-bin/main.hs+1−1
ChangeLog.md+2
@@ -12,6 +12,8 @@ This project's release branch is `master`. This log is written from the perspect
1212* The backend no longer runs in BackendConfigsT.
1313* Add tabulation package. See Data.Tabulation for details.
1414* Add encoders for `DMap`, `HasFields` (cf. Data.Tabulation), and JSON.
15+* Generalised pathSegmentEncoder, added pathFieldEncoder.
16+* Added some Prisms to the encoder library for manipulating DSums (perhaps they should get moved to dependent-sum before release?)
1517* Use IP address for nginx proxy pass instead of localhost
1618* Add "ob doc" command, which lists paths to haddock documentation for specified packages
1719
lib/backend/src/Obelisk/Backend.hs+7−12
@@ -32,7 +32,6 @@ import Data.ByteString (ByteString)
3232import qualified Data.ByteString.Char8 as BSC8
3333import Data.Default (Default (..))
3434import Data.Dependent.Sum
35−import Data.Functor.Sum
3635import Data.Functor.Identity
3736import Data.Map (Map)
3837import qualified Data.Map as Map
@@ -53,7 +52,7 @@ import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog
5352import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
5453
5554data Backend backendRoute frontendRoute = Backend
56− { _backend_routeEncoder :: Encoder (Either Text) Identity (R (Sum backendRoute (ObeliskRoute frontendRoute))) PageName
55+ { _backend_routeEncoder :: Encoder (Either Text) Identity (R (FullRoute backendRoute frontendRoute)) PageName
5756 , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()
5857 }
5958
@@ -115,11 +114,7 @@ getPageName :: (MonadSnap m) => m PageName
115114getPageName = do
116115 p <- getsRequest rqPathInfo
117116 q <- getsRequest rqQueryString
118− let pageNameEncoder' :: Encoder Identity Identity PageName (String, String)
119− pageNameEncoder' = bimap
120− (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)
121− (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)
122− return $ decode pageNameEncoder' (T.unpack (decodeUtf8 p), T.unpack (decodeUtf8 q))
117+ return $ byteStringsToPageName p q
123118
124119getRouteWith :: (MonadSnap m) => Encoder Identity parse route PageName -> m (parse route)
125120getRouteWith e = do
@@ -175,7 +170,7 @@ serveGhcjsApp urlEnc app config = \case
175170 writeBS <=< renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app
176171 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments
177172
178−runBackend :: Backend fullRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
173+runBackend :: Backend backendRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
179174runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of
180175 Left e -> fail $ "backend error:\n" <> T.unpack e
181176 Right validFullEncoder -> do
@@ -184,15 +179,15 @@ runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend
184179 runSnapWithCommandLineArgs $ do
185180 getRouteWith validFullEncoder >>= \case
186181 Identity r -> case r of
187− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a
188− InR obeliskRoute :=> Identity a ->
182+ FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a
183+ FullRoute_Frontend obeliskRoute :/ a ->
189184 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $
190185 obeliskRoute :/ a
191186
192−mkRouteToUrl :: Encoder Identity parse (R (Sum f (ObeliskRoute r))) PageName -> R r -> Text
187+mkRouteToUrl :: Encoder Identity parse (R (FullRoute br fr)) PageName -> R fr -> Text
193188mkRouteToUrl validFullEncoder =
194189 let pageNameEncoder' :: Encoder Identity (Either Text) PageName PathQuery = pageNameEncoder
195− in \(k :/ v) -> T.pack . uncurry (<>) . encode pageNameEncoder' . encode validFullEncoder $ (InR $ ObeliskRoute_App k) :/ v
190+ in \(k :/ v) -> T.pack . uncurry (<>) . encode pageNameEncoder' . encode validFullEncoder $ (FullRoute_Frontend $ ObeliskRoute_App k) :/ v
196191
197192renderGhcjsFrontend
198193 :: (MonadSnap m, HasCookies m)
lib/executable-config/lookup/src/Obelisk/Configs.hs+4
@@ -31,6 +31,7 @@ import Data.ByteString (ByteString)
3131import Data.Map (Map)
3232import qualified Data.Map as Map
3333import Data.Text (Text)
34+import qualified Data.Text.Encoding as T
3435import Reflex
3536import Reflex.Host.Class
3637import Reflex.Dom
@@ -50,6 +51,9 @@ class Monad m => HasConfigs m where
5051instance Monad m => HasConfigs (ConfigsT m) where
5152 getConfigs = ConfigsT ask
5253
54+getTextConfig :: HasConfigs m => Text -> m (Maybe Text)
55+getTextConfig k = fmap T.decodeUtf8 <$> getConfig k
56+
5357instance HasConfigs m => HasConfigs (BehaviorWriterT t w m)
5458instance HasConfigs m => HasConfigs (DynamicWriterT t w m)
5559instance HasConfigs m => HasConfigs (EventWriterT t w m)
lib/frontend/src/Obelisk/Frontend.hs+6−5
@@ -83,6 +83,7 @@ type ObeliskWidget js t route m =
8383 , PrebuildAgnostic t route (Client m)
8484 , HasConfigs m
8585 , HasCookies m
86+ , MonadIO (Performable m)
8687 )
8788
8889type PrebuildAgnostic t route m =
@@ -144,7 +145,7 @@ data FrontendMode = FrontendMode
144145-- Selects FrontendMode based on platform; this doesn't work for jsaddle-warp
145146runFrontend
146147 :: forall backendRoute route
147− . Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
148+ . Encoder Identity Identity (R (FullRoute backendRoute route)) PageName
148149 -> Frontend (R route)
149150 -> JSM ()
150151runFrontend validFullEncoder frontend = do
@@ -172,14 +173,14 @@ runFrontend validFullEncoder frontend = do
172173 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend
173174
174175runFrontendWithConfigsAndCurrentRoute
175− :: forall backendRoute route
176+ :: forall backendRoute frontendRoute
176177 . FrontendMode
177178 -> Map Text ByteString
178− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
179− -> Frontend (R route)
179+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName
180+ -> Frontend (R frontendRoute)
180181 -> JSM ()
181182runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do
182− let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _InR . _ObeliskRoute_App))
183+ let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _FullRoute_Frontend . _ObeliskRoute_App))
183184 errorLeft = \case
184185 Left _ -> error "runFrontend: Unexpected non-app ObeliskRoute reached the frontend. This shouldn't happen."
185186 Right x -> Identity x
lib/route/src/Obelisk/Route.hs+191−21
@@ -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 #-}
@@ -62,10 +63,15 @@ module Obelisk.Route
6263 , shadowEncoder
6364 , prismEncoder
6465 , rPrism
66+ , _R
6567 , obeliskRouteEncoder
6668 , obeliskRouteSegment
6769 , pageNameEncoder
6870 , handleEncoder
71+ , FullRoute (..)
72+ , _FullRoute_Frontend
73+ , _FullRoute_Backend
74+ , mkFullRouteEncoder
6975 , ObeliskRoute (..)
7076 , _ObeliskRoute_App
7177 , _ObeliskRoute_Resource
@@ -90,7 +96,9 @@ module Obelisk.Route
9096 , Decoder(..)
9197 , dmapEncoder
9298 , fieldMapEncoder
99+ , pathFieldEncoder
93100 , jsonEncoder
101+ , byteStringsToPageName
94102 ) where
95103
96104import Prelude hiding ((.), id)
@@ -101,8 +109,31 @@ import qualified Control.Categorical.Functor as Cat
101109import Control.Categorical.Bifunctor
102110import Control.Category.Associative
103111import Control.Category.Monoidal
104−import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
112+import Control.Category.Braided
113+import Control.Lens
114+ ( Identity (..)
115+ , (^.)
116+ , (^?)
117+ , _Just
118+ , _Nothing
119+ , Cons(..)
120+ , from
121+ , imap
122+ , iso
123+ , Iso'
124+ , itraverse
125+ , makePrisms
126+ , Prism'
127+ , prism'
128+ , re
129+ , view
130+ , Wrapped (..)
131+ )
105132import Control.Monad.Except
133+import Control.Monad.Writer (execWriter, tell)
134+import qualified Control.Monad.State.Strict as State
135+import Control.Monad.Trans (lift)
136+import qualified Data.ByteString as BS
106137import qualified Data.ByteString.Lazy as BSL
107138import Data.Dependent.Sum (DSum (..))
108139import Data.Dependent.Map (DMap)
@@ -252,6 +283,10 @@ instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (E
252283 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
253284 }
254285
286+instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where
287+ braid = isoEncoder (iso swap swap)
288+
289+
255290instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
256291 first f = bimap f id
257292instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
@@ -265,6 +300,34 @@ instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (Enco
265300 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve
266301 }
267302
303+instance Monad parse => PFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
304+ first f = bimap f id
305+instance Monad parse => QFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
306+ second g = bimap id g
307+instance Monad parse => Bifunctor Either (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
308+ bimap f g = EncoderImpl
309+ { _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)
310+ , _encoderImpl_decode = \case
311+ Left a -> Left <$> _encoderImpl_decode f a
312+ Right b -> Right <$> _encoderImpl_decode g b
313+ }
314+
315+instance (Monad parse, Applicative check) => QFunctor Either (Encoder check parse) (Encoder check parse) where
316+ second g = bimap id g
317+instance (Monad parse, Applicative check) => PFunctor Either (Encoder check parse) (Encoder check parse) where
318+ first f = bimap f id
319+instance (Monad parse, Applicative check) => Bifunctor Either (Encoder check parse) (Encoder check parse) (Encoder check parse) where
320+ bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)
321+
322+instance (Applicative check, Monad parse) => Associative (Encoder check parse) Either where
323+ associate = isoEncoder (iso (associate @(->) @Either) disassociate)
324+ disassociate = isoEncoder (iso disassociate associate)
325+
326+instance (Monad parse, Applicative check) => Braided (Encoder check parse) Either where
327+ braid = isoEncoder (iso swap swap)
328+
329+
330+
268331instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
269332 fmap e = Encoder $ do
270333 ve <- unEncoder e
@@ -664,10 +727,47 @@ joinPairTextEncoder = Encoder . \case
664727 _ -> return (kt, T.drop (T.length separator) vt)
665728 }
666729
667−--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum
668−-- Or, more likely, the user can compose it themselves
669−rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
670−rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)
730+-- This slight generalization of 'rPrism' happens to be enough to write all our
731+-- prism combinators so far.
732+dSumPrism
733+ :: forall f f' g
734+ . (forall a. Prism' (f a) (f' a))
735+ -> Prism' (DSum f g) (DSum f' g)
736+dSumPrism p = prism'
737+ (\(f' :=> x) -> f' ^. re p :=> x)
738+ (\(f :=> x) -> (:=> x) <$> (f ^? p))
739+
740+-- already in obelisk
741+rPrism
742+ :: forall f f'
743+ . (forall a. Prism' (f a) (f' a))
744+ -> Prism' (R f) (R f')
745+rPrism p = dSumPrism p
746+
747+dSumPrism'
748+ :: forall f g a
749+ . (forall b. Prism' (f b) (a :~: b))
750+ -> Prism' (DSum f g) (g a)
751+dSumPrism' p = dSumPrism p . iso (\(Refl :=> b) -> b) (Refl :=>)
752+
753+dSumGEqPrism
754+ :: GEq f
755+ => f a
756+ -> Prism' (DSum f g) (g a)
757+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)
758+
759+-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual
760+-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'
761+-- generalized a usual sum type.
762+--
763+-- [This is given the '_R' name of the "cannonical" prism not because it is the
764+-- most general, but because it seems the most useful for routes, and 'R' itself
765+-- trades generality for route-specificity.]
766+_R
767+ :: GEq f
768+ => f a
769+ -> Prism' (R f) a
770+_R variant = dSumGEqPrism variant . iso runIdentity Identity
671771
672772-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
673773-- if the prism doesn't match.
@@ -711,6 +811,45 @@ handleEncoder recover e = Encoder $ do
711811-- Actual obelisk route info
712812--------------------------------------------------------------------------------
713813
814+-- | The typical full route type comprising all of an Obelisk application's routes.
815+-- Parameterised by the top level GADTs that define backend and frontend routes, respectively.
816+data FullRoute :: (* -> *) -> (* -> *) -> * -> * where
817+ FullRoute_Backend :: br a -> FullRoute br fr a
818+ FullRoute_Frontend :: ObeliskRoute fr a -> FullRoute br fr a
819+
820+instance (GShow br, GShow fr) => GShow (FullRoute br fr) where
821+ gshowsPrec p = \case
822+ FullRoute_Backend x -> showParen (p > 10) (showString "FullRoute_Backend " . gshowsPrec 11 x)
823+ FullRoute_Frontend x -> showParen (p > 10) (showString "FullRoute_Frontend " . gshowsPrec 11 x)
824+
825+instance (GEq br, GEq fr) => GEq (FullRoute br fr) where
826+ geq (FullRoute_Backend x) (FullRoute_Backend y) = geq x y
827+ geq (FullRoute_Frontend x) (FullRoute_Frontend y) = geq x y
828+ geq _ _ = Nothing
829+
830+instance (GCompare br, GCompare fr) => GCompare (FullRoute br fr) where
831+ gcompare (FullRoute_Backend _) (FullRoute_Frontend _) = GLT
832+ gcompare (FullRoute_Frontend _) (FullRoute_Backend _) = GGT
833+ gcompare (FullRoute_Backend x) (FullRoute_Backend y) = gcompare x y
834+ gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y
835+
836+instance (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) where
837+ universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]
838+ ++ [Some (FullRoute_Frontend x) | Some x <- universeSome]
839+
840+-- | Build the typical top level application route encoder from a route for handling 404's,
841+-- and segment encoders for backend and frontend routes.
842+mkFullRouteEncoder
843+ :: (GCompare br, GCompare fr, GShow br, GShow fr, UniverseSome br, UniverseSome fr)
844+ => R (FullRoute br fr) -- ^ 404 handler
845+ -> (forall a. br a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single backend route segment
846+ -> (forall a. fr a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single frontend route segment
847+ -> Encoder (Either Text) Identity (R (FullRoute br fr)) PageName
848+mkFullRouteEncoder missing backendSegment frontendSegment = handleEncoder (const missing) $
849+ pathComponentEncoder $ \case
850+ FullRoute_Backend backendRoute -> backendSegment backendRoute
851+ FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute frontendSegment
852+
714853-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
715854-- frontend.
716855data ObeliskRoute :: (* -> *) -> * -> * where
@@ -840,7 +979,7 @@ concat <$> mapM deriveRouteComponent
840979 ]
841980
842981makePrisms ''ObeliskRoute
843−
982+makePrisms ''FullRoute
844983deriveGEq ''Void1
845984deriveGCompare ''Void1
846985
@@ -848,27 +987,27 @@ deriveGCompare ''Void1
848987-- and query string). See 'checkEncoder' for how to produce a checked encoder.
849988renderBackendRoute
850989 :: forall br a.
851− Encoder Identity Identity (R (Sum br a)) PageName
990+ Encoder Identity Identity (R (FullRoute br a)) PageName
852991 -> R br
853992 -> Text
854−renderBackendRoute enc = renderObeliskRoute enc . hoistR InL
993+renderBackendRoute enc = renderObeliskRoute enc . hoistR FullRoute_Backend
855994
856995-- | Renders a frontend route with the supplied checked encoder
857996renderFrontendRoute
858997 :: forall a fr.
859− Encoder Identity Identity (R (Sum a (ObeliskRoute fr))) PageName
998+ Encoder Identity Identity (R (FullRoute a fr)) PageName
860999 -> R fr
8611000 -> Text
862−renderFrontendRoute enc = renderObeliskRoute enc . hoistR (InR . ObeliskRoute_App)
1001+renderFrontendRoute enc = renderObeliskRoute enc . hoistR (FullRoute_Frontend . ObeliskRoute_App)
8631002
8641003-- | Renders a route of the form typically found in an Obelisk project
8651004renderObeliskRoute
8661005 :: forall a b.
867− Encoder Identity Identity (R (Sum a b)) PageName
868− -> R (Sum a b)
1006+ Encoder Identity Identity (R (FullRoute a b)) PageName
1007+ -> R (FullRoute a b)
8691008 -> Text
8701009renderObeliskRoute e r =
871− let enc :: Encoder Identity (Either Text) (R (Sum a b)) PathQuery
1010+ let enc :: Encoder Identity (Either Text) (R (FullRoute a b)) PathQuery
8721011 enc = (pageNameEncoder . hoistParse (pure . runIdentity) e)
8731012 in (T.pack . uncurry (<>)) $ encode enc r
8741013
@@ -878,14 +1017,9 @@ readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
8781017integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
8791018integralEncoder = prismEncoder (Numeric.Lens.integral)
8801019
881−pathSegmentEncoder :: (MonadError Text parse, Applicative check) =>
882− Encoder check parse (Text, PageName) PageName
883−pathSegmentEncoder = unsafeMkEncoder EncoderImpl
884− { _encoderImpl_encode = \(x, (y, z)) -> (x:y, z)
885− , _encoderImpl_decode = \(xss, y) -> case xss of
886− [] -> throwError "not enough path segments"
887− (x:xs) -> pure (x, (xs, y))
888− }
1020+pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
1021+ Encoder check parse (a, (as, b)) (as, b)
1022+pathSegmentEncoder = first (prismEncoder _Cons) . disassociate
8891023
8901024newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
8911025
@@ -939,6 +1073,32 @@ fieldMapEncoder = unsafeEncoder $ do
9391073 Just (Identity v) -> return v
9401074 }
9411075
1076+-- this is in base 4.12 (GHC 8.6);
1077+newtype Ap f a = Ap {getAp :: f a}
1078+
1079+instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where
1080+ Ap x <> Ap y = Ap (liftA2 (<>) x y)
1081+
1082+instance (Applicative f, Monoid a) => Monoid (Ap f a) where
1083+ mappend = (<>)
1084+ mempty = Ap (pure mempty)
1085+
1086+pathFieldEncoder :: forall a p check parse . (HasFields a, Monad check, MonadError Text parse, GCompare (Field a)) => (forall x. Field a x -> Encoder check parse x p) -> Encoder check parse (a, [p]) [p]
1087+pathFieldEncoder fieldEncoder = unsafeEncoder $ do
1088+ fieldEncoderPureMap :: DMap.DMap (Field a) (Decoder Identity parse p) <- getAp $ getConst $ tabulateFieldsA @a $ \f -> Const (Ap $ fmap (DMap.singleton f . Decoder) $ (checkEncoder @Identity) $ fieldEncoder f)
1089+ let fieldEncoderPure :: forall x. Field a x -> Encoder Identity parse x p
1090+ fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
1091+ pure $ EncoderImpl
1092+ { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1093+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x
1094+ tell rest
1095+ , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
1096+ [] -> throwError $ T.pack "not enough path components"
1097+ p:ps -> do
1098+ State.put ps
1099+ lift $ tryDecode (fieldEncoderPure f) p
1100+ }
1101+
9421102-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
9431103jsonEncoder :: forall check parse r.
9441104 ( ToJSON r
@@ -955,4 +1115,14 @@ jsonEncoder = unsafeEncoder $ do
9551115 Right x -> return x
9561116 }
9571117
1118+-- Useful for app server integration.
1119+-- p must not start with slashes
1120+byteStringsToPageName :: BS.ByteString -> BS.ByteString -> PageName
1121+byteStringsToPageName p q =
1122+ let pageNameEncoder' :: Encoder Identity Identity PageName (String, String)
1123+ pageNameEncoder' = bimap
1124+ (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)
1125+ (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)
1126+ in decode pageNameEncoder' (T.unpack (T.decodeUtf8 p), T.unpack (T.decodeUtf8 q))
1127+
9581128--TODO: decodeURIComponent as appropriate
lib/run/src/Obelisk/Run.hs+11−12
@@ -20,11 +20,10 @@ import Control.Exception
2020import Control.Lens ((%~), (^?), _Just, _Right)
2121import qualified Data.Attoparsec.ByteString.Char8 as A
2222import Data.ByteString (ByteString)
23+import qualified Data.ByteString as BS
2324import qualified Data.ByteString.Char8 as BSC
2425import qualified Data.ByteString.Lazy.Char8 as BSLC
25−import Data.Dependent.Sum (DSum (..))
2626import Data.Functor.Identity
27−import Data.Functor.Sum
2827import Data.List (uncons)
2928import Data.Map (Map)
3029import qualified Data.Map as Map
@@ -81,8 +80,8 @@ run port serveStaticAsset backend frontend = do
8180 runSnapWithCommandLineArgs $ do
8281 getRouteWith validFullEncoder >>= \case
8382 Identity r -> case r of
84− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a
85− InR obeliskRoute :=> Identity a ->
83+ FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a
84+ FullRoute_Frontend obeliskRoute :/ a ->
8685 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a
8786 let conf = defRunConfig { _runConfig_redirectPort = port }
8887 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid
@@ -103,8 +102,8 @@ getConfigRoute configs = case Map.lookup "common/route" configs of
103102runWidget
104103 :: RunConfig
105104 -> Map Text ByteString
106− -> Frontend (R route)
107− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
105+ -> Frontend (R frontendRoute)
106+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName
108107 -> IO ()
109108runWidget conf configs frontend validFullEncoder = do
110109 uri <- either (fail . T.unpack) pure $ getConfigRoute configs
@@ -123,11 +122,11 @@ runWidget conf configs frontend validFullEncoder = do
123122 runSettingsSocket settings skt app)
124123
125124obeliskApp
126− :: forall route backendRoute
125+ :: forall frontendRoute backendRoute
127126 . Map Text ByteString
128127 -> ConnectionOptions
129− -> Frontend (R route)
130− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
128+ -> Frontend (R frontendRoute)
129+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName
131130 -> URI
132131 -> Application
133132 -> IO Application
@@ -143,14 +142,14 @@ obeliskApp configs opts frontend validFullEncoder uri backend = do
143142 let jsaddleUri = BSLC.fromStrict $ URI.renderBs $ uri & uriPath %~ (<>[jsaddlePath])
144143 Right (jsaddleWarpRouteValidEncoder :: Encoder Identity (Either Text) (R JSaddleWarpRoute) PageName) <- return $ checkEncoder jsaddleWarpRouteEncoder
145144 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
145+ return $ \req sendResponse -> case tryDecode validFullEncoder $ byteStringsToPageName (BS.dropWhile (== (fromIntegral $ fromEnum '/')) $ W.rawPathInfo req) (BS.drop 1 $ W.rawQueryString req) of
147146 Identity r -> case r of
148− InR (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :=> Identity jsaddleRoute -> case jsaddleRoute of
147+ FullRoute_Frontend (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :/ jsaddleRoute -> case jsaddleRoute of
149148 JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False
150149 _ -> flip jsaddle sendResponse $ req
151150 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute
152151 }
153− InR (ObeliskRoute_App appRouteComponent) :=> Identity appRouteRest -> do
152+ FullRoute_Frontend (ObeliskRoute_App appRouteComponent) :/ appRouteRest -> do
154153 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)
155154 html <- renderJsaddleFrontend configs cookies (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend
156155 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/default.nix+7−8
@@ -1,12 +1,11 @@
11{ obelisk ? import ./.obelisk/impl {
2− system = builtins.currentSystem;
3− iosSdkVersion = "10.2";
4− # You must accept the Android Software Development Kit License Agreement at
5− # https://developer.android.com/studio/terms in order to build Android apps.
6− # Uncomment and set this to `true` to indicate your acceptance:
7− # config.android_sdk.accept_license = false;
2+ system = builtins.currentSystem;
3+ iosSdkVersion = "10.2";
4+ # You must accept the Android Software Development Kit License Agreement at
5+ # https://developer.android.com/studio/terms in order to build Android apps.
6+ # Uncomment and set this to `true` to indicate your acceptance:
7+ # config.android_sdk.accept_license = false;
88 }
9−, projectOverrides ? {}
109}:
1110with obelisk;
1211project ./. ({ ... }: {
@@ -14,4 +13,4 @@ project ./. ({ ... }: {
1413 android.displayName = "Obelisk Minimal Example";
1514 ios.bundleIdentifier = "systems.obsidian.obelisk.examples.minimal";
1615 ios.bundleName = "Obelisk Minimal Example";
17−} // projectOverrides)
16+})
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