Network/HTTP/Lucu/MIMEType.hs

   1 -- #prune
   2
   3 -- |Manipulation of MIME Types.
   4 module Network.HTTP.Lucu.MIMEType
   5     ( MIMEType(..)
   6     , (</>)
   7     , (<:>)
   8     , (<=>)
   9     , mimeTypeP
  10     , mimeTypeListP
  11     )
  12     where
  13
  14 import           Network.HTTP.Lucu.Parser
  15 import           Network.HTTP.Lucu.Parser.Http
  16 import           Network.HTTP.Lucu.Utils
  17
  18 -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
  19 -- represents \"major\/minor; name=value\".
  20 data MIMEType = MIMEType {
  21       mtMajor  :: String
  22     , mtMinor  :: String
  23     , mtParams :: [ (String, String) ]
  24     } deriving (Eq)
  25
  26
  27 instance Show MIMEType where
  28     show (MIMEType maj min params)
  29         = maj ++ "/" ++ min ++
  30           if null params then
  31               ""
  32           else
  33               "; " ++ joinWith "; " (map showPair params)
  34         where
  35           showPair :: (String, String) -> String
  36           showPair (name, value)
  37               = name ++ "=" ++ if any (not . isToken) value then
  38                                    quoteStr value
  39                                else
  40                                    value
  41
  42
  43 infix  9 </>, <=>
  44 infixl 8 <:>
  45
  46 -- |@\"major\" \<\/\> \"minor\"@ constructs a MIME Type
  47 -- \"major\/minor\".
  48 (</>) :: String -> String -> MIMEType
  49 maj </> min
  50     = MIMEType maj min []
  51
  52 -- |This operator appends a @(name, value)@ pair to a MIME Type.
  53 (<:>) :: MIMEType -> (String, String) -> MIMEType
  54 mt@(MIMEType _ _ params) <:> pair
  55     = mt {
  56         mtParams = mtParams mt ++ [pair]
  57       }
  58
  59 -- |This operator takes two strings and makes a tuple of them. So you
  60 -- can say
  61 --
  62 -- > "text" </> "xml" <:> "charset" <=> "UTF-8" <:> "q" <=> "0.9"
  63 --
  64 -- to represent \"text\/xml; charset=UTF-8; q=0.9\".
  65 (<=>) :: String -> String -> (String, String)
  66 name <=> value = (name, value)
  67
  68
  69 mimeTypeP :: Parser MIMEType
  70 mimeTypeP = allowEOF $
  71             do maj <- token
  72                char '/'
  73                min <- token
  74                params <- many paramP
  75                return $ MIMEType maj min params
  76     where
  77       paramP :: Parser (String, String)
  78       paramP = do many lws
  79                   char ';'
  80                   many lws
  81                   name <- token
  82                   char '='
  83                   value <- token <|> quotedStr
  84                   return (name, value)
  85
  86 mimeTypeListP :: Parser [MIMEType]
  87 mimeTypeListP = allowEOF $ listOf mimeTypeP