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 qualified Data.Ascii as A
  21 import Data.Attoparsec.Char8 as P
  22 import Data.Convertible.Base
  23 import Data.Convertible.Instances.Ascii ()
  24 import Data.Convertible.Utils
  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.OrphanInstances ()
  30 import Network.HTTP.Lucu.Parser
  31 import Network.HTTP.Lucu.Parser.Http
  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  = $(lift mtMedia )
  47              , mtSub    = $(lift mtSub   )
  48              , mtParams = $(lift mtParams)
  49              }
  50            |]
  51
  52 instance ConvertSuccess MIMEType Ascii where
  53     {-# INLINE convertSuccess #-}
  54     convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
  55
  56 instance ConvertSuccess MIMEType AsciiBuilder where
  57     {-# INLINEABLE convertSuccess #-}
  58     convertSuccess (MIMEType {..})
  59         = cs mtMedia       ⊕
  60           cs ("/" ∷ Ascii) ⊕
  61           cs mtSub         ⊕
  62           cs mtParams
  63
  64 deriveAttempts [ ([t| MIMEType |], [t| Ascii        |])
  65                , ([t| MIMEType |], [t| AsciiBuilder |])
  66                ]
  67
  68 -- |Parse 'MIMEType' from an 'Ascii'. For MIME type literals, consider
  69 -- using 'Network.HTTP.Lucu.MIMEType.TH.mimeType'.
  70 instance ConvertAttempt Ascii MIMEType where
  71     {-# INLINEABLE convertAttempt #-}
  72     convertAttempt str
  73         = case parseOnly (finishOff mimeType) (cs str) of
  74             Right  t → return t
  75             Left err → fail ("Unparsable MIME Type: " ⧺ cs 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