Network/HTTP/Lucu/MIMEType.hs

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