module Text.URI.Render
( render
, render'
, renderBs
, renderBs'
, renderStr
, renderStr' )
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 Numeric (showInt)
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.Semigroup as S
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
renderStr :: URI -> String
renderStr = ($ []) . renderStr'
renderStr' :: URI -> ShowS
renderStr' = toShowS . genericRender (DString . showInt) (\e ->
fromString . T.unpack . 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
newtype DString = DString { toShowS :: ShowS }
instance S.Semigroup DString where
DString a <> DString b = DString (a . b)
instance Monoid DString where
mempty = DString id
mappend = (S.<>)
instance IsString DString where
fromString str = DString (str ++)
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