Network/HTTP/Lucu/MIMEType.hs

   1 -- #prune
   2
   3 -- |Manipulation of MIME Types.
   4 module Network.HTTP.Lucu.MIMEType
   5     ( MIMEType(..)
   6     , parseMIMEType
   7     , mimeTypeP
   8     , mimeTypeListP
   9     )
  10     where
  11
  12 import           Network.HTTP.Lucu.Parser
  13 import           Network.HTTP.Lucu.Parser.Http
  14 import           Network.HTTP.Lucu.Utils
  15
  16 -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
  17 -- represents \"major\/minor; name=value\".
  18 data MIMEType = MIMEType {
  19       mtMajor  :: !String
  20     , mtMinor  :: !String
  21     , mtParams :: ![ (String, String) ]
  22     } deriving (Eq)
  23
  24
  25 instance Show MIMEType where
  26     show (MIMEType maj min params)
  27         = maj ++ "/" ++ min ++
  28           if null params then
  29               ""
  30           else
  31               "; " ++ joinWith "; " (map showPair params)
  32         where
  33           showPair :: (String, String) -> String
  34           showPair (name, value)
  35               = name ++ "=" ++ if any (not . isToken) value then
  36                                    quoteStr value
  37                                else
  38                                    value
  39
  40
  41 instance Read MIMEType where
  42     readsPrec _ s = [(parseMIMEType s, "")]
  43
  44 -- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an
  45 -- exception for parse error.
  46 parseMIMEType :: String -> MIMEType
  47 parseMIMEType str = case parseStr mimeTypeP str of
  48                       (Success t, _) -> t
  49                       _              -> error ("Unparsable MIME Type: " ++ str)
  50
  51
  52 mimeTypeP :: Parser MIMEType
  53 mimeTypeP = allowEOF $!
  54             do maj <- token
  55                char '/'
  56                min <- token
  57                params <- many paramP
  58                return $ MIMEType maj min params
  59     where
  60       paramP :: Parser (String, String)
  61       paramP = do many lws
  62                   char ';'
  63                   many lws
  64                   name <- token
  65                   char '='
  66                   value <- token <|> quotedStr
  67                   return (name, value)
  68
  69 mimeTypeListP :: Parser [MIMEType]
  70 mimeTypeListP = allowEOF $! listOf mimeTypeP