{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Yesod.Page.RenderedRoute
( RenderedRoute
, renderedRouteLink
, getRenderedRoute
, updateQueryParameter
)
where
import Data.Aeson
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text, intercalate, pack, unpack)
import Network.HTTP.Link
import Network.URI (URI(..), escapeURIString, isUnescapedInURIComponent)
import UnliftIO (throwString)
import Yesod.Core
( HandlerSite
, MonadHandler
, RenderRoute
, getCurrentRoute
, getRequest
, renderRoute
, reqGetParams
)
data RenderedRoute = RenderedRoute
{ renderedRoutePath :: [Text]
, renderedRouteQuery :: [(Text, Text)]
}
instance ToJSON RenderedRoute where
toJSON = String . pack . show . renderedRouteURI
renderedRouteLink :: Text -> RenderedRoute -> Link
renderedRouteLink rel = flip Link [(Rel, rel)] . renderedRouteURI
renderedRouteURI :: RenderedRoute -> URI
renderedRouteURI RenderedRoute {..} = URI
{ uriScheme = ""
, uriAuthority = Nothing
, uriPath = unpack $ "/" <> intercalate "/" renderedRoutePath
, uriQuery = unpack $ query renderedRouteQuery
, uriFragment = ""
}
where
query [] = ""
query qs = "?" <> intercalate "&" (parts qs)
parts = map $ \(k, v) -> k <> "=" <> escape v
escape = pack . escapeURIString isUnescapedInURIComponent . unpack
getRenderedRoute
:: (MonadHandler m, RenderRoute (HandlerSite m)) => m RenderedRoute
getRenderedRoute = do
route <- maybe (throwString "no route") pure =<< getCurrentRoute
let (path, _query) = renderRoute route
query <- reqGetParams <$> getRequest
pure $ RenderedRoute {renderedRoutePath = path, renderedRouteQuery = query}
updateQueryParameter :: Text -> Maybe Text -> RenderedRoute -> RenderedRoute
updateQueryParameter name = overQuery . asMap . updateKey name
overQuery
:: ([(Text, Text)] -> [(Text, Text)]) -> RenderedRoute -> RenderedRoute
overQuery f renderedRoute =
renderedRoute { renderedRouteQuery = f $ renderedRouteQuery renderedRoute }
asMap :: Ord k => (Map k v -> Map k v) -> [(k, v)] -> [(k, v)]
asMap f = Map.toList . f . Map.fromList
updateKey :: Ord k => k -> Maybe v -> Map k v -> Map k v
updateKey k = maybe (Map.delete k) $ Map.insert k