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     , printMIMEType
  12
  13     , mimeTypeP
  14     , mimeTypeListP
  15     )
  16     where
  17 import Data.Ascii (Ascii, CIAscii)
  18 import qualified Data.Ascii as A
  19 import qualified Data.ByteString.Lazy as B
  20 import Network.HTTP.Lucu.Parser.Http
  21 import Network.HTTP.Lucu.Utils
  22 import Prelude hiding (min)
  23
  24 -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
  25 -- represents \"major\/minor; name=value\".
  26 data MIMEType = MIMEType {
  27       mtMajor  :: !CIAscii
  28     , mtMinor  :: !CIAscii
  29     , mtParams :: ![ (CIAscii, Ascii) ]
  30     } deriving (Eq, Show)
  31
  32 -- |Convert a 'MIMEType' to 'Ascii'.
  33 printMIMEType ∷ MIMEType → Ascii
  34 printMIMEType (MIMEType maj min params)
  35     = A.fromAsciiBuilder $
  36       ( A.toAsciiBuilder maj ⊕
  37         A.toAsciiBuilder "/" ⊕
  38         A.toAsciiBuilder min ⊕
  39         if null params then
  40             (∅)
  41         else
  42             A.toAsciiBuilder "; " ⊕
  43             joinWith "; " (map printPair params)
  44       )
  45     where
  46       printPair ∷ (CIAscii, Ascii) → A.AsciiBuilder
  47       printPair (name, value)
  48           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  49             A.toAsciiBuilder "=" ⊕
  50             if any ((¬) ∘ isToken) value then
  51                 quoteStr value
  52             else
  53                 A.toAsciiBuilder value
  54
  55 -- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an
  56 -- exception for parse error.
  57 parseMIMEType :: String -> MIMEType
  58 parseMIMEType str = case parseStr mimeTypeP str of
  59                       (# Success t, r #) -> if B.null r
  60                                             then t
  61                                             else error ("unparsable MIME Type: " ++ str)
  62                       (# _        , _ #) -> error ("unparsable MIME Type: " ++ str)
  63
  64
  65 mimeTypeP :: Parser MIMEType
  66 mimeTypeP = allowEOF $!
  67             do maj    <- token
  68                _      <- char '/'
  69                min    <- token
  70                params <- many paramP
  71                return $ MIMEType maj min params
  72     where
  73       paramP :: Parser (String, String)
  74       paramP = do _     <- many lws
  75                   _     <- char ';'
  76                   _     <- many lws
  77                   name  <- token
  78                   _     <- char '='
  79                   value <- token <|> quotedStr
  80                   return (name, value)
  81
  82 mimeTypeListP :: Parser [MIMEType]
  83 mimeTypeListP = allowEOF $! listOf mimeTypeP