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