Network/HTTP/Lucu/MIMEType.hs

   1 {-# LANGUAGE
   2     UnboxedTuples
   3   , UnicodeSyntax
   4   #-}
   5 {-# OPTIONS_HADDOCK prune #-}
   6
   7 -- |Manipulation of MIME Types.
   8 module Network.HTTP.Lucu.MIMEType
   9     ( MIMEType(..)
  10     , parseMIMEType
  11     , mimeTypeP
  12     , mimeTypeListP
  13     )
  14     where
  15
  16 import qualified Data.ByteString.Lazy as B
  17 import           Network.HTTP.Lucu.Parser
  18 import           Network.HTTP.Lucu.Parser.Http
  19 import           Network.HTTP.Lucu.Utils
  20 import           Prelude hiding (min)
  21
  22 -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
  23 -- represents \"major\/minor; name=value\".
  24 data MIMEType = MIMEType {
  25       mtMajor  :: !String
  26     , mtMinor  :: !String
  27     , mtParams :: ![ (String, String) ]
  28     } deriving (Eq)
  29
  30
  31 instance Show MIMEType where
  32     show (MIMEType maj min params)
  33         = maj ++ "/" ++ min ++
  34           if null params then
  35               ""
  36           else
  37               "; " ++ joinWith "; " (map showPair params)
  38         where
  39           showPair :: (String, String) -> String
  40           showPair (name, value)
  41               = name ++ "=" ++ if any (not . isToken) value then
  42                                    quoteStr value
  43                                else
  44                                    value
  45
  46
  47 instance Read MIMEType where
  48     readsPrec _ s = [(parseMIMEType s, "")]
  49
  50 -- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an
  51 -- exception for parse error.
  52 parseMIMEType :: String -> MIMEType
  53 parseMIMEType str = case parseStr mimeTypeP str of
  54                       (# Success t, r #) -> if B.null r
  55                                             then t
  56                                             else error ("unparsable MIME Type: " ++ str)
  57                       (# _        , _ #) -> error ("unparsable MIME Type: " ++ str)
  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