Network/HTTP/Lucu/MIMEType.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , FlexibleInstances
   4   , MultiParamTypeClasses
   5   , OverloadedStrings
   6   , RecordWildCards
   7   , TemplateHaskell
   8   , TypeSynonymInstances
   9   , UnicodeSyntax
  10   , ViewPatterns
  11   #-}
  12 -- |Parsing and printing MIME Media Types
  13 -- (<http://tools.ietf.org/html/rfc2046>).
  14 module Network.HTTP.Lucu.MIMEType
  15     ( MIMEType(..)
  16     , mimeType
  17     )
  18     where
  19 import Control.Applicative
  20 import Control.Monad.Unicode
  21 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
  22 import Data.Attempt
  23 import Data.Attoparsec.Char8
  24 import Data.Convertible.Base
  25 import Data.Convertible.Instances.Ascii ()
  26 import Data.Convertible.Utils
  27 import Data.Default
  28 import Data.Monoid.Unicode
  29 import Data.Typeable
  30 import Language.Haskell.TH.Syntax
  31 import Language.Haskell.TH.Quote
  32 import Network.HTTP.Lucu.MIMEParams
  33 import Network.HTTP.Lucu.OrphanInstances ()
  34 import Network.HTTP.Lucu.Parser
  35 import Network.HTTP.Lucu.Parser.Http
  36 import Network.HTTP.Lucu.Utils
  37 import Prelude.Unicode
  38
  39 -- |A media type, subtype, and parameters.
  40 data MIMEType
  41     = MIMEType {
  42         mtMedia  ∷ !CIAscii
  43       , mtSub    ∷ !CIAscii
  44       , mtParams ∷ !MIMEParams
  45       }
  46     deriving (Eq, Show, Read, Typeable)
  47
  48 instance Lift MIMEType where
  49     lift (MIMEType {..})
  50         = [| MIMEType {
  51                mtMedia  = $(lift mtMedia )
  52              , mtSub    = $(lift mtSub   )
  53              , mtParams = $(lift mtParams)
  54              }
  55            |]
  56
  57 instance ConvertSuccess MIMEType Ascii where
  58     {-# INLINE convertSuccess #-}
  59     convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
  60
  61 instance ConvertSuccess MIMEType AsciiBuilder where
  62     {-# INLINEABLE convertSuccess #-}
  63     convertSuccess (MIMEType {..})
  64         = cs mtMedia       ⊕
  65           cs ("/" ∷ Ascii) ⊕
  66           cs mtSub         ⊕
  67           cs mtParams
  68
  69 deriveAttempts [ ([t| MIMEType |], [t| Ascii        |])
  70                , ([t| MIMEType |], [t| AsciiBuilder |])
  71                ]
  72
  73 -- |Parse 'MIMEType' from an 'Ascii'. For MIME type literals, consider
  74 -- using 'mimeType' quasi-quoter.
  75 instance ConvertAttempt Ascii MIMEType where
  76     {-# INLINEABLE convertAttempt #-}
  77     convertAttempt str
  78         = case parseOnly (finishOff def) (cs str) of
  79             Right  t → return t
  80             Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err)
  81
  82 instance Default (Parser MIMEType) where
  83     {-# INLINEABLE def #-}
  84     def = do media  ← cs <$> token
  85              _      ← char '/'
  86              sub    ← cs <$> token
  87              params ← def
  88              return $ MIMEType media sub params
  89
  90 instance Default (Parser [MIMEType]) where
  91     {-# INLINE def #-}
  92     def = listOf def
  93
  94 -- |'QuasiQuoter' for 'MIMEType' literals.
  95 --
  96 -- @
  97 --   textPlain :: 'MIMEType'
  98 --   textPlain = ['mimeType'| text/plain; charset=\"UTF-8\" |]
  99 -- @
 100 mimeType ∷ QuasiQuoter
 101 mimeType = QuasiQuoter {
 102              quoteExp  = (lift =≪) ∘ (parseType =≪) ∘ toAscii
 103            , quotePat  = const unsupported
 104            , quoteType = const unsupported
 105            , quoteDec  = const unsupported
 106            }
 107     where
 108       parseType ∷ Monad m ⇒ Ascii → m MIMEType
 109       parseType a
 110           = case ca a of
 111               Success t → return t
 112               Failure e → fail (show e)
 113
 114       toAscii ∷ Monad m ⇒ String → m Ascii
 115       toAscii (trim → s)
 116           = case ca s of
 117               Success a → return a
 118               Failure e → fail (show e)
 119
 120       unsupported ∷ Monad m ⇒ m α
 121       unsupported = fail "Unsupported usage of mimeType quasi-quoter."