{-# LANGUAGE RecordWildCards, OverloadedStrings #-}

module Main (main) where

import qualified Data.BufferBuilder as BB
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Char8 as BSC
import Criterion
import Criterion.Main
import Data.Word (Word16)
import Data.Monoid
import Control.Monad
import Network.HTTP.Types (urlEncode)

type Protocol = BS.ByteString
type PathPiece = BS.ByteString

type Hash = BS.ByteString

data SMaybe a = SNothing | SJust !a
    deriving (Eq, Show, Ord) 

data UrlHost = UrlHost
    { uhHostName :: !BS.ByteString
    , uhPort     :: {-# UNPACK #-} !Word16         -- 0 = no port
    , uhUserName :: !BS.ByteString  -- empty = no username
    , uhPasswd   :: !BS.ByteString  -- empty = no password
    } deriving (Show, Ord, Eq)

{- | The type of a URL's query arguments.
   The RFC does not specify any particular format for this section of a URL, but, since
   it is so common to use form encoding, we include a representation which is a list of
   parsed key=value&key=value pairs.

   When parsing a URL, we first assume that the query is form encoded.  If this parse fails,
   the 'UnparsedQuery' constructor is instead used to encode a URL whose query encoding is
   unknown.
-}
data QueryPair = QueryPair !BS.ByteString !BS.ByteString
     deriving (Show, Ord, Eq)
data Query
    = UnparsedQuery !BS.ByteString
    | ParsedQuery [QueryPair]
      deriving (Show, Ord, Eq)
               
{- | Symbolic URL type.
   It is intended that this type can capture all \"conventional\" URLs losslessly and symbolically.

   In short, if you ever find yourself resorting to direct string parsing or generation, you are
   either doing it wrong, or this library is missing something you need.
 -}

data UrlHead = FullyQualified !Protocol !UrlHost
             | ProtocolRelative !UrlHost
             | Absolute
             | Relative
             deriving (Eq, Ord, Show)

data Url = Url
    { urlHead     :: !UrlHead
    , urlPath     :: ![PathPiece]
    , urlQuery    :: !(SMaybe Query)
    , urlHash     :: !(SMaybe Hash)
    } deriving (Eq, Ord, Show)


builderToBS :: BSB.Builder -> BS.ByteString
builderToBS = BSL.toStrict . BSB.toLazyByteString

escapeString :: BS.ByteString -> BSB.Builder
escapeString = BSB.byteString . urlEncode False

toByteString :: Url -> BS.ByteString
toByteString = builderToBS . toBuilder

toBuilder :: Url -> BSB.Builder
toBuilder Url{..} =
    renderHead urlHead
    <> renderPath urlPath
    <> renderQuery urlQuery
    <> renderHash urlHash
  where
    toBB = BSB.byteString
    char = BSB.char7

    renderHead :: UrlHead -> BSB.Builder
    renderHead (FullyQualified protocol host) = toBB protocol <> char ':' <> renderHost host <> char '/'
    renderHead (ProtocolRelative host) = renderHost host <> char '/'
    renderHead Absolute = char '/'
    renderHead Relative = mempty

    renderHost :: UrlHost -> BSB.Builder
    renderHost UrlHost{..} = char '/' <> char '/' <> renderUser uhUserName uhPasswd <> renderHostName uhHostName uhPort

    renderPath :: [PathPiece] -> BSB.Builder
    renderPath [] = mempty
    renderPath path = interc (char '/') (map escapeString path)

    renderQuery :: SMaybe Query -> BSB.Builder
    renderQuery SNothing = mempty
    renderQuery (SJust (UnparsedQuery q)) = char '?' <> toBB q
    renderQuery (SJust (ParsedQuery pairs)) = char '?' <> interc (char '&') (map renderPair pairs)

    renderPair (QueryPair k v) = escapeString k <> char '=' <> escapeString v

    renderHash h = case h of
        SNothing -> mempty
        SJust hash -> char '#' <> toBB hash

    renderHostName hostName hnPort
        | 0 /= hnPort = toBB hostName <> char ':' <> BSB.intDec (fromIntegral hnPort)
        | otherwise   = toBB hostName

    renderUser uhName uhPasswd
        | BS.null uhName = mempty
        | BS.null uhPasswd = escapeString uhName <> char '@'
        | otherwise = escapeString uhName <> char ':' <> escapeString uhPasswd <> char '@'

    interc _ [] = mempty
    interc _ [x] = x
    interc sep (x:y:xs) = x <> sep <> interc sep (y:xs)

renderHost' :: UrlHost -> BB.BufferBuilder ()
renderHost' UrlHost{..} = do
    BB.appendChar8 '/'
    BB.appendChar8 '/'

    when (not $ BS.null uhUserName) $ do
        BB.appendUrlEncoded uhUserName
        when (not $ BS.null uhPasswd) $ do
            BB.appendChar8 ':'
            BB.appendUrlEncoded uhPasswd
        BB.appendChar8 '@'

    BB.appendBS uhHostName
    if (uhPort /= 0) then do
        BB.appendChar8 ':'
        BB.appendDecimalSignedInt (fromIntegral uhPort)
    else
        return ()
        
    BB.appendChar8 '/'

renderPair' :: QueryPair -> BB.BufferBuilder ()
renderPair' (QueryPair key value) = do
    BB.appendUrlEncoded key
    BB.appendChar8 '='
    BB.appendUrlEncoded value
    
render :: Url -> BB.BufferBuilder ()
render Url{..} = do
    case urlHead of
        (FullyQualified protocol host) -> do
            BB.appendBS protocol
            BB.appendChar8 ':'
            renderHost' host
        (ProtocolRelative host) -> renderHost' host
        Absolute -> BB.appendChar8 '/'
        Relative -> return ()

    case urlPath of
        [] -> return ()
        (x:xs) -> do
            BB.appendUrlEncoded x
            forM_ xs $ \ps -> do
                BB.appendChar8 '/'
                BB.appendUrlEncoded ps

    case urlQuery of
        SNothing -> return ()
        (SJust (UnparsedQuery q)) -> do
            BB.appendChar8 '?'
            BB.appendBS q
        (SJust (ParsedQuery pairs)) -> do
            BB.appendChar8 '?'
            case pairs of
                [] -> return ()
                (x:xs) -> do
                    renderPair' x
                    forM_ xs $ \pair -> do
                        BB.appendChar8 '&'
                        renderPair' pair


    case urlHash of
        SNothing -> return ()
        (SJust h) -> do
            BB.appendChar8 '#'
            BB.appendBS h

viaBufferBuilder :: Url -> BS.ByteString
viaBufferBuilder = BB.runBufferBuilder . render

main :: IO ()
main = do
    let host = UrlHost
            { uhHostName = "example.com"
            , uhPort = 80
            , uhUserName = ""
            , uhPasswd = ""
            }

    let url = Url
            { urlHead = FullyQualified "http" host
            , urlPath = ["service", "one", "two", "three"]
            , urlQuery = SJust (ParsedQuery
                                  [ QueryPair "limit" "30"
                                  , QueryPair "next" "123456"
                                  , QueryPair "previous" "987654"
                                  ])
            , urlHash = SJust "anchor"
            }

    BSC.putStrLn $ "bytestring builder: " <> toByteString url
    BSC.putStrLn $ "bufferbuilder: " <> viaBufferBuilder url

    defaultMain [ bgroup "render url"
                    [ bench "bufferbuilder" $ nf viaBufferBuilder url
                    , bench "bytestring builder" $ nf toByteString url
                    --, bench "vector text" $ nf Json.encodeJson (Vector.replicate 100000 ("hello world" :: Text))
                    ]
                ]