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     = pair `seq`
  56       mt {
  57         mtParams = mtParams mt ++ [pair]
  58       }
  59
  60 -- |This operator takes two strings and makes a tuple of them. So you
  61 -- can say
  62 --
  63 -- > "text" </> "xml" <:> "charset" <=> "UTF-8" <:> "q" <=> "0.9"
  64 --
  65 -- to represent \"text\/xml; charset=UTF-8; q=0.9\".
  66 (<=>) :: String -> String -> (String, String)
  67 name <=> value = (name, value)
  68
  69
  70 mimeTypeP :: Parser MIMEType
  71 mimeTypeP = allowEOF $!
  72             do maj <- token
  73                char '/'
  74                min <- token
  75                params <- many paramP
  76                return $ MIMEType maj min params
  77     where
  78       paramP :: Parser (String, String)
  79       paramP = do many lws
  80                   char ';'
  81                   many lws
  82                   name <- token
  83                   char '='
  84                   value <- token <|> quotedStr
  85                   return (name, value)
  86
  87 mimeTypeListP :: Parser [MIMEType]
  88 mimeTypeListP = allowEOF $! listOf mimeTypeP