@@ -0,0 +1,456 @@
1+{-# LANGUAGE ApplicativeDo #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PatternSynonyms #-}
11+{-# LANGUAGE RankNTypes #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TemplateHaskell #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE ViewPatterns #-}
17+module Obelisk.Route
18+ ( R
19+ , pattern (:/)
20+ , pattern (:~)
21+ , PageName
22+ , Encoder (..) --TODO: unsafe
23+ , checkEncoder
24+ , ValidEncoder (..) --TODO: unsafe
25+ , mapSome
26+ , pathComponentEncoder
27+ , enumEncoder
28+ , endValidEncoder
29+ , pathOnlyValidEncoder
30+ , singletonListValidEncoder
31+ , unpackTextEncoder
32+ , prefixTextEncoder
33+ , intercalateTextEncoder
34+ , listToNonEmptyEncoder
35+ , prefixNonemptyTextEncoder
36+ , joinPairTextEncoder
37+ , toListMapEncoder
38+ , shadowEncoder
39+ , prismValidEncoder
40+ , rPrism
41+ , obeliskRouteEncoder
42+ , _ObeliskRoute_App
43+ , _ObeliskRoute_Static
44+ ) where
45+
46+import Prelude hiding ((.), id)
47+
48+import Control.Applicative
49+import Control.Category (Category (..), (.), id)
50+import qualified Control.Categorical.Functor as Cat
51+import Control.Categorical.Bifunctor
52+import Control.Category.Cartesian
53+import Control.Lens hiding (Bifunctor, bimap, universe)
54+import Control.Monad.Except
55+import Data.Constraint
56+import Data.Dependent.Sum (DSum (..), ShowTag (..))
57+import Data.Dependent.Map (DMap)
58+import qualified Data.Dependent.Map as DMap
59+import Data.Foldable
60+import Data.GADT.Compare
61+import Data.GADT.Compare.TH
62+import Data.GADT.Show
63+import Data.GADT.Show.TH
64+import Data.List.NonEmpty (NonEmpty (..))
65+import Data.Map (Map)
66+import qualified Data.Map as Map
67+import Data.Maybe
68+import Data.Monoid
69+import Data.Set (Set)
70+import qualified Data.Set as Set
71+import Data.Some (Some)
72+import qualified Data.Some as Some
73+import Data.Text (Text)
74+import qualified Data.Text as T
75+import Data.Either.Validation (Validation (..))
76+import Data.Universe
77+import Data.Functor.Compose
78+import Data.Functor.Identity
79+import Reflex.Class
80+
81+-- Design goals:
82+-- No start-up time on the frontend (not yet met)
83+-- Able to ensure that there aren't overlapping routes prior to deployment
84+-- Easy to write common types of parsers
85+-- Completeness checking
86+
87+-- Laws:
88+-- We statically know that all valid Routes can be turned into valid URIs
89+-- - This means we need to know whether there are any overlaps, e.g. with the static file namespace
90+
91+--TODO:
92+-- Backend:
93+-- Redirect the user to a canonical route
94+-- Pre-render
95+-- Frontend:
96+-- Intercept links that can be kept within the app
97+-- Fragments
98+
99+--------------------------------------------------------------------------------
100+-- Subroutes/paths
101+--------------------------------------------------------------------------------
102+
103+type R f = DSum f Identity --TODO: Better name
104+
105+infixr 5 :/
106+pattern (:/) :: f a -> a -> R f
107+pattern a :/ b = a :=> Identity b
108+
109+infixr 5 :~
110+pattern (:~) :: Reflex t => f a -> Dynamic t a -> DSum f (Compose (Dynamic t) Identity)
111+pattern a :~ b <- a :=> (coerceDynamic . getCompose -> b)
112+
113+mapSome :: (forall a. f a -> g a) -> Some f -> Some g
114+mapSome f (Some.This a) = Some.This $ f a
115+
116+--------------------------------------------------------------------------------
117+-- Encoder fundamentals
118+--------------------------------------------------------------------------------
119+
120+newtype Encoder check parse decoded encoded = Encoder { unEncoder :: check (ValidEncoder parse decoded encoded) }
121+
122+-- | Law:
123+-- forall p. _totalEncoder_decode p . _totalEncoder_encode == id
124+-- 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, decode . encode must be idemponent.
125+type TotalEncoder = Encoder Identity
126+
127+-- | TODO: Should this be turned around? That would match enumEncoder better
128+data ValidEncoder parse decoded encoded = ValidEncoder
129+ { _validEncoder_decode :: !(encoded -> parse decoded) -- Can fail; can lose information; must always succeed on outputs of `_validEncoder_encode` and result in the original value
130+ , _validEncoder_encode :: !(decoded -> encoded) -- Must be injective
131+ }
132+
133+checkEncoder :: Encoder check parse decoded encoded -> check (ValidEncoder parse decoded encoded)
134+checkEncoder = unEncoder
135+
136+instance (Applicative check, Monad parse) => Category (Encoder check parse) where
137+ id = Encoder $ pure id
138+ Encoder f . Encoder g = Encoder $ liftA2 (.) f g
139+
140+instance Monad parse => Category (ValidEncoder parse) where
141+ id = ValidEncoder
142+ { _validEncoder_decode = pure
143+ , _validEncoder_encode = id
144+ }
145+ f . g = ValidEncoder
146+ { _validEncoder_decode = _validEncoder_decode g <=< _validEncoder_decode f
147+ , _validEncoder_encode = _validEncoder_encode f . _validEncoder_encode g
148+ }
149+
150+instance Monad parse => PFunctor (,) (ValidEncoder parse) (ValidEncoder parse) where
151+ first f = bimap f id
152+instance Monad parse => QFunctor (,) (ValidEncoder parse) (ValidEncoder parse) where
153+ second g = bimap id g
154+instance Monad parse => Bifunctor (,) (ValidEncoder parse) (ValidEncoder parse) (ValidEncoder parse) where
155+ bimap f g = ValidEncoder
156+ { _validEncoder_encode = bimap (_validEncoder_encode f) (_validEncoder_encode g)
157+ , _validEncoder_decode = \(a, b) -> liftA2 (,) (_validEncoder_decode f a) (_validEncoder_decode g b)
158+ }
159+
160+instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
161+ fmap e = Encoder $ do
162+ ve <- checkEncoder e
163+ pure $ ValidEncoder
164+ { _validEncoder_encode = fmap $ _validEncoder_encode ve
165+ , _validEncoder_decode = traverse $ _validEncoder_decode ve
166+ }
167+
168+--------------------------------------------------------------------------------
169+-- Specific instances of encoders
170+--------------------------------------------------------------------------------
171+
172+-- | A path and query string, in which trailing slashes don't matter in the path
173+-- and duplicate query parameters are not allowed
174+type PageName = ([Text], Map Text Text)
175+
176+newtype Flip f a b = Flip { unFlip :: f b a }
177+
178+pathComponentEncoder :: forall check parse p. (Monad check, Monad parse) => (Encoder check parse (Some p) (Maybe Text)) -> (forall a. p a -> ValidEncoder parse a PageName) -> Encoder check parse (R p) PageName
179+pathComponentEncoder this rest = chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consValidEncoder) this rest
180+
181+--NOTE: Naming convention in this module is to always talk about things in the *encoding* direction, never in the *decoding* direction
182+
183+chainEncoder
184+ :: forall check parse p r b.
185+ ( Monad check
186+ , Monad parse
187+ )
188+ => ValidEncoder parse (b, r) r
189+ -> Encoder check parse (Some p) b
190+ -> (forall a. p a -> ValidEncoder parse a r)
191+ -> Encoder check parse (R p) r
192+chainEncoder cons this rest = Encoder $ do
193+ thisValid <- checkEncoder this
194+ pure $ ValidEncoder
195+ { _validEncoder_decode = \v -> do
196+ (here, following) <- _validEncoder_decode cons v
197+ Some.This r <- _validEncoder_decode thisValid here
198+ (r :/) <$> _validEncoder_decode (rest r) following
199+ , _validEncoder_encode = \(r :/ s) ->
200+ _validEncoder_encode cons (_validEncoder_encode thisValid $ Some.This r, _validEncoder_encode (rest r) s)
201+ }
202+
203+--TODO: Do this in terms of a lens instead
204+lensEncoder :: Applicative parse => (b -> [a] -> b) -> (b -> [a]) -> ValidEncoder parse (c, [a]) [a] -> ValidEncoder parse (c, b) b
205+lensEncoder set get g = ValidEncoder
206+ { _validEncoder_encode = \(ma, b) -> set b $ _validEncoder_encode g (ma, get b)
207+ , _validEncoder_decode = \b -> do
208+ (ma, la) <- _validEncoder_decode g $ get b
209+ pure (ma, set b la)
210+ }
211+
212+consValidEncoder :: Applicative parse => ValidEncoder parse (Maybe a, [a]) [a] --TODO: Really shouldn't *always* have the [a], even in the Nothing case
213+consValidEncoder = ValidEncoder
214+ { _validEncoder_encode = \(h, t) -> maybeToList h <> t
215+ , _validEncoder_decode = pure . \case
216+ [] -> (Nothing, [])
217+ h:t -> (Just h, t)
218+ }
219+
220+tshow :: Show a => a -> Text
221+tshow = T.pack . show
222+
223+shadowEncoder
224+ :: ( Universe a
225+ , MonadError Text check
226+ , Show a
227+ , Show b
228+ , Show c
229+ , check ~ parse --TODO: Get rid of this
230+ )
231+ => Encoder check parse a c
232+ -> Encoder check parse b c
233+ -> Encoder check parse (Either a b) c
234+shadowEncoder f g = Encoder $ do
235+ vf <- checkEncoder f
236+ vg <- checkEncoder g
237+ let gCanParse c = catchError (Just <$> _validEncoder_decode vg c) (\_ -> pure Nothing)
238+ overlaps <- fmap catMaybes $ forM universe $ \a -> do
239+ let c = _validEncoder_encode vf a
240+ mb <- gCanParse c
241+ pure $ fmap (\b -> (a, b, c)) mb
242+ case overlaps of
243+ [] -> pure ()
244+ _ -> throwError $ "shadowEncoder: overlap detected: " <> T.unlines
245+ (flip fmap overlaps $ \(a, b, c) -> "first encoder encodes " <> tshow a <> " as " <> tshow c <> ", which second encoder decodes as " <> tshow b)
246+ pure $ ValidEncoder
247+ { _validEncoder_encode = \case
248+ Left a -> _validEncoder_encode vf a
249+ Right b -> _validEncoder_encode vg b
250+ , _validEncoder_decode = \c -> (Left <$> _validEncoder_decode vf c) `catchError` \_ -> Right <$> _validEncoder_decode vg c
251+ }
252+
253+-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that
254+-- have a large number of values - it will use a lot of memory.
255+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
256+enumEncoder f = Encoder $ do
257+ let reversed = Map.fromListWith (<>) [ (f p, Set.singleton p) | p <- universe ]
258+ checkSingleton k vs = case Set.toList vs of
259+ [] -> error "enumEncoder: empty reverse mapping; should be impossible"
260+ [e] -> Success e
261+ _ -> Failure $ Map.singleton k vs
262+ showRedundant :: r -> Set p -> [Text]
263+ showRedundant k vs = (" " <> T.pack (show k) <> " can decode to any of:")
264+ : fmap ((" "<>) . T.pack . show) (Set.toList vs)
265+ case itraverse checkSingleton reversed :: Validation (Map r (Set p)) (Map r p) of
266+ Failure ambiguousEntries -> throwError $ T.unlines $
267+ "enumEncoder: ambiguous encodings detected:" : concat (Map.elems $ imap showRedundant ambiguousEntries)
268+ Success m -> pure $ ValidEncoder
269+ { _validEncoder_decode = \r -> case Map.lookup r m of
270+ Just a -> pure a
271+ Nothing -> throwError $ "enumEncoder: not recognized: " <> T.pack (show r) --TODO: Report this as a better type
272+ , _validEncoder_encode = f
273+ }
274+
275+endValidEncoder :: (MonadError Text parse, Show r, Eq r) => r -> ValidEncoder parse () r
276+endValidEncoder expected = ValidEncoder
277+ { _validEncoder_decode = \obtained ->
278+ if obtained == expected
279+ then pure ()
280+ else throwError $ "endValidEncoder: expected " <> T.pack (show expected) <> ", got " <> T.pack (show obtained)
281+ , _validEncoder_encode = \_ -> expected
282+ }
283+
284+pathOnlyValidEncoder :: (MonadError Text parse) => ValidEncoder parse [Text] PageName
285+pathOnlyValidEncoder = ValidEncoder
286+ { _validEncoder_decode = \(path, query) ->
287+ if query == mempty
288+ then pure path
289+ else throwError "pathOnlyValidEncoder: query was provided"
290+ , _validEncoder_encode = \path -> (path, mempty)
291+ }
292+
293+singletonListValidEncoder :: (MonadError Text parse) => ValidEncoder parse a [a]
294+singletonListValidEncoder = ValidEncoder
295+ { _validEncoder_decode = \case
296+ [a] -> pure a
297+ l -> throwError $ "singletonListValidEncoder: expected one item, got " <> T.pack (show $ length l)
298+ , _validEncoder_encode = (:[])
299+ }
300+
301+--TODO: To know this is reversible, we must know that the separator isn't included anywhere in the input text
302+intercalateTextEncoder :: (MonadError Text check, Applicative parse) => Text -> Encoder check parse (NonEmpty Text) Text
303+intercalateTextEncoder = Encoder . \case
304+ "" -> throwError "splitOnTextEncoder: empty split string"
305+ separator -> pure $ ValidEncoder
306+ { _validEncoder_encode = T.intercalate separator . toList
307+ , _validEncoder_decode = \r -> pure $ case T.splitOn separator r of
308+ [] -> error "intercalateTextEncoder: Data.Text.splitOn should never return an empty list"
309+ h : t -> h :| t
310+ }
311+
312+listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
313+listToNonEmptyEncoder = Encoder $ pure $ ValidEncoder
314+ { _validEncoder_encode = \case
315+ [] -> mempty :| []
316+ h : t -> h :| t
317+ , _validEncoder_decode = \(h :| t) -> pure $
318+ if h == mempty
319+ then []
320+ else h : t
321+ }
322+
323+prefixTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encoder check parse Text Text
324+prefixTextEncoder p = Encoder $ pure $ ValidEncoder
325+ { _validEncoder_encode = mappend p
326+ , _validEncoder_decode = \v -> case T.stripPrefix p v of
327+ Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> T.pack (show p)
328+ Just stripped -> pure stripped
329+ }
330+
331+prefixNonemptyTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encoder check parse Text Text
332+prefixNonemptyTextEncoder p = Encoder $ pure $ ValidEncoder
333+ { _validEncoder_encode = \case
334+ "" -> ""
335+ v -> p <> v
336+ , _validEncoder_decode = \case
337+ "" -> pure ""
338+ v -> case T.stripPrefix p v of
339+ Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> T.pack (show p)
340+ Just stripped -> pure stripped
341+ }
342+
343+unpackTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse Text String
344+unpackTextEncoder = Encoder $ pure $ ValidEncoder
345+ { _validEncoder_encode = T.unpack
346+ , _validEncoder_decode = pure . T.pack
347+ }
348+
349+toListMapEncoder :: (Applicative check, Applicative parse, Ord k) => Encoder check parse (Map k v) [(k, v)]
350+toListMapEncoder = Encoder $ pure $ ValidEncoder
351+ { _validEncoder_encode = Map.toList
352+ , _validEncoder_decode = pure . Map.fromList --TODO: Should we be stricter about repeated keys?
353+ }
354+
355+joinPairTextEncoder :: (MonadError Text check, MonadError Text parse, Applicative parse) => Text -> Encoder check parse (Text, Text) Text
356+joinPairTextEncoder = Encoder . \case
357+ "" -> throwError "joinPairTextEncoder: empty separator"
358+ separator -> pure $ ValidEncoder
359+ { _validEncoder_encode = \(k, v) -> k <> separator <> v
360+ , _validEncoder_decode = \r ->
361+ let (kt, vt) = T.breakOn separator r
362+ in case vt of
363+ -- The separator was not found
364+ "" -> throwError $ "joinPairTextEncoder: separator not found; expected " <> T.pack (show separator)
365+ _ -> return (kt, T.drop (T.length separator) vt)
366+ }
367+
368+--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum
369+-- Or, more likely, the user can compose it themselves
370+rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
371+rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)
372+
373+-- An encoder that only works on the items available via the prism
374+prismValidEncoder :: MonadError Text parse => Prism' b a -> ValidEncoder parse a b
375+prismValidEncoder p = ValidEncoder
376+ { _validEncoder_encode = (^. re p)
377+ , _validEncoder_decode = \r -> case r ^? p of
378+ Just p -> pure p
379+ Nothing -> throwError "prismValidEncoder: value is not present in the prism"
380+ }
381+
382+--------------------------------------------------------------------------------
383+-- Actual obelisk route info
384+--------------------------------------------------------------------------------
385+
386+data ObeliskRoute :: (* -> *) -> * -> * where
387+ -- 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
388+ ObeliskRoute_App :: f a -> ObeliskRoute f a
389+ ObeliskRoute_Static :: ObeliskRoute f [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")
390+
391+newtype ValidEncoderFunc parse p r = ValidEncoderFunc { unValidEncoderFunc :: forall a. p a -> ValidEncoder parse a r }
392+
393+checkSomeUniverseEncoder
394+ :: forall check parse p r.
395+ ( Universe (Some p)
396+ , GCompare p
397+ , Monad check
398+ )
399+ => (forall a. p a -> Encoder check parse a r)
400+ -> check (ValidEncoderFunc parse p r)
401+checkSomeUniverseEncoder f = do
402+ validEncoders :: DMap p (Flip (ValidEncoder parse) r) <- DMap.fromList <$> traverse (\(Some.This p) -> (p :=>) . Flip <$> checkEncoder (f p)) universe
403+ pure $ ValidEncoderFunc $ \p -> unFlip $ DMap.findWithDefault (error "checkSomeUniverseEncoder: ValidEncoder not found (should be impossible)") p validEncoders
404+
405+obeliskRouteEncoder
406+ :: forall check parse appRoute.
407+ ( Universe (Some appRoute)
408+ , GCompare appRoute
409+ , GShow appRoute
410+ , MonadError Text check
411+ , MonadError Text parse
412+ )
413+ => (Some appRoute -> Maybe Text)
414+ -> (forall a. appRoute a -> Encoder check parse a PageName)
415+ -> Encoder check parse (R (ObeliskRoute appRoute)) PageName
416+obeliskRouteEncoder showAppRoute appRouteEncoder = Encoder $ do
417+ ValidEncoderFunc appRouteValidEncoder <- checkSomeUniverseEncoder appRouteEncoder
418+ checkEncoder $ pathComponentEncoder (enumEncoder (showRoute showAppRoute)) $ \case
419+ ObeliskRoute_App appRoute -> appRouteValidEncoder appRoute
420+ ObeliskRoute_Static -> pathOnlyValidEncoder
421+
422+instance ShowTag appRoute Identity => ShowTag (ObeliskRoute appRoute) Identity where
423+ showTaggedPrec = \case
424+ ObeliskRoute_App a -> showTaggedPrec a
425+ ObeliskRoute_Static -> showsPrec
426+
427+instance Universe (Some appRoute) => Universe (Some (ObeliskRoute appRoute)) where
428+ universe = mconcat
429+ [ mapSome ObeliskRoute_App <$> universe
430+ , [Some.This ObeliskRoute_Static]
431+ ]
432+
433+showRoute :: (Some appRoute -> Maybe Text) -> Some (ObeliskRoute appRoute) -> Maybe Text
434+showRoute showAppRoute (Some.This r) = case r of
435+ ObeliskRoute_App appRoute -> showAppRoute $ Some.This appRoute
436+ ObeliskRoute_Static -> Just "static"
437+
438+instance GCompare appRoute => GCompare (ObeliskRoute appRoute) where
439+ gcompare a b = case (a, b) of
440+ (ObeliskRoute_App aa, ObeliskRoute_App ab) -> gcompare aa ab
441+ (ObeliskRoute_App _, ObeliskRoute_Static) -> GLT
442+ (ObeliskRoute_Static, ObeliskRoute_App _) -> GGT
443+ (ObeliskRoute_Static, ObeliskRoute_Static) -> GEQ
444+
445+instance GEq appRoute => GEq (ObeliskRoute appRoute) where
446+ geq a b = case (a, b) of
447+ (ObeliskRoute_App aa, ObeliskRoute_App ab) -> geq aa ab
448+ (ObeliskRoute_App _, ObeliskRoute_Static) -> Nothing
449+ (ObeliskRoute_Static, ObeliskRoute_App _) -> Nothing
450+ (ObeliskRoute_Static, ObeliskRoute_Static) -> Just Refl
451+
452+instance GShow appRoute => GShow (ObeliskRoute appRoute) where
453+
454+makePrisms ''ObeliskRoute
455+
456+--TODO: decodeURIComponent as appropriate