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