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