Network/HTTP/Lucu/MIMEType.hs

   1 {-# OPTIONS_HADDOCK 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 import           Prelude hiding (min)
  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 instance Read MIMEType where
  44     readsPrec _ s = [(parseMIMEType s, "")]
  45
  46 -- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an
  47 -- exception for parse error.
  48 parseMIMEType :: String -> MIMEType
  49 parseMIMEType str = case parseStr mimeTypeP str of
  50                       (# Success t, r #) -> if B.null r
  51                                             then t
  52                                             else 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