]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/MIMEParams.hs
Code clean-up using convertible-text.
[Lucu.git] / 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     {-# INLINEABLE 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 deriveAttempts [ ([t| MIMEParams |], [t| Ascii        |])
123                , ([t| MIMEParams |], [t| AsciiBuilder |])
124                ]
125
126 data ExtendedParam
127     = InitialEncodedParam {
128         epName    ∷ !CIAscii
129       , epCharset ∷ !CIAscii
130       , epPayload ∷ !BS.ByteString
131       }
132     | ContinuedEncodedParam {
133         epName    ∷ !CIAscii
134       , epSection ∷ !Integer
135       , epPayload ∷ !BS.ByteString
136       }
137     | AsciiParam {
138         epName    ∷ !CIAscii
139       , epSection ∷ !Integer
140       , apPayload ∷ !Ascii
141       }
142
143 section ∷ ExtendedParam → Integer
144 {-# INLINE section #-}
145 section (InitialEncodedParam {..}) = 0
146 section ep                         = epSection ep
147
148 -- |'Parser' for MIME parameter values.
149 mimeParams ∷ Parser MIMEParams
150 {-# INLINEABLE mimeParams #-}
151 mimeParams = decodeParams =≪ many (try paramP)
152
153 paramP ∷ Parser ExtendedParam
154 paramP = do skipMany lws
155             void $ char ';'
156             skipMany lws
157             epm ← nameP
158             void $ char '='
159             case epm of
160               (name, 0, True)
161                   → do (charset, payload) ← initialEncodedValue
162                        return $ InitialEncodedParam name charset payload
163               (name, sect, True)
164                   → do payload ← encodedPayload
165                        return $ ContinuedEncodedParam name sect payload
166               (name, sect, False)
167                   → do payload ← token <|> quotedStr
168                        return $ AsciiParam name sect payload
169
170 nameP ∷ Parser (CIAscii, Integer, Bool)
171 nameP = do name      ← (A.toCIAscii ∘ 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 (name, 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 = (A.toCIAscii ∘ 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                                           , A.toString $ A.fromCIAscii $ 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                                        , A.toString $ A.fromCIAscii $ 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                   → let t = A.toText apPayload
300                     in
301                       decodeSeq' Nothing xs $ singleton t
302
303       decodeSeq' ∷ Monad m
304                  ⇒ Maybe Decoder
305                  → Seq ExtendedParam
306                  → Seq Text
307                  → m Text
308       decodeSeq' decoder sects chunks
309           = case front sects of
310               Nothing
311                   → return $ T.concat $ toList chunks
312               Just (InitialEncodedParam {}, _)
313                   → fail "decodeSeq': internal error: IEP at section > 0"
314               Just (ContinuedEncodedParam {..}, xs)
315                   → case decoder of
316                        Just d
317                            → do t ← decodeStr d epPayload
318                                 decodeSeq' decoder xs $ chunks ⊳ t
319                        Nothing
320                            → fail (concat [ "Section "
321                                           , show epSection
322                                           , " for parameter '"
323                                           , A.toString $ A.fromCIAscii epName
324                                           , "' is encoded but its first section is not"
325                                           ])
326               Just (AsciiParam {..}, xs)
327                   → let t = A.toText apPayload
328                     in
329                       decodeSeq' decoder xs $ chunks ⊳ t
330
331 type Decoder = BS.ByteString → Either UnicodeException Text
332
333 decodeStr ∷ Monad m ⇒ Decoder → BS.ByteString → m Text
334 decodeStr decoder str
335     = case decoder str of
336         Right t → return t
337         Left  e → fail $ show e
338
339 getDecoder ∷ Monad m ⇒ CIAscii → m Decoder
340 getDecoder charset
341     | charset ≡ "UTF-8"    = return decodeUtf8'
342     | charset ≡ "US-ASCII" = return decodeUtf8'
343     | otherwise            = fail $ "No decoders found for charset: "
344                                   ⧺ A.toString (A.fromCIAscii charset)