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