Network/HTTP/Lucu/MIMEParams.hs

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