X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEParams.hs;h=88dbb6fdd71a47bdc832cca03dc4b36797f3230b;hp=36982139ce257433018b4530f5f9058352c041a6;hb=0678be8;hpb=852d97c73c367bc7880600850d92463f580ca1ca diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index 3698213..88dbb6f 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -10,95 +10,64 @@ , TypeSynonymInstances , UnicodeSyntax #-} -{-# OPTIONS_GHC -ddump-splices #-} -- FIXME --- THINKME: GHC 7.0.3 gives us a false warning. +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} -- |Parsing and printing MIME parameter values -- (). module Network.HTTP.Lucu.MIMEParams ( MIMEParams - , printMIMEParams , mimeParams ) where import Control.Applicative hiding (empty) -import Control.Arrow 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 import Data.Monoid.Unicode import Data.Sequence (Seq) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding import Data.Text.Encoding.Error -import Data.Typeable import Data.Word +import Network.HTTP.Lucu.MIMEParams.Internal import Network.HTTP.Lucu.OrphanInstances () import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils -import Prelude hiding (concat, filter, foldr, lookup, mapM, null, takeWhile) +import Prelude hiding (concat, lookup, mapM, takeWhile) import Prelude.Unicode --- |A 'Map' from MIME parameter attributes to values. Attributes are --- always case-insensitive according to RFC 2045 --- (). -newtype MIMEParams - = MIMEParams (M.Map CIAscii Text) - deriving (Eq, Show, Read, Monoid, Typeable) - C.derive [d| instance Unfoldable MIMEParams (CIAscii, Text) instance Foldable MIMEParams (CIAscii, Text) instance Collection MIMEParams (CIAscii, Text) instance Indexed MIMEParams CIAscii Text + instance Map MIMEParams CIAscii Text + instance SortingCollection MIMEParams (CIAscii, Text) |] --- FIXME: auto-derive -instance Map MIMEParams CIAscii Text where - {-# INLINE lookup #-} - lookup k (MIMEParams m) = lookup k m - {-# INLINE mapWithKey #-} - mapWithKey f (MIMEParams m) - = MIMEParams $ mapWithKey f m - {-# INLINE unionWith #-} - unionWith f (MIMEParams α) (MIMEParams β) - = MIMEParams $ unionWith f α β - {-# INLINE intersectionWith #-} - intersectionWith f (MIMEParams α) (MIMEParams β) - = MIMEParams $ intersectionWith f α β - {-# INLINE differenceWith #-} - differenceWith f (MIMEParams α) (MIMEParams β) - = MIMEParams $ differenceWith f α β - {-# INLINE isSubmapBy #-} - isSubmapBy f (MIMEParams α) (MIMEParams β) - = isSubmapBy f α β - {-# INLINE isProperSubmapBy #-} - isProperSubmapBy f (MIMEParams α) (MIMEParams β) - = isProperSubmapBy f α β - --- FIXME: auto-derive -instance SortingCollection MIMEParams (CIAscii, Text) where - {-# INLINE minView #-} - minView (MIMEParams m) = second MIMEParams <$> minView m +instance ConvertSuccess MIMEParams Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder) --- |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 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 #-} @@ -111,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 #-} @@ -132,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' #-} @@ -150,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 @@ -175,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 @@ -222,7 +195,7 @@ initialEncodedValue 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 #-}