{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Yesod.Page.RenderedRoute
( RenderedRoute
, renderedRouteLink
, getRenderedRoute
, getRenderedRouteAbsolute
, updateQueryParameter
)
where
import Data.Aeson
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text, intercalate, pack, unpack)
import Network.HTTP.Link.Compat
import Network.URI
(URI(..), escapeURIString, isUnescapedInURIComponent, parseAbsoluteURI)
import UnliftIO (throwString)
import Yesod.Core
( HandlerSite
, MonadHandler
, RenderRoute
, Yesod
, approot
, getApprootText
, getCurrentRoute
, getRequest
, getYesod
, renderRoute
, reqGetParams
, waiRequest
)
data RenderedRoute = RenderedRoute
{ RenderedRoute -> Text
renderedApproot :: Text
, RenderedRoute -> [Text]
renderedRoutePath :: [Text]
, RenderedRoute -> [(Text, Text)]
renderedRouteQuery :: [(Text, Text)]
}
instance ToJSON RenderedRoute where
toJSON :: RenderedRoute -> Value
toJSON = Text -> Value
String (Text -> Value)
-> (RenderedRoute -> Text) -> RenderedRoute -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text)
-> (RenderedRoute -> String) -> RenderedRoute -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
forall a. Show a => a -> String
show (URI -> String)
-> (RenderedRoute -> URI) -> RenderedRoute -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderedRoute -> URI
renderedRouteURI
renderedRouteLink :: Text -> RenderedRoute -> Link
renderedRouteLink :: Text -> RenderedRoute -> Link
renderedRouteLink Text
rel = (URI -> [(LinkParam, Text)] -> Link)
-> [(LinkParam, Text)] -> URI -> Link
forall a b c. (a -> b -> c) -> b -> a -> c
flip URI -> [(LinkParam, Text)] -> Link
linkURI [(LinkParam
Rel, Text
rel)] (URI -> Link) -> (RenderedRoute -> URI) -> RenderedRoute -> Link
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderedRoute -> URI
renderedRouteURI
renderedRouteURI :: RenderedRoute -> URI
renderedRouteURI :: RenderedRoute -> URI
renderedRouteURI RenderedRoute {[(Text, Text)]
[Text]
Text
renderedRouteQuery :: [(Text, Text)]
renderedRoutePath :: [Text]
renderedApproot :: Text
renderedRouteQuery :: RenderedRoute -> [(Text, Text)]
renderedRoutePath :: RenderedRoute -> [Text]
renderedApproot :: RenderedRoute -> Text
..} = URI :: String -> Maybe URIAuth -> String -> String -> String -> URI
URI
{ uriScheme :: String
uriScheme = String
scheme
, uriAuthority :: Maybe URIAuth
uriAuthority = Maybe URIAuth
authority
, uriPath :: String
uriPath = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"/" [Text]
renderedRoutePath
, uriQuery :: String
uriQuery = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> Text
query [(Text, Text)]
renderedRouteQuery
, uriFragment :: String
uriFragment = String
""
}
where
query :: [(Text, Text)] -> Text
query [] = Text
""
query [(Text, Text)]
qs = Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"&" ([(Text, Text)] -> [Text]
parts [(Text, Text)]
qs)
parts :: [(Text, Text)] -> [Text]
parts = ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (((Text, Text) -> Text) -> [(Text, Text)] -> [Text])
-> ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ \(Text
k, Text
v) -> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escape Text
v
escape :: Text -> Text
escape = String -> Text
pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isUnescapedInURIComponent (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
(String
scheme, Maybe URIAuth
authority) = (String, Maybe URIAuth)
-> Maybe (String, Maybe URIAuth) -> (String, Maybe URIAuth)
forall a. a -> Maybe a -> a
fromMaybe (String
"", Maybe URIAuth
forall a. Maybe a
Nothing) (Maybe (String, Maybe URIAuth) -> (String, Maybe URIAuth))
-> Maybe (String, Maybe URIAuth) -> (String, Maybe URIAuth)
forall a b. (a -> b) -> a -> b
$ do
URI
uri <- String -> Maybe URI
parseAbsoluteURI (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
renderedApproot
(String, Maybe URIAuth) -> Maybe (String, Maybe URIAuth)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI -> String
uriScheme URI
uri, URI -> Maybe URIAuth
uriAuthority URI
uri)
getRenderedRoute
:: (MonadHandler m, RenderRoute (HandlerSite m)) => m RenderedRoute
getRenderedRoute :: m RenderedRoute
getRenderedRoute = do
Route (HandlerSite m)
route <- m (Route (HandlerSite m))
-> (Route (HandlerSite m) -> m (Route (HandlerSite m)))
-> Maybe (Route (HandlerSite m))
-> m (Route (HandlerSite m))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m (Route (HandlerSite m))
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"no route") Route (HandlerSite m) -> m (Route (HandlerSite m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Route (HandlerSite m)) -> m (Route (HandlerSite m)))
-> m (Maybe (Route (HandlerSite m))) -> m (Route (HandlerSite m))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe (Route (HandlerSite m)))
forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute
let ([Text]
path, [(Text, Text)]
_query) = Route (HandlerSite m) -> ([Text], [(Text, Text)])
forall a. RenderRoute a => Route a -> ([Text], [(Text, Text)])
renderRoute Route (HandlerSite m)
route
[(Text, Text)]
query <- YesodRequest -> [(Text, Text)]
reqGetParams (YesodRequest -> [(Text, Text)])
-> m YesodRequest -> m [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
RenderedRoute -> m RenderedRoute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RenderedRoute -> m RenderedRoute)
-> RenderedRoute -> m RenderedRoute
forall a b. (a -> b) -> a -> b
$ RenderedRoute :: Text -> [Text] -> [(Text, Text)] -> RenderedRoute
RenderedRoute
{ renderedApproot :: Text
renderedApproot = Text
""
, renderedRoutePath :: [Text]
renderedRoutePath = [Text]
path
, renderedRouteQuery :: [(Text, Text)]
renderedRouteQuery = [(Text, Text)]
query
}
getRenderedRouteAbsolute
:: (MonadHandler m, Yesod (HandlerSite m), RenderRoute (HandlerSite m))
=> m RenderedRoute
getRenderedRouteAbsolute :: m RenderedRoute
getRenderedRouteAbsolute = do
Route (HandlerSite m)
route <- m (Route (HandlerSite m))
-> (Route (HandlerSite m) -> m (Route (HandlerSite m)))
-> Maybe (Route (HandlerSite m))
-> m (Route (HandlerSite m))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m (Route (HandlerSite m))
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"no route") Route (HandlerSite m) -> m (Route (HandlerSite m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Route (HandlerSite m)) -> m (Route (HandlerSite m)))
-> m (Maybe (Route (HandlerSite m))) -> m (Route (HandlerSite m))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe (Route (HandlerSite m)))
forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute
let ([Text]
path, [(Text, Text)]
_query) = Route (HandlerSite m) -> ([Text], [(Text, Text)])
forall a. RenderRoute a => Route a -> ([Text], [(Text, Text)])
renderRoute Route (HandlerSite m)
route
[(Text, Text)]
query <- YesodRequest -> [(Text, Text)]
reqGetParams (YesodRequest -> [(Text, Text)])
-> m YesodRequest -> m [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
Text
root <- Approot (HandlerSite m) -> HandlerSite m -> Request -> Text
forall site. Approot site -> site -> Request -> Text
getApprootText Approot (HandlerSite m)
forall site. Yesod site => Approot site
approot (HandlerSite m -> Request -> Text)
-> m (HandlerSite m) -> m (Request -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod m (Request -> Text) -> m Request -> m Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
RenderedRoute -> m RenderedRoute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RenderedRoute -> m RenderedRoute)
-> RenderedRoute -> m RenderedRoute
forall a b. (a -> b) -> a -> b
$ RenderedRoute :: Text -> [Text] -> [(Text, Text)] -> RenderedRoute
RenderedRoute
{ renderedApproot :: Text
renderedApproot = Text
root
, renderedRoutePath :: [Text]
renderedRoutePath = [Text]
path
, renderedRouteQuery :: [(Text, Text)]
renderedRouteQuery = [(Text, Text)]
query
}
updateQueryParameter :: Text -> Maybe Text -> RenderedRoute -> RenderedRoute
updateQueryParameter :: Text -> Maybe Text -> RenderedRoute -> RenderedRoute
updateQueryParameter Text
name = ([(Text, Text)] -> [(Text, Text)])
-> RenderedRoute -> RenderedRoute
overQuery (([(Text, Text)] -> [(Text, Text)])
-> RenderedRoute -> RenderedRoute)
-> (Maybe Text -> [(Text, Text)] -> [(Text, Text)])
-> Maybe Text
-> RenderedRoute
-> RenderedRoute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Text Text -> Map Text Text)
-> [(Text, Text)] -> [(Text, Text)]
forall k v. Ord k => (Map k v -> Map k v) -> [(k, v)] -> [(k, v)]
asMap ((Map Text Text -> Map Text Text)
-> [(Text, Text)] -> [(Text, Text)])
-> (Maybe Text -> Map Text Text -> Map Text Text)
-> Maybe Text
-> [(Text, Text)]
-> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> Map Text Text -> Map Text Text
forall k v. Ord k => k -> Maybe v -> Map k v -> Map k v
updateKey Text
name
overQuery
:: ([(Text, Text)] -> [(Text, Text)]) -> RenderedRoute -> RenderedRoute
overQuery :: ([(Text, Text)] -> [(Text, Text)])
-> RenderedRoute -> RenderedRoute
overQuery [(Text, Text)] -> [(Text, Text)]
f RenderedRoute
renderedRoute =
RenderedRoute
renderedRoute { renderedRouteQuery :: [(Text, Text)]
renderedRouteQuery = [(Text, Text)] -> [(Text, Text)]
f ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ RenderedRoute -> [(Text, Text)]
renderedRouteQuery RenderedRoute
renderedRoute }
asMap :: Ord k => (Map k v -> Map k v) -> [(k, v)] -> [(k, v)]
asMap :: (Map k v -> Map k v) -> [(k, v)] -> [(k, v)]
asMap Map k v -> Map k v
f = Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map k v -> [(k, v)])
-> ([(k, v)] -> Map k v) -> [(k, v)] -> [(k, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> Map k v
f (Map k v -> Map k v)
-> ([(k, v)] -> Map k v) -> [(k, v)] -> Map k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
updateKey :: Ord k => k -> Maybe v -> Map k v -> Map k v
updateKey :: k -> Maybe v -> Map k v -> Map k v
updateKey k
k = (Map k v -> Map k v)
-> (v -> Map k v -> Map k v) -> Maybe v -> Map k v -> Map k v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (k -> Map k v -> Map k v
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
k) ((v -> Map k v -> Map k v) -> Maybe v -> Map k v -> Map k v)
-> (v -> Map k v -> Map k v) -> Maybe v -> Map k v -> Map k v
forall a b. (a -> b) -> a -> b
$ k -> v -> Map k v -> Map k v
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k