@@ -33,7 +33,6 @@ module Obelisk.Route
3333 , singletonListValidEncoder
3434 , unpackTextEncoder
3535 , prefixTextEncoder
36− , intercalateTextEncoder
3736 , listToNonEmptyEncoder
3837 , prefixNonemptyTextEncoder
3938 , joinPairTextEncoder
@@ -88,7 +87,9 @@ import Data.Some (Some)
8887import qualified Data.Some as Some
8988import Data.Text (Text)
9089import qualified Data.Text as T
90+import Data.Text.Encoding
9191import Data.Universe
92+import Network.HTTP.Types.URI
9293
9394-- Design goals:
9495-- No start-up time on the frontend (not yet met)
@@ -184,7 +185,7 @@ instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder che
184185
185186-- | A path and query string, in which trailing slashes don't matter in the path
186187-- and duplicate query parameters are not allowed
187−type PageName = ([Text], Map Text Text)
188+type PageName = ([Text], Map Text (Maybe Text))
188189
189190newtype Flip f a b = Flip { unFlip :: f b a }
190191
@@ -323,16 +324,43 @@ singletonListValidEncoder = ValidEncoder
323324 , _validEncoder_encode = (:[])
324325 }
325326
327+splitTextNonEmpty :: Text -> Text -> NonEmpty Text
328+splitTextNonEmpty separator v = case T.splitOn separator v of
329+ [] -> error "splitTextNonEmpty: Data.Text.splitOn should never return an empty list"
330+ h : t -> h :| t
331+
326332--TODO: To know this is reversible, we must know that the separator isn't included anywhere in the input text
327−intercalateTextEncoder :: (MonadError Text check, Applicative parse) => Text -> Encoder check parse (NonEmpty Text) Text
328−intercalateTextEncoder = Encoder . \case
329− "" -> throwError "splitOnTextEncoder: empty split string"
330− separator -> pure $ ValidEncoder
331− { _validEncoder_encode = T.intercalate separator . toList
332− , _validEncoder_decode = \r -> pure $ case T.splitOn separator r of
333− [] -> error "intercalateTextEncoder: Data.Text.splitOn should never return an empty list"
334− h : t -> h :| t
335− }
333+pathSegmentsTextEncoder :: (MonadError Text check, Applicative parse) => Encoder check parse (NonEmpty Text) Text
334+pathSegmentsTextEncoder = Encoder $ pure $ ValidEncoder
335+ { _validEncoder_encode = T.intercalate "/" . fmap (urlEncodeText False) . toList
336+ , _validEncoder_decode = pure . fmap (urlDecodeText False) . splitTextNonEmpty "/"
337+ }
338+
339+queryParametersTextEncoder :: (Applicative check, Applicative parse) => Encoder check parse [(Text, Maybe Text)] Text
340+queryParametersTextEncoder = Encoder $ pure $ ValidEncoder
341+ { _validEncoder_encode = \case
342+ [] -> ""
343+ params -> T.intercalate "&" (fmap encodeParameter params)
344+ , _validEncoder_decode = pure . \case
345+ "" -> []
346+ encoded ->
347+ let h :| t = splitTextNonEmpty "&" encoded
348+ in fmap decodeParameter $ h : t
349+ }
350+ where
351+ encodeParameter (k, mv) = urlEncodeText True k <> case mv of
352+ Nothing -> ""
353+ Just v -> "=" <> urlEncodeText True v
354+ decodeParameter t =
355+ let (k, eqV) = T.breakOn "=" t
356+ mv = T.stripPrefix "=" eqV
357+ in (urlDecodeText True k, urlDecodeText True <$> mv)
358+
359+urlEncodeText :: Bool -> Text -> Text
360+urlEncodeText q = decodeUtf8 . urlEncode q . encodeUtf8
361+
362+urlDecodeText :: Bool -> Text -> Text
363+urlDecodeText q = decodeUtf8 . urlDecode q . encodeUtf8
336364
337365listToNonEmptyEncoder :: (Applicative check, Applicative parse, Monoid a, Eq a) => Encoder check parse [a] (NonEmpty a)
338366listToNonEmptyEncoder = Encoder $ pure $ ValidEncoder
@@ -410,8 +438,8 @@ prismValidEncoder p = ValidEncoder
410438pageNameValidEncoder :: MonadError Text parse => ValidEncoder parse PageName (String, String)
411439pageNameValidEncoder = ve
412440 where Right ve = checkEncoder $ bimap
413− (unpackTextEncoder . prefixTextEncoder "/" . intercalateTextEncoder "/" . listToNonEmptyEncoder)
414− (unpackTextEncoder . prefixNonemptyTextEncoder "?" . intercalateTextEncoder "&" . listToNonEmptyEncoder . Cat.fmap (joinPairTextEncoder "=") . toListMapEncoder)
441+ (unpackTextEncoder . prefixTextEncoder "/" . pathSegmentsTextEncoder . listToNonEmptyEncoder)
442+ (unpackTextEncoder . prefixNonemptyTextEncoder "?" . queryParametersTextEncoder . toListMapEncoder)
415443
416444catchValidEncoder :: (e -> a) -> ValidEncoder (Either e) a b -> ValidEncoder Identity a b
417445catchValidEncoder recover ve = ve
@@ -585,7 +613,15 @@ indexOnlyRouteComponentEncoder = enum1Encoder $ \case
585613
586614indexOnlyRouteRestEncoder :: (Applicative check, MonadError Text parse) => IndexOnlyRoute a -> Encoder check parse a PageName
587615indexOnlyRouteRestEncoder = \case
588− IndexOnlyRoute -> Encoder $ pure $ endValidEncoder mempty --TODO: Allow anything to parse
616+ IndexOnlyRoute -> Encoder $ pure $ constLaxValidEncoder mempty
617+
618+--TODO: Come up with a naming scheme that is better at describing how permissive
619+--versus strict things are
620+constLaxValidEncoder :: Applicative parse => a -> ValidEncoder parse () a
621+constLaxValidEncoder a = ValidEncoder
622+ { _validEncoder_encode = \_ -> a
623+ , _validEncoder_decode = \_ -> pure ()
624+ }
589625
590626instance ShowTag IndexOnlyRoute Identity where
591627 showTaggedPrec = \case
@@ -617,8 +653,6 @@ instance GShow Void1 where
617653 gshowsPrec _ = \case {}
618654
619655makePrisms ''ObeliskRoute
620−--TODO: Prevent deriveGShow from creating this warning:
621−-- Defined but not used: ‘p’
622656deriveGShow ''ResourceRoute
623657deriveGEq ''ResourceRoute
624658deriveGCompare ''ResourceRoute