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