{-# 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.Compat
import Network.URI (URI(..), escapeURIString, isUnescapedInURIComponent)
import UnliftIO (throwString)
import Yesod.Core
  ( HandlerSite
  , MonadHandler
  , RenderRoute
  , getCurrentRoute
  , getRequest
  , renderRoute
  , reqGetParams
  )

-- | Information about a relative Route with query string
data RenderedRoute = RenderedRoute
  { 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]
renderedRouteQuery :: [(Text, Text)]
renderedRoutePath :: [Text]
renderedRouteQuery :: RenderedRoute -> [(Text, Text)]
renderedRoutePath :: RenderedRoute -> [Text]
..} = URI :: String -> Maybe URIAuth -> String -> String -> String -> URI
URI
  { uriScheme :: String
uriScheme = String
""
  , uriAuthority :: Maybe URIAuth
uriAuthority = Maybe URIAuth
forall a. Maybe a
Nothing
  , 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

-- | 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)] -> RenderedRoute
RenderedRoute { 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