{-# LANGUAGE
    OverloadedStrings
  , UnicodeSyntax
  #-}
{-# OPTIONS_HADDOCK prune #-}

-- |Manipulation of MIME Types.
module Network.HTTP.Lucu.MIMEType
    ( MIMEType(..)
    , parseMIMEType
    , printMIMEType

    , mimeTypeP
    , mimeTypeListP
    )
    where
import Control.Applicative
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8 as P
import qualified Data.ByteString.Char8 as C8
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
import Prelude hiding (min)
import Prelude.Unicode

-- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
-- represents \"major\/minor; name=value\".
data MIMEType = MIMEType {
      mtMajor  ∷ !CIAscii
    , mtMinor  ∷ !CIAscii
    , mtParams ∷ ![ (CIAscii, Ascii) ]
    } deriving (Eq, Show)

-- |Convert a 'MIMEType' to 'Ascii'.
printMIMEType ∷ MIMEType → Ascii
printMIMEType (MIMEType maj min params)
    = A.fromAsciiBuilder $
      ( A.toAsciiBuilder (A.fromCIAscii maj) ⊕
        A.toAsciiBuilder "/" ⊕
        A.toAsciiBuilder (A.fromCIAscii min) ⊕
        if null params then
            (∅)
        else
            A.toAsciiBuilder "; " ⊕
            joinWith "; " (map printPair params)
      )
    where
      printPair ∷ (CIAscii, Ascii) → A.AsciiBuilder
      printPair (name, value)
          = A.toAsciiBuilder (A.fromCIAscii name) ⊕
            A.toAsciiBuilder "=" ⊕
            if C8.any ((¬) ∘ isToken) (A.toByteString value) then
                quoteStr value
            else
                A.toAsciiBuilder value

-- |Parse 'MIMEType' from an 'Ascii'. This function throws an
-- exception for parse error.
parseMIMEType ∷ Ascii → MIMEType
parseMIMEType str
    = let p  = do t ← mimeTypeP
                  endOfInput
                  return t
          bs = A.toByteString str
      in
        case parseOnly p bs of
          Right  t → t
          Left err → error ("unparsable MIME Type: " ⧺ C8.unpack bs ⧺ ": " ⧺ err)

mimeTypeP ∷ Parser MIMEType
mimeTypeP = try $
            do maj    ← A.toCIAscii <$> token
               _      ← char '/'
               min    ← A.toCIAscii <$> token
               params ← P.many paramP
               return $ MIMEType maj min params
    where
      paramP ∷ Parser (CIAscii, Ascii)
      paramP = try $
               do skipMany lws
                  _     ← char ';'
                  skipMany lws
                  name  ← A.toCIAscii <$> token
                  _     ← char '='
                  value ← token <|> quotedStr
                  return (name, value)

mimeTypeListP ∷ Parser [MIMEType]
mimeTypeListP = listOf mimeTypeP