Network/HTTP/Lucu/RFC2231.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5 -- |Provide facilities to encode/decode MIME parameter values in
   6 -- character sets other than US-ASCII. See:
   7 -- http://www.faqs.org/rfcs/rfc2231.html
   8 module Network.HTTP.Lucu.RFC2231
   9     ( printParams
  10 --    , paramsP
  11     )
  12     where
  13 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
  14 import qualified Data.Ascii as A
  15 import Data.Bits
  16 import qualified Data.ByteString.Char8 as BS
  17 import Data.Map (Map)
  18 import qualified Data.Map as M
  19 import Data.Monoid.Unicode
  20 import Data.Text (Text)
  21 import qualified Data.Text as T
  22 import Data.Text.Encoding
  23 import Data.Word
  24 import Network.HTTP.Lucu.Parser.Http
  25 import Network.HTTP.Lucu.Utils
  26 import Prelude.Unicode
  27
  28 printParams ∷ Map CIAscii Text → AsciiBuilder
  29 printParams params
  30     | M.null params = (∅)
  31     | otherwise     = A.toAsciiBuilder "; " ⊕
  32                       joinWith "; " (map printPair $ M.toList params)
  33     where
  34       printPair ∷ (CIAscii, Text) → AsciiBuilder
  35       printPair (name, value)
  36           | T.any (> '\xFF') value
  37               = printPairInUTF8 name value
  38           | otherwise
  39               = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value)
  40
  41       printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder
  42       printPairInUTF8 name value
  43           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  44             A.toAsciiBuilder "*=utf-8''" ⊕
  45             escapeUnsafeChars (encodeUtf8 value) (∅)
  46
  47       printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder
  48       printPairInAscii name value
  49           = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  50             A.toAsciiBuilder "=" ⊕
  51             if BS.any ((¬) ∘ isToken) (A.toByteString value) then
  52                 quoteStr value
  53             else
  54                 A.toAsciiBuilder value
  55
  56       escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
  57       escapeUnsafeChars bs b
  58           = case BS.uncons bs of
  59               Nothing         → b
  60               Just (c, bs')
  61                   | isToken c → escapeUnsafeChars bs' $
  62                                     b ⊕ A.toAsciiBuilder (A.unsafeFromString [c])
  63                   | otherwise → escapeUnsafeChars bs' $
  64                                     b ⊕ toHex (fromIntegral $ fromEnum c)
  65
  66       toHex ∷ Word8 → AsciiBuilder
  67       toHex o = A.toAsciiBuilder "%" ⊕
  68                 A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8)
  69                                                      , toHex' (o .&.   0x0F) ])
  70
  71       toHex' ∷ Word8 → Char
  72       toHex' o
  73           | o ≤ 0x09  = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o
  74           | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A)
  75
  76 {-
  77 decode ∷ [(CIAscii, Ascii)] → Map CIAscii Text
  78 {-# INLINEABLE decode #-}
  79 decode = error "FIXME: not implemented"
  80 -}