Network/HTTP/Lucu/MIMEType.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , FlexibleInstances
   4   , MultiParamTypeClasses
   5   , OverloadedStrings
   6   , RecordWildCards
   7   , TemplateHaskell
   8   , UnicodeSyntax
   9   #-}
  10 -- |Parsing and printing MIME Media Types
  11 -- (<http://tools.ietf.org/html/rfc2046>).
  12 module Network.HTTP.Lucu.MIMEType
  13     ( MIMEType(..)
  14     , mimeType
  15     , mimeTypeList
  16     )
  17     where
  18 import Control.Applicative
  19 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
  20 import Data.Attoparsec.Char8
  21 import Data.Convertible.Base
  22 import Data.Convertible.Instances.Ascii ()
  23 import Data.Convertible.Utils
  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.OrphanInstances ()
  29 import Network.HTTP.Lucu.Parser
  30 import Network.HTTP.Lucu.Parser.Http
  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  = $(lift mtMedia )
  46              , mtSub    = $(lift mtSub   )
  47              , mtParams = $(lift mtParams)
  48              }
  49            |]
  50
  51 instance ConvertSuccess MIMEType Ascii where
  52     {-# INLINE convertSuccess #-}
  53     convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
  54
  55 instance ConvertSuccess MIMEType AsciiBuilder where
  56     {-# INLINEABLE convertSuccess #-}
  57     convertSuccess (MIMEType {..})
  58         = cs mtMedia       ⊕
  59           cs ("/" ∷ Ascii) ⊕
  60           cs mtSub         ⊕
  61           cs mtParams
  62
  63 deriveAttempts [ ([t| MIMEType |], [t| Ascii        |])
  64                , ([t| MIMEType |], [t| AsciiBuilder |])
  65                ]
  66
  67 -- |Parse 'MIMEType' from an 'Ascii'. For MIME type literals, consider
  68 -- using 'Network.HTTP.Lucu.MIMEType.TH.mimeType'.
  69 instance ConvertAttempt Ascii MIMEType where
  70     {-# INLINEABLE convertAttempt #-}
  71     convertAttempt str
  72         = case parseOnly (finishOff mimeType) (cs str) of
  73             Right  t → return t
  74             Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err)
  75
  76 -- |'Parser' for an 'MIMEType'.
  77 mimeType ∷ Parser MIMEType
  78 {-# INLINEABLE mimeType #-}
  79 mimeType = do media  ← cs <$> token
  80               _      ← char '/'
  81               sub    ← cs <$> token
  82               params ← mimeParams
  83               return $ MIMEType media sub params
  84
  85 -- |'Parser' for a list of 'MIMEType's.
  86 mimeTypeList ∷ Parser [MIMEType]
  87 {-# INLINE mimeTypeList #-}
  88 mimeTypeList = listOf mimeType