{-# 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
  )

-- | Information about a relative Route with query string
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

-- | Convert a @'RenderedRoute'@ into a @'Link'@ with the given @'Rel'@
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

-- | Convert a @'RenderedRoute'@ into a (relative) @'URI'@
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)

-- | Get the current route as a @'RenderedRoute'@
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

  -- When I just use _query, it's always empty. Why would renderRoute return
  -- this tuple if the Route value (apparently) never has the query information?
  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

  -- When I just use _query, it's always empty. Why would renderRoute return
  -- this tuple if the Route value (apparently) never has the query information?
  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
    }

-- | Update a single query parameter and preserve the rest
--
-- If given @'Nothing'@, the parameter is removed.
--
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

-- Lens? meh
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