{-# 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 qualified Data.List.NonEmpty as NE
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 = Text -> Text
TL.toStrict (Text -> Text) -> (URI -> Text) -> URI -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TLB.toLazyText (Builder -> Text) -> (URI -> Builder) -> URI -> Text
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 => RText l -> Builder)
-> (forall s. Reifies s (Renders Builder) => Tagged s Builder)
-> Builder
forall b.
(Word -> b)
-> (forall (l :: RTextLabel). RLabel l => RText l -> b)
-> (forall s. Reifies s (Renders b) => Tagged s b)
-> b
equip
    Word -> Builder
forall a. Integral a => a -> Builder
TLB.decimal
    (Text -> Builder
TLB.fromText (Text -> Builder) -> (RText l -> Text) -> RText l -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (RText 'Scheme) -> RText l -> Text
forall (l :: RTextLabel).
RLabel l =>
Maybe (RText 'Scheme) -> RText l -> Text
percentEncode (URI -> Maybe (RText 'Scheme)
uriScheme URI
x))
    (URI -> Tagged s Builder
forall b. Render URI b
genericRender URI
x)

-- | Render a given 'URI' value as a strict 'ByteString'.
renderBs :: URI -> ByteString
renderBs :: URI -> ByteString
renderBs = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (URI -> ByteString) -> URI -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> (URI -> Builder) -> URI -> ByteString
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 => RText l -> Builder)
-> (forall s. Reifies s (Renders Builder) => Tagged s Builder)
-> Builder
forall b.
(Word -> b)
-> (forall (l :: RTextLabel). RLabel l => RText l -> b)
-> (forall s. Reifies s (Renders b) => Tagged s b)
-> b
equip
    Word -> Builder
BB.wordDec
    (ByteString -> Builder
BB.byteString (ByteString -> Builder)
-> (RText l -> ByteString) -> RText l -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> (RText l -> Text) -> RText l -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (RText 'Scheme) -> RText l -> Text
forall (l :: RTextLabel).
RLabel l =>
Maybe (RText 'Scheme) -> RText l -> Text
percentEncode (URI -> Maybe (RText 'Scheme)
uriScheme URI
x))
    (URI -> Tagged s Builder
forall b. Render URI 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 => RText l -> DString)
-> (forall s. Reifies s (Renders DString) => Tagged s DString)
-> DString
forall b.
(Word -> b)
-> (forall (l :: RTextLabel). RLabel l => 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)
      (String -> DString
forall a. IsString a => String -> a
fromString (String -> DString) -> (RText l -> String) -> RText l -> DString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (RText l -> Text) -> RText l -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (RText 'Scheme) -> RText l -> Text
forall (l :: RTextLabel).
RLabel l =>
Maybe (RText 'Scheme) -> RText l -> Text
percentEncode (URI -> Maybe (RText 'Scheme)
uriScheme URI
x))
      (URI -> Tagged s DString
forall b. Render URI b
genericRender URI
x)

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

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

equip ::
  forall b.
  (Word -> b) ->
  (forall l. RLabel l => RText l -> b) ->
  (forall (s :: Type). Reifies s (Renders b) => Tagged s b) ->
  b
equip :: (Word -> b)
-> (forall (l :: RTextLabel). RLabel l => RText l -> b)
-> (forall s. Reifies s (Renders b) => Tagged s b)
-> b
equip Word -> b
rWord forall (l :: RTextLabel). RLabel l => 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 :: forall b.
(Word -> b)
-> (forall (l :: RTextLabel). RLabel l => RText l -> b)
-> Renders b
Renders {Word -> b
forall (l :: RTextLabel). RLabel l => RText l -> b
rText :: forall (l :: RTextLabel). RLabel l => RText l -> b
rWord :: Word -> b
rText :: forall (l :: RTextLabel). RLabel l => RText l -> b
rWord :: Word -> 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 :: 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
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 :: 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 => RText l -> b
forall b.
Renders b -> forall (l :: RTextLabel). RLabel l => RText l -> b
rText (Proxy s -> Renders b
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s))

----------------------------------------------------------------------------
-- 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 :: URI -> Tagged s b
genericRender URI {[QueryParam]
Maybe (Bool, NonEmpty (RText 'PathPiece))
Maybe (RText 'Scheme)
Maybe (RText 'Fragment)
Either Bool Authority
uriFragment :: URI -> Maybe (RText 'Fragment)
uriQuery :: URI -> [QueryParam]
uriPath :: URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
uriAuthority :: URI -> Either Bool Authority
uriFragment :: Maybe (RText 'Fragment)
uriQuery :: [QueryParam]
uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriAuthority :: Either Bool Authority
uriScheme :: Maybe (RText 'Scheme)
uriScheme :: URI -> Maybe (RText 'Scheme)
..} =
  [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. Render (RText 'Scheme) 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. Render Authority 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
-> Maybe (Bool, NonEmpty (RText 'PathPiece)) -> Tagged s 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. Render (Maybe (Bool, NonEmpty (RText 'PathPiece))) b
rPath Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath,
      [QueryParam] -> Tagged s b
forall b. Render [QueryParam] 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. Render (RText 'Fragment) b
rFragment Maybe (RText 'Fragment)
uriFragment
    ]
{-# INLINE genericRender #-}

rJust :: Monoid m => (a -> m) -> Maybe a -> m
rJust :: (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 :: 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 :: Authority -> Tagged s b
rAuthority Authority {Maybe Word
Maybe UserInfo
RText 'Host
authPort :: Authority -> Maybe Word
authHost :: Authority -> RText 'Host
authUserInfo :: Authority -> Maybe UserInfo
authPort :: Maybe Word
authHost :: RText 'Host
authUserInfo :: 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. Render UserInfo 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 :: UserInfo -> Tagged s b
rUserInfo UserInfo {Maybe (RText 'Password)
RText 'Username
uiPassword :: UserInfo -> Maybe (RText 'Password)
uiUsername :: UserInfo -> RText 'Username
uiPassword :: Maybe (RText 'Password)
uiUsername :: 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 :: 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 :: 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)
-> (NonEmpty (RText 'PathPiece) -> [Tagged s b])
-> NonEmpty (RText 'PathPiece)
-> 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])
-> (NonEmpty (RText 'PathPiece) -> [Tagged s b])
-> NonEmpty (RText 'PathPiece)
-> [Tagged s b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RText 'PathPiece -> Tagged s b)
-> [RText 'PathPiece] -> [Tagged s 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] -> [Tagged s b])
-> (NonEmpty (RText 'PathPiece) -> [RText 'PathPiece])
-> NonEmpty (RText 'PathPiece)
-> [Tagged s b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (RText 'PathPiece) -> [RText 'PathPiece]
forall a. NonEmpty a -> [a]
NE.toList) NonEmpty (RText 'PathPiece)
ps
        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 :: [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. Render QueryParam 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 :: 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 :: 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) ->
  -- | Input text to encode
  RText l ->
  -- | Percent-encoded text
  Text
percentEncode :: Maybe (RText 'Scheme) -> RText l -> Text
percentEncode Maybe (RText 'Scheme)
mscheme 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 a. Integral a => a -> 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 :: a -> NonEmpty Char
encodeByte a
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) = a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
16
    nne :: Word8 -> Bool
nne = 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
    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

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