1{-# LANGUAGE ApplicativeDo #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE EmptyCase #-}
4{-# LANGUAGE EmptyDataDecls #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
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 TypeApplications #-}
17{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE ViewPatterns #-}
39 , pathComponentEncoder
42 , checkEnum1EncoderFunc
45 , singletonListEncoder
50 , singlePathSegmentEncoder
52 , maybeToEitherEncoder
58 , listToNonEmptyEncoder
59 , prefixNonemptyTextEncoder
71 , _ObeliskRoute_Resource
73 , JSaddleWarpRoute (..)
74 , jsaddleWarpRouteEncoder
76 , indexOnlyRouteSegment
77 , indexOnlyRouteEncoder
81 , pathSegmentsTextEncoder
82 , queryParametersTextEncoder
96import Prelude hiding ((.), id)
98import Control.Applicative
99import Control.Category (Category (..))
100import qualified Control.Categorical.Functor as Cat
101import Control.Categorical.Bifunctor
102import Control.Category.Associative
103import Control.Category.Monoidal
104import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
105import Control.Monad.Except
106import qualified Data.ByteString.Lazy as BSL
107import Data.Dependent.Sum (DSum (..))
108import Data.Dependent.Map (DMap)
109import qualified Data.Dependent.Map as DMap
110import Data.Either.Validation (Validation (..))
112import Data.Functor.Sum
113import Data.GADT.Compare
114import Data.GADT.Compare.TH
116import Data.List.NonEmpty (NonEmpty (..))
118import qualified Data.Map as Map
120import Data.Monoid ((<>))
122import qualified Data.Set as Set
123import Data.Some (Some(Some))
124import Data.Text (Text)
125import qualified Data.Text as T
126import qualified Data.Text.Encoding as T
128import Data.Universe.Some
129import Network.HTTP.Types.URI
130import qualified Numeric.Lens
131import Obelisk.Route.TH
132import Text.Read (readMaybe)
133import Data.Tabulation
134import qualified Data.Aeson as Aeson
135import Data.Aeson (FromJSON, ToJSON)
138-- No start-up time on the frontend (not yet met)
139-- Able to ensure that there aren't overlapping routes prior to deployment
140-- Easy to write common types of parsers
141-- Completeness checking
144-- We statically know that all valid Routes can be turned into valid URIs
145-- - This means we need to know whether there are any overlaps, e.g. with the static file namespace
149-- Redirect the user to a canonical route
152-- Intercept links that can be kept within the app
155--------------------------------------------------------------------------------
157--------------------------------------------------------------------------------
159type R f = DSum f Identity --TODO: Better name
163pattern (:/) :: f a -> a -> R f
164pattern a :/ b = a :=> Identity b
166mapSome :: (forall a. f a -> g a) -> Some f -> Some g
167mapSome f (Some a) = Some $ f a
169hoistR :: (forall x. f x -> g x) -> R f -> R g
170hoistR f (x :=> Identity y) = f x :/ y
172--------------------------------------------------------------------------------
173-- Encoder fundamentals
174--------------------------------------------------------------------------------
176-- | This is the type of route encoder/decoders. It is parameterised over two monads: Firstly, the monad
177-- used to check the validity of the encoder (i.e. that it is total), secondly the monad used for parsing
178-- during the decode phase. The following two parameters are respectively the type of decoded data, and the
180newtype Encoder check parse decoded encoded =
181 Encoder { unEncoder :: check (EncoderImpl parse decoded encoded) }
183unsafeEncoder :: check (EncoderImpl parse decoded encoded) -> Encoder check parse decoded encoded
184unsafeEncoder = Encoder
186-- | The internal type used to construct primitive 'Encoder' values.
188-- forall p. _encoderImpl_decode ve . _encoderImpl_encode ve p == pure
189-- 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.
190data EncoderImpl parse decoded encoded = EncoderImpl
191 { _encoderImpl_decode :: !(encoded -> parse decoded) -- Can fail; can lose information; must always succeed on outputs of `_encoderImpl_encode` and result in the original value
192 , _encoderImpl_encode :: !(decoded -> encoded) -- Must be injective
195-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', and its parser is total
196-- so that its parse monad is also 'Identity', it may be used to actually decode by applying this function.
197decode :: Encoder Identity Identity decoded encoded -> encoded -> decoded
198decode e x = runIdentity (tryDecode e x)
200-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', even if the same is not true of the
201-- parse monad, we may still attempt to decode with it in its parse monad.
202tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded
203tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x
205-- | Similar to 'decode', once an encoder has been checked so that its check monad is Identity, it
206-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,
207-- one should usually be applying decode and encode to the same 'Encoder'
208encode :: Encoder Identity parse decoded encoded -> decoded -> encoded
209encode (Encoder (Identity impl)) x = _encoderImpl_encode impl x
211-- | This is a primitive used to build encoders which can't fail to check. It should not be used unless one is
212-- reasonably certain that the law given for 'EncoderImpl' above holds.
213unsafeMkEncoder :: (Applicative check) => EncoderImpl parse decoded encoded -> Encoder check parse decoded encoded
214unsafeMkEncoder impl = Encoder (pure impl)
216-- | Transform the check monad of an 'Encoder' by applying a natural transformation.
217hoistCheck :: (forall t. check t -> check' t) -> Encoder check parse a b -> Encoder check' parse a b
218hoistCheck f (Encoder x) = Encoder (f x)
220-- | Transform the parse monad of an 'Encoder' by applying a natural transformation.
221hoistParse :: (Functor check)
222 => (forall t. parse t -> parse' t) -> Encoder check parse a b -> Encoder check parse' a b
223hoistParse f (Encoder x) = Encoder (fmap (\(EncoderImpl dec enc) -> EncoderImpl (f . dec) enc) x)
225-- | Check an 'Encoder', transforming it into one whose check monad is anything we want (usually Identity).
226checkEncoder :: (Applicative check', Functor check)
227 => Encoder check parse decoded encoded
228 -> check (Encoder check' parse decoded encoded)
229checkEncoder = fmap unsafeMkEncoder . unEncoder
231instance (Applicative check, Monad parse) => Category (Encoder check parse) where
232 id = Encoder $ pure id
233 Encoder f . Encoder g = Encoder $ liftA2 (.) f g
235instance Monad parse => Category (EncoderImpl parse) where
237 { _encoderImpl_decode = pure
238 , _encoderImpl_encode = id
241 { _encoderImpl_decode = _encoderImpl_decode g <=< _encoderImpl_decode f
242 , _encoderImpl_encode = _encoderImpl_encode f . _encoderImpl_encode g
245instance Monad parse => PFunctor (,) (EncoderImpl parse) (EncoderImpl parse) where
247instance Monad parse => QFunctor (,) (EncoderImpl parse) (EncoderImpl parse) where
248 second g = bimap id g
249instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
250 bimap f g = EncoderImpl
251 { _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)
252 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
255instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
257instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
258 second g = bimap id g
259instance (Applicative check, Monad parse) => Bifunctor (,) (Encoder check parse) (Encoder check parse) (Encoder check parse) where
260 bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)
262instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (EncoderImpl parse) where
263 fmap ve = EncoderImpl
264 { _encoderImpl_encode = fmap $ _encoderImpl_encode ve
265 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve
268instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
269 fmap e = Encoder $ do
273instance Monad parse => Associative (EncoderImpl parse) (,) where
274 associate = EncoderImpl
275 { _encoderImpl_encode = associate
276 , _encoderImpl_decode = pure . disassociate
278 disassociate = EncoderImpl
279 { _encoderImpl_encode = disassociate
280 , _encoderImpl_decode = pure . associate
283instance Monad parse => Monoidal (EncoderImpl parse) (,) where
284 type Id (EncoderImpl parse) (,) = ()
286 { _encoderImpl_encode = idl
287 , _encoderImpl_decode = pure . coidl
290 { _encoderImpl_encode = idr
291 , _encoderImpl_decode = pure . coidr
294 { _encoderImpl_encode = coidl
295 , _encoderImpl_decode = pure . idl
298 { _encoderImpl_encode = coidr
299 , _encoderImpl_decode = pure . idr
302instance (Applicative check, Monad parse) => Associative (Encoder check parse) (,) where
303 associate = Encoder $ pure associate
304 disassociate = Encoder $ pure disassociate
306instance (Applicative check, Monad parse) => Monoidal (Encoder check parse) (,) where
307 type Id (Encoder check parse) (,) = ()
308 idl = Encoder $ pure idl
309 idr = Encoder $ pure idr
310 coidl = Encoder $ pure coidl
311 coidr = Encoder $ pure coidr
313--------------------------------------------------------------------------------
314-- Specific instances of encoders
315--------------------------------------------------------------------------------
317-- | Given a valid 'Iso' from lens, construct an 'Encoder'
318isoEncoder :: (Applicative check, Applicative parse) => Iso' a b -> Encoder check parse a b
319isoEncoder f = unsafeMkEncoder $ EncoderImpl
320 { _encoderImpl_encode = view f
321 , _encoderImpl_decode = pure . view (from f)
324wrappedEncoder :: (Wrapped a, Applicative check, Applicative parse) => Encoder check parse (Unwrapped a) a
325wrappedEncoder = isoEncoder $ from _Wrapped'
327unwrappedEncoder :: (Wrapped a, Applicative check, Applicative parse) => Encoder check parse a (Unwrapped a)
328unwrappedEncoder = isoEncoder _Wrapped'
330maybeToEitherEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Maybe a) (Either () a)
331maybeToEitherEncoder = unsafeMkEncoder $ EncoderImpl
332 { _encoderImpl_encode = \case
335 , _encoderImpl_decode = pure . \case
341 :: ( MonadError Text check
346 => Encoder check parse () b
347 -> Encoder check parse a b
348 -> Encoder check parse (Maybe a) b
349maybeEncoder f g = shadowEncoder f g . maybeToEitherEncoder
351-- | Encode a value by simply applying 'Just'
352justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
353justEncoder = prismEncoder _Just
355-- | Encode () to 'Nothing'.
356nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
357nothingEncoder = prismEncoder _Nothing
359someConstEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Const a)) a
360someConstEncoder = unsafeMkEncoder $ EncoderImpl
361 { _encoderImpl_encode = \(Some (Const a)) -> a
362 , _encoderImpl_decode = pure . Some . Const
365-- | WARNING: This is only safe if the Show and Read instances for 'a' are
366-- inverses of each other
367unsafeTshowEncoder :: (Show a, Read a, Applicative check, MonadError Text parse) => Encoder check parse a Text
368unsafeTshowEncoder = unsafeMkEncoder $ EncoderImpl
369 { _encoderImpl_encode = tshow
370 , _encoderImpl_decode = \raw -> case readMaybe $ T.unpack raw of
371 Nothing -> throwError $ "unsafeTshowEncoderImpl: couldn't decode " <> tshow raw
372 Just parsed -> pure parsed
375newtype EncoderFunc check parse p r = EncoderFunc { runEncoderImplFunc :: forall a. p a -> Encoder check parse a r }
377newtype Flip f a b = Flip { unFlip :: f b a }
380 :: forall check check' parse p r.
386 => (forall a. p a -> Encoder check parse a r)
387 -> check (EncoderFunc check' parse p r)
388checkEnum1EncoderFunc f = do
389 (encoderImpls :: DMap p (Flip (EncoderImpl parse) r)) <- DMap.fromList <$>
390 traverse (\(Some p) -> (p :=>) . Flip <$> unEncoder (f p)) universe
391 pure $ EncoderFunc $ \p -> unsafeMkEncoder . unFlip $
392 DMap.findWithDefault (error "checkEnum1EncoderFunc: EncoderImpl not found (should be impossible)") p encoderImpls
394-- | 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)`.
395data SegmentResult check parse a =
396 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
397 | 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.
399-- | Encode a dependent sum of type `(R p)` into a PageName (i.e. the path and query part of a URL) by using the
400-- supplied function to decide how to encode the constructors of p using the SegmentResult type. It is important
401-- that the number of values of type `(Some p)` be relatively small in order for checking to complete quickly.
403 :: forall check parse p.
407 , MonadError Text check
408 , MonadError Text parse )
409 => (forall a. p a -> SegmentResult check parse a)
410 -> Encoder check parse (R p) PageName
411pathComponentEncoder f = Encoder $ do
412 let extractEncoder = \case
413 PathEnd e -> first (unitEncoder []) . coidl . e
415 extractPathSegment = \case
417 PathSegment t _ -> Just t
418 EncoderFunc f' <- checkEnum1EncoderFunc (extractEncoder . f)
419 unEncoder (pathComponentEncoderImpl (enum1Encoder (extractPathSegment . f)) f')
421pathComponentEncoderImpl :: forall check parse p. (Monad check, Monad parse)
422 => (Encoder check parse (Some p) (Maybe Text))
423 -> (forall a. p a -> Encoder Identity parse a PageName)
424 -> Encoder check parse (R p) PageName
425pathComponentEncoderImpl this rest =
426 chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder) this rest
428--NOTE: Naming convention in this module is to always talk about things in the *encoding* direction, never in the *decoding* direction
431 :: forall check parse p r b.
435 => Encoder check parse (b, r) r
436 -> Encoder check parse (Some p) b
437 -> (forall a. p a -> Encoder Identity parse a r)
438 -> Encoder check parse (R p) r
439chainEncoder cons this rest = Encoder $ do
440 consValid <- unEncoder cons
441 thisValid <- unEncoder this
443 { _encoderImpl_decode = \v -> do
444 (here, following) <- _encoderImpl_decode consValid v
445 Some r <- _encoderImpl_decode thisValid here
446 (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following
447 , _encoderImpl_encode = \(r :/ s) ->
448 _encoderImpl_encode consValid
449 ( _encoderImpl_encode thisValid $ Some r
450 , _encoderImpl_encode (runIdentity . unEncoder $ rest r) s)
453--TODO: Do this in terms of a lens instead
454lensEncoder :: (Applicative check, Monad parse)
455 => (b -> [a] -> b) -> (b -> [a]) -> Encoder check parse (c, [a]) [a] -> Encoder check parse (c, b) b
456lensEncoder set get g = Encoder $ do
459 { _encoderImpl_encode = \(ma, b) -> set b $ _encoderImpl_encode gImpl (ma, get b)
460 , _encoderImpl_decode = \b -> do
461 (ma, la) <- _encoderImpl_decode gImpl $ get b
465consEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Maybe a, [a]) [a] --TODO: Really shouldn't *always* have the [a], even in the Nothing case
466consEncoder = unsafeMkEncoder $ EncoderImpl
467 { _encoderImpl_encode = \(h, t) -> maybeToList h <> t
468 , _encoderImpl_decode = pure . \case
473tshow :: Show a => a -> Text
478 , MonadError Text check
482 , check ~ parse --TODO: Get rid of this
484 => Encoder check parse a c -- ^ Overlaps; should have a small number of possible routes
485 -> Encoder check parse b c -- ^ Gets overlapped
486 -> Encoder check parse (Either a b) c
487shadowEncoder f g = Encoder $ do
490 let gCanParse c = catchError (Just <$> _encoderImpl_decode vg c) (\_ -> pure Nothing)
491 overlaps <- fmap catMaybes $ forM universe $ \a -> do
492 let c = _encoderImpl_encode vf a
494 pure $ fmap (\b -> (a, b, c)) mb
497 _ -> throwError $ "shadowEncoder: overlap detected: " <> T.unlines
498 (flip fmap overlaps $ \(a, b, c) -> "first encoder encodes " <> tshow a <> " as " <> tshow c <> ", which second encoder decodes as " <> tshow b)
500 { _encoderImpl_encode = \case
501 Left a -> _encoderImpl_encode vf a
502 Right b -> _encoderImpl_encode vg b
503 , _encoderImpl_decode = \c -> (Left <$> _encoderImpl_decode vf c) `catchError` \_ -> Right <$> _encoderImpl_decode vg c
507 :: ( Universe (Some p)
510 , MonadError Text check
511 , MonadError Text parse
515 => (forall a. p a -> r) -> Encoder check parse (Some p) r
516enum1Encoder f = enumEncoder $ \(Some p) -> f p
518-- | Encode an enumerable, bounded type. WARNING: Don't use this on types that
519-- have a large number of values - it will use a lot of memory.
520enumEncoder :: 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
521enumEncoder f = Encoder $ do
522 let reversed = Map.fromListWith (<>) [ (f p, Set.singleton p) | p <- universe ]
523 checkSingleton k vs = case Set.toList vs of
524 [] -> error "enumEncoder: empty reverse mapping; should be impossible"
526 _ -> Failure $ Map.singleton k vs
527 showRedundant :: r -> Set p -> [Text]
528 showRedundant k vs = (" " <> tshow k <> " can decode to any of:")
529 : fmap ((" "<>) . tshow) (Set.toList vs)
530 case itraverse checkSingleton reversed :: Validation (Map r (Set p)) (Map r p) of
531 Failure ambiguousEntries -> throwError $ T.unlines $
532 "enumEncoder: ambiguous encodings detected:" : concat (Map.elems $ imap showRedundant ambiguousEntries)
533 Success m -> pure $ EncoderImpl
534 { _encoderImpl_decode = \r -> case Map.lookup r m of
536 Nothing -> throwError $ "enumEncoder: not recognized: " <> tshow r --TODO: Report this as a better type
537 , _encoderImpl_encode = f
540unitEncoder :: (Applicative check, MonadError Text parse, Show r, Eq r) => r -> Encoder check parse () r
541unitEncoder expected = unsafeMkEncoder $ EncoderImpl
542 { _encoderImpl_decode = \obtained ->
543 if obtained == expected
545 else throwError $ "endEncoderImpl: expected " <> tshow expected <> ", got " <> tshow obtained
546 , _encoderImpl_encode = \_ -> expected
549singlePathSegmentEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse Text PageName
550singlePathSegmentEncoder = pathOnlyEncoder . singletonListEncoder
552pathOnlyEncoderIgnoringQuery :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
553pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl
554 { _encoderImpl_decode = \(path, _query) -> pure path
555 , _encoderImpl_encode = \path -> (path, mempty)
558pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
559pathOnlyEncoder = second (unitEncoder mempty) . coidr
561queryOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Map Text (Maybe Text)) PageName
562queryOnlyEncoder = first (unitEncoder []) . coidl
564singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
565singletonListEncoder = unsafeMkEncoder $ EncoderImpl
566 { _encoderImpl_decode = \case
568 l -> throwError $ "singletonListEncoderImpl: expected one item, got " <> tshow (length l)
569 , _encoderImpl_encode = (:[])
572splitTextNonEmpty :: Text -> Text -> NonEmpty Text
573splitTextNonEmpty separator v = case T.splitOn separator v of
574 [] -> error "splitTextNonEmpty: Data.Text.splitOn should never return an empty list"
577--TODO: To know this is reversible, we must know that the separator isn't included anywhere in the input text
578pathSegmentsTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse (NonEmpty Text) Text
579pathSegmentsTextEncoder = unsafeMkEncoder $ EncoderImpl
580 { _encoderImpl_encode = T.intercalate "/" . fmap (urlEncodeText False) . toList
581 , _encoderImpl_decode = pure . fmap (urlDecodeText False) . splitTextNonEmpty "/"
584queryParametersTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse [(Text, Maybe Text)] Text
585queryParametersTextEncoder = Encoder $ pure $ EncoderImpl
586 { _encoderImpl_encode = \case
588 params -> T.intercalate "&" (fmap encodeParameter params)
589 , _encoderImpl_decode = pure . \case
592 let h :| t = splitTextNonEmpty "&" encoded
593 in fmap decodeParameter $ h : t
596 encodeParameter (k, mv) = urlEncodeText True k <> case mv of
598 Just v -> "=" <> urlEncodeText True v
600 let (k, eqV) = T.breakOn "=" t
601 mv = T.stripPrefix "=" eqV
602 in (urlDecodeText True k, urlDecodeText True <$> mv)
604urlEncodeText :: Bool -> Text -> Text
605urlEncodeText q = T.decodeUtf8 . urlEncode q . T.encodeUtf8
607urlDecodeText :: Bool -> Text -> Text
608urlDecodeText q = T.decodeUtf8 . urlDecode q . T.encodeUtf8
610listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
611listToNonEmptyEncoder = Encoder $ pure $ EncoderImpl
612 { _encoderImpl_encode = \case
615 , _encoderImpl_decode = \(h :| t) -> pure $
621prefixTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encoder check parse Text Text
622prefixTextEncoder p = Encoder $ pure $ EncoderImpl
623 { _encoderImpl_encode = mappend p
624 , _encoderImpl_decode = \v -> case T.stripPrefix p v of
625 Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> tshow p <> ", got " <> tshow (T.take (T.length p) v)
626 Just stripped -> pure stripped
629prefixNonemptyTextEncoder :: (Applicative check, MonadError Text parse) => Text -> Encoder check parse Text Text
630prefixNonemptyTextEncoder p = Encoder $ pure $ EncoderImpl
631 { _encoderImpl_encode = \case
634 , _encoderImpl_decode = \case
636 v -> case T.stripPrefix p v of
637 Nothing -> throwError $ "prefixTextEncoder: wrong prefix; expected " <> tshow p
638 Just stripped -> pure stripped
641unpackTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse Text String
642unpackTextEncoder = Encoder $ pure $ EncoderImpl
643 { _encoderImpl_encode = T.unpack
644 , _encoderImpl_decode = pure . T.pack
647toListMapEncoder :: (Applicative check, Applicative parse, Ord k) => Encoder check parse (Map k v) [(k, v)]
648toListMapEncoder = Encoder $ pure $ EncoderImpl
649 { _encoderImpl_encode = Map.toList
650 , _encoderImpl_decode = pure . Map.fromList --TODO: Should we be stricter about repeated keys?
653joinPairTextEncoder :: (MonadError Text check, MonadError Text parse) => Text -> Encoder check parse (Text, Text) Text
654joinPairTextEncoder = Encoder . \case
655 "" -> throwError "joinPairTextEncoder: empty separator"
656 separator -> pure $ EncoderImpl
657 { _encoderImpl_encode = \(k, v) -> k <> separator <> v
658 , _encoderImpl_decode = \r ->
659 let (kt, vt) = T.breakOn separator r
661 -- The separator was not found
662 "" -> throwError $ "joinPairTextEncoder: separator not found; expected " <> tshow separator
663 _ -> return (kt, T.drop (T.length separator) vt)
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
668rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)
669rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)
671-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad
672-- if the prism doesn't match.
673prismEncoder :: (Applicative check, MonadError Text parse) => Prism' b a -> Encoder check parse a b
674prismEncoder p = unsafeMkEncoder $ EncoderImpl
675 { _encoderImpl_encode = (^. re p)
676 , _encoderImpl_decode = \r -> case r ^? p of
678 Nothing -> throwError "prismEncoder: value is not present in the prism"
681-- | A URL path and query string, in which trailing slashes don't matter in the path
682-- and duplicate query parameters are not allowed. A final goal of encoders using this library
683-- will frequently be to produce this.
684type PageName = ([Text], Map Text (Maybe Text))
686-- | A path (separated by slashes), and a query string.
687type PathQuery = (String, String)
689-- | Encode a PageName into a path and query string.
690pageNameEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse PageName PathQuery
691pageNameEncoder = bimap
692 (unpackTextEncoder . prefixTextEncoder "/" . pathSegmentsTextEncoder . listToNonEmptyEncoder)
693 (unpackTextEncoder . prefixNonemptyTextEncoder "?" . queryParametersTextEncoder . toListMapEncoder)
695-- | Handle an error in parsing, for example, in order to redirect to a 404 page.
699 -> Encoder check (Either e) a b
700 -> Encoder check Identity a b
701handleEncoder recover e = Encoder $ do
704 { _encoderImpl_decode = \a -> pure $ case _encoderImpl_decode i a of
706 Left err -> recover err
709--------------------------------------------------------------------------------
710-- Actual obelisk route info
711--------------------------------------------------------------------------------
713-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
715data ObeliskRoute :: (* -> *) -> * -> * where
716 -- 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
717 ObeliskRoute_App :: f a -> ObeliskRoute f a
718 ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
720instance UniverseSome f => UniverseSome (ObeliskRoute f) where
721 universeSome = concat
722 [ (\(Some x) -> Some (ObeliskRoute_App x)) <$> universe
723 , (\(Some x) -> Some (ObeliskRoute_Resource x)) <$> universe
726instance GEq f => GEq (ObeliskRoute f) where
727 geq (ObeliskRoute_App x) (ObeliskRoute_App y) = geq x y
728 geq (ObeliskRoute_Resource x) (ObeliskRoute_Resource y) = geq x y
731instance GCompare f => GCompare (ObeliskRoute f) where
732 gcompare (ObeliskRoute_App x) (ObeliskRoute_App y) = gcompare x y
733 gcompare (ObeliskRoute_Resource x) (ObeliskRoute_Resource y) = gcompare x y
734 gcompare (ObeliskRoute_App _) (ObeliskRoute_Resource _) = GLT
735 gcompare (ObeliskRoute_Resource _) (ObeliskRoute_App _) = GGT
737-- | A type representing the various resource routes served by Obelisk. These can in principle map to any physical routes you want,
738-- but sane defaults are provided by 'resourceRouteSegment'
739data ResourceRoute :: * -> * where
740 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")
741 ResourceRoute_Ghcjs :: ResourceRoute [Text]
742 ResourceRoute_JSaddleWarp :: ResourceRoute (R JSaddleWarpRoute)
743 ResourceRoute_Version :: ResourceRoute ()
745-- | If there are no additional backend routes in your app (i.e. ObeliskRoute gives you all the routes you need),
746-- this constructs a suitable 'Encoder' to use for encoding routes to 'PageName's. If you do have additional backend routes,
747-- you'll want to use 'pathComponentEncoder' yourself, applied to a function that will likely use obeliskRouteSegment in order to
748-- handle the ObeliskRoute case (i.e. Obelisk resource routes and app frontend routes).
749obeliskRouteEncoder :: forall check parse appRoute.
750 ( Universe (Some (ObeliskRoute appRoute))
751 , GCompare (ObeliskRoute appRoute)
753 , MonadError Text check
754 , check ~ parse --TODO: Get rid of this
756 => (forall a. appRoute a -> SegmentResult check parse a)
757 -> Encoder check parse (R (ObeliskRoute appRoute)) PageName
758obeliskRouteEncoder appRouteSegment = pathComponentEncoder $ \r ->
759 obeliskRouteSegment r appRouteSegment
761-- | From a function which explains how app-specific frontend routes translate into segments, produce a function which does the
762-- same for ObeliskRoute. This uses the given function for the 'ObeliskRoute_App' case, and 'resourceRouteSegment' for the
763-- 'ObeliskRoute_Resource' case.
764obeliskRouteSegment :: forall check parse appRoute a.
765 (MonadError Text check, MonadError Text parse)
766 => ObeliskRoute appRoute a
767 -> (forall b. appRoute b -> SegmentResult check parse b)
768 -> SegmentResult check parse a
769obeliskRouteSegment r appRouteSegment = case r of
770 ObeliskRoute_App appRoute -> appRouteSegment appRoute
771 ObeliskRoute_Resource resourceRoute -> resourceRouteSegment resourceRoute
773-- | A function which gives a sane default for how to encode Obelisk resource routes. It's given in this form, because it will
774-- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.
775resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a
776resourceRouteSegment = \case
777 ResourceRoute_Static -> PathSegment "static" $ pathOnlyEncoderIgnoringQuery
778 ResourceRoute_Ghcjs -> PathSegment "ghcjs" $ pathOnlyEncoder
779 ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" $ jsaddleWarpRouteEncoder
780 ResourceRoute_Version -> PathSegment "version" $ unitEncoder mempty
782data JSaddleWarpRoute :: * -> * where
783 JSaddleWarpRoute_JavaScript :: JSaddleWarpRoute ()
784 JSaddleWarpRoute_WebSocket :: JSaddleWarpRoute ()
785 JSaddleWarpRoute_Sync :: JSaddleWarpRoute [Text]
787jsaddleWarpRouteEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (R JSaddleWarpRoute) PageName
788jsaddleWarpRouteEncoder = pathComponentEncoder $ \case
789 JSaddleWarpRoute_JavaScript -> PathSegment "jsaddle.js" $ unitEncoder mempty
790 JSaddleWarpRoute_WebSocket -> PathEnd $ unitEncoder mempty
791 JSaddleWarpRoute_Sync -> PathSegment "sync" $ pathOnlyEncoder
793instance GShow appRoute => GShow (ObeliskRoute appRoute) where
794 gshowsPrec prec = \case
795 ObeliskRoute_App appRoute -> showParen (prec > 10) $
796 showString "ObeliskRoute_App " . gshowsPrec 11 appRoute
797 ObeliskRoute_Resource appRoute -> showParen (prec > 10) $
798 showString "ObeliskRoute_Resource " . gshowsPrec 11 appRoute
800data IndexOnlyRoute :: * -> * where
801 IndexOnlyRoute :: IndexOnlyRoute ()
803indexOnlyRouteSegment :: (Applicative check, MonadError Text parse) => IndexOnlyRoute a -> SegmentResult check parse a
804indexOnlyRouteSegment = \case
805 IndexOnlyRoute -> PathEnd $ unitEncoder mempty
807indexOnlyRouteEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (R IndexOnlyRoute) PageName
808indexOnlyRouteEncoder = pathComponentEncoder indexOnlyRouteSegment
810someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))
811someSumEncoder = Encoder $ pure $ EncoderImpl
812 { _encoderImpl_encode = \(Some t) -> case t of
813 InL l -> Left $ Some l
814 InR r -> Right $ Some r
815 , _encoderImpl_decode = pure . \case
816 Left (Some l) -> Some (InL l)
817 Right (Some r) -> Some (InR r)
820data Void1 :: * -> * where {}
822instance Universe (Some Void1) where
825void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
826void1Encoder = Encoder $ pure $ EncoderImpl
827 { _encoderImpl_encode = \case
828 Some f -> case f of {}
829 , _encoderImpl_decode = \_ -> throwError "void1Encoder: can't decode anything"
832instance GShow Void1 where
833 gshowsPrec _ = \case {}
835concat <$> mapM deriveRouteComponent
841makePrisms ''ObeliskRoute
844deriveGCompare ''Void1
846-- | Given a backend route and a checked route encoder, render the route (path
847-- and query string). See 'checkEncoder' for how to produce a checked encoder.
850 Encoder Identity Identity (R (Sum br a)) PageName
853renderBackendRoute enc = renderObeliskRoute enc . hoistR InL
855-- | Renders a frontend route with the supplied checked encoder
858 Encoder Identity Identity (R (Sum a (ObeliskRoute fr))) PageName
861renderFrontendRoute enc = renderObeliskRoute enc . hoistR (InR . ObeliskRoute_App)
863-- | Renders a route of the form typically found in an Obelisk project
866 Encoder Identity Identity (R (Sum a b)) PageName
869renderObeliskRoute e r =
870 let enc :: Encoder Identity (Either Text) (R (Sum a b)) PathQuery
871 enc = (pageNameEncoder . hoistParse (pure . runIdentity) e)
872 in (T.pack . uncurry (<>)) $ encode enc r
874readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName
875readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
877integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
878integralEncoder = prismEncoder (Numeric.Lens.integral)
880pathSegmentEncoder :: (MonadError Text parse, Applicative check) =>
881 Encoder check parse (Text, PageName) PageName
882pathSegmentEncoder = 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))
889newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
891dmapEncoder :: forall check parse k k' v.
893 , MonadError Text parse
899 => Encoder check parse (Some k') k
900 -> (forall v'. k' v' -> Encoder check parse v' v)
901 -> Encoder check parse (DMap k' Identity) (Map k v)
902dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do
903 keyEncoder :: Encoder Identity parse (Some k') k <- checkEncoder keyEncoder'
904 valueDecoders :: DMap k' (Decoder Identity parse v) <- fmap DMap.fromList . forM universe $ \(Some (k' :: k' t)) -> do
905 ve :: Encoder Identity parse t v <- checkEncoder (valueEncoderFor k')
906 return $ (k' :: k' t) :=> (Decoder ve :: Decoder Identity parse v t)
907 let keyError k = "dmapEncoder: key `" <> k <> "' was missing from the Universe instance for its type."
909 { _encoderImpl_encode = \dm -> Map.fromList $ do
910 ((k' :: k' t) :=> Identity v') <- DMap.toList dm
911 return ( encode keyEncoder (Some k')
912 , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'
914 , _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
920 return (k' :=> Identity v')
923fieldMapEncoder :: forall check parse r.
925 , MonadError Text parse
927 , Universe (Some (Field r))
931 => Encoder check parse r (DMap (Field r) Identity)
932fieldMapEncoder = unsafeEncoder $ do
934 { _encoderImpl_encode = \r -> DMap.fromList [ f :=> Identity (indexField r f) | Some f <- universe ]
935 , _encoderImpl_decode = \dm -> tabulateFieldsA $ \f -> do
936 case DMap.lookup f dm of
937 Nothing -> throwError $ "fieldMapEncoder: Couldn't find key for `" <> T.pack (gshow f) <> "' in DMap."
938 Just (Identity v) -> return v
941-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
942jsonEncoder :: forall check parse r.
946 , MonadError Text parse
948 => Encoder check parse r Text
949jsonEncoder = unsafeEncoder $ do
951 { _encoderImpl_encode = \r -> T.decodeUtf8 . BSL.toStrict $ Aeson.encode r
952 , _encoderImpl_decode = \t -> case Aeson.eitherDecodeStrict $ T.encodeUtf8 t of
953 Left err -> throwError ("jsonEncoder: " <> T.pack err)
957--TODO: decodeURIComponent as appropriate
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list