Network/HTTP/Lucu/RFC2231.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , ScopedTypeVariables
   6   , UnicodeSyntax
   7   #-}
   8 -- |Provide functionalities to encode/decode MIME parameter values in
   9 -- character sets other than US-ASCII. See:
  10 -- <http://www.faqs.org/rfcs/rfc2231.html>
  11 --
  12 -- You usually don't have to use this module directly.
  13 module Network.HTTP.Lucu.RFC2231
  14     ( printParams
  15     , paramsP
  16     )
  17     where
  18 import Control.Applicative
  19 import qualified Control.Exception as E
  20 import Control.Monad.Unicode
  21 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
  22 import qualified Data.Ascii as A
  23 import Data.Attoparsec.Char8 as P
  24 import Data.Bits
  25 import qualified Data.ByteString.Char8 as BS
  26 import Data.Char
  27 import Data.Foldable
  28 import Data.Map (Map)
  29 import qualified Data.Map as M
  30 import Data.Monoid.Unicode
  31 import Data.Sequence (Seq, ViewL(..))
  32 import qualified Data.Sequence as S
  33 import Data.Sequence.Unicode hiding ((∅))
  34 import Data.Text (Text)
  35 import qualified Data.Text as T
  36 import qualified Data.Text.ICU.Convert as TC
  37 import Data.Text.Encoding
  38 import Data.Text.ICU.Error
  39 import Data.Traversable
  40 import Data.Word
  41 import Network.HTTP.Lucu.Parser.Http
  42 import Network.HTTP.Lucu.Utils
  43 import Prelude hiding (concat, mapM, takeWhile)
  44 import Prelude.Unicode
  45 import System.IO.Unsafe
  46
  47 -- |Convert parameter values to an 'AsciiBuilder'.
  48 printParams ∷ Map CIAscii Text → AsciiBuilder
  49 printParams params
  50     | M.null params = (∅)
  51     | otherwise     = A.toAsciiBuilder "; " ⊕
  52                       joinWith "; " (map printPair $ M.toList params)
  53
  54 printPair ∷ (CIAscii, Text) → AsciiBuilder
  55 printPair (name, value)
  56     | T.any (> '\xFF') value
  57         = printPairInUTF8 name value
  58     | otherwise
  59         = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value)
  60
  61 printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder
  62 printPairInUTF8 name value
  63     = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  64       A.toAsciiBuilder "*=utf-8''" ⊕
  65       escapeUnsafeChars (encodeUtf8 value) (∅)
  66
  67 printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder
  68 printPairInAscii name value
  69     = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  70       A.toAsciiBuilder "=" ⊕
  71       if BS.any ((¬) ∘ isToken) (A.toByteString value) then
  72           quoteStr value
  73       else
  74           A.toAsciiBuilder value
  75
  76 escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
  77 escapeUnsafeChars bs b
  78     = case BS.uncons bs of
  79         Nothing         → b
  80         Just (c, bs')
  81             | isToken c → escapeUnsafeChars bs' $
  82                           b ⊕ A.toAsciiBuilder (A.unsafeFromString [c])
  83             | otherwise → escapeUnsafeChars bs' $
  84                           b ⊕ toHex (fromIntegral $ fromEnum c)
  85
  86 toHex ∷ Word8 → AsciiBuilder
  87 toHex o = A.toAsciiBuilder "%" ⊕
  88           A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8)
  89                                                , toHex' (o .&.   0x0F) ])
  90
  91 toHex' ∷ Word8 → Char
  92 toHex' o
  93     | o ≤ 0x09  = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o
  94     | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A)
  95
  96
  97 data ExtendedParam
  98     = InitialEncodedParam {
  99         epName    ∷ !CIAscii
 100       , epCharset ∷ !CIAscii
 101       , epPayload ∷ !BS.ByteString
 102       }
 103     | ContinuedEncodedParam {
 104         epName    ∷ !CIAscii
 105       , epSection ∷ !Integer
 106       , epPayload ∷ !BS.ByteString
 107       }
 108     | AsciiParam {
 109         epName    ∷ !CIAscii
 110       , epSection ∷ !Integer
 111       , apPayload ∷ !Ascii
 112       }
 113
 114 section ∷ ExtendedParam → Integer
 115 section (InitialEncodedParam {..}) = 0
 116 section ep                         = epSection ep
 117
 118 -- |'Parser' for parameter values.
 119 paramsP ∷ Parser (Map CIAscii Text)
 120 paramsP = decodeParams =≪ P.many (try paramP)
 121
 122 paramP ∷ Parser ExtendedParam
 123 paramP = do skipMany lws
 124             _   ← char ';'
 125             skipMany lws
 126             epm ← nameP
 127             _   ← char '='
 128             case epm of
 129               (name, 0, True)
 130                   → do (charset, payload) ← initialEncodedValue
 131                        return $ InitialEncodedParam name charset payload
 132               (name, sect, True)
 133                   → do payload ← encodedPayload
 134                        return $ ContinuedEncodedParam name sect payload
 135               (name, sect, False)
 136                   → do payload ← token <|> quotedStr
 137                        return $ AsciiParam name sect payload
 138
 139 nameP ∷ Parser (CIAscii, Integer, Bool)
 140 nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
 141                        takeWhile1 (\c → isToken c ∧ c ≢ '*')
 142            sect      ← option 0 $
 143                        try $
 144                        do _ ← char '*'
 145                           n ← decimal
 146                           return n
 147            isEncoded ← option False $
 148                        do _ ← char '*'
 149                           return True
 150            return (name, sect, isEncoded)
 151
 152 initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
 153 initialEncodedValue
 154     = do charset ← metadata
 155          _       ← char '\''
 156          _       ← metadata -- Ignore the language tag
 157          _       ← char '\''
 158          payload ← encodedPayload
 159          if charset ≡ "" then
 160              -- NOTE: I'm not sure this is the right thing, but RFC
 161              -- 2231 doesn't tell us what we should do when the
 162              -- charset is omitted.
 163              return ("US-ASCII", payload)
 164          else
 165              return (charset, payload)
 166     where
 167       metadata ∷ Parser CIAscii
 168       metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
 169                  takeWhile (\c → isToken c ∧ c ≢ '\'')
 170
 171 encodedPayload ∷ Parser BS.ByteString
 172 encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars)
 173
 174 hexChar ∷ Parser BS.ByteString
 175 hexChar = do _ ← char '%'
 176              h ← satisfy isHexChar
 177              l ← satisfy isHexChar
 178              return $ BS.singleton $ hexToChar h l
 179
 180 isHexChar ∷ Char → Bool
 181 isHexChar = inClass "0-9a-fA-F"
 182
 183 hexToChar ∷ Char → Char → Char
 184 hexToChar h l
 185     = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l
 186
 187 hexToInt ∷ Char → Int
 188 hexToInt c
 189     | c ≤ '9'   = ord c - ord '0'
 190     | c ≤ 'F'   = ord c - ord 'A' + 10
 191     | otherwise = ord c - ord 'a' + 10
 192
 193 rawChars ∷ Parser BS.ByteString
 194 rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%')
 195
 196 decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text)
 197 decodeParams = (mapM decodeSections =≪) ∘ sortBySection
 198
 199 sortBySection ∷ ∀m. Monad m
 200               ⇒ [ExtendedParam]
 201               → m (Map CIAscii (Map Integer ExtendedParam))
 202 sortBySection = flip go (∅)
 203     where
 204       go ∷ [ExtendedParam]
 205          → Map CIAscii (Map Integer ExtendedParam)
 206          → m (Map CIAscii (Map Integer ExtendedParam))
 207       go []     m = return m
 208       go (x:xs) m
 209           = case M.lookup (epName x) m of
 210               Nothing
 211                   → let s  = M.singleton (section x) x
 212                         m' = M.insert (epName x) s m
 213                     in
 214                       go xs m'
 215               Just s
 216                   → case M.insertLookupWithKey (\_ s' _ → s') (section x) x s of
 217                        (Nothing, s')
 218                            → let m' = M.insert (epName x) s' m
 219                              in
 220                                go xs m'
 221                        (Just _, _)
 222                            → fail (concat [ "Duplicate section "
 223                                           , show $ section x
 224                                           , " for parameter '"
 225                                           , A.toString $ A.fromCIAscii $ epName x
 226                                           , "'"
 227                                           ])
 228
 229 decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text
 230 decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
 231     where
 232       toSeq ∷ Map Integer ExtendedParam
 233             → Integer
 234             → Seq ExtendedParam
 235             → m (Seq ExtendedParam)
 236       toSeq m expectedSect sects
 237           = case M.minViewWithKey m of
 238               Nothing
 239                   → return sects
 240               Just ((sect, p), m')
 241                   | sect ≡ expectedSect
 242                         → toSeq m' (expectedSect + 1) (sects ⊳ p)
 243                   | otherwise
 244                         → fail (concat [ "Missing section "
 245                                        , show $ section p
 246                                        , " for parameter '"
 247                                        , A.toString $ A.fromCIAscii $ epName p
 248                                        , "'"
 249                                        ])
 250
 251       decodeSeq ∷ Seq ExtendedParam → m Text
 252       decodeSeq sects
 253           = case S.viewl sects of
 254               EmptyL
 255                   → fail "decodeSeq: internal error: empty seq"
 256               InitialEncodedParam {..} :< xs
 257                   → do conv ← openConv epCharset
 258                        let t = TC.toUnicode conv epPayload
 259                        decodeSeq' (Just conv) xs $ S.singleton t
 260               ContinuedEncodedParam {..} :< _
 261                   → fail "decodeSeq: internal error: CEP at section 0"
 262               AsciiParam {..} :< xs
 263                   → let t = A.toText apPayload
 264                     in
 265                       decodeSeq' Nothing xs $ S.singleton t
 266
 267       decodeSeq' ∷ Maybe (TC.Converter)
 268                  → Seq ExtendedParam
 269                  → Seq Text
 270                  → m Text
 271       decodeSeq' convM sects chunks
 272           = case S.viewl sects of
 273               EmptyL
 274                   → return $ T.concat $ toList chunks
 275               InitialEncodedParam {..} :< _
 276                   → fail "decodeSeq': internal error: IEP at section > 0"
 277               ContinuedEncodedParam {..} :< xs
 278                   → case convM of
 279                        Just conv
 280                            → let t = TC.toUnicode conv epPayload
 281                              in
 282                                decodeSeq' convM xs $ chunks ⊳ t
 283                        Nothing
 284                            → fail (concat [ "Section "
 285                                           , show epSection
 286                                           , " for parameter '"
 287                                           , A.toString $ A.fromCIAscii epName
 288                                           , "' is encoded but its first section is not"
 289                                           ])
 290               AsciiParam {..} :< xs
 291                   → let t = A.toText apPayload
 292                     in
 293                       decodeSeq' convM xs $ chunks ⊳ t
 294
 295       openConv ∷ CIAscii → m TC.Converter
 296       openConv charset
 297           = let cs    = A.toString $ A.fromCIAscii charset
 298                 open' = TC.open cs (Just True)
 299             in
 300               case unsafePerformIO $ E.try open' of
 301                 Right conv → return conv
 302                 Left  err  → fail $ show (err ∷ ICUError)