{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      :  Text.URI.Render
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- URI renders, an internal module.
module Text.URI.Render
  ( render,
    render',
    renderBs,
    renderBs',
    renderStr,
    renderStr',
  )
where

import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import Data.Char (chr, intToDigit)
import Data.Kind (Type)
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Proxy
import Data.Reflection
import qualified Data.Semigroup as S
import Data.String (IsString (..))
import Data.Tagged
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder.Int as TLB
import Data.Word (Word8)
import Numeric (showInt)
import Text.URI.Types

----------------------------------------------------------------------------
-- High-level wrappers

-- | Render a given 'URI' value as strict 'Text'.
render :: URI -> Text
render :: URI -> Text
render = LazyText -> Text
TL.toStrict (LazyText -> Text) -> (URI -> LazyText) -> URI -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyText
TLB.toLazyText (Builder -> LazyText) -> (URI -> Builder) -> URI -> LazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Builder
render'

-- | Render a given 'URI' value as a 'TLB.Builder'.
render' :: URI -> TLB.Builder
render' :: URI -> Builder
render' URI
x =
  (Word -> Builder)
-> (forall (l :: RTextLabel).
    RLabel l =>
    Maybe Word8 -> RText l -> Builder)
-> (forall s. Reifies s (Renders Builder) => Tagged s Builder)
-> Builder
forall b.
(Word -> b)
-> (forall (l :: RTextLabel).
    RLabel l =>
    Maybe Word8 -> RText l -> b)
-> (forall s. Reifies s (Renders b) => Tagged s b)
-> b
equip
    Word -> Builder
forall a. Integral a => a -> Builder
TLB.decimal
    ( \Maybe Word8
mw RText l
r ->
        Text -> Builder
TLB.fromText
          ( Maybe (RText 'Scheme) -> Maybe Word8 -> RText l -> Text
forall (l :: RTextLabel).
RLabel l =>
Maybe (RText 'Scheme) -> Maybe Word8 -> RText l -> Text
percentEncode
              (URI -> Maybe (RText 'Scheme)
uriScheme URI
x)
              (URI -> Maybe Word8 -> Maybe Word8
mediateExtraEscaping URI
x Maybe Word8
mw)
              RText l
r
          )
    )
    (URI -> Tagged s Builder
forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
URI -> Tagged s b
genericRender URI
x)

-- | Render a given 'URI' value as a strict 'ByteString'.
renderBs :: URI -> ByteString
renderBs :: URI -> ByteString
renderBs = LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString)
-> (URI -> LazyByteString) -> URI -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
BB.toLazyByteString (Builder -> LazyByteString)
-> (URI -> Builder) -> URI -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Builder
renderBs'

-- | Render a given 'URI' value as a 'BB.Builder'.
renderBs' :: URI -> BB.Builder
renderBs' :: URI -> Builder
renderBs' URI
x =
  (Word -> Builder)
-> (forall (l :: RTextLabel).
    RLabel l =>
    Maybe Word8 -> RText l -> Builder)
-> (forall s. Reifies s (Renders Builder) => Tagged s Builder)
-> Builder
forall b.
(Word -> b)
-> (forall (l :: RTextLabel).
    RLabel l =>
    Maybe Word8 -> RText l -> b)
-> (forall s. Reifies s (Renders b) => Tagged s b)
-> b
equip
    Word -> Builder
BB.wordDec
    ( \Maybe Word8
mw RText l
r ->
        ByteString -> Builder
BB.byteString
          ( Text -> ByteString
TE.encodeUtf8
              ( Maybe (RText 'Scheme) -> Maybe Word8 -> RText l -> Text
forall (l :: RTextLabel).
RLabel l =>
Maybe (RText 'Scheme) -> Maybe Word8 -> RText l -> Text
percentEncode
                  (URI -> Maybe (RText 'Scheme)
uriScheme URI
x)
                  (URI -> Maybe Word8 -> Maybe Word8
mediateExtraEscaping URI
x Maybe Word8
mw)
                  RText l
r
              )
          )
    )
    (URI -> Tagged s Builder
forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
URI -> Tagged s b
genericRender URI
x)

-- | Render a given 'URI' value as a 'String'.
--
-- @since 0.0.2.0
renderStr :: URI -> String
renderStr :: URI -> String
renderStr = ((String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ []) ((String -> String) -> String)
-> (URI -> String -> String) -> URI -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String -> String
renderStr'

-- | Render a given 'URI' value as 'ShowS'.
--
-- @since 0.0.2.0
renderStr' :: URI -> ShowS
renderStr' :: URI -> String -> String
renderStr' URI
x =
  DString -> String -> String
toShowS (DString -> String -> String) -> DString -> String -> String
forall a b. (a -> b) -> a -> b
$
    (Word -> DString)
-> (forall (l :: RTextLabel).
    RLabel l =>
    Maybe Word8 -> RText l -> DString)
-> (forall s. Reifies s (Renders DString) => Tagged s DString)
-> DString
forall b.
(Word -> b)
-> (forall (l :: RTextLabel).
    RLabel l =>
    Maybe Word8 -> RText l -> b)
-> (forall s. Reifies s (Renders b) => Tagged s b)
-> b
equip
      ((String -> String) -> DString
DString ((String -> String) -> DString)
-> (Word -> String -> String) -> Word -> DString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String -> String
forall a. Integral a => a -> String -> String
showInt)
      ( \Maybe Word8
mw RText l
r ->
          String -> DString
forall a. IsString a => String -> a
fromString
            ( Text -> String
T.unpack
                ( Maybe (RText 'Scheme) -> Maybe Word8 -> RText l -> Text
forall (l :: RTextLabel).
RLabel l =>
Maybe (RText 'Scheme) -> Maybe Word8 -> RText l -> Text
percentEncode
                    (URI -> Maybe (RText 'Scheme)
uriScheme URI
x)
                    (URI -> Maybe Word8 -> Maybe Word8
mediateExtraEscaping URI
x Maybe Word8
mw)
                    RText l
r
                )
            )
      )
      (URI -> Tagged s DString
forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
URI -> Tagged s b
genericRender URI
x)

-- | This is a (slightly hackish) way used to only escape ':' in the first
-- path segment and only if there no scheme and no authority component.
mediateExtraEscaping :: URI -> Maybe Word8 -> Maybe Word8
mediateExtraEscaping :: URI -> Maybe Word8 -> Maybe Word8
mediateExtraEscaping URI
uri Maybe Word8
mw =
  case (URI -> Maybe (RText 'Scheme)
uriScheme URI
uri, URI -> Either Bool Authority
uriAuthority URI
uri) of
    (Maybe (RText 'Scheme)
Nothing, Left Bool
_) -> Maybe Word8
mw
    (Maybe (RText 'Scheme), Either Bool Authority)
_ -> Maybe Word8
forall a. Maybe a
Nothing

----------------------------------------------------------------------------
-- Reflection stuff

data Renders b = Renders
  { forall b. Renders b -> Word -> b
rWord :: Word -> b,
    forall b.
Renders b
-> forall (l :: RTextLabel).
   RLabel l =>
   Maybe Word8 -> RText l -> b
rText :: forall l. (RLabel l) => Maybe Word8 -> RText l -> b
  }

equip ::
  forall b.
  (Word -> b) ->
  (forall l. (RLabel l) => Maybe Word8 -> RText l -> b) ->
  (forall (s :: Type). (Reifies s (Renders b)) => Tagged s b) ->
  b
equip :: forall b.
(Word -> b)
-> (forall (l :: RTextLabel).
    RLabel l =>
    Maybe Word8 -> RText l -> b)
-> (forall s. Reifies s (Renders b) => Tagged s b)
-> b
equip Word -> b
rWord forall (l :: RTextLabel). RLabel l => Maybe Word8 -> RText l -> b
rText forall s. Reifies s (Renders b) => Tagged s b
f = Renders b -> (forall s. Reifies s (Renders b) => Proxy s -> b) -> b
forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify Renders {Maybe Word8 -> RText l -> b
Word -> b
forall (l :: RTextLabel). RLabel l => Maybe Word8 -> RText l -> b
rWord :: Word -> b
rText :: forall (l :: RTextLabel). RLabel l => Maybe Word8 -> RText l -> b
rWord :: Word -> b
rText :: forall (l :: RTextLabel). RLabel l => Maybe Word8 -> RText l -> b
..} ((forall s. Reifies s (Renders b) => Proxy s -> b) -> b)
-> (forall s. Reifies s (Renders b) => Proxy s -> b) -> b
forall a b. (a -> b) -> a -> b
$ \(Proxy s
Proxy :: Proxy s') ->
  Tagged s b -> b
forall {k} (s :: k) b. Tagged s b -> b
unTagged (Tagged s b
forall s. Reifies s (Renders b) => Tagged s b
f :: Tagged s' b)

renderWord ::
  forall s b.
  (Reifies s (Renders b)) =>
  Word ->
  Tagged s b
renderWord :: forall s b. Reifies s (Renders b) => Word -> Tagged s b
renderWord = b -> Tagged s b
forall {k} (s :: k) b. b -> Tagged s b
Tagged (b -> Tagged s b) -> (Word -> b) -> Word -> Tagged s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Renders b -> Word -> b
forall b. Renders b -> Word -> b
rWord (Proxy s -> Renders b
forall {k} (s :: k) a (proxy :: k -> *).
Reifies s a =>
proxy s -> a
forall (proxy :: * -> *). proxy s -> Renders b
reflect (Proxy s
forall {k} (t :: k). Proxy t
Proxy :: Proxy s))

renderText ::
  forall s b l.
  (Reifies s (Renders b), RLabel l) =>
  RText l ->
  Tagged s b
renderText :: forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
RText l -> Tagged s b
renderText = b -> Tagged s b
forall {k} (s :: k) b. b -> Tagged s b
Tagged (b -> Tagged s b) -> (RText l -> b) -> RText l -> Tagged s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Renders b
-> forall (l :: RTextLabel).
   RLabel l =>
   Maybe Word8 -> RText l -> b
forall b.
Renders b
-> forall (l :: RTextLabel).
   RLabel l =>
   Maybe Word8 -> RText l -> b
rText (Proxy s -> Renders b
forall {k} (s :: k) a (proxy :: k -> *).
Reifies s a =>
proxy s -> a
forall (proxy :: * -> *). proxy s -> Renders b
reflect (Proxy s
forall {k} (t :: k). Proxy t
Proxy :: Proxy s)) Maybe Word8
forall a. Maybe a
Nothing

renderTextEscaping ::
  forall s b l.
  (Reifies s (Renders b), RLabel l) =>
  Word8 ->
  RText l ->
  Tagged s b
renderTextEscaping :: forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
Word8 -> RText l -> Tagged s b
renderTextEscaping Word8
w = b -> Tagged s b
forall {k} (s :: k) b. b -> Tagged s b
Tagged (b -> Tagged s b) -> (RText l -> b) -> RText l -> Tagged s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Renders b
-> forall (l :: RTextLabel).
   RLabel l =>
   Maybe Word8 -> RText l -> b
forall b.
Renders b
-> forall (l :: RTextLabel).
   RLabel l =>
   Maybe Word8 -> RText l -> b
rText (Proxy s -> Renders b
forall {k} (s :: k) a (proxy :: k -> *).
Reifies s a =>
proxy s -> a
forall (proxy :: * -> *). proxy s -> Renders b
reflect (Proxy s
forall {k} (t :: k). Proxy t
Proxy :: Proxy s)) (Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
w)

----------------------------------------------------------------------------
-- Generic render

type Render a b =
  forall (s :: Type).
  (Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
  a ->
  Tagged s b

genericRender :: Render URI b
genericRender :: forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
URI -> Tagged s b
genericRender URI {[QueryParam]
Maybe (Bool, NonEmpty (RText 'PathPiece))
Maybe (RText 'Scheme)
Maybe (RText 'Fragment)
Either Bool Authority
uriScheme :: URI -> Maybe (RText 'Scheme)
uriAuthority :: URI -> Either Bool Authority
uriScheme :: Maybe (RText 'Scheme)
uriAuthority :: Either Bool Authority
uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriQuery :: [QueryParam]
uriFragment :: Maybe (RText 'Fragment)
uriFragment :: URI -> Maybe (RText 'Fragment)
uriQuery :: URI -> [QueryParam]
uriPath :: URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
..} =
  [Tagged s b] -> Tagged s b
forall a. Monoid a => [a] -> a
mconcat
    [ (RText 'Scheme -> Tagged s b)
-> Maybe (RText 'Scheme) -> Tagged s b
forall m a. Monoid m => (a -> m) -> Maybe a -> m
rJust RText 'Scheme -> Tagged s b
forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
RText 'Scheme -> Tagged s b
rScheme Maybe (RText 'Scheme)
uriScheme,
      (Authority -> Tagged s b) -> Maybe Authority -> Tagged s b
forall m a. Monoid m => (a -> m) -> Maybe a -> m
rJust Authority -> Tagged s b
forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
Authority -> Tagged s b
rAuthority ((Bool -> Maybe Authority)
-> (Authority -> Maybe Authority)
-> Either Bool Authority
-> Maybe Authority
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Authority -> Bool -> Maybe Authority
forall a b. a -> b -> a
const Maybe Authority
forall a. Maybe a
Nothing) Authority -> Maybe Authority
forall a. a -> Maybe a
Just Either Bool Authority
uriAuthority),
      Either Bool Authority
-> Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b
forall a b.
Either Bool a
-> Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b
rAbsPathSlash Either Bool Authority
uriAuthority Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath,
      Maybe (Bool, NonEmpty (RText 'PathPiece)) -> Tagged s b
forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
Maybe (Bool, NonEmpty (RText 'PathPiece)) -> Tagged s b
rPath Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath,
      [QueryParam] -> Tagged s b
forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
[QueryParam] -> Tagged s b
rQuery [QueryParam]
uriQuery,
      (RText 'Fragment -> Tagged s b)
-> Maybe (RText 'Fragment) -> Tagged s b
forall m a. Monoid m => (a -> m) -> Maybe a -> m
rJust RText 'Fragment -> Tagged s b
forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
RText 'Fragment -> Tagged s b
rFragment Maybe (RText 'Fragment)
uriFragment
    ]
{-# INLINE genericRender #-}

rJust :: (Monoid m) => (a -> m) -> Maybe a -> m
rJust :: forall m a. Monoid m => (a -> m) -> Maybe a -> m
rJust = m -> (a -> m) -> Maybe a -> m
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m
forall a. Monoid a => a
mempty

rScheme :: Render (RText 'Scheme) b
rScheme :: forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
RText 'Scheme -> Tagged s b
rScheme = (Tagged s b -> Tagged s b -> Tagged s b
forall a. Semigroup a => a -> a -> a
<> Tagged s b
":") (Tagged s b -> Tagged s b)
-> (RText 'Scheme -> Tagged s b) -> RText 'Scheme -> Tagged s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RText 'Scheme -> Tagged s b
forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
RText l -> Tagged s b
renderText
{-# INLINE rScheme #-}

rAuthority :: Render Authority b
rAuthority :: forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
Authority -> Tagged s b
rAuthority Authority {Maybe Word
Maybe UserInfo
RText 'Host
authUserInfo :: Maybe UserInfo
authHost :: RText 'Host
authPort :: Maybe Word
authPort :: Authority -> Maybe Word
authHost :: Authority -> RText 'Host
authUserInfo :: Authority -> Maybe UserInfo
..} =
  [Tagged s b] -> Tagged s b
forall a. Monoid a => [a] -> a
mconcat
    [ Tagged s b
"//",
      (UserInfo -> Tagged s b) -> Maybe UserInfo -> Tagged s b
forall m a. Monoid m => (a -> m) -> Maybe a -> m
rJust UserInfo -> Tagged s b
forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
UserInfo -> Tagged s b
rUserInfo Maybe UserInfo
authUserInfo,
      RText 'Host -> Tagged s b
forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
RText l -> Tagged s b
renderText RText 'Host
authHost,
      (Word -> Tagged s b) -> Maybe Word -> Tagged s b
forall m a. Monoid m => (a -> m) -> Maybe a -> m
rJust ((Tagged s b
":" Tagged s b -> Tagged s b -> Tagged s b
forall a. Semigroup a => a -> a -> a
<>) (Tagged s b -> Tagged s b)
-> (Word -> Tagged s b) -> Word -> Tagged s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Tagged s b
forall s b. Reifies s (Renders b) => Word -> Tagged s b
renderWord) Maybe Word
authPort
    ]
{-# INLINE rAuthority #-}

rUserInfo :: Render UserInfo b
rUserInfo :: forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
UserInfo -> Tagged s b
rUserInfo UserInfo {Maybe (RText 'Password)
RText 'Username
uiUsername :: RText 'Username
uiPassword :: Maybe (RText 'Password)
uiPassword :: UserInfo -> Maybe (RText 'Password)
uiUsername :: UserInfo -> RText 'Username
..} =
  [Tagged s b] -> Tagged s b
forall a. Monoid a => [a] -> a
mconcat
    [ RText 'Username -> Tagged s b
forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
RText l -> Tagged s b
renderText RText 'Username
uiUsername,
      (RText 'Password -> Tagged s b)
-> Maybe (RText 'Password) -> Tagged s b
forall m a. Monoid m => (a -> m) -> Maybe a -> m
rJust ((Tagged s b
":" Tagged s b -> Tagged s b -> Tagged s b
forall a. Semigroup a => a -> a -> a
<>) (Tagged s b -> Tagged s b)
-> (RText 'Password -> Tagged s b) -> RText 'Password -> Tagged s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RText 'Password -> Tagged s b
forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
RText l -> Tagged s b
renderText) Maybe (RText 'Password)
uiPassword,
      Tagged s b
"@"
    ]
{-# INLINE rUserInfo #-}

rAbsPathSlash ::
  Either Bool a ->
  Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b
rAbsPathSlash :: forall a b.
Either Bool a
-> Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b
rAbsPathSlash (Left Bool
isAbsolute) Maybe (Bool, NonEmpty (RText 'PathPiece))
_ = if Bool
isAbsolute then Tagged s b
"/" else Tagged s b
forall a. Monoid a => a
mempty
rAbsPathSlash (Right a
_) Maybe (Bool, NonEmpty (RText 'PathPiece))
Nothing = Tagged s b
forall a. Monoid a => a
mempty
rAbsPathSlash (Right a
_) (Just (Bool, NonEmpty (RText 'PathPiece))
_) = Tagged s b
"/"
{-# INLINE rAbsPathSlash #-}

rPath :: Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b
rPath :: forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
Maybe (Bool, NonEmpty (RText 'PathPiece)) -> Tagged s b
rPath Maybe (Bool, NonEmpty (RText 'PathPiece))
path =
  case Maybe (Bool, NonEmpty (RText 'PathPiece))
path of
    Maybe (Bool, NonEmpty (RText 'PathPiece))
Nothing -> Tagged s b
forall a. Monoid a => a
mempty
    Just (Bool
trailingSlash, NonEmpty (RText 'PathPiece)
ps) ->
      ( [Tagged s b] -> Tagged s b
forall a. Monoid a => [a] -> a
mconcat ([Tagged s b] -> Tagged s b)
-> ([Tagged s b] -> [Tagged s b]) -> [Tagged s b] -> Tagged s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged s b -> [Tagged s b] -> [Tagged s b]
forall a. a -> [a] -> [a]
intersperse Tagged s b
"/" ([Tagged s b] -> Tagged s b) -> [Tagged s b] -> Tagged s b
forall a b. (a -> b) -> a -> b
$ case NonEmpty (RText 'PathPiece)
ps of
          (RText 'PathPiece
x :| [RText 'PathPiece]
xs) -> Word8 -> RText 'PathPiece -> Tagged s b
forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
Word8 -> RText l -> Tagged s b
renderTextEscaping Word8
58 RText 'PathPiece
x Tagged s b -> [Tagged s b] -> [Tagged s b]
forall a. a -> [a] -> [a]
: (RText 'PathPiece -> Tagged s b)
-> [RText 'PathPiece] -> [Tagged s b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RText 'PathPiece -> Tagged s b
forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
RText l -> Tagged s b
renderText [RText 'PathPiece]
xs
      )
        Tagged s b -> Tagged s b -> Tagged s b
forall a. Semigroup a => a -> a -> a
<> if Bool
trailingSlash then Tagged s b
"/" else Tagged s b
forall a. Monoid a => a
mempty
{-# INLINE rPath #-}

rQuery :: Render [QueryParam] b
rQuery :: forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
[QueryParam] -> Tagged s b
rQuery = \case
  [] -> Tagged s b
forall a. Monoid a => a
mempty
  [QueryParam]
qs -> Tagged s b
"?" Tagged s b -> Tagged s b -> Tagged s b
forall a. Semigroup a => a -> a -> a
<> [Tagged s b] -> Tagged s b
forall a. Monoid a => [a] -> a
mconcat (Tagged s b -> [Tagged s b] -> [Tagged s b]
forall a. a -> [a] -> [a]
intersperse Tagged s b
"&" (QueryParam -> Tagged s b
forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
QueryParam -> Tagged s b
rQueryParam (QueryParam -> Tagged s b) -> [QueryParam] -> [Tagged s b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QueryParam]
qs))
{-# INLINE rQuery #-}

rQueryParam :: Render QueryParam b
rQueryParam :: forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
QueryParam -> Tagged s b
rQueryParam = \case
  QueryFlag RText 'QueryKey
flag -> RText 'QueryKey -> Tagged s b
forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
RText l -> Tagged s b
renderText RText 'QueryKey
flag
  QueryParam RText 'QueryKey
k RText 'QueryValue
v -> RText 'QueryKey -> Tagged s b
forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
RText l -> Tagged s b
renderText RText 'QueryKey
k Tagged s b -> Tagged s b -> Tagged s b
forall a. Semigroup a => a -> a -> a
<> Tagged s b
"=" Tagged s b -> Tagged s b -> Tagged s b
forall a. Semigroup a => a -> a -> a
<> RText 'QueryValue -> Tagged s b
forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
RText l -> Tagged s b
renderText RText 'QueryValue
v
{-# INLINE rQueryParam #-}

rFragment :: Render (RText 'Fragment) b
rFragment :: forall b s.
(Semigroup b, Monoid b, IsString b, Reifies s (Renders b)) =>
RText 'Fragment -> Tagged s b
rFragment = (Tagged s b
"#" Tagged s b -> Tagged s b -> Tagged s b
forall a. Semigroup a => a -> a -> a
<>) (Tagged s b -> Tagged s b)
-> (RText 'Fragment -> Tagged s b) -> RText 'Fragment -> Tagged s b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RText 'Fragment -> Tagged s b
forall s b (l :: RTextLabel).
(Reifies s (Renders b), RLabel l) =>
RText l -> Tagged s b
renderText
{-# INLINE rFragment #-}

----------------------------------------------------------------------------
-- DString

newtype DString = DString {DString -> String -> String
toShowS :: ShowS}

instance S.Semigroup DString where
  DString String -> String
a <> :: DString -> DString -> DString
<> DString String -> String
b = (String -> String) -> DString
DString (String -> String
a (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
b)

instance Monoid DString where
  mempty :: DString
mempty = (String -> String) -> DString
DString String -> String
forall a. a -> a
id
  mappend :: DString -> DString -> DString
mappend = DString -> DString -> DString
forall a. Semigroup a => a -> a -> a
(S.<>)

instance IsString DString where
  fromString :: String -> DString
fromString String
str = (String -> String) -> DString
DString (String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++)

----------------------------------------------------------------------------
-- Percent-encoding

-- | Percent-encode a 'Text' value.
percentEncode ::
  forall l.
  (RLabel l) =>
  -- | Scheme of the URI
  Maybe (RText 'Scheme) ->
  -- | A byte to additionally escape
  Maybe Word8 ->
  -- | Input text to encode
  RText l ->
  -- | Percent-encoded text
  Text
percentEncode :: forall (l :: RTextLabel).
RLabel l =>
Maybe (RText 'Scheme) -> Maybe Word8 -> RText l -> Text
percentEncode Maybe (RText 'Scheme)
mscheme Maybe Word8
alsoEscape RText l
rtxt =
  if Proxy l -> Text -> Bool
forall (l :: RTextLabel). RLabel l => Proxy l -> Text -> Bool
skipEscaping (Proxy l
forall {k} (t :: k). Proxy t
Proxy :: Proxy l) Text
txt
    then Text
txt
    else ((ByteString, String) -> Maybe (Char, (ByteString, String)))
-> (ByteString, String) -> Text
forall a. (a -> Maybe (Char, a)) -> a -> Text
T.unfoldr (ByteString, String) -> Maybe (Char, (ByteString, String))
f (Text -> ByteString
TE.encodeUtf8 Text
txt, [])
  where
    f :: (ByteString, String) -> Maybe (Char, (ByteString, String))
f (ByteString
bs', []) =
      case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs' of
        Maybe (Word8, ByteString)
Nothing -> Maybe (Char, (ByteString, String))
forall a. Maybe a
Nothing
        Just (Word8
w, ByteString
bs'') ->
          (Char, (ByteString, String)) -> Maybe (Char, (ByteString, String))
forall a. a -> Maybe a
Just ((Char, (ByteString, String))
 -> Maybe (Char, (ByteString, String)))
-> (Char, (ByteString, String))
-> Maybe (Char, (ByteString, String))
forall a b. (a -> b) -> a -> b
$
            if
              | Bool
sap Bool -> Bool -> Bool
&& Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32 -> (Char
'+', (ByteString
bs'', []))
              | Word8 -> Bool
nne Word8
w -> (Int -> Char
chr (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w), (ByteString
bs'', []))
              | Bool
otherwise ->
                  let Char
c :| String
cs = Word8 -> NonEmpty Char
forall {p}. Integral p => p -> NonEmpty Char
encodeByte Word8
w
                   in (Char
c, (ByteString
bs'', String
cs))
    f (ByteString
bs', Char
x : String
xs) = (Char, (ByteString, String)) -> Maybe (Char, (ByteString, String))
forall a. a -> Maybe a
Just (Char
x, (ByteString
bs', String
xs))
    encodeByte :: p -> NonEmpty Char
encodeByte p
x = Char
'%' Char -> String -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:| [Int -> Char
intToDigit Int
h, Int -> Char
intToDigit Int
l]
      where
        (Int
h, Int
l) = p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
x Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
16
    nne :: Word8 -> Bool
nne Word8
w =
      let normalCase :: Bool
normalCase = Proxy l -> Maybe (RText 'Scheme) -> Word8 -> Bool
forall (l :: RTextLabel).
RLabel l =>
Proxy l -> Maybe (RText 'Scheme) -> Word8 -> Bool
needsNoEscaping (Proxy l
forall {k} (t :: k). Proxy t
Proxy :: Proxy l) Maybe (RText 'Scheme)
mscheme Word8
w
       in case Maybe Word8
alsoEscape of
            Maybe Word8
Nothing -> Bool
normalCase
            Just Word8
w' -> if Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
w' then Bool
False else Bool
normalCase
    sap :: Bool
sap = Proxy l -> Bool
forall (l :: RTextLabel). RLabel l => Proxy l -> Bool
spaceAsPlus (Proxy l
forall {k} (t :: k). Proxy t
Proxy :: Proxy l)
    txt :: Text
txt = RText l -> Text
forall (l :: RTextLabel). RText l -> Text
unRText RText l
rtxt
{-# INLINE percentEncode #-}

-- | This type class attaches some predicates that control serialization to
-- the type level label of kind 'RTextLabel'.
class RLabel (l :: RTextLabel) where
  -- | The predicate selects bytes that are not to be percent-escaped in
  -- rendered URI.
  needsNoEscaping :: Proxy l -> Maybe (RText 'Scheme) -> Word8 -> Bool

  -- | Whether to serialize space as the plus sign.
  spaceAsPlus :: Proxy l -> Bool
  spaceAsPlus Proxy l
Proxy = Bool
False

  -- | Whether to skip percent-escaping altogether for this value.
  skipEscaping :: Proxy l -> Text -> Bool
  skipEscaping Proxy l
Proxy Text
_ = Bool
False

instance RLabel 'Scheme where
  needsNoEscaping :: Proxy 'Scheme -> Maybe (RText 'Scheme) -> Word8 -> Bool
needsNoEscaping Proxy 'Scheme
Proxy Maybe (RText 'Scheme)
_ Word8
x = Word8 -> Bool
isAlphaNum Word8
x Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
43 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
45 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
46

instance RLabel 'Host where
  needsNoEscaping :: Proxy 'Host -> Maybe (RText 'Scheme) -> Word8 -> Bool
needsNoEscaping Proxy 'Host
Proxy Maybe (RText 'Scheme)
_ Word8
x = Word8 -> Bool
isUnreserved Word8
x Bool -> Bool -> Bool
|| Word8 -> Bool
isDelim Word8
x
  skipEscaping :: Proxy 'Host -> Text -> Bool
skipEscaping Proxy 'Host
Proxy Text
x = Int -> Text -> Text
T.take Int
1 Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"["

instance RLabel 'Username where
  needsNoEscaping :: Proxy 'Username -> Maybe (RText 'Scheme) -> Word8 -> Bool
needsNoEscaping Proxy 'Username
Proxy Maybe (RText 'Scheme)
_ Word8
x = Word8 -> Bool
isUnreserved Word8
x Bool -> Bool -> Bool
|| Word8 -> Bool
isDelim Word8
x

instance RLabel 'Password where
  needsNoEscaping :: Proxy 'Password -> Maybe (RText 'Scheme) -> Word8 -> Bool
needsNoEscaping Proxy 'Password
Proxy Maybe (RText 'Scheme)
_ Word8
x = Word8 -> Bool
isUnreserved Word8
x Bool -> Bool -> Bool
|| Word8 -> Bool
isDelim Word8
x Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
58

instance RLabel 'PathPiece where
  needsNoEscaping :: Proxy 'PathPiece -> Maybe (RText 'Scheme) -> Word8 -> Bool
needsNoEscaping Proxy 'PathPiece
Proxy Maybe (RText 'Scheme)
mscheme Word8
x =
    case Maybe (RText 'Scheme)
mscheme of
      Maybe (RText 'Scheme)
Nothing -> Bool
commonCase
      Just RText 'Scheme
scheme ->
        if RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
unRText RText 'Scheme
scheme Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"mailto"
          then Bool
commonCase Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
64
          else Bool
commonCase
    where
      commonCase :: Bool
commonCase = Word8 -> Bool
isUnreserved Word8
x Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
58

instance RLabel 'QueryKey where
  needsNoEscaping :: Proxy 'QueryKey -> Maybe (RText 'Scheme) -> Word8 -> Bool
needsNoEscaping Proxy 'QueryKey
Proxy Maybe (RText 'Scheme)
_ Word8
x =
    (Word8 -> Bool) -> Word8 -> Bool
isPChar Word8 -> Bool
isDelim' Word8
x Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
47 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
63
  spaceAsPlus :: Proxy 'QueryKey -> Bool
spaceAsPlus Proxy 'QueryKey
Proxy = Bool
True

instance RLabel 'QueryValue where
  needsNoEscaping :: Proxy 'QueryValue -> Maybe (RText 'Scheme) -> Word8 -> Bool
needsNoEscaping Proxy 'QueryValue
Proxy Maybe (RText 'Scheme)
_ Word8
x =
    (Word8 -> Bool) -> Word8 -> Bool
isPChar Word8 -> Bool
isDelim' Word8
x Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
47 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
63
  spaceAsPlus :: Proxy 'QueryValue -> Bool
spaceAsPlus Proxy 'QueryValue
Proxy = Bool
True

instance RLabel 'Fragment where
  needsNoEscaping :: Proxy 'Fragment -> Maybe (RText 'Scheme) -> Word8 -> Bool
needsNoEscaping Proxy 'Fragment
Proxy Maybe (RText 'Scheme)
_ Word8
x =
    (Word8 -> Bool) -> Word8 -> Bool
isPChar Word8 -> Bool
isDelim Word8
x Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
47 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
63

isPChar :: (Word8 -> Bool) -> Word8 -> Bool
isPChar :: (Word8 -> Bool) -> Word8 -> Bool
isPChar Word8 -> Bool
f Word8
x = Word8 -> Bool
isUnreserved Word8
x Bool -> Bool -> Bool
|| Word8 -> Bool
f Word8
x Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
58 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
64

isUnreserved :: Word8 -> Bool
isUnreserved :: Word8 -> Bool
isUnreserved Word8
x = Word8 -> Bool
isAlphaNum Word8
x Bool -> Bool -> Bool
|| Bool
other
  where
    other :: Bool
other = case Word8
x of
      Word8
45 -> Bool
True
      Word8
46 -> Bool
True
      Word8
95 -> Bool
True
      Word8
126 -> Bool
True
      Word8
_ -> Bool
False

isAlphaNum :: Word8 -> Bool
isAlphaNum :: Word8 -> Bool
isAlphaNum Word8
x
  | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
65 Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
90 = Bool
True -- 'A'..'Z'
  | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
97 Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
122 = Bool
True -- 'a'..'z'
  | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
57 = Bool
True -- '0'..'9'
  | Bool
otherwise = Bool
False

isDelim :: Word8 -> Bool
isDelim :: Word8 -> Bool
isDelim Word8
x
  | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
33 = Bool
True
  | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
36 = Bool
True
  | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
38 Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
44 = Bool
True
  | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
59 = Bool
True
  | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
61 = Bool
True
  | Bool
otherwise = Bool
False

isDelim' :: Word8 -> Bool
isDelim' :: Word8 -> Bool
isDelim' Word8
x
  | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
33 = Bool
True
  | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
36 = Bool
True
  | Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
39 Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
42 = Bool
True
  | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
44 = Bool
True
  | Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
59 = Bool
True
  | Bool
otherwise = Bool
False