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