X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEParams.hs;fp=Network%2FHTTP%2FLucu%2FMIMEParams.hs;h=6f9eb7e1b8a9f4055b0bc878578d6b2679952991;hp=89b2bfda4e0ecb15beb5781f7d45a88e48e2bd4a;hb=5f2ef377345fc47aabc63c1325df82c1cd9da9ed;hpb=313924e79d4ed48d3efb9f2530a48305fdd68c4b diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index 89b2bfd..6f9eb7e 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -16,7 +16,6 @@ -- (). module Network.HTTP.Lucu.MIMEParams ( MIMEParams - , printMIMEParams , mimeParams ) where @@ -25,13 +24,16 @@ 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.Attoparsec.Char8 import Data.Bits import qualified Data.ByteString.Char8 as BS import Data.Char import Data.Collections import Data.Collections.BaseInstances () import qualified Data.Collections.Newtype.TH as C +import Data.Convertible.Base +import Data.Convertible.Instances.Ascii () +import Data.Convertible.Utils import qualified Data.Map as M (Map) import Data.Monoid.Unicode import Data.Sequence (Seq) @@ -55,14 +57,17 @@ C.derive [d| instance Unfoldable MIMEParams (CIAscii, Text) instance SortingCollection MIMEParams (CIAscii, Text) |] --- |Convert MIME parameter values to an 'AsciiBuilder'. -printMIMEParams ∷ MIMEParams → AsciiBuilder -{-# INLINEABLE printMIMEParams #-} -printMIMEParams = foldl' f (∅) - where - f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder - {-# INLINE f #-} - f ab (k, v) = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v +instance ConvertSuccess MIMEParams Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) + +instance ConvertSuccess MIMEParams AsciiBuilder where + {-# INLINEABLE convertSuccess #-} + convertSuccess = foldl' f (∅) + where + f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder + {-# INLINE f #-} + f ab (k, v) = ab ⊕ cs ("; " ∷ Ascii) ⊕ printPair k v printPair ∷ CIAscii → Text → AsciiBuilder {-# INLINEABLE printPair #-} @@ -75,19 +80,19 @@ printPair name value printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder {-# INLINEABLE printPairInUTF8 #-} printPairInUTF8 name value - = A.toAsciiBuilder (A.fromCIAscii name) ⊕ - A.toAsciiBuilder "*=utf-8''" ⊕ + = cs name ⊕ + cs ("*=utf-8''" ∷ Ascii) ⊕ 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 + = cs name ⊕ + cs ("=" ∷ Ascii) ⊕ + if BS.any ((¬) ∘ isToken) (cs value) then quoteStr value else - A.toAsciiBuilder value + cs value escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder {-# INLINEABLE escapeUnsafeChars #-} @@ -96,15 +101,15 @@ escapeUnsafeChars bs b Nothing → b Just (c, bs') | isToken c → escapeUnsafeChars bs' $ - b ⊕ A.toAsciiBuilder (A.unsafeFromString [c]) + b ⊕ cs (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) ]) +toHex o = cs ("%" ∷ Ascii) ⊕ + cs (A.unsafeFromString [ toHex' (o `shiftR` 8) + , toHex' (o .&. 0x0F) ]) where toHex' ∷ Word8 → Char {-# INLINEABLE toHex' #-} @@ -114,6 +119,10 @@ toHex o = A.toAsciiBuilder "%" ⊕ | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (h - 0x0A) +deriveAttempts [ ([t| MIMEParams |], [t| Ascii |]) + , ([t| MIMEParams |], [t| AsciiBuilder |]) + ] + data ExtendedParam = InitialEncodedParam { epName ∷ !CIAscii @@ -139,7 +148,7 @@ section ep = epSection ep -- |'Parser' for MIME parameter values. mimeParams ∷ Parser MIMEParams {-# INLINEABLE mimeParams #-} -mimeParams = decodeParams =≪ P.many (try paramP) +mimeParams = decodeParams =≪ many (try paramP) paramP ∷ Parser ExtendedParam paramP = do skipMany lws @@ -159,7 +168,7 @@ paramP = do skipMany lws return $ AsciiParam name sect payload nameP ∷ Parser (CIAscii, Integer, Bool) -nameP = do name ← (A.toCIAscii ∘ A.unsafeFromByteString) <$> +nameP = do name ← (cs ∘ A.unsafeFromByteString) <$> takeWhile1 (\c → isToken c ∧ c ≢ '*') sect ← option 0 $ try (char '*' *> decimal ) isEncoded ← option False $ try (char '*' *> pure True) @@ -181,12 +190,12 @@ initialEncodedValue return (charset, payload) where metadata ∷ Parser CIAscii - metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$> + metadata = (cs ∘ A.unsafeFromByteString) <$> takeWhile (\c → c ≢ '\'' ∧ isToken c) encodedPayload ∷ Parser BS.ByteString {-# INLINE encodedPayload #-} -encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars) +encodedPayload = BS.concat <$> many (hexChar <|> rawChars) hexChar ∷ Parser BS.ByteString {-# INLINEABLE hexChar #-} @@ -248,7 +257,7 @@ sortBySection = flip go (∅) → fail (concat [ "Duplicate section " , show $ section x , " for parameter '" - , A.toString $ A.fromCIAscii $ epName x + , cs $ epName x , "'" ]) @@ -271,7 +280,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) → fail (concat [ "Missing section " , show $ section p , " for parameter '" - , A.toString $ A.fromCIAscii $ epName p + , cs $ epName p , "'" ]) @@ -287,9 +296,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) Just (ContinuedEncodedParam {..}, _) → fail "decodeSeq: internal error: CEP at section 0" Just (AsciiParam {..}, xs) - → let t = A.toText apPayload - in - decodeSeq' Nothing xs $ singleton t + → decodeSeq' Nothing xs $ singleton $ cs apPayload decodeSeq' ∷ Monad m ⇒ Maybe Decoder @@ -311,13 +318,11 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) → fail (concat [ "Section " , show epSection , " for parameter '" - , A.toString $ A.fromCIAscii epName + , cs epName , "' is encoded but its first section is not" ]) Just (AsciiParam {..}, xs) - → let t = A.toText apPayload - in - decodeSeq' decoder xs $ chunks ⊳ t + → decodeSeq' decoder xs $ chunks ⊳ cs apPayload type Decoder = BS.ByteString → Either UnicodeException Text @@ -331,5 +336,4 @@ getDecoder ∷ Monad m ⇒ CIAscii → m Decoder getDecoder charset | charset ≡ "UTF-8" = return decodeUtf8' | charset ≡ "US-ASCII" = return decodeUtf8' - | otherwise = fail $ "No decoders found for charset: " - ⧺ A.toString (A.fromCIAscii charset) + | otherwise = fail $ "No decoders found for charset: " ⊕ cs charset