Network/HTTP/Lucu/MIMEType.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , FlexibleInstances
   4   , MultiParamTypeClasses
   5   , OverloadedStrings
   6   , RecordWildCards
   7   , TemplateHaskell
   8   , UnicodeSyntax
   9   , ViewPatterns
  10   #-}
  11 -- |Parsing and printing MIME Media Types
  12 -- (<http://tools.ietf.org/html/rfc2046>).
  13 module Network.HTTP.Lucu.MIMEType
  14     ( MIMEType(..)
  15     , mimeType
  16     )
  17     where
  18 import Control.Applicative
  19 import Control.Monad.Unicode
  20 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
  21 import Data.Attempt
  22 import Data.Attoparsec.Char8
  23 import Data.Attoparsec.Parsable
  24 import Data.ByteString (ByteString)
  25 import Data.Convertible.Base
  26 import Data.Convertible.Instances.Ascii ()
  27 import Data.Convertible.Utils
  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 parser) (cs str) of
  79             Right  t → return t
  80             Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err)
  81
  82 instance Parsable ByteString MIMEType where
  83     {-# INLINEABLE parser #-}
  84     parser = do media  ← cs <$> token
  85                 _      ← char '/'
  86                 sub    ← cs <$> token
  87                 params ← parser
  88                 return $ MIMEType media sub params
  89
  90 instance Parsable ByteString [MIMEType] where
  91     {-# INLINE parser #-}
  92     parser = listOf parser
  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."