@@ -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
@@ -663,10 +726,47 @@ joinPairTextEncoder = Encoder . \case
663726 _ -> return (kt, T.drop (T.length separator) vt)
664727 }
665728
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)
729+-- This slight generalization of 'rPrism' happens to be enough to write all our
730+-- prism combinators so far.
731+dSumPrism
732+ :: forall f f' g
733+ . (forall a. Prism' (f a) (f' a))
734+ -> Prism' (DSum f g) (DSum f' g)
735+dSumPrism p = prism'
736+ (\(f' :=> x) -> f' ^. re p :=> x)
737+ (\(f :=> x) -> (:=> x) <$> (f ^? p))
738+
739+-- already in obelisk
740+rPrism
741+ :: forall f f'
742+ . (forall a. Prism' (f a) (f' a))
743+ -> Prism' (R f) (R f')
744+rPrism p = dSumPrism p
745+
746+dSumPrism'
747+ :: forall f g a
748+ . (forall b. Prism' (f b) (a :~: b))
749+ -> Prism' (DSum f g) (g a)
750+dSumPrism' p = dSumPrism p . iso (\(Refl :=> b) -> b) (Refl :=>)
751+
752+dSumGEqPrism
753+ :: GEq f
754+ => f a
755+ -> Prism' (DSum f g) (g a)
756+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)
757+
758+-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual
759+-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'
760+-- generalized a usual sum type.
761+--
762+-- [This is given the '_R' name of the "cannonical" prism not because it is the
763+-- most general, but because it seems the most useful for routes, and 'R' itself
764+-- trades generality for route-specificity.]
765+_R
766+ :: GEq f
767+ => f a
768+ -> Prism' (R f) a
769+_R variant = dSumGEqPrism variant . iso runIdentity Identity
670770
671771-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
672772-- if the prism doesn't match.
@@ -710,6 +810,45 @@ handleEncoder recover e = Encoder $ do
710810-- Actual obelisk route info
711811--------------------------------------------------------------------------------
712812
813+-- | The typical full route type comprising all of an Obelisk application's routes.
814+-- Parameterised by the top level GADTs that define backend and frontend routes, respectively.
815+data FullRoute :: (* -> *) -> (* -> *) -> * -> * where
816+ FullRoute_Backend :: br a -> FullRoute br fr a
817+ FullRoute_Frontend :: ObeliskRoute fr a -> FullRoute br fr a
818+
819+instance (GShow br, GShow fr) => GShow (FullRoute br fr) where
820+ gshowsPrec p = \case
821+ FullRoute_Backend x -> showParen (p > 10) (showString "FullRoute_Backend " . gshowsPrec 11 x)
822+ FullRoute_Frontend x -> showParen (p > 10) (showString "FullRoute_Frontend " . gshowsPrec 11 x)
823+
824+instance (GEq br, GEq fr) => GEq (FullRoute br fr) where
825+ geq (FullRoute_Backend x) (FullRoute_Backend y) = geq x y
826+ geq (FullRoute_Frontend x) (FullRoute_Frontend y) = geq x y
827+ geq _ _ = Nothing
828+
829+instance (GCompare br, GCompare fr) => GCompare (FullRoute br fr) where
830+ gcompare (FullRoute_Backend _) (FullRoute_Frontend _) = GLT
831+ gcompare (FullRoute_Frontend _) (FullRoute_Backend _) = GGT
832+ gcompare (FullRoute_Backend x) (FullRoute_Backend y) = gcompare x y
833+ gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y
834+
835+instance (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) where
836+ universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]
837+ ++ [Some (FullRoute_Frontend x) | Some x <- universeSome]
838+
839+-- | Build the typical top level application route encoder from a route for handling 404's,
840+-- and segment encoders for backend and frontend routes.
841+mkFullRouteEncoder
842+ :: (GCompare br, GCompare fr, GShow br, GShow fr, UniverseSome br, UniverseSome fr)
843+ => R (FullRoute br fr) -- ^ 404 handler
844+ -> (forall a. br a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single backend route segment
845+ -> (forall a. fr a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single frontend route segment
846+ -> Encoder (Either Text) Identity (R (FullRoute br fr)) PageName
847+mkFullRouteEncoder missing backendSegment frontendSegment = handleEncoder (const missing) $
848+ pathComponentEncoder $ \case
849+ FullRoute_Backend backendRoute -> backendSegment backendRoute
850+ FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute frontendSegment
851+
713852-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
714853-- frontend.
715854data ObeliskRoute :: (* -> *) -> * -> * where
@@ -839,7 +978,7 @@ concat <$> mapM deriveRouteComponent
839978 ]
840979
841980makePrisms ''ObeliskRoute
842−
981+makePrisms ''FullRoute
843982deriveGEq ''Void1
844983deriveGCompare ''Void1
845984
@@ -847,27 +986,27 @@ deriveGCompare ''Void1
847986-- and query string). See 'checkEncoder' for how to produce a checked encoder.
848987renderBackendRoute
849988 :: forall br a.
850− Encoder Identity Identity (R (Sum br a)) PageName
989+ Encoder Identity Identity (R (FullRoute br a)) PageName
851990 -> R br
852991 -> Text
853−renderBackendRoute enc = renderObeliskRoute enc . hoistR InL
992+renderBackendRoute enc = renderObeliskRoute enc . hoistR FullRoute_Backend
854993
855994-- | Renders a frontend route with the supplied checked encoder
856995renderFrontendRoute
857996 :: forall a fr.
858− Encoder Identity Identity (R (Sum a (ObeliskRoute fr))) PageName
997+ Encoder Identity Identity (R (FullRoute a fr)) PageName
859998 -> R fr
860999 -> Text
861−renderFrontendRoute enc = renderObeliskRoute enc . hoistR (InR . ObeliskRoute_App)
1000+renderFrontendRoute enc = renderObeliskRoute enc . hoistR (FullRoute_Frontend . ObeliskRoute_App)
8621001
8631002-- | Renders a route of the form typically found in an Obelisk project
8641003renderObeliskRoute
8651004 :: forall a b.
866− Encoder Identity Identity (R (Sum a b)) PageName
867− -> R (Sum a b)
1005+ Encoder Identity Identity (R (FullRoute a b)) PageName
1006+ -> R (FullRoute a b)
8681007 -> Text
8691008renderObeliskRoute e r =
870− let enc :: Encoder Identity (Either Text) (R (Sum a b)) PathQuery
1009+ let enc :: Encoder Identity (Either Text) (R (FullRoute a b)) PathQuery
8711010 enc = (pageNameEncoder . hoistParse (pure . runIdentity) e)
8721011 in (T.pack . uncurry (<>)) $ encode enc r
8731012
@@ -877,14 +1016,9 @@ readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
8771016integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
8781017integralEncoder = prismEncoder (Numeric.Lens.integral)
8791018
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− }
1019+pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
1020+ Encoder check parse (a, (as, b)) (as, b)
1021+pathSegmentEncoder = first (prismEncoder _Cons) . disassociate
8881022
8891023newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
8901024
@@ -938,6 +1072,32 @@ fieldMapEncoder = unsafeEncoder $ do
9381072 Just (Identity v) -> return v
9391073 }
9401074
1075+-- this is in base 4.12 (GHC 8.6);
1076+newtype Ap f a = Ap {getAp :: f a}
1077+
1078+instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where
1079+ Ap x <> Ap y = Ap (liftA2 (<>) x y)
1080+
1081+instance (Applicative f, Monoid a) => Monoid (Ap f a) where
1082+ mappend = (<>)
1083+ mempty = Ap (pure mempty)
1084+
1085+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]
1086+pathFieldEncoder fieldEncoder = unsafeEncoder $ do
1087+ 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)
1088+ let fieldEncoderPure :: forall x. Field a x -> Encoder Identity parse x p
1089+ fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
1090+ pure $ EncoderImpl
1091+ { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1092+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x
1093+ tell rest
1094+ , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
1095+ [] -> throwError $ T.pack "not enough path components"
1096+ p:ps -> do
1097+ State.put ps
1098+ lift $ tryDecode (fieldEncoderPure f) p
1099+ }
1100+
9411101-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
9421102jsonEncoder :: forall check parse r.
9431103 ( ToJSON r
@@ -954,4 +1114,14 @@ jsonEncoder = unsafeEncoder $ do
9541114 Right x -> return x
9551115 }
9561116
1117+-- Useful for app server integration.
1118+-- p must not start with slashes
1119+byteStringsToPageName :: BS.ByteString -> BS.ByteString -> PageName
1120+byteStringsToPageName p q =
1121+ let pageNameEncoder' :: Encoder Identity Identity PageName (String, String)
1122+ pageNameEncoder' = bimap
1123+ (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)
1124+ (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)
1125+ in decode pageNameEncoder' (T.unpack (T.decodeUtf8 p), T.unpack (T.decodeUtf8 q))
1126+
9571127--TODO: decodeURIComponent as appropriate