Network/HTTP/Lucu/MIMEType.hs

   1 module Network.HTTP.Lucu.MIMEType
   2     ( MIMEType(..)
   3     , (+/+)         -- String -> String -> MIMEType
   4     , (+:+)         -- MIMEType -> (String, String) -> MIMEType
   5     , (+=+)         -- String -> String -> (String, String)
   6     , mimeTypeP     -- Parser MIMEType
   7     , mimeTypeListP -- Parser [MIMEType]
   8     )
   9     where
  10
  11 import           Network.HTTP.Lucu.Parser
  12 import           Network.HTTP.Lucu.Parser.Http
  13 import           Network.HTTP.Lucu.Utils
  14
  15
  16 data MIMEType = MIMEType {
  17       mtMajor  :: String
  18     , mtMinor  :: String
  19     , mtParams :: [ (String, String) ]
  20     } deriving (Eq)
  21
  22
  23 instance Show MIMEType where
  24     show (MIMEType maj min params)
  25         = maj ++ "/" ++ min ++
  26           if null params then
  27               ""
  28           else
  29               "; " ++ joinWith "; " (map showPair params)
  30         where
  31           showPair :: (String, String) -> String
  32           showPair (name, value)
  33               = name ++ "=" ++ if any (not . isToken) value then
  34                                    quoteStr value
  35                                else
  36                                    value
  37
  38
  39 infix  9 +/+, +=+
  40 infixl 8 +:+
  41
  42
  43 (+/+) :: String -> String -> MIMEType
  44 maj +/+ min
  45     = MIMEType maj min []
  46
  47
  48 (+:+) :: MIMEType -> (String, String) -> MIMEType
  49 mt@(MIMEType _ _ params) +:+ pair
  50     = mt {
  51         mtParams = mtParams mt ++ [pair]
  52       }
  53
  54
  55 (+=+) :: String -> String -> (String, String)
  56 name +=+ value = (name, value)
  57
  58
  59
  60 mimeTypeP :: Parser MIMEType
  61 mimeTypeP = allowEOF $
  62             do maj <- token
  63                char '/'
  64                min <- token
  65                params <- many paramP
  66                return $ MIMEType maj min params
  67     where
  68       paramP :: Parser (String, String)
  69       paramP = do many lws
  70                   char ';'
  71                   many lws
  72                   name <- token
  73                   char '='
  74                   value <- token <|> quotedStr
  75                   return (name, value)
  76
  77 mimeTypeListP :: Parser [MIMEType]
  78 mimeTypeListP = allowEOF $ listOf mimeTypeP