MIMEType.hs

-- #prune

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

import qualified Data.ByteString.Lazy as B
import           Network.HTTP.Lucu.Parser
import           Network.HTTP.Lucu.Parser.Http
import           Network.HTTP.Lucu.Utils
import           Prelude hiding (min)

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


instance Show MIMEType where
    show (MIMEType maj min params)
        = maj ++ "/" ++ min ++
          if null params then
              ""
          else
              "; " ++ joinWith "; " (map showPair params)
        where
          showPair :: (String, String) -> String
          showPair (name, value)
              = name ++ "=" ++ if any (not . isToken) value then
                                   quoteStr value
                               else
                                   value


instance Read MIMEType where
    readsPrec _ s = [(parseMIMEType s, "")]

-- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an
-- exception for parse error.
parseMIMEType :: String -> MIMEType
parseMIMEType str = case parseStr mimeTypeP str of
                      (# Success t, r #) -> if B.null r
                                            then t
                                            else error ("unparsable MIME Type: " ++ str)
                      (# _        , _ #) -> error ("unparsable MIME Type: " ++ str)


mimeTypeP :: Parser MIMEType
mimeTypeP = allowEOF $!
            do maj <- token
               char '/'
               min <- token
               params <- many paramP
               return $ MIMEType maj min params
    where
      paramP :: Parser (String, String)
      paramP = do many lws
                  char ';'
                  many lws
                  name <- token
                  char '='
                  value <- token <|> quotedStr
                  return (name, value)

mimeTypeListP :: Parser [MIMEType]
mimeTypeListP = allowEOF $! listOf mimeTypeP