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, 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 'Ascii'.
  39 printMIMEType ∷ MIMEType → Ascii
  40 printMIMEType (MIMEType maj min params)
  41     = A.fromAsciiBuilder $
  42       ( A.toAsciiBuilder (A.fromCIAscii maj) ⊕
  43         A.toAsciiBuilder "/" ⊕
  44         A.toAsciiBuilder (A.fromCIAscii min) ⊕
  45         printParams params
  46       )
  47
  48 -- |Parse 'MIMEType' from an 'Ascii'. This function throws an
  49 -- exception for parse error.
  50 parseMIMEType ∷ Ascii → MIMEType
  51 parseMIMEType str
  52     = let p  = do t ← mimeTypeP
  53                   endOfInput
  54                   return t
  55           bs = A.toByteString str
  56       in
  57         case parseOnly p bs of
  58           Right  t → t
  59           Left err → error ("unparsable MIME Type: " ⧺ C8.unpack bs ⧺ ": " ⧺ err)
  60
  61 mimeTypeP ∷ Parser MIMEType
  62 mimeTypeP = do maj    ← A.toCIAscii <$> token
  63                _      ← char '/'
  64                min    ← A.toCIAscii <$> token
  65                params ← paramsP
  66                return $ MIMEType maj min params
  67
  68 mimeTypeListP ∷ Parser [MIMEType]
  69 mimeTypeListP = listOf mimeTypeP