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
  13     , parseMIMEType
  14     , printMIMEType
  15
  16     , mimeType
  17     , mimeTypeList
  18     )
  19     where
  20 import Control.Applicative
  21 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
  22 import qualified Data.Ascii as A
  23 import Data.Attoparsec.Char8 as P
  24 import Data.Monoid.Unicode
  25 import Data.Typeable
  26 import Language.Haskell.TH.Syntax
  27 import Network.HTTP.Lucu.MIMEParams
  28 import Network.HTTP.Lucu.Parser
  29 import Network.HTTP.Lucu.Parser.Http
  30 import Network.HTTP.Lucu.Utils
  31 import Prelude.Unicode
  32
  33 -- |A media type, subtype, and parameters.
  34 data MIMEType
  35     = MIMEType {
  36         mtMedia  ∷ !CIAscii
  37       , mtSub    ∷ !CIAscii
  38       , mtParams ∷ !MIMEParams
  39       }
  40     deriving (Eq, Show, Read, Typeable)
  41
  42 instance Lift MIMEType where
  43     lift (MIMEType {..})
  44         = [| MIMEType {
  45                mtMedia  = $(liftCIAscii mtMedia)
  46              , mtSub    = $(liftCIAscii mtSub)
  47              , mtParams = $(lift mtParams)
  48              }
  49            |]
  50
  51 -- |Convert a 'MIMEType' to an 'AsciiBuilder'.
  52 printMIMEType ∷ MIMEType → AsciiBuilder
  53 {-# INLINEABLE printMIMEType #-}
  54 printMIMEType (MIMEType {..})
  55     = A.toAsciiBuilder (A.fromCIAscii mtMedia) ⊕
  56       A.toAsciiBuilder "/" ⊕
  57       A.toAsciiBuilder (A.fromCIAscii mtSub) ⊕
  58       printMIMEParams mtParams
  59
  60 -- |Parse 'MIMEType' from an 'Ascii'. This function throws an
  61 -- exception for parse error. For literals consider using
  62 -- 'Network.HTTP.Lucu.MIMEType.TH.mimeType'.
  63 parseMIMEType ∷ Ascii → MIMEType
  64 {-# INLINEABLE parseMIMEType #-}
  65 parseMIMEType str
  66     = case parseOnly (finishOff mimeType) $ A.toByteString str of
  67         Right  t → t
  68         Left err → error ("unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err)
  69
  70 -- |'Parser' for an 'MIMEType'.
  71 mimeType ∷ Parser MIMEType
  72 {-# INLINEABLE mimeType #-}
  73 mimeType = do media  ← A.toCIAscii <$> token
  74               _      ← char '/'
  75               sub    ← A.toCIAscii <$> token
  76               params ← mimeParams
  77               return $ MIMEType media sub params
  78
  79 -- |'Parser' for a list of 'MIMEType's.
  80 mimeTypeList ∷ Parser [MIMEType]
  81 {-# INLINE mimeTypeList #-}
  82 mimeTypeList = listOf mimeType