{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Network.TigHTTP.Papillon (
	ContentType(..), Type(..), Subtype(..), Parameter(..), Charset(..),
		parseContentType, showContentType,
) where

import Data.Char
import Text.Papillon

import Data.ByteString (ByteString)
import Data.ByteString.Char8 (pack)
import qualified Data.ByteString as BS

import Network.TigHTTP.Token

data ContentType = ContentType Type Subtype [Parameter]
	deriving (Show, Eq)

parseContentType :: BS.ByteString -> ContentType
parseContentType ct = case runError . contentType $ parse ct of
	Left _ -> error "parseContentType"
	Right (r, _) -> r

showContentType :: ContentType -> BS.ByteString
showContentType (ContentType t st ps) = showType t
	`BS.append` "/"
	`BS.append` showSubtype st
	`BS.append` showParameters ps

data Type
	= Text
	| TypeRaw BS.ByteString
	deriving (Show, Eq)

mkType :: BS.ByteString -> Type
mkType "text" = Text
mkType t = TypeRaw t

showType :: Type -> BS.ByteString
showType Text = "text"
showType (TypeRaw t) = t

data Subtype
	= Plain
	| Html
	| Css
	| SubtypeRaw BS.ByteString
	deriving (Show, Eq)

mkSubtype :: BS.ByteString -> Subtype
mkSubtype "html" = Html
mkSubtype "plain" = Plain
mkSubtype "css" = Css
mkSubtype s = SubtypeRaw s

showSubtype :: Subtype -> BS.ByteString
showSubtype Plain = "plain"
showSubtype Html = "html"
showSubtype Css = "css"
showSubtype (SubtypeRaw s) = s

data Parameter
	= Charset Charset
	| ParameterRaw BS.ByteString BS.ByteString
	deriving (Show, Eq)

mkParameter :: BS.ByteString -> BS.ByteString -> Parameter
mkParameter "charset" "UTF-8" = Charset Utf8
mkParameter "charset" v = Charset $ CharsetRaw v
mkParameter a v = ParameterRaw a v

showParameters :: [Parameter] -> BS.ByteString
showParameters [] = ""
showParameters (Charset v : ps) = "; " `BS.append` "charset"
	`BS.append` "=" `BS.append` showCharset v `BS.append` showParameters ps
showParameters (ParameterRaw a v : ps) = "; " `BS.append` a
	`BS.append` "=" `BS.append` v `BS.append` showParameters ps

data Charset
	= Utf8
	| CharsetRaw BS.ByteString
	deriving (Show, Eq)

showCharset :: Charset -> BS.ByteString
showCharset Utf8 = "UTF-8"
showCharset (CharsetRaw cs) = cs

bsconcat :: [ByteString] -> ByteString
bsconcat = BS.concat

[papillon|

source: ByteString

contentType :: ContentType
	= c:token '/' sc:token ps:(';' ' '* p:parameter { p })*
	{ ContentType (mkType c) (mkSubtype sc) ps }

token :: ByteString
	= t:<isTokenChar>+			{ pack t }

quotedString :: ByteString
	= '"' t:(qt:qdtext { qt } / qp:quotedPair { pack [qp] })* '"'
						{ bsconcat t }

quotedPair :: Char
	= '\\' c:<isAscii>			{ c }

crlf :: () = '\r' '\n'

lws :: () = _:crlf _:(' ' / '\t')+

-- text :: ByteString
--	= ts:(cs:<isTextChar>+ { cs } / _:lws { " " })+		{ pack $ concat ts }

qdtext :: ByteString
	= ts:(cs:<isQdtextChar>+ { cs } / _:lws { " " })+	{ pack $ concat ts }

parameter :: Parameter
	= a:attribute '=' v:value				{ mkParameter a v }

attribute :: ByteString = t:token				{ t }

value :: ByteString
	= t:token						{ t }
	/ qs:quotedString					{ qs }

|]