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