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