@@ -0,0 +1,795 @@
1+{-# LANGUAGE ApplicativeDo #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE EmptyCase #-}
4+{-# LANGUAGE EmptyDataDecls #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE KindSignatures #-}
9+{-# LANGUAGE LambdaCase #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
11+{-# LANGUAGE OverloadedStrings #-}
12+{-# LANGUAGE PatternSynonyms #-}
13+{-# LANGUAGE RankNTypes #-}
14+{-# LANGUAGE ScopedTypeVariables #-}
15+{-# LANGUAGE TemplateHaskell #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE TypeOperators #-}
18+{-# LANGUAGE ViewPatterns #-}
19+module Obelisk.Route
20+ ( R
21+ , pattern (:/)
22+ , PageName
23+ , PathQuery
24+ , Encoder
25+ , unsafeEncoder
26+ , checkEncoder
27+ , EncoderImpl (..)
28+ , EncoderFunc (..)
29+ , unsafeMkEncoder
30+ , encode
31+ , decode
32+ , tryDecode
33+ , hoistCheck
34+ , hoistParse
35+ , mapSome
36+ , SegmentResult (..)
37+ , pathComponentEncoder
38+ , enumEncoder
39+ , enum1Encoder
40+ , checkEnum1EncoderFunc
41+ , unitEncoder
42+ , pathOnlyEncoder
43+ , singletonListEncoder
44+ , unpackTextEncoder
45+ , prefixTextEncoder
46+ , unsafeTshowEncoder
47+ , someConstEncoder
48+ , singlePathSegmentEncoder
49+ , justEncoder
50+ , nothingEncoder
51+ , isoEncoder
52+ , wrappedEncoder
53+ , unwrappedEncoder
54+ , listToNonEmptyEncoder
55+ , prefixNonemptyTextEncoder
56+ , joinPairTextEncoder
57+ , toListMapEncoder
58+ , shadowEncoder
59+ , prismEncoder
60+ , rPrism
61+ , obeliskRouteEncoder
62+ , obeliskRouteSegment
63+ , pageNameEncoder
64+ , handleEncoder
65+ , ObeliskRoute (..)
66+ , _ObeliskRoute_App
67+ , _ObeliskRoute_Resource
68+ , ResourceRoute (..)
69+ , JSaddleWarpRoute (..)
70+ , jsaddleWarpRouteEncoder
71+ , IndexOnlyRoute (..)
72+ , indexOnlyRouteSegment
73+ , indexOnlyRouteEncoder
74+ , someSumEncoder
75+ , Void1
76+ , void1Encoder
77+ , pathSegmentsTextEncoder
78+ , queryParametersTextEncoder
79+ ) where
80+
81+import Prelude hiding ((.), id)
82+
83+import Control.Applicative
84+import Control.Category (Category (..))
85+import qualified Control.Categorical.Functor as Cat
86+import Control.Categorical.Bifunctor
87+import Control.Category.Associative
88+import Control.Category.Monoidal
89+import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
90+import Control.Monad.Except
91+import Data.Dependent.Sum (DSum (..))
92+import Data.Dependent.Map (DMap)
93+import qualified Data.Dependent.Map as DMap
94+import Data.Either.Validation (Validation (..))
95+import Data.Foldable
96+import Data.Functor.Sum
97+import Data.GADT.Compare
98+import Data.GADT.Compare.TH
99+import Data.GADT.Show
100+import Data.List.NonEmpty (NonEmpty (..))
101+import Data.Map (Map)
102+import qualified Data.Map as Map
103+import Data.Maybe
104+import Data.Set (Set)
105+import qualified Data.Set as Set
106+import Data.Some (Some)
107+import qualified Data.Some as Some
108+import Data.Some.Universe.Orphans ()
109+import Data.Text (Text)
110+import qualified Data.Text as T
111+import Data.Text.Encoding
112+import Data.Universe
113+import Network.HTTP.Types.URI
114+import Obelisk.Route.TH
115+import Text.Read (readMaybe)
116+
117+-- Design goals:
118+-- No start-up time on the frontend (not yet met)
119+-- Able to ensure that there aren't overlapping routes prior to deployment
120+-- Easy to write common types of parsers
121+-- Completeness checking
122+
123+-- Laws:
124+-- We statically know that all valid Routes can be turned into valid URIs
125+-- - This means we need to know whether there are any overlaps, e.g. with the static file namespace
126+
127+--TODO:
128+-- Backend:
129+-- Redirect the user to a canonical route
130+-- Pre-render
131+-- Frontend:
132+-- Intercept links that can be kept within the app
133+-- Fragments
134+
135+--------------------------------------------------------------------------------
136+-- Subroutes/paths
137+--------------------------------------------------------------------------------
138+
139+type R f = DSum f Identity --TODO: Better name
140+
141+--TODO: COMPLETE pragma
142+infixr 5 :/
143+pattern (:/) :: f a -> a -> R f
144+pattern a :/ b = a :=> Identity b
145+
146+mapSome :: (forall a. f a -> g a) -> Some f -> Some g
147+mapSome f (Some.This a) = Some.This $ f a
148+
149+--------------------------------------------------------------------------------
150+-- Encoder fundamentals
151+--------------------------------------------------------------------------------
152+
153+-- | This is the type of route encoder/decoders. It is parameterised over two monads: Firstly, the monad
154+-- used to check the validity of the encoder (i.e. that it is total), secondly the monad used for parsing
155+-- during the decode phase. The following two parameters are respectively the type of decoded data, and the
156+-- encoded type.
157+newtype Encoder check parse decoded encoded =
158+ Encoder { unEncoder :: check (EncoderImpl parse decoded encoded) }
159+
160+unsafeEncoder :: check (EncoderImpl parse decoded encoded) -> Encoder check parse decoded encoded
161+unsafeEncoder = Encoder
162+
163+-- | The internal type used to construct primitive 'Encoder' values.
164+-- Law:
165+-- forall p. _encoderImpl_decode ve . _encoderImpl_encode ve p == pure
166+-- Note that the reverse may not be the case: when parsing, a route may be canonicalized, and erroneous routes may be collapsed to a single 404 route. However, as a consequence of the law, encode . decode must be idempotent.
167+data EncoderImpl parse decoded encoded = EncoderImpl
168+ { _encoderImpl_decode :: !(encoded -> parse decoded) -- Can fail; can lose information; must always succeed on outputs of `_encoderImpl_encode` and result in the original value
169+ , _encoderImpl_encode :: !(decoded -> encoded) -- Must be injective
170+ }
171+
172+-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', and its parser is total
173+-- so that its parse monad is also 'Identity', it may be used to actually decode by applying this function.
174+decode :: Encoder Identity Identity decoded encoded -> encoded -> decoded
175+decode e x = runIdentity (tryDecode e x)
176+
177+-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', even if the same is not true of the
178+-- parse monad, we may still attempt to decode with it in its parse monad.
179+tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded
180+tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x
181+
182+-- | Similar to 'decode' above, once an encoder has been checked so that its check monad is Identity, it
183+-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,
184+-- one should usually be applying decode and encode to the same 'Encoder'
185+encode :: Encoder Identity parse decoded encoded -> decoded -> encoded
186+encode (Encoder (Identity impl)) x = _encoderImpl_encode impl x
187+
188+-- | This is a primitive used to build encoders which can't fail to check. It should not be used unless one is
189+-- reasonably certain that the law given for 'EncoderImpl' above holds.
190+unsafeMkEncoder :: (Applicative check) => EncoderImpl parse decoded encoded -> Encoder check parse decoded encoded
191+unsafeMkEncoder impl = Encoder (pure impl)
192+
193+-- | Transform the check monad of an 'Encoder' by applying a natural transformation.
194+hoistCheck :: (forall t. check t -> check' t) -> Encoder check parse a b -> Encoder check' parse a b
195+hoistCheck f (Encoder x) = Encoder (f x)
196+
197+-- | Transform the parse monad of an 'Encoder' by applying a natural transformation.
198+hoistParse :: (Functor check)
199+ => (forall t. parse t -> parse' t) -> Encoder check parse a b -> Encoder check parse' a b
200+hoistParse f (Encoder x) = Encoder (fmap (\(EncoderImpl dec enc) -> EncoderImpl (f . dec) enc) x)
201+
202+-- | Check an 'Encoder', transforming it into one whose check monad is anything we want (usually Identity).
203+checkEncoder :: (Applicative check', Functor check)
204+ => Encoder check parse decoded encoded
205+ -> check (Encoder check' parse decoded encoded)
206+checkEncoder = fmap unsafeMkEncoder . unEncoder
207+
208+instance (Applicative check, Monad parse) => Category (Encoder check parse) where
209+ id = Encoder $ pure id
210+ Encoder f . Encoder g = Encoder $ liftA2 (.) f g
211+
212+instance Monad parse => Category (EncoderImpl parse) where
213+ id = EncoderImpl
214+ { _encoderImpl_decode = pure
215+ , _encoderImpl_encode = id
216+ }
217+ f . g = EncoderImpl
218+ { _encoderImpl_decode = _encoderImpl_decode g <=< _encoderImpl_decode f
219+ , _encoderImpl_encode = _encoderImpl_encode f . _encoderImpl_encode g
220+ }
221+
222+instance Monad parse => PFunctor (,) (EncoderImpl parse) (EncoderImpl parse) where
223+ first f = bimap f id
224+instance Monad parse => QFunctor (,) (EncoderImpl parse) (EncoderImpl parse) where
225+ second g = bimap id g
226+instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
227+ bimap f g = EncoderImpl
228+ { _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)
229+ , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
230+ }
231+
232+instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
233+ first f = bimap f id
234+instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
235+ second g = bimap id g
236+instance (Applicative check, Monad parse) => Bifunctor (,) (Encoder check parse) (Encoder check parse) (Encoder check parse) where
237+ bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)
238+
239+instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (EncoderImpl parse) where
240+ fmap ve = EncoderImpl
241+ { _encoderImpl_encode = fmap $ _encoderImpl_encode ve
242+ , _encoderImpl_decode = traverse $ _encoderImpl_decode ve
243+ }
244+
245+instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
246+ fmap e = Encoder $ do
247+ ve <- unEncoder e
248+ pure $ Cat.fmap ve
249+
250+instance Monad parse => Associative (EncoderImpl parse) (,) where
251+ associate = EncoderImpl
252+ { _encoderImpl_encode = associate
253+ , _encoderImpl_decode = pure . disassociate
254+ }
255+ disassociate = EncoderImpl
256+ { _encoderImpl_encode = disassociate
257+ , _encoderImpl_decode = pure . associate
258+ }
259+
260+instance Monad parse => Monoidal (EncoderImpl parse) (,) where
261+ type Id (EncoderImpl parse) (,) = ()
262+ idl = EncoderImpl
263+ { _encoderImpl_encode = idl
264+ , _encoderImpl_decode = pure . coidl
265+ }
266+ idr = EncoderImpl
267+ { _encoderImpl_encode = idr
268+ , _encoderImpl_decode = pure . coidr
269+ }
270+ coidl = EncoderImpl
271+ { _encoderImpl_encode = coidl
272+ , _encoderImpl_decode = pure . idl
273+ }
274+ coidr = EncoderImpl
275+ { _encoderImpl_encode = coidr
276+ , _encoderImpl_decode = pure . idr
277+ }
278+
279+instance (Applicative check, Monad parse) => Associative (Encoder check parse) (,) where
280+ associate = Encoder $ pure associate
281+ disassociate = Encoder $ pure disassociate
282+
283+instance (Applicative check, Monad parse) => Monoidal (Encoder check parse) (,) where
284+ type Id (Encoder check parse) (,) = ()
285+ idl = Encoder $ pure idl
286+ idr = Encoder $ pure idr
287+ coidl = Encoder $ pure coidl
288+ coidr = Encoder $ pure coidr
289+
290+--------------------------------------------------------------------------------
291+-- Specific instances of encoders
292+--------------------------------------------------------------------------------
293+
294+-- | Given a valid 'Iso' from lens, construct an 'Encoder'
295+isoEncoder :: (Applicative check, Applicative parse) => Iso' a b -> Encoder check parse a b
296+isoEncoder f = unsafeMkEncoder $ EncoderImpl
297+ { _encoderImpl_encode = view f
298+ , _encoderImpl_decode = pure . view (from f)
299+ }
300+
301+wrappedEncoder :: (Wrapped a, Applicative check, Applicative parse) => Encoder check parse (Unwrapped a) a
302+wrappedEncoder = isoEncoder $ from _Wrapped'
303+
304+unwrappedEncoder :: (Wrapped a, Applicative check, Applicative parse) => Encoder check parse a (Unwrapped a)
305+unwrappedEncoder = isoEncoder _Wrapped'
306+
307+-- | Encodea a value by simply applying 'Just'
308+justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
309+justEncoder = prismEncoder _Just
310+
311+-- |
312+nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
313+nothingEncoder = prismEncoder _Nothing
314+
315+someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a
316+someConstEncoder = unsafeMkEncoder $ EncoderImpl
317+ { _encoderImpl_encode = \(Some.This (Const a)) -> a
318+ , _encoderImpl_decode = pure . Some.This . Const
319+ }
320+
321+-- | WARNING: This is only safe if the Show and Read instances for 'a' are
322+-- inverses of each other
323+unsafeTshowEncoder :: (Show a, Read a, Applicative check, MonadError Text parse) => Encoder check parse a Text
324+unsafeTshowEncoder = unsafeMkEncoder $ EncoderImpl
325+ { _encoderImpl_encode = tshow
326+ , _encoderImpl_decode = \raw -> case readMaybe $ T.unpack raw of
327+ Nothing -> throwError $ "unsafeTshowEncoderImpl: couldn't decode " <> tshow raw
328+ Just parsed -> pure parsed
329+ }
330+
331+newtype EncoderFunc check parse p r = EncoderFunc { runEncoderImplFunc :: forall a. p a -> Encoder check parse a r }
332+
333+newtype Flip f a b = Flip { unFlip :: f b a }
334+
335+checkEnum1EncoderFunc
336+ :: forall check check' parse p r.
337+ ( Universe (Some p)
338+ , GCompare p
339+ , Monad check
340+ , Applicative check'
341+ )
342+ => (forall a. p a -> Encoder check parse a r)
343+ -> check (EncoderFunc check' parse p r)
344+checkEnum1EncoderFunc f = do
345+ (encoderImpls :: DMap p (Flip (EncoderImpl parse) r)) <- DMap.fromList <$>
346+ traverse (\(Some.This p) -> (p :=>) . Flip <$> unEncoder (f p)) universe
347+ pure $ EncoderFunc $ \p -> unsafeMkEncoder . unFlip $
348+ DMap.findWithDefault (error "checkEnum1EncoderFunc: EncoderImpl not found (should be impossible)") p encoderImpls
349+
350+-- | This type is used by pathComponentEncoder to allow the user to indicate how to treat various cases when encoding a dependent sum of type `(R p)`.
351+data SegmentResult check parse a =
352+ PathEnd (Encoder check parse a (Map Text (Maybe Text))) -- ^ Indicate that the path is finished, with an Encoder that translates the corresponding value into query parameters
353+ | PathSegment Text (Encoder check parse a PageName) -- ^ Indicate that the key should be represented by an additional path segment with the given 'Text', and give an Encoder for translating the corresponding value into the remainder of the route.
354+
355+-- | Encode a dependent sum of type `(R p)` into a PageName (i.e. the path and query part of a URL) by using the
356+-- supplied function to decide how to encode the constructors of p using the SegmentResult type. It is important
357+-- that the number of values of type `(Some p)` be relatively small in order for checking to complete quickly.
358+pathComponentEncoder
359+ :: forall check parse p.
360+ ( Universe (Some p)
361+ , GShow p
362+ , GCompare p
363+ , MonadError Text check
364+ , MonadError Text parse )
365+ => (forall a. p a -> SegmentResult check parse a)
366+ -> Encoder check parse (R p) PageName
367+pathComponentEncoder f = Encoder $ do
368+ let extractEncoder = \case
369+ PathEnd e -> first (unitEncoder []) . coidl . e
370+ PathSegment _ e -> e
371+ extractPathSegment = \case
372+ PathEnd _ -> Nothing
373+ PathSegment t _ -> Just t
374+ EncoderFunc f' <- checkEnum1EncoderFunc (extractEncoder . f)
375+ unEncoder (pathComponentEncoderImpl (enum1Encoder (extractPathSegment . f)) f')
376+
377+pathComponentEncoderImpl :: forall check parse p. (Monad check, Monad parse)
378+ => (Encoder check parse (Some p) (Maybe Text))
379+ -> (forall a. p a -> Encoder Identity parse a PageName)
380+ -> Encoder check parse (R p) PageName
381+pathComponentEncoderImpl this rest =
382+ chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder) this rest
383+
384+--NOTE: Naming convention in this module is to always talk about things in the *encoding* direction, never in the *decoding* direction
385+
386+chainEncoder
387+ :: forall check parse p r b.
388+ ( Monad check
389+ , Monad parse
390+ )
391+ => Encoder check parse (b, r) r
392+ -> Encoder check parse (Some p) b
393+ -> (forall a. p a -> Encoder Identity parse a r)
394+ -> Encoder check parse (R p) r
395+chainEncoder cons this rest = Encoder $ do
396+ consValid <- unEncoder cons
397+ thisValid <- unEncoder this
398+ pure $ EncoderImpl
399+ { _encoderImpl_decode = \v -> do
400+ (here, following) <- _encoderImpl_decode consValid v
401+ Some.This r <- _encoderImpl_decode thisValid here
402+ (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
403+ , _encoderImpl_encode = \(r :/ s) ->
404+ _encoderImpl_encode consValid
405+ ( _encoderImpl_encode thisValid $ Some.This r
406+ , _encoderImpl_encode (runIdentity . unEncoder $ rest r) s)
407+ }
408+
409+--TODO: Do this in terms of a lens instead
410+lensEncoder :: (Applicative check, Monad parse)
411+ => (b -> [a] -> b) -> (b -> [a]) -> Encoder check parse (c, [a]) [a] -> Encoder check parse (c, b) b
412+lensEncoder set get g = Encoder $ do
413+ gImpl <- unEncoder g
414+ pure $ EncoderImpl
415+ { _encoderImpl_encode = \(ma, b) -> set b $ _encoderImpl_encode gImpl (ma, get b)
416+ , _encoderImpl_decode = \b -> do
417+ (ma, la) <- _encoderImpl_decode gImpl $ get b
418+ pure (ma, set b la)
419+ }
420+
421+consEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Maybe a, [a]) [a] --TODO: Really shouldn't *always* have the [a], even in the Nothing case
422+consEncoder = unsafeMkEncoder $ EncoderImpl
423+ { _encoderImpl_encode = \(h, t) -> maybeToList h <> t
424+ , _encoderImpl_decode = pure . \case
425+ [] -> (Nothing, [])
426+ h:t -> (Just h, t)
427+ }
428+
429+tshow :: Show a => a -> Text
430+tshow = T.pack . show
431+
432+shadowEncoder
433+ :: ( Universe a
434+ , MonadError Text check
435+ , Show a
436+ , Show b
437+ , Show c
438+ , check ~ parse --TODO: Get rid of this
439+ )
440+ => Encoder check parse a c -- ^ Overlaps; should have a small number of possible routes
441+ -> Encoder check parse b c -- ^ Gets overlapped
442+ -> Encoder check parse (Either a b) c
443+shadowEncoder f g = Encoder $ do
444+ vf <- unEncoder f
445+ vg <- unEncoder g
446+ let gCanParse c = catchError (Just <$> _encoderImpl_decode vg c) (\_ -> pure Nothing)
447+ overlaps <- fmap catMaybes $ forM universe $ \a -> do
448+ let c = _encoderImpl_encode vf a
449+ mb <- gCanParse c
450+ pure $ fmap (\b -> (a, b, c)) mb
451+ case overlaps of
452+ [] -> pure ()
453+ _ -> throwError $ "shadowEncoder: overlap detected: " <> T.unlines
454+ (flip fmap overlaps $ \(a, b, c) -> "first encoder encodes " <> tshow a <> " as " <> tshow c <> ", which second encoder decodes as " <> tshow b)
455+ pure $ EncoderImpl
456+ { _encoderImpl_encode = \case
457+ Left a -> _encoderImpl_encode vf a
458+ Right b -> _encoderImpl_encode vg b
459+ , _encoderImpl_decode = \c -> (Left <$> _encoderImpl_decode vf c) `catchError` \_ -> Right <$> _encoderImpl_decode vg c
460+ }
461+
462+enum1Encoder
463+ :: ( Universe (Some p)
464+ , GShow p
465+ , GCompare p
466+ , MonadError Text check
467+ , MonadError Text parse
468+ , Ord r
469+ , Show r
470+ )
471+ => (forall a. p a -> r) -> Encoder check parse (Some p) r
472+enum1Encoder f = enumEncoder $ \(Some.This p) -> f p
473+
474+-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that
475+-- have a large number of values - it will use a lot of memory.
476+enumEncoder :: forall parse check p r. (Universe p, Show p, Ord p, Ord r, MonadError Text parse, MonadError Text check, Show r) => (p -> r) -> Encoder check parse p r
477+enumEncoder f = Encoder $ do
478+ let reversed = Map.fromListWith (<>) [ (f p, Set.singleton p) | p <- universe ]
479+ checkSingleton k vs = case Set.toList vs of
480+ [] -> error "enumEncoder: empty reverse mapping; should be impossible"
481+ [e] -> Success e
482+ _ -> Failure $ Map.singleton k vs
483+ showRedundant :: r -> Set p -> [Text]
484+ showRedundant k vs = (" " <> tshow k <> " can decode to any of:")
485+ : fmap ((" "<>) . tshow) (Set.toList vs)
486+ case itraverse checkSingleton reversed :: Validation (Map r (Set p)) (Map r p) of
487+ Failure ambiguousEntries -> throwError $ T.unlines $
488+ "enumEncoder: ambiguous encodings detected:" : concat (Map.elems $ imap showRedundant ambiguousEntries)
489+ Success m -> pure $ EncoderImpl
490+ { _encoderImpl_decode = \r -> case Map.lookup r m of
491+ Just a -> pure a
492+ Nothing -> throwError $ "enumEncoder: not recognized: " <> tshow r --TODO: Report this as a better type
493+ , _encoderImpl_encode = f
494+ }
495+
496+unitEncoder :: (Applicative check, MonadError Text parse, Show r, Eq r) => r -> Encoder check parse () r
497+unitEncoder expected = unsafeMkEncoder $ EncoderImpl
498+ { _encoderImpl_decode = \obtained ->
499+ if obtained == expected
500+ then pure ()
501+ else throwError $ "endEncoderImpl: expected " <> tshow expected <> ", got " <> tshow obtained
502+ , _encoderImpl_encode = \_ -> expected
503+ }
504+
505+singlePathSegmentEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse Text PageName
506+singlePathSegmentEncoder = pathOnlyEncoder . singletonListEncoder
507+
508+pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
509+pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl
510+ { _encoderImpl_decode = \(path, query) ->
511+ if query == mempty
512+ then pure path
513+ else throwError "pathOnlyEncoderImpl: query was provided"
514+ , _encoderImpl_encode = \path -> (path, mempty)
515+ }
516+
517+singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
518+singletonListEncoder = unsafeMkEncoder $ EncoderImpl
519+ { _encoderImpl_decode = \case
520+ [a] -> pure a
521+ l -> throwError $ "singletonListEncoderImpl: expected one item, got " <> tshow (length l)
522+ , _encoderImpl_encode = (:[])
523+ }
524+
525+splitTextNonEmpty :: Text -> Text -> NonEmpty Text
526+splitTextNonEmpty separator v = case T.splitOn separator v of
527+ [] -> error "splitTextNonEmpty: Data.Text.splitOn should never return an empty list"
528+ h : t -> h :| t
529+
530+--TODO: To know this is reversible, we must know that the separator isn't included anywhere in the input text
531+pathSegmentsTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse (NonEmpty Text) Text
532+pathSegmentsTextEncoder = unsafeMkEncoder $ EncoderImpl
533+ { _encoderImpl_encode = T.intercalate "/" . fmap (urlEncodeText False) . toList
534+ , _encoderImpl_decode = pure . fmap (urlDecodeText False) . splitTextNonEmpty "/"
535+ }
536+
537+queryParametersTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse [(Text, Maybe Text)] Text
538+queryParametersTextEncoder = Encoder $ pure $ EncoderImpl
539+ { _encoderImpl_encode = \case
540+ [] -> ""
541+ params -> T.intercalate "&" (fmap encodeParameter params)
542+ , _encoderImpl_decode = pure . \case
543+ "" -> []
544+ encoded ->
545+ let h :| t = splitTextNonEmpty "&" encoded
546+ in fmap decodeParameter $ h : t
547+ }
548+ where
549+ encodeParameter (k, mv) = urlEncodeText True k <> case mv of
550+ Nothing -> ""
551+ Just v -> "=" <> urlEncodeText True v
552+ decodeParameter t =
553+ let (k, eqV) = T.breakOn "=" t
554+ mv = T.stripPrefix "=" eqV
555+ in (urlDecodeText True k, urlDecodeText True <$> mv)
556+
557+urlEncodeText :: Bool -> Text -> Text
558+urlEncodeText q = decodeUtf8 . urlEncode q . encodeUtf8
559+
560+urlDecodeText :: Bool -> Text -> Text
561+urlDecodeText q = decodeUtf8 . urlDecode q . encodeUtf8
562+
563+listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
564+listToNonEmptyEncoder = Encoder $ pure $ EncoderImpl
565+ { _encoderImpl_encode = \case
566+ [] -> mempty :| []
567+ h : t -> h :| t
568+ , _encoderImpl_decode = \(h :| t) -> pure $
569+ if h == mempty
570+ then []
571+ else h : t
572+ }
573+
574+prefixTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encoder check parse Text Text
575+prefixTextEncoder p = Encoder $ pure $ EncoderImpl
576+ { _encoderImpl_encode = mappend p
577+ , _encoderImpl_decode = \v -> case T.stripPrefix p v of
578+ Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> tshow p <> ", got " <> tshow (T.take (T.length p) v)
579+ Just stripped -> pure stripped
580+ }
581+
582+prefixNonemptyTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encoder check parse Text Text
583+prefixNonemptyTextEncoder p = Encoder $ pure $ EncoderImpl
584+ { _encoderImpl_encode = \case
585+ "" -> ""
586+ v -> p <> v
587+ , _encoderImpl_decode = \case
588+ "" -> pure ""
589+ v -> case T.stripPrefix p v of
590+ Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> tshow p
591+ Just stripped -> pure stripped
592+ }
593+
594+unpackTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse Text String
595+unpackTextEncoder = Encoder $ pure $ EncoderImpl
596+ { _encoderImpl_encode = T.unpack
597+ , _encoderImpl_decode = pure . T.pack
598+ }
599+
600+toListMapEncoder :: (Applicative check, Applicative parse, Ord k) => Encoder check parse (Map k v) [(k, v)]
601+toListMapEncoder = Encoder $ pure $ EncoderImpl
602+ { _encoderImpl_encode = Map.toList
603+ , _encoderImpl_decode = pure . Map.fromList --TODO: Should we be stricter about repeated keys?
604+ }
605+
606+joinPairTextEncoder :: (MonadError Text check, MonadError Text parse) => Text -> Encoder check parse (Text, Text) Text
607+joinPairTextEncoder = Encoder . \case
608+ "" -> throwError "joinPairTextEncoder: empty separator"
609+ separator -> pure $ EncoderImpl
610+ { _encoderImpl_encode = \(k, v) -> k <> separator <> v
611+ , _encoderImpl_decode = \r ->
612+ let (kt, vt) = T.breakOn separator r
613+ in case vt of
614+ -- The separator was not found
615+ "" -> throwError $ "joinPairTextEncoder: separator not found; expected " <> tshow separator
616+ _ -> return (kt, T.drop (T.length separator) vt)
617+ }
618+
619+--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum
620+-- Or, more likely, the user can compose it themselves
621+rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
622+rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)
623+
624+-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
625+-- if the prism doesn't match.
626+prismEncoder :: (Applicative check, MonadError Text parse) => Prism' b a -> Encoder check parse a b
627+prismEncoder p = unsafeMkEncoder $ EncoderImpl
628+ { _encoderImpl_encode = (^. re p)
629+ , _encoderImpl_decode = \r -> case r ^? p of
630+ Just a -> pure a
631+ Nothing -> throwError "prismEncoder: value is not present in the prism"
632+ }
633+
634+-- | A URL path and query string, in which trailing slashes don't matter in the path
635+-- and duplicate query parameters are not allowed. A final goal of encoders using this library
636+-- will frequently be to produce this.
637+type PageName = ([Text], Map Text (Maybe Text))
638+
639+-- | A path (separated by slashes), and a query string.
640+type PathQuery = (String, String)
641+
642+-- | Encode a PageName into a path and query string.
643+pageNameEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse PageName PathQuery
644+pageNameEncoder = bimap
645+ (unpackTextEncoder . prefixTextEncoder "/" . pathSegmentsTextEncoder . listToNonEmptyEncoder)
646+ (unpackTextEncoder . prefixNonemptyTextEncoder "?" . queryParametersTextEncoder . toListMapEncoder)
647+
648+-- | Handle an error in parsing, for example, in order to redirect to a 404 page.
649+handleEncoder
650+ :: (Functor check)
651+ => (e -> a)
652+ -> Encoder check (Either e) a b
653+ -> Encoder check Identity a b
654+handleEncoder recover e = Encoder $ do
655+ i <- unEncoder e
656+ return $ i
657+ { _encoderImpl_decode = \a -> pure $ case _encoderImpl_decode i a of
658+ Right r -> r
659+ Left err -> recover err
660+ }
661+
662+--------------------------------------------------------------------------------
663+-- Actual obelisk route info
664+--------------------------------------------------------------------------------
665+
666+-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
667+-- frontend.
668+data ObeliskRoute :: (* -> *) -> * -> * where
669+ -- We need to have the `f a` as an argument here, because otherwise we have no way to specifically check for overlap between us and the given encoder
670+ ObeliskRoute_App :: f a -> ObeliskRoute f a
671+ ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
672+
673+instance Universe (Some f) => Universe (Some (ObeliskRoute f)) where
674+ universe = fmap (\(Some.This x) -> Some.This (ObeliskRoute_App x)) universe
675+ ++ fmap (\(Some.This x) -> Some.This (ObeliskRoute_Resource x)) universe
676+
677+instance GEq f => GEq (ObeliskRoute f) where
678+ geq (ObeliskRoute_App x) (ObeliskRoute_App y) = geq x y
679+ geq (ObeliskRoute_Resource x) (ObeliskRoute_Resource y) = geq x y
680+ geq _ _ = Nothing
681+
682+instance GCompare f => GCompare (ObeliskRoute f) where
683+ gcompare (ObeliskRoute_App x) (ObeliskRoute_App y) = gcompare x y
684+ gcompare (ObeliskRoute_Resource x) (ObeliskRoute_Resource y) = gcompare x y
685+ gcompare (ObeliskRoute_App _) (ObeliskRoute_Resource _) = GLT
686+ gcompare (ObeliskRoute_Resource _) (ObeliskRoute_App _) = GGT
687+
688+-- | A type representing the various resource routes served by Obelisk. These can in principle map to any physical routes you want,
689+-- but sane defaults are provided by 'resourceRouteSegment'
690+data ResourceRoute :: * -> * where
691+ 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")
692+ ResourceRoute_Ghcjs :: ResourceRoute [Text]
693+ ResourceRoute_JSaddleWarp :: ResourceRoute (R JSaddleWarpRoute)
694+
695+-- | If there are no additional backend routes in your app (i.e. ObeliskRoute gives you all the routes you need),
696+-- this constructs a suitable 'Encoder' to use for encoding routes to 'PageName's. If you do have additional backend routes,
697+-- you'll want to use 'pathComponentEncoder' yourself, applied to a function that will likely use obeliskRouteSegment in order to
698+-- handle the ObeliskRoute case (i.e. Obelisk resource routes and app frontend routes).
699+obeliskRouteEncoder :: forall check parse appRoute.
700+ ( Universe (Some (ObeliskRoute appRoute))
701+ , GCompare (ObeliskRoute appRoute)
702+ , GShow appRoute
703+ , MonadError Text check
704+ , check ~ parse --TODO: Get rid of this
705+ )
706+ => (forall a. appRoute a -> SegmentResult check parse a)
707+ -> Encoder check parse (R (ObeliskRoute appRoute)) PageName
708+obeliskRouteEncoder appRouteSegment = pathComponentEncoder $ \r ->
709+ obeliskRouteSegment r appRouteSegment
710+
711+-- | From a function which explains how app-specific frontend routes translate into segments, produce a function which does the
712+-- same for ObeliskRoute. This uses the given function for the 'ObeliskRoute_App' case, and 'resourceRouteSegment' for the
713+-- 'ObeliskRoute_Resource' case.
714+obeliskRouteSegment :: forall check parse appRoute a.
715+ (MonadError Text check, MonadError Text parse)
716+ => ObeliskRoute appRoute a
717+ -> (forall a. appRoute a -> SegmentResult check parse a)
718+ -> SegmentResult check parse a
719+obeliskRouteSegment r appRouteSegment = case r of
720+ ObeliskRoute_App appRoute -> appRouteSegment appRoute
721+ ObeliskRoute_Resource resourceRoute -> resourceRouteSegment resourceRoute
722+
723+-- | A function which gives a sane default for how to encode Obelisk resource routes. It's given in this form, because it will
724+-- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.
725+resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a
726+resourceRouteSegment = \case
727+ ResourceRoute_Static -> PathSegment "static" $ pathOnlyEncoder
728+ ResourceRoute_Ghcjs -> PathSegment "ghcjs" $ pathOnlyEncoder
729+ ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" $ jsaddleWarpRouteEncoder
730+
731+data JSaddleWarpRoute :: * -> * where
732+ JSaddleWarpRoute_JavaScript :: JSaddleWarpRoute ()
733+ JSaddleWarpRoute_WebSocket :: JSaddleWarpRoute ()
734+ JSaddleWarpRoute_Sync :: JSaddleWarpRoute [Text]
735+
736+jsaddleWarpRouteEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (R JSaddleWarpRoute) PageName
737+jsaddleWarpRouteEncoder = pathComponentEncoder $ \case
738+ JSaddleWarpRoute_JavaScript -> PathSegment "jsaddle.js" $ unitEncoder mempty
739+ JSaddleWarpRoute_WebSocket -> PathEnd $ unitEncoder mempty
740+ JSaddleWarpRoute_Sync -> PathSegment "sync" $ pathOnlyEncoder
741+
742+instance GShow appRoute => GShow (ObeliskRoute appRoute) where
743+ gshowsPrec prec = \case
744+ ObeliskRoute_App appRoute -> showParen (prec > 10) $
745+ showString "ObeliskRoute_App " . gshowsPrec 11 appRoute
746+ ObeliskRoute_Resource appRoute -> showParen (prec > 10) $
747+ showString "ObeliskRoute_Resource " . gshowsPrec 11 appRoute
748+
749+data IndexOnlyRoute :: * -> * where
750+ IndexOnlyRoute :: IndexOnlyRoute ()
751+
752+indexOnlyRouteSegment :: (Applicative check, MonadError Text parse) => IndexOnlyRoute a -> SegmentResult check parse a
753+indexOnlyRouteSegment = \case
754+ IndexOnlyRoute -> PathEnd $ unitEncoder mempty
755+
756+indexOnlyRouteEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (R IndexOnlyRoute) PageName
757+indexOnlyRouteEncoder = pathComponentEncoder indexOnlyRouteSegment
758+
759+someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))
760+someSumEncoder = Encoder $ pure $ EncoderImpl
761+ { _encoderImpl_encode = \(Some.This t) -> case t of
762+ InL l -> Left $ Some.This l
763+ InR r -> Right $ Some.This r
764+ , _encoderImpl_decode = pure . \case
765+ Left (Some.This l) -> Some.This (InL l)
766+ Right (Some.This r) -> Some.This (InR r)
767+ }
768+
769+data Void1 :: * -> * where {}
770+
771+instance Universe (Some Void1) where
772+ universe = []
773+
774+void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
775+void1Encoder = Encoder $ pure $ EncoderImpl
776+ { _encoderImpl_encode = \case
777+ Some.This f -> case f of {}
778+ , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"
779+ }
780+
781+instance GShow Void1 where
782+ gshowsPrec _ = \case {}
783+
784+concat <$> mapM deriveRouteComponent
785+ [ ''ResourceRoute
786+ , ''JSaddleWarpRoute
787+ , ''IndexOnlyRoute
788+ ]
789+
790+makePrisms ''ObeliskRoute
791+
792+deriveGEq ''Void1
793+deriveGCompare ''Void1
794+
795+--TODO: decodeURIComponent as appropriate