@@ -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
@@ -442,8 +505,9 @@ chainEncoder cons this rest = Encoder $ do
442505 pure $ EncoderImpl
443506 { _encoderImpl_decode = \v -> do
444507 (here, following) <- _encoderImpl_decode consValid v
445− Some r <- _encoderImpl_decode thisValid here
446− (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
508+ _encoderImpl_decode thisValid here >>= \case
509+ Some r ->
510+ (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
447511 , _encoderImpl_encode = \(r :/ s) ->
448512 _encoderImpl_encode consValid
449513 ( _encoderImpl_encode thisValid $ Some r
@@ -663,10 +727,47 @@ joinPairTextEncoder = Encoder . \case
663727 _ -> return (kt, T.drop (T.length separator) vt)
664728 }
665729
666−--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum
667−-- Or, more likely, the user can compose it themselves
668−rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
669−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
670771
671772-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
672773-- if the prism doesn't match.
@@ -710,6 +811,45 @@ handleEncoder recover e = Encoder $ do
710811-- Actual obelisk route info
711812--------------------------------------------------------------------------------
712813
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+
713853-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
714854-- frontend.
715855data ObeliskRoute :: (* -> *) -> * -> * where
@@ -839,7 +979,7 @@ concat <$> mapM deriveRouteComponent
839979 ]
840980
841981makePrisms ''ObeliskRoute
842−
982+makePrisms ''FullRoute
843983deriveGEq ''Void1
844984deriveGCompare ''Void1
845985
@@ -847,27 +987,27 @@ deriveGCompare ''Void1
847987-- and query string). See 'checkEncoder' for how to produce a checked encoder.
848988renderBackendRoute
849989 :: forall br a.
850− Encoder Identity Identity (R (Sum br a)) PageName
990+ Encoder Identity Identity (R (FullRoute br a)) PageName
851991 -> R br
852992 -> Text
853−renderBackendRoute enc = renderObeliskRoute enc . hoistR InL
993+renderBackendRoute enc = renderObeliskRoute enc . hoistR FullRoute_Backend
854994
855995-- | Renders a frontend route with the supplied checked encoder
856996renderFrontendRoute
857997 :: forall a fr.
858− Encoder Identity Identity (R (Sum a (ObeliskRoute fr))) PageName
998+ Encoder Identity Identity (R (FullRoute a fr)) PageName
859999 -> R fr
8601000 -> Text
861−renderFrontendRoute enc = renderObeliskRoute enc . hoistR (InR . ObeliskRoute_App)
1001+renderFrontendRoute enc = renderObeliskRoute enc . hoistR (FullRoute_Frontend . ObeliskRoute_App)
8621002
8631003-- | Renders a route of the form typically found in an Obelisk project
8641004renderObeliskRoute
8651005 :: forall a b.
866− Encoder Identity Identity (R (Sum a b)) PageName
867− -> R (Sum a b)
1006+ Encoder Identity Identity (R (FullRoute a b)) PageName
1007+ -> R (FullRoute a b)
8681008 -> Text
8691009renderObeliskRoute e r =
870− let enc :: Encoder Identity (Either Text) (R (Sum a b)) PathQuery
1010+ let enc :: Encoder Identity (Either Text) (R (FullRoute a b)) PathQuery
8711011 enc = (pageNameEncoder . hoistParse (pure . runIdentity) e)
8721012 in (T.pack . uncurry (<>)) $ encode enc r
8731013
@@ -877,14 +1017,9 @@ readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
8771017integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
8781018integralEncoder = prismEncoder (Numeric.Lens.integral)
8791019
880−pathSegmentEncoder :: (MonadError Text parse, Applicative check) =>
881− Encoder check parse (Text, PageName) PageName
882−pathSegmentEncoder = unsafeMkEncoder EncoderImpl
883− { _encoderImpl_encode = \(x, (y, z)) -> (x:y, z)
884− , _encoderImpl_decode = \(xss, y) -> case xss of
885− [] -> throwError "not enough path segments"
886− (x:xs) -> pure (x, (xs, y))
887− }
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
8881023
8891024newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
8901025
@@ -912,12 +1047,12 @@ dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do
9121047 , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'
9131048 )
9141049 , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do
915− Some (k' :: k' t) <- tryDecode keyEncoder k
916− case DMap.lookup k' valueDecoders of
917− Nothing -> throwError . T.pack . keyError $ gshow k'
918− Just (Decoder e) -> do
919− v' <- tryDecode e v
920− return (k' :=> Identity v')
1050+ tryDecode keyEncoder k >>= \case
1051+ Some (k' :: k' t) -> case DMap.lookup k' valueDecoders of
1052+ Nothing -> throwError . T.pack . keyError $ gshow k'
1053+ Just (Decoder e) -> do
1054+ v' <- tryDecode e v
1055+ return (k' :=> Identity v')
9211056 }
9221057
9231058fieldMapEncoder :: forall check parse r.
@@ -938,6 +1073,32 @@ fieldMapEncoder = unsafeEncoder $ do
9381073 Just (Identity v) -> return v
9391074 }
9401075
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+
9411102-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
9421103jsonEncoder :: forall check parse r.
9431104 ( ToJSON r
@@ -954,4 +1115,14 @@ jsonEncoder = unsafeEncoder $ do
9541115 Right x -> return x
9551116 }
9561117
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+
9571128--TODO: decodeURIComponent as appropriate