{-# 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 }

|]