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