Network/HTTP/Lucu/MIMEType.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   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 Control.Applicative
  18 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
  19 import qualified Data.Ascii as A
  20 import Data.Attoparsec.Char8 as P
  21 import qualified Data.ByteString.Char8 as C8
  22 import Data.Map (Map)
  23 import Data.Monoid.Unicode
  24 import Data.Text (Text)
  25 import Network.HTTP.Lucu.Parser.Http
  26 import Network.HTTP.Lucu.RFC2231
  27 import Prelude hiding (min)
  28 import Prelude.Unicode
  29
  30 -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
  31 -- represents \"major\/minor; name=value\".
  32 data MIMEType = MIMEType {
  33       mtMajor  ∷ !CIAscii
  34     , mtMinor  ∷ !CIAscii
  35     , mtParams ∷ !(Map CIAscii Text)
  36     } deriving (Eq, Show)
  37
  38 -- |Convert a 'MIMEType' to 'AsciiBuilder'.
  39 printMIMEType ∷ MIMEType → AsciiBuilder
  40 printMIMEType (MIMEType maj min params)
  41     = A.toAsciiBuilder (A.fromCIAscii maj) ⊕
  42       A.toAsciiBuilder "/" ⊕
  43       A.toAsciiBuilder (A.fromCIAscii min) ⊕
  44       printParams params
  45
  46 -- |Parse 'MIMEType' from an 'Ascii'. This function throws an
  47 -- exception for parse error.
  48 parseMIMEType ∷ Ascii → MIMEType
  49 parseMIMEType str
  50     = let p  = do t ← mimeTypeP
  51                   endOfInput
  52                   return t
  53           bs = A.toByteString str
  54       in
  55         case parseOnly p bs of
  56           Right  t → t
  57           Left err → error ("unparsable MIME Type: " ⧺ C8.unpack bs ⧺ ": " ⧺ err)
  58
  59 mimeTypeP ∷ Parser MIMEType
  60 mimeTypeP = do maj    ← A.toCIAscii <$> token
  61                _      ← char '/'
  62                min    ← A.toCIAscii <$> token
  63                params ← paramsP
  64                return $ MIMEType maj min params
  65
  66 mimeTypeListP ∷ Parser [MIMEType]
  67 mimeTypeListP = listOf mimeTypeP