Network/HTTP/Lucu/MIMEType.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5 {-# OPTIONS_HADDOCK prune #-}
   6
   7 -- |Manipulation of MIME Types.
   8 module Network.HTTP.Lucu.MIMEType
   9     ( MIMEType(..)
  10     , parseMIMEType
  11     , printMIMEType
  12
  13     , mimeTypeP
  14     , mimeTypeListP
  15     )
  16     where
  17 import Control.Applicative
  18 import Data.Ascii (Ascii, CIAscii)
  19 import qualified Data.Ascii as A
  20 import Data.Attoparsec.Char8 as P
  21 import qualified Data.ByteString.Char8 as C8
  22 import Data.Map (Map)
  23 import Data.Monoid.Unicode
  24 import Data.Text (Text)
  25 import Network.HTTP.Lucu.Parser.Http
  26 import Network.HTTP.Lucu.Utils
  27 import Prelude hiding (min)
  28 import Prelude.Unicode
  29
  30 -- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
  31 -- represents \"major\/minor; name=value\".
  32 data MIMEType = MIMEType {
  33       mtMajor  ∷ !CIAscii
  34     , mtMinor  ∷ !CIAscii
  35     , mtParams ∷ !(Map CIAscii Text)
  36     } deriving (Eq, Show)
  37
  38 -- |Convert a 'MIMEType' to 'Ascii'.
  39 printMIMEType ∷ MIMEType → Ascii
  40 printMIMEType (MIMEType maj min params)
  41     = A.fromAsciiBuilder $
  42       ( A.toAsciiBuilder (A.fromCIAscii maj) ⊕
  43         A.toAsciiBuilder "/" ⊕
  44         A.toAsciiBuilder (A.fromCIAscii min) ⊕
  45         if null params then
  46             (∅)
  47         else
  48             A.toAsciiBuilder "; " ⊕
  49             joinWith "; " (map printPair params)
  50       )
  51     where
  52       printPair ∷ (CIAscii, Ascii) → A.AsciiBuilder
  53       printPair (name, value)
  54           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  55             A.toAsciiBuilder "=" ⊕
  56             if C8.any ((¬) ∘ isToken) (A.toByteString value) then
  57                 quoteStr value
  58             else
  59                 A.toAsciiBuilder value
  60
  61 -- |Parse 'MIMEType' from an 'Ascii'. This function throws an
  62 -- exception for parse error.
  63 parseMIMEType ∷ Ascii → MIMEType
  64 parseMIMEType str
  65     = let p  = do t ← mimeTypeP
  66                   endOfInput
  67                   return t
  68           bs = A.toByteString str
  69       in
  70         case parseOnly p bs of
  71           Right  t → t
  72           Left err → error ("unparsable MIME Type: " ⧺ C8.unpack bs ⧺ ": " ⧺ err)
  73
  74 mimeTypeP ∷ Parser MIMEType
  75 mimeTypeP = try $
  76             do maj    ← A.toCIAscii <$> token
  77                _      ← char '/'
  78                min    ← A.toCIAscii <$> token
  79                params ← P.many paramP
  80                return $ MIMEType maj min params
  81     where
  82       paramP ∷ Parser (CIAscii, Ascii)
  83       paramP = try $
  84                do skipMany lws
  85                   _     ← char ';'
  86                   skipMany lws
  87                   name  ← A.toCIAscii <$> token
  88                   _     ← char '='
  89                   value ← token <|> quotedStr
  90                   return (name, value)
  91
  92 mimeTypeListP ∷ Parser [MIMEType]
  93 mimeTypeListP = listOf mimeTypeP