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     , mkMIMEType
  10
  11     , parseMIMEType
  12     , printMIMEType
  13
  14     , mimeTypeP
  15     , mimeTypeListP
  16     )
  17     where
  18 import Control.Applicative
  19 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
  20 import qualified Data.Ascii as A
  21 import Data.Attoparsec.Char8 as P
  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)
  37
  38 instance Show MIMEType where
  39     show = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
  40
  41 -- |Construct a 'MIMEType' without any parameters.
  42 mkMIMEType ∷ CIAscii → CIAscii → MIMEType
  43 {-# INLINE mkMIMEType #-}
  44 mkMIMEType maj min
  45     = MIMEType maj min (∅)
  46
  47 -- |Convert a 'MIMEType' to 'AsciiBuilder'.
  48 printMIMEType ∷ MIMEType → AsciiBuilder
  49 {-# INLINEABLE printMIMEType #-}
  50 printMIMEType (MIMEType maj min params)
  51     = A.toAsciiBuilder (A.fromCIAscii maj) ⊕
  52       A.toAsciiBuilder "/" ⊕
  53       A.toAsciiBuilder (A.fromCIAscii min) ⊕
  54       printParams params
  55
  56 -- |Parse 'MIMEType' from an 'Ascii'. This function throws an
  57 -- exception for parse error.
  58 parseMIMEType ∷ Ascii → MIMEType
  59 {-# INLINEABLE parseMIMEType #-}
  60 parseMIMEType str
  61     = case parseOnly p $ A.toByteString str of
  62         Right  t → t
  63         Left err → error ("unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err)
  64     where
  65       p ∷ Parser MIMEType
  66       {-# INLINE p #-}
  67       p = do t ← mimeTypeP
  68              endOfInput
  69              return t
  70
  71 mimeTypeP ∷ Parser MIMEType
  72 {-# INLINEABLE mimeTypeP #-}
  73 mimeTypeP = do maj    ← A.toCIAscii <$> token
  74                _      ← char '/'
  75                min    ← A.toCIAscii <$> token
  76                params ← paramsP
  77                return $ MIMEType maj min params
  78
  79 mimeTypeListP ∷ Parser [MIMEType]
  80 {-# INLINE mimeTypeListP #-}
  81 mimeTypeListP = listOf mimeTypeP