X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRFC2231.hs;h=791c891f46d8be9009da9632537b40400c4bf378;hb=ece223c516e66223ef1d5d8e6bbe4054a235d983;hp=e0f6e422ce867b96e9e1b36e2a3024dff5e3cfb3;hpb=087d94db0e7d5b2014487d191c37e829e3129e8d;p=Lucu.git diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs index e0f6e42..791c891 100644 --- a/Network/HTTP/Lucu/RFC2231.hs +++ b/Network/HTTP/Lucu/RFC2231.hs @@ -1,83 +1,109 @@ {-# LANGUAGE DoAndIfThenElse , OverloadedStrings + , RecordWildCards + , ScopedTypeVariables , UnicodeSyntax #-} --- |Provide facilities to encode/decode MIME parameter values in +-- |Provide functionalities to encode/decode MIME parameter values in -- character sets other than US-ASCII. See: --- http://www.faqs.org/rfcs/rfc2231.html +-- +-- +-- You usually don't have to use this module directly. module Network.HTTP.Lucu.RFC2231 ( printParams , paramsP ) where import Control.Applicative +import qualified Control.Exception as E +import Control.Monad hiding (mapM) +import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P import Data.Bits import qualified Data.ByteString.Char8 as BS import Data.Char +import Data.Foldable import Data.Map (Map) import qualified Data.Map as M import Data.Monoid.Unicode +import Data.Sequence (Seq, ViewL(..)) +import qualified Data.Sequence as S +import Data.Sequence.Unicode hiding ((∅)) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.ICU.Convert as TC import Data.Text.Encoding +import Data.Text.ICU.Error +import Data.Traversable import Data.Word import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils -import Prelude hiding (takeWhile) +import Prelude hiding (concat, mapM, takeWhile) import Prelude.Unicode +import System.IO.Unsafe +-- |Convert parameter values to an 'AsciiBuilder'. printParams ∷ Map CIAscii Text → AsciiBuilder -printParams params - | M.null params = (∅) - | otherwise = A.toAsciiBuilder "; " ⊕ - joinWith "; " (map printPair $ M.toList params) +{-# INLINEABLE printParams #-} +printParams m = M.foldlWithKey f (∅) m + -- THINKME: Use foldlWithKey' for newer Data.Map where - printPair ∷ (CIAscii, Text) → AsciiBuilder - printPair (name, value) - | T.any (> '\xFF') value - = printPairInUTF8 name value - | otherwise - = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value) - - printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder - printPairInUTF8 name value - = A.toAsciiBuilder (A.fromCIAscii name) ⊕ - A.toAsciiBuilder "*=utf-8''" ⊕ - escapeUnsafeChars (encodeUtf8 value) (∅) - - printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder - printPairInAscii name value - = A.toAsciiBuilder (A.fromCIAscii name) ⊕ - A.toAsciiBuilder "=" ⊕ - if BS.any ((¬) ∘ isToken) (A.toByteString value) then - quoteStr value - else - A.toAsciiBuilder value - - escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder - escapeUnsafeChars bs b - = case BS.uncons bs of - Nothing → b - Just (c, bs') - | isToken c → escapeUnsafeChars bs' $ - b ⊕ A.toAsciiBuilder (A.unsafeFromString [c]) - | otherwise → escapeUnsafeChars bs' $ - b ⊕ toHex (fromIntegral $ fromEnum c) - - toHex ∷ Word8 → AsciiBuilder - toHex o = A.toAsciiBuilder "%" ⊕ - A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8) - , toHex' (o .&. 0x0F) ]) + f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder + {-# INLINE f #-} + f ab k v = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v - toHex' ∷ Word8 → Char - toHex' o - | o ≤ 0x09 = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o - | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A) +printPair ∷ CIAscii → Text → AsciiBuilder +{-# INLINEABLE printPair #-} +printPair name value + | T.any (> '\xFF') value + = printPairInUTF8 name value + | otherwise + = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value) + +printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder +{-# INLINEABLE printPairInUTF8 #-} +printPairInUTF8 name value + = A.toAsciiBuilder (A.fromCIAscii name) ⊕ + A.toAsciiBuilder "*=utf-8''" ⊕ + escapeUnsafeChars (encodeUtf8 value) (∅) + +printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder +{-# INLINEABLE printPairInAscii #-} +printPairInAscii name value + = A.toAsciiBuilder (A.fromCIAscii name) ⊕ + A.toAsciiBuilder "=" ⊕ + if BS.any ((¬) ∘ isToken) (A.toByteString value) then + quoteStr value + else + A.toAsciiBuilder value +escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder +{-# INLINEABLE escapeUnsafeChars #-} +escapeUnsafeChars bs b + = case BS.uncons bs of + Nothing → b + Just (c, bs') + | isToken c → escapeUnsafeChars bs' $ + b ⊕ A.toAsciiBuilder (A.unsafeFromString [c]) + | otherwise → escapeUnsafeChars bs' $ + b ⊕ toHex (fromIntegral $ fromEnum c) + +toHex ∷ Word8 → AsciiBuilder +{-# INLINEABLE toHex #-} +toHex o = A.toAsciiBuilder "%" ⊕ + A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8) + , toHex' (o .&. 0x0F) ]) + where + toHex' ∷ Word8 → Char + {-# INLINEABLE toHex' #-} + toHex' h + | h ≤ 0x09 = toEnum $ fromIntegral + $ fromEnum '0' + fromIntegral h + | otherwise = toEnum $ fromIntegral + $ fromEnum 'A' + fromIntegral (h - 0x0A) data ExtendedParam = InitialEncodedParam { @@ -96,75 +122,195 @@ data ExtendedParam , apPayload ∷ !Ascii } +section ∷ ExtendedParam → Integer +{-# INLINE section #-} +section (InitialEncodedParam {..}) = 0 +section ep = epSection ep + +-- |'Parser' for parameter values. paramsP ∷ Parser (Map CIAscii Text) -paramsP = decodeParams <$> P.many (try paramP) +{-# INLINEABLE paramsP #-} +paramsP = decodeParams =≪ P.many (try paramP) + +paramP ∷ Parser ExtendedParam +paramP = do skipMany lws + void $ char ';' + skipMany lws + epm ← nameP + void $ char '=' + case epm of + (name, 0, True) + → do (charset, payload) ← initialEncodedValue + return $ InitialEncodedParam name charset payload + (name, sect, True) + → do payload ← encodedPayload + return $ ContinuedEncodedParam name sect payload + (name, sect, False) + → do payload ← token <|> quotedStr + return $ AsciiParam name sect payload + +nameP ∷ Parser (CIAscii, Integer, Bool) +nameP = do name ← (A.toCIAscii ∘ A.unsafeFromByteString) <$> + takeWhile1 (\c → isToken c ∧ c ≢ '*') + sect ← option 0 $ try (char '*' *> decimal ) + isEncoded ← option False $ try (char '*' *> pure True) + return (name, sect, isEncoded) + +initialEncodedValue ∷ Parser (CIAscii, BS.ByteString) +initialEncodedValue + = do charset ← metadata + void $ char '\'' + void $ metadata -- Ignore the language tag + void $ char '\'' + payload ← encodedPayload + if charset ≡ "" then + -- NOTE: I'm not sure this is the right thing, but RFC + -- 2231 doesn't tell us what we should do when the + -- charset is omitted. + return ("US-ASCII", payload) + else + return (charset, payload) + where + metadata ∷ Parser CIAscii + metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$> + takeWhile (\c → c ≢ '\'' ∧ isToken c) + +encodedPayload ∷ Parser BS.ByteString +{-# INLINE encodedPayload #-} +encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars) + +hexChar ∷ Parser BS.ByteString +{-# INLINEABLE hexChar #-} +hexChar = do void $ char '%' + h ← satisfy isHexChar + l ← satisfy isHexChar + return $ BS.singleton $ hexToChar h l + +isHexChar ∷ Char → Bool +isHexChar = inClass "0-9a-fA-F" + +hexToChar ∷ Char → Char → Char +{-# INLINE hexToChar #-} +hexToChar h l + = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l + +hexToInt ∷ Char → Int +{-# INLINEABLE hexToInt #-} +hexToInt c + | c ≤ '9' = ord c - ord '0' + | c ≤ 'F' = ord c - ord 'A' + 10 + | otherwise = ord c - ord 'a' + 10 + +rawChars ∷ Parser BS.ByteString +{-# INLINE rawChars #-} +rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%') + +decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text) +{-# INLINE decodeParams #-} +decodeParams = (mapM decodeSections =≪) ∘ sortBySection + +sortBySection ∷ ∀m. Monad m + ⇒ [ExtendedParam] + → m (Map CIAscii (Map Integer ExtendedParam)) +sortBySection = flip go (∅) + where + go ∷ [ExtendedParam] + → Map CIAscii (Map Integer ExtendedParam) + → m (Map CIAscii (Map Integer ExtendedParam)) + go [] m = return m + go (x:xs) m + = case M.lookup (epName x) m of + Nothing + → let s = M.singleton (section x) x + m' = M.insert (epName x) s m + in + go xs m' + Just s + → case M.lookup (section x) s of + Nothing + → let s' = M.insert (section x) x s + m' = M.insert (epName x) s' m + in + go xs m' + Just _ + → fail (concat [ "Duplicate section " + , show $ section x + , " for parameter '" + , A.toString $ A.fromCIAscii $ epName x + , "'" + ]) + +decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text +decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) where - paramP ∷ Parser ExtendedParam - paramP = do skipMany lws - _ ← char ';' - skipMany lws - epm ← nameP - _ ← char '=' - case epm of - (name, 0, True) - → do (charset, payload) ← initialEncodedValue - return $ InitialEncodedParam name charset payload - (name, section, True) - → do payload ← encodedPayload - return $ ContinuedEncodedParam name section payload - (name, section, False) - → do payload ← token <|> quotedStr - return $ AsciiParam name section payload - - nameP ∷ Parser (CIAscii, Integer, Bool) - nameP = do name ← (A.toCIAscii ∘ A.unsafeFromByteString) <$> - takeWhile1 (\c → isToken c ∧ c ≢ '*') - section ← option 0 $ - try $ - do _ ← char '*' - n ← decimal - return n - isEncoded ← option False $ - do _ ← char '*' - return True - return (name, section, isEncoded) - - initialEncodedValue ∷ Parser (CIAscii, BS.ByteString) - initialEncodedValue = do charset ← metadata - _ ← char '\'' - _ ← metadata -- Ignore the language tag - _ ← char '\'' - payload ← encodedPayload - return (charset, payload) - where - metadata ∷ Parser CIAscii - metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$> - takeWhile (\c → isToken c ∧ c ≢ '\'') - - encodedPayload ∷ Parser BS.ByteString - encodedPayload = BS.concat <$> P.many (hexChar <|> literal) - where - hexChar ∷ Parser BS.ByteString - hexChar = do _ ← char '%' - h ← satisfy isHexChar - l ← satisfy isHexChar - return $ BS.singleton $ hexToChar h l - - isHexChar ∷ Char → Bool - isHexChar = inClass "0-9a-fA-F" - - hexToChar ∷ Char → Char → Char - hexToChar h l - = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l - - hexToInt ∷ Char → Int - hexToInt c - | c ≤ '9' = ord c - ord '0' - | c ≤ 'F' = ord c - ord 'A' + 10 - | otherwise = ord c - ord 'a' + 10 - - literal ∷ Parser BS.ByteString - literal = takeWhile1 (\c → isToken c ∧ c ≢ '%') - - decodeParams ∷ [ExtendedParam] → Map CIAscii Text - decodeParams = error "FIXME" + toSeq ∷ Map Integer ExtendedParam + → Integer + → Seq ExtendedParam + → m (Seq ExtendedParam) + toSeq m expectedSect sects + = case M.minViewWithKey m of + Nothing + → return sects + Just ((sect, p), m') + | sect ≡ expectedSect + → toSeq m' (expectedSect + 1) (sects ⊳ p) + | otherwise + → fail (concat [ "Missing section " + , show $ section p + , " for parameter '" + , A.toString $ A.fromCIAscii $ epName p + , "'" + ]) + + decodeSeq ∷ Seq ExtendedParam → m Text + decodeSeq sects + = case S.viewl sects of + EmptyL + → fail "decodeSeq: internal error: empty seq" + InitialEncodedParam {..} :< xs + → do conv ← openConv epCharset + let t = TC.toUnicode conv epPayload + decodeSeq' (Just conv) xs $ S.singleton t + ContinuedEncodedParam {..} :< _ + → fail "decodeSeq: internal error: CEP at section 0" + AsciiParam {..} :< xs + → let t = A.toText apPayload + in + decodeSeq' Nothing xs $ S.singleton t + + decodeSeq' ∷ Maybe (TC.Converter) + → Seq ExtendedParam + → Seq Text + → m Text + decodeSeq' convM sects chunks + = case S.viewl sects of + EmptyL + → return $ T.concat $ toList chunks + InitialEncodedParam {..} :< _ + → fail "decodeSeq': internal error: IEP at section > 0" + ContinuedEncodedParam {..} :< xs + → case convM of + Just conv + → let t = TC.toUnicode conv epPayload + in + decodeSeq' convM xs $ chunks ⊳ t + Nothing + → fail (concat [ "Section " + , show epSection + , " for parameter '" + , A.toString $ A.fromCIAscii epName + , "' is encoded but its first section is not" + ]) + AsciiParam {..} :< xs + → let t = A.toText apPayload + in + decodeSeq' convM xs $ chunks ⊳ t + + openConv ∷ CIAscii → m TC.Converter + openConv charset + = let cs = A.toString $ A.fromCIAscii charset + open' = TC.open cs (Just True) + in + case unsafePerformIO $ E.try open' of + Right conv → return conv + Left err → fail $ show (err ∷ ICUError)