X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRFC2231.hs;h=791c891f46d8be9009da9632537b40400c4bf378;hb=ece223c516e66223ef1d5d8e6bbe4054a235d983;hp=9e99829025956543632e6a05db9f11a5ca9f7692;hpb=05f49fae07dfcac0c039f25c8a51123603918a93;p=Lucu.git diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs index 9e99829..791c891 100644 --- a/Network/HTTP/Lucu/RFC2231.hs +++ b/Network/HTTP/Lucu/RFC2231.hs @@ -1,80 +1,316 @@ {-# LANGUAGE - OverloadedStrings + 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 + , 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 (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 +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 - toHex' o - | o ≤ 0x09 = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o - | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A) - -{- -decode ∷ [(CIAscii, Ascii)] → Map CIAscii Text -{-# INLINEABLE decode #-} -decode = error "FIXME: not implemented" --} \ No newline at end of file + {-# INLINEABLE toHex' #-} + toHex' h + | h ≤ 0x09 = toEnum $ fromIntegral + $ fromEnum '0' + fromIntegral h + | otherwise = toEnum $ fromIntegral + $ fromEnum 'A' + fromIntegral (h - 0x0A) + +data ExtendedParam + = InitialEncodedParam { + epName ∷ !CIAscii + , epCharset ∷ !CIAscii + , epPayload ∷ !BS.ByteString + } + | ContinuedEncodedParam { + epName ∷ !CIAscii + , epSection ∷ !Integer + , epPayload ∷ !BS.ByteString + } + | AsciiParam { + epName ∷ !CIAscii + , epSection ∷ !Integer + , apPayload ∷ !Ascii + } + +section ∷ ExtendedParam → Integer +{-# INLINE section #-} +section (InitialEncodedParam {..}) = 0 +section ep = epSection ep + +-- |'Parser' for parameter values. +paramsP ∷ Parser (Map CIAscii Text) +{-# 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 + 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)