module Text.URI.Render
( render
, render'
, renderBs
, renderBs' )
where
import Data.ByteString (ByteString)
import Data.Char (chr, intToDigit)
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Monoid
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Word (Word8)
import Text.URI.Types
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Builder as BLB
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
render :: URI -> Text
render = TL.toStrict . TLB.toLazyText . render'
render' :: URI -> TLB.Builder
render' = genericRender TLB.decimal $ \e ->
TLB.fromText . percentEncode e . unRText
renderBs :: URI -> ByteString
renderBs = BL.toStrict . BLB.toLazyByteString . renderBs'
renderBs' :: URI -> BLB.Builder
renderBs' = genericRender BLB.wordDec $ \e ->
BLB.byteString . TE.encodeUtf8 . percentEncode e . unRText
data Escaping = N | P | Q deriving (Eq)
type Render a b = (forall l. Escaping -> RText l -> b) -> a -> b
type R b = (Monoid b, IsString b)
genericRender :: R b => (Word -> b) -> Render URI b
genericRender d r URI {..} = mconcat
[ rJust (rScheme r) uriScheme
, rJust (rAuthority d r) uriAuthority
, rPath r uriPath
, rQuery r uriQuery
, rJust (rFragment r) uriFragment ]
rJust :: Monoid m => (a -> m) -> Maybe a -> m
rJust = maybe mempty
rScheme :: R b => Render (RText 'Scheme) b
rScheme r = (<> ":") . r Q
rAuthority :: R b => (Word -> b) -> Render Authority b
rAuthority d r Authority {..} = mconcat
[ "//"
, rJust (rUserInfo r) authUserInfo
, if T.head (unRText authHost) == '['
then r N authHost
else r Q authHost
, rJust ((":" <>) . d) authPort ]
rUserInfo :: R b => Render UserInfo b
rUserInfo r UserInfo {..} = mconcat
[ r Q uiUsername
, rJust ((":" <>) . r Q) uiPassword
, "@" ]
rPath :: R b => Render [RText 'PathPiece] b
rPath r ps = "/" <> mconcat (intersperse "/" (r P <$> ps))
rQuery :: R b => Render [QueryParam] b
rQuery r = \case
[] -> mempty
qs -> "?" <> mconcat (intersperse "&" (rQueryParam r <$> qs))
rQueryParam :: R b => Render QueryParam b
rQueryParam r = \case
QueryFlag flag -> r P flag
QueryParam k v -> r P k <> "=" <> r P v
rFragment :: R b => Render (RText 'Fragment) b
rFragment r = ("#" <>) . r P
percentEncode
:: Escaping
-> Text
-> Text
percentEncode N txt = txt
percentEncode e txt = T.unfoldrN n f (bs, [])
where
f (bs', []) =
case B.uncons bs' of
Nothing -> Nothing
Just (w, bs'') -> Just $
if isUnreserved (e == P) w
then (chr (fromIntegral w), (bs'', []))
else let c:|cs = encodeByte w
in (c, (bs'', cs))
f (bs', x:xs) = Just (x, (bs', xs))
bs = TE.encodeUtf8 txt
n = B.foldl' (\n' w -> g w + n') 0 bs
g x = if isUnreserved (e == P) x then 1 else 3
encodeByte x = '%' :| [intToDigit h, intToDigit l]
where
(h, l) = fromIntegral x `quotRem` 16
isUnreserved :: Bool -> Word8 -> Bool
isUnreserved t x
| x >= 65 && x <= 90 = True
| x >= 97 && x <= 122 = True
| x >= 48 && x <= 57 = True
| x == 45 = True
| x == 95 = True
| x == 46 = True
| x == 126 = True
| t && x == 58 = True
| t && x == 64 = True
| otherwise = False