From: PHO Date: Fri, 12 Aug 2011 06:05:49 +0000 (+0900) Subject: RFC2231.printParams X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=05f49fae07dfcac0c039f25c8a51123603918a93 RFC2231.printParams Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/Lucu.cabal b/Lucu.cabal index de76987..3ac356e 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -79,6 +79,7 @@ Library Network.HTTP.Lucu.MIMEType.DefaultExtensionMap Network.HTTP.Lucu.MIMEType.Guess Network.HTTP.Lucu.Parser.Http + Network.HTTP.Lucu.RFC2231 Network.HTTP.Lucu.Request Network.HTTP.Lucu.Resource Network.HTTP.Lucu.Resource.Tree diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index 4128f53..318526d 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -19,7 +19,9 @@ import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P import qualified Data.ByteString.Char8 as C8 +import Data.Map (Map) import Data.Monoid.Unicode +import Data.Text (Text) import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils import Prelude hiding (min) @@ -30,7 +32,7 @@ import Prelude.Unicode data MIMEType = MIMEType { mtMajor ∷ !CIAscii , mtMinor ∷ !CIAscii - , mtParams ∷ ![ (CIAscii, Ascii) ] + , mtParams ∷ !(Map CIAscii Text) } deriving (Eq, Show) -- |Convert a 'MIMEType' to 'Ascii'. diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 2319477..3344f4b 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns - , UnboxedTuples , UnicodeSyntax #-} -- |MIME Type guessing by a file extension. This is a poor man's way diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index 4dcf076..10d1f64 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -2,7 +2,6 @@ DoAndIfThenElse , OverloadedStrings , ScopedTypeVariables - , UnboxedTuples , UnicodeSyntax #-} module Network.HTTP.Lucu.MultipartForm @@ -16,15 +15,17 @@ import qualified Data.Ascii as A import Data.Attoparsec.Char8 import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LS -import Data.Char -import Data.List +import Data.Char +import Data.List +import Data.Map (Map) import Data.Maybe import Data.Monoid.Unicode import Data.Text (Text) -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.RFC2231 +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Utils import Prelude.Unicode -- |This data type represents a form value and possibly an uploaded @@ -49,7 +50,7 @@ instance HasHeaders Part where data ContDispo = ContDispo { dType ∷ !CIAscii - , dParams ∷ ![(CIAscii, Ascii)] + , dParams ∷ !(Map CIAscii Text) } printContDispo ∷ ContDispo → Ascii @@ -57,20 +58,7 @@ printContDispo d = A.fromAsciiBuilder $ ( A.toAsciiBuilder (A.fromCIAscii $ dType d) ⊕ - ( if null $ dParams d then - (∅) - else - A.toAsciiBuilder "; " ⊕ - joinWith "; " (map printPair $ dParams d) ) ) - where - printPair ∷ (CIAscii, Ascii) → AsciiBuilder - printPair (name, value) - = A.toAsciiBuilder (A.fromCIAscii name) ⊕ - A.toAsciiBuilder "=" ⊕ - ( if BS.any ((¬) ∘ isToken) $ A.toByteString value then - quoteStr value - else - A.toAsciiBuilder value ) + printParams (dParams d) ) multipartFormP ∷ Ascii → Parser [(Text, FormData)] multipartFormP boundary diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs new file mode 100644 index 0000000..9e99829 --- /dev/null +++ b/Network/HTTP/Lucu/RFC2231.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} +-- |Provide facilities to encode/decode MIME parameter values in +-- character sets other than US-ASCII. See: +-- http://www.faqs.org/rfcs/rfc2231.html +module Network.HTTP.Lucu.RFC2231 + ( printParams +-- , paramsP + ) + where +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) +import qualified Data.Ascii as A +import Data.Bits +import qualified Data.ByteString.Char8 as BS +import Data.Map (Map) +import qualified Data.Map as M +import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Word +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils +import Prelude.Unicode + +printParams ∷ Map CIAscii Text → AsciiBuilder +printParams params + | M.null params = (∅) + | otherwise = A.toAsciiBuilder "; " ⊕ + joinWith "; " (map printPair $ M.toList params) + 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) ]) + + 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