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')+
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 }
|]