Network/HTTP/Lucu/RFC2231.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , ScopedTypeVariables
   6   , UnicodeSyntax
   7   #-}
   8 -- |Provide facilities to encode/decode MIME parameter values in
   9 -- character sets other than US-ASCII. See:
  10 -- http://www.faqs.org/rfcs/rfc2231.html
  11 module Network.HTTP.Lucu.RFC2231
  12     ( printParams
  13     , paramsP
  14     )
  15     where
  16 import Control.Applicative
  17 import Control.Monad.Unicode
  18 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
  19 import qualified Data.Ascii as A
  20 import Data.Attoparsec.Char8 as P
  21 import Data.Bits
  22 import qualified Data.ByteString.Char8 as BS
  23 import Data.Char
  24 import Data.Foldable
  25 import Data.Map (Map)
  26 import qualified Data.Map as M
  27 import Data.Monoid.Unicode
  28 import qualified Data.Sequence as S
  29 import Data.Sequence.Unicode hiding ((∅))
  30 import Data.Text (Text)
  31 import qualified Data.Text as T
  32 import Data.Text.Encoding
  33 import Data.Traversable
  34 import Data.Word
  35 import Network.HTTP.Lucu.Parser.Http
  36 import Network.HTTP.Lucu.Utils
  37 import Prelude hiding (concat, mapM, takeWhile)
  38 import Prelude.Unicode
  39
  40 printParams ∷ Map CIAscii Text → AsciiBuilder
  41 printParams params
  42     | M.null params = (∅)
  43     | otherwise     = A.toAsciiBuilder "; " ⊕
  44                       joinWith "; " (map printPair $ M.toList params)
  45
  46 printPair ∷ (CIAscii, Text) → AsciiBuilder
  47 printPair (name, value)
  48     | T.any (> '\xFF') value
  49         = printPairInUTF8 name value
  50     | otherwise
  51         = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value)
  52
  53 printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder
  54 printPairInUTF8 name value
  55     = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  56       A.toAsciiBuilder "*=utf-8''" ⊕
  57       escapeUnsafeChars (encodeUtf8 value) (∅)
  58
  59 printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder
  60 printPairInAscii name value
  61     = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  62       A.toAsciiBuilder "=" ⊕
  63       if BS.any ((¬) ∘ isToken) (A.toByteString value) then
  64           quoteStr value
  65       else
  66           A.toAsciiBuilder value
  67
  68 escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
  69 escapeUnsafeChars bs b
  70     = case BS.uncons bs of
  71         Nothing         → b
  72         Just (c, bs')
  73             | isToken c → escapeUnsafeChars bs' $
  74                           b ⊕ A.toAsciiBuilder (A.unsafeFromString [c])
  75             | otherwise → escapeUnsafeChars bs' $
  76                           b ⊕ toHex (fromIntegral $ fromEnum c)
  77
  78 toHex ∷ Word8 → AsciiBuilder
  79 toHex o = A.toAsciiBuilder "%" ⊕
  80           A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8)
  81                                                , toHex' (o .&.   0x0F) ])
  82
  83 toHex' ∷ Word8 → Char
  84 toHex' o
  85     | o ≤ 0x09  = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o
  86     | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A)
  87
  88
  89 data ExtendedParam
  90     = InitialEncodedParam {
  91         epName    ∷ !CIAscii
  92       , epCharset ∷ !CIAscii
  93       , epPayload ∷ !BS.ByteString
  94       }
  95     | ContinuedEncodedParam {
  96         epName    ∷ !CIAscii
  97       , epSection ∷ !Integer
  98       , epPayload ∷ !BS.ByteString
  99       }
 100     | AsciiParam {
 101         epName    ∷ !CIAscii
 102       , epSection ∷ !Integer
 103       , apPayload ∷ !Ascii
 104       }
 105
 106 section ∷ ExtendedParam → Integer
 107 section (InitialEncodedParam {..}) = 0
 108 section ep                         = epSection ep
 109
 110 paramsP ∷ Parser (Map CIAscii Text)
 111 paramsP = decodeParams =≪ P.many (try paramP)
 112
 113 paramP ∷ Parser ExtendedParam
 114 paramP = do skipMany lws
 115             _   ← char ';'
 116             skipMany lws
 117             epm ← nameP
 118             _   ← char '='
 119             case epm of
 120               (name, 0, True)
 121                   → do (charset, payload) ← initialEncodedValue
 122                        return $ InitialEncodedParam name charset payload
 123               (name, sect, True)
 124                   → do payload ← encodedPayload
 125                        return $ ContinuedEncodedParam name sect payload
 126               (name, sect, False)
 127                   → do payload ← token <|> quotedStr
 128                        return $ AsciiParam name sect payload
 129
 130 nameP ∷ Parser (CIAscii, Integer, Bool)
 131 nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
 132                        takeWhile1 (\c → isToken c ∧ c ≢ '*')
 133            sect      ← option 0 $
 134                        try $
 135                        do _ ← char '*'
 136                           n ← decimal
 137                           return n
 138            isEncoded ← option False $
 139                        do _ ← char '*'
 140                           return True
 141            return (name, sect, isEncoded)
 142
 143 initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
 144 initialEncodedValue = do charset ← metadata
 145                          _       ← char '\''
 146                          _       ← metadata -- Ignore the language tag
 147                          _       ← char '\''
 148                          payload ← encodedPayload
 149                          return (charset, payload)
 150     where
 151       metadata ∷ Parser CIAscii
 152       metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
 153                  takeWhile (\c → isToken c ∧ c ≢ '\'')
 154
 155 encodedPayload ∷ Parser BS.ByteString
 156 encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars)
 157
 158 hexChar ∷ Parser BS.ByteString
 159 hexChar = do _ ← char '%'
 160              h ← satisfy isHexChar
 161              l ← satisfy isHexChar
 162              return $ BS.singleton $ hexToChar h l
 163
 164 isHexChar ∷ Char → Bool
 165 isHexChar = inClass "0-9a-fA-F"
 166
 167 hexToChar ∷ Char → Char → Char
 168 hexToChar h l
 169     = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l
 170
 171 hexToInt ∷ Char → Int
 172 hexToInt c
 173     | c ≤ '9'   = ord c - ord '0'
 174     | c ≤ 'F'   = ord c - ord 'A' + 10
 175     | otherwise = ord c - ord 'a' + 10
 176
 177 rawChars ∷ Parser BS.ByteString
 178 rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%')
 179
 180 decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text)
 181 decodeParams = (mapM decodeSections =≪) ∘ sortBySection
 182
 183 sortBySection ∷ ∀m. Monad m
 184               ⇒ [ExtendedParam]
 185               → m (Map CIAscii (Map Integer ExtendedParam))
 186 sortBySection = flip go (∅)
 187     where
 188       go ∷ [ExtendedParam]
 189          → Map CIAscii (Map Integer ExtendedParam)
 190          → m (Map CIAscii (Map Integer ExtendedParam))
 191       go []     m = return m
 192       go (x:xs) m
 193           = case M.lookup (epName x) m of
 194               Nothing
 195                   → let s  = M.singleton (section x) x
 196                         m' = M.insert (epName x) s m
 197                     in
 198                       go xs m'
 199               Just s
 200                   → case M.insertLookupWithKey (\_ s' _ → s') (section x) x s of
 201                        (Nothing, s')
 202                            → let m' = M.insert (epName x) s' m
 203                              in
 204                                go xs m'
 205                        (Just _, _)
 206                            → fail (concat [ "Duplicate section "
 207                                           , show $ section x
 208                                           , " for parameter '"
 209                                           , A.toString $ A.fromCIAscii $ epName x
 210                                           , "'"
 211                                           ])
 212
 213 decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text
 214 decodeSections = flip (flip go 0) (∅)
 215     where
 216       go ∷ Map Integer ExtendedParam → Integer → S.Seq Text → m Text
 217       go m expectedSect chunks
 218           = case M.minViewWithKey m of
 219               Nothing
 220                   → return $ T.concat $ toList chunks
 221               Just ((sect, p), m')
 222                   | sect ≡ expectedSect
 223                         → error "FIXME"
 224                   | otherwise
 225                         → fail (concat [ "Missing section "
 226                                        , show $ section p
 227                                        , " for parameter '"
 228                                        , A.toString $ A.fromCIAscii $ epName p
 229                                        , "'"
 230                                        ])