Network/HTTP/Lucu/MIMEType.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , TemplateHaskell
   6   , UnicodeSyntax
   7   #-}
   8 -- |Parsing and printing MIME Media Types
   9 -- (<http://tools.ietf.org/html/rfc2046>).
  10 module Network.HTTP.Lucu.MIMEType
  11     ( MIMEType(..)
  12     , mkMIMEType
  13
  14     , parseMIMEType
  15     , printMIMEType
  16
  17     , mimeType
  18     , mimeTypeList
  19     )
  20     where
  21 import Control.Applicative
  22 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
  23 import qualified Data.Ascii as A
  24 import Data.Attoparsec.Char8 as P
  25 import Data.Monoid.Unicode
  26 import Data.Typeable
  27 import Language.Haskell.TH.Syntax
  28 import Network.HTTP.Lucu.MIMEParams
  29 import Network.HTTP.Lucu.Parser
  30 import Network.HTTP.Lucu.Parser.Http
  31 import Network.HTTP.Lucu.Utils
  32 import Prelude.Unicode
  33
  34 -- |A media type, subtype, and parameters.
  35 data MIMEType
  36     = MIMEType {
  37         mtMedia  ∷ !CIAscii
  38       , mtSub    ∷ !CIAscii
  39       , mtParams ∷ !MIMEParams
  40       }
  41     deriving (Eq, Show, Read, Typeable)
  42
  43 instance Lift MIMEType where
  44     lift (MIMEType {..})
  45         = [| MIMEType {
  46                mtMedia  = $(liftCIAscii mtMedia)
  47              , mtSub    = $(liftCIAscii mtSub)
  48              , mtParams = $(lift mtParams)
  49              }
  50            |]
  51
  52 -- |@'mkMIMEType' media sub@ returns a 'MIMEType' with the given
  53 -- @media@ and @sub@ types but without any parameters.
  54 mkMIMEType ∷ CIAscii → CIAscii → MIMEType
  55 {-# INLINE mkMIMEType #-}
  56 mkMIMEType = flip flip (∅) ∘ MIMEType
  57
  58 -- |Convert a 'MIMEType' to an 'AsciiBuilder'.
  59 printMIMEType ∷ MIMEType → AsciiBuilder
  60 {-# INLINEABLE printMIMEType #-}
  61 printMIMEType (MIMEType {..})
  62     = A.toAsciiBuilder (A.fromCIAscii mtMedia) ⊕
  63       A.toAsciiBuilder "/" ⊕
  64       A.toAsciiBuilder (A.fromCIAscii mtSub) ⊕
  65       printMIMEParams mtParams
  66
  67 -- |Parse 'MIMEType' from an 'Ascii'. This function throws an
  68 -- exception for parse error. For literals consider using
  69 -- 'Network.HTTP.Lucu.MIMEType.TH.mimeType'.
  70 parseMIMEType ∷ Ascii → MIMEType
  71 {-# INLINEABLE parseMIMEType #-}
  72 parseMIMEType str
  73     = case parseOnly (finishOff mimeType) $ A.toByteString str of
  74         Right  t → t
  75         Left err → error ("unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err)
  76
  77 -- |'Parser' for an 'MIMEType'.
  78 mimeType ∷ Parser MIMEType
  79 {-# INLINEABLE mimeType #-}
  80 mimeType = do media  ← A.toCIAscii <$> token
  81               _      ← char '/'
  82               sub    ← A.toCIAscii <$> token
  83               params ← mimeParams
  84               return $ MIMEType media sub params
  85
  86 -- |'Parser' for a list of 'MIMEType's.
  87 mimeTypeList ∷ Parser [MIMEType]
  88 {-# INLINE mimeTypeList #-}
  89 mimeTypeList = listOf mimeType