Network/HTTP/Lucu/MIMEParams.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , DoAndIfThenElse
   4   , FlexibleInstances
   5   , GeneralizedNewtypeDeriving
   6   , MultiParamTypeClasses
   7   , OverloadedStrings
   8   , RecordWildCards
   9   , TemplateHaskell
  10   , TypeSynonymInstances
  11   , UnicodeSyntax
  12   #-}
  13 {-# OPTIONS_GHC -fno-warn-orphans #-}
  14 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
  15 -- |Parsing and printing MIME parameter values
  16 -- (<http://tools.ietf.org/html/rfc2231>).
  17 module Network.HTTP.Lucu.MIMEParams
  18     ( MIMEParams
  19     , printMIMEParams
  20     , mimeParams
  21     )
  22     where
  23 import Control.Applicative hiding (empty)
  24 import Control.Monad hiding (mapM)
  25 import Control.Monad.Unicode
  26 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
  27 import qualified Data.Ascii as A
  28 import Data.Attoparsec.Char8
  29 import Data.Bits
  30 import qualified Data.ByteString.Char8 as BS
  31 import Data.Char
  32 import Data.Collections
  33 import Data.Collections.BaseInstances ()
  34 import qualified Data.Collections.Newtype.TH as C
  35 import qualified Data.Map as M (Map)
  36 import Data.Monoid.Unicode
  37 import Data.Sequence (Seq)
  38 import Data.Text (Text)
  39 import qualified Data.Text as T
  40 import Data.Text.Encoding
  41 import Data.Text.Encoding.Error
  42 import Data.Word
  43 import Network.HTTP.Lucu.MIMEParams.Internal
  44 import Network.HTTP.Lucu.OrphanInstances ()
  45 import Network.HTTP.Lucu.Parser.Http
  46 import Network.HTTP.Lucu.Utils
  47 import Prelude hiding (concat, lookup, mapM, takeWhile)
  48 import Prelude.Unicode
  49
  50 C.derive [d| instance Unfoldable MIMEParams (CIAscii, Text)
  51              instance Foldable   MIMEParams (CIAscii, Text)
  52              instance Collection MIMEParams (CIAscii, Text)
  53              instance Indexed    MIMEParams  CIAscii  Text
  54              instance Map        MIMEParams  CIAscii  Text
  55              instance SortingCollection MIMEParams (CIAscii, Text)
  56            |]
  57
  58 -- |Convert MIME parameter values to an 'AsciiBuilder'.
  59 printMIMEParams ∷ MIMEParams → AsciiBuilder
  60 {-# INLINEABLE printMIMEParams #-}
  61 printMIMEParams = foldl' f (∅)
  62     where
  63       f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder
  64       {-# INLINE f #-}
  65       f ab (k, v) = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v
  66
  67 printPair ∷ CIAscii → Text → AsciiBuilder
  68 {-# INLINEABLE printPair #-}
  69 printPair name value
  70     | T.any (> '\xFF') value
  71         = printPairInUTF8 name value
  72     | otherwise
  73         = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value)
  74
  75 printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder
  76 {-# INLINEABLE printPairInUTF8 #-}
  77 printPairInUTF8 name value
  78     = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  79       A.toAsciiBuilder "*=utf-8''" ⊕
  80       escapeUnsafeChars (encodeUtf8 value) (∅)
  81
  82 printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder
  83 {-# INLINEABLE printPairInAscii #-}
  84 printPairInAscii name value
  85     = A.toAsciiBuilder (A.fromCIAscii name) ⊕
  86       A.toAsciiBuilder "=" ⊕
  87       if BS.any ((¬) ∘ isToken) (A.toByteString value) then
  88           quoteStr value
  89       else
  90           A.toAsciiBuilder value
  91
  92 escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
  93 {-# INLINEABLE escapeUnsafeChars #-}
  94 escapeUnsafeChars bs b
  95     = case BS.uncons bs of
  96         Nothing         → b
  97         Just (c, bs')
  98             | isToken c → escapeUnsafeChars bs' $
  99                           b ⊕ A.toAsciiBuilder (A.unsafeFromString [c])
 100             | otherwise → escapeUnsafeChars bs' $
 101                           b ⊕ toHex (fromIntegral $ fromEnum c)
 102
 103 toHex ∷ Word8 → AsciiBuilder
 104 {-# INLINEABLE toHex #-}
 105 toHex o = A.toAsciiBuilder "%" ⊕
 106           A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8)
 107                                                , toHex' (o .&.   0x0F) ])
 108     where
 109       toHex' ∷ Word8 → Char
 110       {-# INLINEABLE toHex' #-}
 111       toHex' h
 112           | h ≤ 0x09  = toEnum $ fromIntegral
 113                                $ fromEnum '0' + fromIntegral h
 114           | otherwise = toEnum $ fromIntegral
 115                                $ fromEnum 'A' + fromIntegral (h - 0x0A)
 116
 117 data ExtendedParam
 118     = InitialEncodedParam {
 119         epName    ∷ !CIAscii
 120       , epCharset ∷ !CIAscii
 121       , epPayload ∷ !BS.ByteString
 122       }
 123     | ContinuedEncodedParam {
 124         epName    ∷ !CIAscii
 125       , epSection ∷ !Integer
 126       , epPayload ∷ !BS.ByteString
 127       }
 128     | AsciiParam {
 129         epName    ∷ !CIAscii
 130       , epSection ∷ !Integer
 131       , apPayload ∷ !Ascii
 132       }
 133
 134 section ∷ ExtendedParam → Integer
 135 {-# INLINE section #-}
 136 section (InitialEncodedParam {..}) = 0
 137 section ep                         = epSection ep
 138
 139 -- |'Parser' for MIME parameter values.
 140 mimeParams ∷ Parser MIMEParams
 141 {-# INLINEABLE mimeParams #-}
 142 mimeParams = decodeParams =≪ many (try paramP)
 143
 144 paramP ∷ Parser ExtendedParam
 145 paramP = do skipMany lws
 146             void $ char ';'
 147             skipMany lws
 148             epm ← nameP
 149             void $ char '='
 150             case epm of
 151               (name, 0, True)
 152                   → do (charset, payload) ← initialEncodedValue
 153                        return $ InitialEncodedParam name charset payload
 154               (name, sect, True)
 155                   → do payload ← encodedPayload
 156                        return $ ContinuedEncodedParam name sect payload
 157               (name, sect, False)
 158                   → do payload ← token <|> quotedStr
 159                        return $ AsciiParam name sect payload
 160
 161 nameP ∷ Parser (CIAscii, Integer, Bool)
 162 nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
 163                        takeWhile1 (\c → isToken c ∧ c ≢ '*')
 164            sect      ← option 0     $ try (char '*' *> decimal  )
 165            isEncoded ← option False $ try (char '*' *> pure True)
 166            return (name, sect, isEncoded)
 167
 168 initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
 169 initialEncodedValue
 170     = do charset ← metadata
 171          void $ char '\''
 172          void $ metadata -- Ignore the language tag
 173          void $ char '\''
 174          payload ← encodedPayload
 175          if charset ≡ "" then
 176              -- NOTE: I'm not sure this is the right thing, but RFC
 177              -- 2231 doesn't tell us what we should do when the
 178              -- charset is omitted.
 179              fail "charset is missing"
 180          else
 181              return (charset, payload)
 182     where
 183       metadata ∷ Parser CIAscii
 184       metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
 185                  takeWhile (\c → c ≢ '\'' ∧ isToken c)
 186
 187 encodedPayload ∷ Parser BS.ByteString
 188 {-# INLINE encodedPayload #-}
 189 encodedPayload = BS.concat <$> many (hexChar <|> rawChars)
 190
 191 hexChar ∷ Parser BS.ByteString
 192 {-# INLINEABLE hexChar #-}
 193 hexChar = do void $ char '%'
 194              h ← satisfy isHexChar
 195              l ← satisfy isHexChar
 196              return $ BS.singleton $ hexToChar h l
 197
 198 isHexChar ∷ Char → Bool
 199 isHexChar = inClass "0-9a-fA-F"
 200
 201 hexToChar ∷ Char → Char → Char
 202 {-# INLINE hexToChar #-}
 203 hexToChar h l
 204     = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l
 205
 206 hexToInt ∷ Char → Int
 207 {-# INLINEABLE hexToInt #-}
 208 hexToInt c
 209     | c ≤ '9'   = ord c - ord '0'
 210     | c ≤ 'F'   = ord c - ord 'A' + 10
 211     | otherwise = ord c - ord 'a' + 10
 212
 213 rawChars ∷ Parser BS.ByteString
 214 {-# INLINE rawChars #-}
 215 rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%')
 216
 217 decodeParams ∷ (Functor m, Monad m) ⇒ [ExtendedParam] → m MIMEParams
 218 {-# INLINE decodeParams #-}
 219 decodeParams = (MIMEParams <$>)
 220                ∘ (mapM (\(k, v) → ((,) k) <$> decodeSections v) =≪)
 221                ∘ sortBySection
 222
 223 sortBySection ∷ Monad m
 224               ⇒ [ExtendedParam]
 225               → m (M.Map CIAscii (M.Map Integer ExtendedParam))
 226 sortBySection = flip go (∅)
 227     where
 228       go ∷ Monad m
 229          ⇒ [ExtendedParam]
 230          → M.Map CIAscii (M.Map Integer ExtendedParam)
 231          → m (M.Map CIAscii (M.Map Integer ExtendedParam))
 232       go []     m = return m
 233       go (x:xs) m
 234           = case lookup (epName x) m of
 235               Nothing
 236                   → let s  = singleton (section x, x)
 237                         m' = insert (epName x, s) m
 238                     in
 239                       go xs m'
 240               Just s
 241                   → case lookup (section x) s of
 242                        Nothing
 243                            → let s' = insert (section x, x ) s
 244                                  m' = insert (epName  x, s') m
 245                              in
 246                                go xs m'
 247                        Just _
 248                            → fail (concat [ "Duplicate section "
 249                                           , show $ section x
 250                                           , " for parameter '"
 251                                           , A.toString $ A.fromCIAscii $ epName x
 252                                           , "'"
 253                                           ])
 254
 255 decodeSections ∷ Monad m ⇒ M.Map Integer ExtendedParam → m Text
 256 decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
 257     where
 258       toSeq ∷ Monad m
 259             ⇒ M.Map Integer ExtendedParam
 260             → Integer
 261             → Seq ExtendedParam
 262             → m (Seq ExtendedParam)
 263       toSeq m expectedSect sects
 264           = case minView m of
 265               Nothing
 266                   → return sects
 267               Just ((sect, p), m')
 268                   | sect ≡ expectedSect
 269                         → toSeq m' (expectedSect + 1) (sects ⊳ p)
 270                   | otherwise
 271                         → fail (concat [ "Missing section "
 272                                        , show $ section p
 273                                        , " for parameter '"
 274                                        , A.toString $ A.fromCIAscii $ epName p
 275                                        , "'"
 276                                        ])
 277
 278       decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text
 279       decodeSeq sects
 280           = case front sects of
 281               Nothing
 282                   → fail "decodeSeq: internal error: empty seq"
 283               Just (InitialEncodedParam {..}, xs)
 284                   → do d ← getDecoder epCharset
 285                        t ← decodeStr d epPayload
 286                        decodeSeq' (Just d) xs $ singleton t
 287               Just (ContinuedEncodedParam {..}, _)
 288                   → fail "decodeSeq: internal error: CEP at section 0"
 289               Just (AsciiParam {..}, xs)
 290                   → let t = A.toText apPayload
 291                     in
 292                       decodeSeq' Nothing xs $ singleton t
 293
 294       decodeSeq' ∷ Monad m
 295                  ⇒ Maybe Decoder
 296                  → Seq ExtendedParam
 297                  → Seq Text
 298                  → m Text
 299       decodeSeq' decoder sects chunks
 300           = case front sects of
 301               Nothing
 302                   → return $ T.concat $ toList chunks
 303               Just (InitialEncodedParam {}, _)
 304                   → fail "decodeSeq': internal error: IEP at section > 0"
 305               Just (ContinuedEncodedParam {..}, xs)
 306                   → case decoder of
 307                        Just d
 308                            → do t ← decodeStr d epPayload
 309                                 decodeSeq' decoder xs $ chunks ⊳ t
 310                        Nothing
 311                            → fail (concat [ "Section "
 312                                           , show epSection
 313                                           , " for parameter '"
 314                                           , A.toString $ A.fromCIAscii epName
 315                                           , "' is encoded but its first section is not"
 316                                           ])
 317               Just (AsciiParam {..}, xs)
 318                   → let t = A.toText apPayload
 319                     in
 320                       decodeSeq' decoder xs $ chunks ⊳ t
 321
 322 type Decoder = BS.ByteString → Either UnicodeException Text
 323
 324 decodeStr ∷ Monad m ⇒ Decoder → BS.ByteString → m Text
 325 decodeStr decoder str
 326     = case decoder str of
 327         Right t → return t
 328         Left  e → fail $ show e
 329
 330 getDecoder ∷ Monad m ⇒ CIAscii → m Decoder
 331 getDecoder charset
 332     | charset ≡ "UTF-8"    = return decodeUtf8'
 333     | charset ≡ "US-ASCII" = return decodeUtf8'
 334     | otherwise            = fail $ "No decoders found for charset: "
 335                                   ⧺ A.toString (A.fromCIAscii charset)