Network/HTTP/Lucu/RFC2231.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , UnicodeSyntax
   5   #-}
   6 -- |Provide facilities to encode/decode MIME parameter values in
   7 -- character sets other than US-ASCII. See:
   8 -- http://www.faqs.org/rfcs/rfc2231.html
   9 module Network.HTTP.Lucu.RFC2231
  10     ( printParams
  11     , paramsP
  12     )
  13     where
  14 import Control.Applicative
  15 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
  16 import qualified Data.Ascii as A
  17 import Data.Attoparsec.Char8 as P
  18 import Data.Bits
  19 import qualified Data.ByteString.Char8 as BS
  20 import Data.Char
  21 import Data.Map (Map)
  22 import qualified Data.Map as M
  23 import Data.Monoid.Unicode
  24 import Data.Text (Text)
  25 import qualified Data.Text as T
  26 import Data.Text.Encoding
  27 import Data.Word
  28 import Network.HTTP.Lucu.Parser.Http
  29 import Network.HTTP.Lucu.Utils
  30 import Prelude hiding (takeWhile)
  31 import Prelude.Unicode
  32
  33 printParams ∷ Map CIAscii Text → AsciiBuilder
  34 printParams params
  35     | M.null params = (∅)
  36     | otherwise     = A.toAsciiBuilder "; " ⊕
  37                       joinWith "; " (map printPair $ M.toList params)
  38     where
  39       printPair ∷ (CIAscii, Text) → AsciiBuilder
  40       printPair (name, value)
  41           | T.any (> '\xFF') value
  42               = printPairInUTF8 name value
  43           | otherwise
  44               = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value)
  45
  46       printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder
  47       printPairInUTF8 name value
  48           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  49             A.toAsciiBuilder "*=utf-8''" ⊕
  50             escapeUnsafeChars (encodeUtf8 value) (∅)
  51
  52       printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder
  53       printPairInAscii name value
  54           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  55             A.toAsciiBuilder "=" ⊕
  56             if BS.any ((¬) ∘ isToken) (A.toByteString value) then
  57                 quoteStr value
  58             else
  59                 A.toAsciiBuilder value
  60
  61       escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
  62       escapeUnsafeChars bs b
  63           = case BS.uncons bs of
  64               Nothing         → b
  65               Just (c, bs')
  66                   | isToken c → escapeUnsafeChars bs' $
  67                                     b ⊕ A.toAsciiBuilder (A.unsafeFromString [c])
  68                   | otherwise → escapeUnsafeChars bs' $
  69                                     b ⊕ toHex (fromIntegral $ fromEnum c)
  70
  71       toHex ∷ Word8 → AsciiBuilder
  72       toHex o = A.toAsciiBuilder "%" ⊕
  73                 A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8)
  74                                                      , toHex' (o .&.   0x0F) ])
  75
  76       toHex' ∷ Word8 → Char
  77       toHex' o
  78           | o ≤ 0x09  = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o
  79           | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A)
  80
  81
  82 data ExtendedParam
  83     = InitialEncodedParam {
  84         epName    ∷ !CIAscii
  85       , epCharset ∷ !CIAscii
  86       , epPayload ∷ !BS.ByteString
  87       }
  88     | ContinuedEncodedParam {
  89         epName    ∷ !CIAscii
  90       , epSection ∷ !Integer
  91       , epPayload ∷ !BS.ByteString
  92       }
  93     | AsciiParam {
  94         epName    ∷ !CIAscii
  95       , epSection ∷ !Integer
  96       , apPayload ∷ !Ascii
  97       }
  98
  99 paramsP ∷ Parser (Map CIAscii Text)
 100 paramsP = decodeParams <$> P.many (try paramP)
 101     where
 102       paramP ∷ Parser ExtendedParam
 103       paramP = do skipMany lws
 104                   _   ← char ';'
 105                   skipMany lws
 106                   epm ← nameP
 107                   _   ← char '='
 108                   case epm of
 109                     (name, 0, True)
 110                         → do (charset, payload) ← initialEncodedValue
 111                              return $ InitialEncodedParam name charset payload
 112                     (name, section, True)
 113                         → do payload ← encodedPayload
 114                              return $ ContinuedEncodedParam name section payload
 115                     (name, section, False)
 116                         → do payload ← token <|> quotedStr
 117                              return $ AsciiParam name section payload
 118
 119       nameP ∷ Parser (CIAscii, Integer, Bool)
 120       nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
 121                              takeWhile1 (\c → isToken c ∧ c ≢ '*')
 122                  section   ← option 0 $
 123                                  try $
 124                                  do _ ← char '*'
 125                                     n ← decimal
 126                                     return n
 127                  isEncoded ← option False $
 128                                  do _ ← char '*'
 129                                     return True
 130                  return (name, section, isEncoded)
 131
 132       initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
 133       initialEncodedValue = do charset ← metadata
 134                                _       ← char '\''
 135                                _       ← metadata -- Ignore the language tag
 136                                _       ← char '\''
 137                                payload ← encodedPayload
 138                                return (charset, payload)
 139           where
 140             metadata ∷ Parser CIAscii
 141             metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
 142                        takeWhile (\c → isToken c ∧ c ≢ '\'')
 143
 144       encodedPayload ∷ Parser BS.ByteString
 145       encodedPayload = BS.concat <$> P.many (hexChar <|> literal)
 146           where
 147             hexChar ∷ Parser BS.ByteString
 148             hexChar = do _ ← char '%'
 149                          h ← satisfy isHexChar
 150                          l ← satisfy isHexChar
 151                          return $ BS.singleton $ hexToChar h l
 152
 153             isHexChar ∷ Char → Bool
 154             isHexChar = inClass "0-9a-fA-F"
 155
 156             hexToChar ∷ Char → Char → Char
 157             hexToChar h l
 158                 = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l
 159
 160             hexToInt ∷ Char → Int
 161             hexToInt c
 162                 | c ≤ '9'   = ord c - ord '0'
 163                 | c ≤ 'F'   = ord c - ord 'A' + 10
 164                 | otherwise = ord c - ord 'a' + 10
 165
 166             literal ∷ Parser BS.ByteString
 167             literal = takeWhile1 (\c → isToken c ∧ c ≢ '%')
 168
 169       decodeParams ∷ [ExtendedParam] → Map CIAscii Text
 170       decodeParams = error "FIXME"