{-# LANGUAGE
- CPP
- , DeriveDataTypeable
+ DeriveDataTypeable
, DoAndIfThenElse
+ , FlexibleInstances
, GeneralizedNewtypeDeriving
+ , MultiParamTypeClasses
, OverloadedStrings
, RecordWildCards
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
-- |Parsing and printing MIME parameter values
-- (<http://tools.ietf.org/html/rfc2231>).
module Network.HTTP.Lucu.MIMEParams
- ( MIMEParams(..)
- , printMIMEParams
+ ( MIMEParams
, mimeParams
)
where
-import Control.Applicative
+import Control.Applicative hiding (empty)
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.Data
-import Data.Foldable
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Monoid
+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, ViewL(..))
-import qualified Data.Sequence as S
-import Data.Sequence.Unicode hiding ((∅))
+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.Traversable
import Data.Word
-import Language.Haskell.TH.Syntax
+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, mapM, 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
--- (<http://tools.ietf.org/html/rfc2045#section-5.1>).
-newtype MIMEParams
- = MIMEParams (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)
+ |]
-instance Lift MIMEParams where
- lift (MIMEParams m) = [| MIMEParams $(liftParams m) |]
- where
- liftParams ∷ Map CIAscii Text → Q Exp
- liftParams = liftMap liftCIAscii liftText
+instance ConvertSuccess MIMEParams Ascii where
+ {-# INLINE convertSuccess #-}
+ convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
--- |Convert MIME parameter values to an 'AsciiBuilder'.
-printMIMEParams ∷ MIMEParams → AsciiBuilder
-{-# INLINEABLE printMIMEParams #-}
-#if MIN_VERSION_containers(0, 4, 1)
-printMIMEParams (MIMEParams m) = M.foldlWithKey' f (∅) m
-#else
-printMIMEParams (MIMEParams m) = M.foldlWithKey f (∅) m
-#endif
- 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 #-}
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 #-}
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' #-}
| otherwise = toEnum $ fromIntegral
$ fromEnum 'A' + fromIntegral (h - 0x0A)
+deriveAttempts [ ([t| MIMEParams |], [t| Ascii |])
+ , ([t| MIMEParams |], [t| AsciiBuilder |])
+ ]
+
data ExtendedParam
= InitialEncodedParam {
epName ∷ !CIAscii
-- |'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
-- 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)
- -- FIXME: Rethink about this behaviour.
+ fail "charset is missing"
else
return (charset, payload)
where
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 #-}
decodeParams ∷ (Functor m, Monad m) ⇒ [ExtendedParam] → m MIMEParams
{-# INLINE decodeParams #-}
-decodeParams = (MIMEParams <$>) ∘ (mapM decodeSections =≪) ∘ sortBySection
+decodeParams = (MIMEParams <$>)
+ ∘ (mapM (\(k, v) → ((,) k) <$> decodeSections v) =≪)
+ ∘ sortBySection
sortBySection ∷ Monad m
⇒ [ExtendedParam]
- → m (Map CIAscii (Map Integer ExtendedParam))
+ → m (M.Map CIAscii (M.Map Integer ExtendedParam))
sortBySection = flip go (∅)
where
go ∷ Monad m
⇒ [ExtendedParam]
- → Map CIAscii (Map Integer ExtendedParam)
- → m (Map CIAscii (Map Integer ExtendedParam))
+ → M.Map CIAscii (M.Map Integer ExtendedParam)
+ → m (M.Map CIAscii (M.Map Integer ExtendedParam))
go [] m = return m
go (x:xs) m
- = case M.lookup (epName x) m of
+ = case lookup (epName x) m of
Nothing
- → let s = M.singleton (section x) x
- m' = M.insert (epName x) s m
+ → let s = singleton (section x, x)
+ m' = insert (epName x, s) m
in
go xs m'
Just s
- → case M.lookup (section x) s of
+ → case lookup (section x) s of
Nothing
- → let s' = M.insert (section x) x s
- m' = M.insert (epName x) s' m
+ → let s' = insert (section x, x ) s
+ m' = insert (epName x, s') m
in
go xs m'
Just _
, "'"
])
-decodeSections ∷ Monad m ⇒ Map Integer ExtendedParam → m Text
+decodeSections ∷ Monad m ⇒ M.Map Integer ExtendedParam → m Text
decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
where
toSeq ∷ Monad m
- ⇒ Map Integer ExtendedParam
+ ⇒ M.Map Integer ExtendedParam
→ Integer
→ Seq ExtendedParam
→ m (Seq ExtendedParam)
toSeq m expectedSect sects
- = case M.minViewWithKey m of
+ = case minView m of
Nothing
→ return sects
Just ((sect, p), m')
decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text
decodeSeq sects
- = case S.viewl sects of
- EmptyL
+ = case front sects of
+ Nothing
→ fail "decodeSeq: internal error: empty seq"
- InitialEncodedParam {..} :< xs
+ Just (InitialEncodedParam {..}, xs)
→ do d ← getDecoder epCharset
t ← decodeStr d epPayload
- decodeSeq' (Just d) xs $ S.singleton t
- ContinuedEncodedParam {..} :< _
+ decodeSeq' (Just d) xs $ singleton t
+ Just (ContinuedEncodedParam {..}, _)
→ fail "decodeSeq: internal error: CEP at section 0"
- AsciiParam {..} :< xs
+ Just (AsciiParam {..}, xs)
→ let t = A.toText apPayload
in
- decodeSeq' Nothing xs $ S.singleton t
+ decodeSeq' Nothing xs $ singleton t
decodeSeq' ∷ Monad m
⇒ Maybe Decoder
→ Seq Text
→ m Text
decodeSeq' decoder sects chunks
- = case S.viewl sects of
- EmptyL
+ = case front sects of
+ Nothing
→ return $ T.concat $ toList chunks
- InitialEncodedParam {..} :< _
+ Just (InitialEncodedParam {}, _)
→ fail "decodeSeq': internal error: IEP at section > 0"
- ContinuedEncodedParam {..} :< xs
+ Just (ContinuedEncodedParam {..}, xs)
→ case decoder of
Just d
→ do t ← decodeStr d epPayload
, A.toString $ A.fromCIAscii epName
, "' is encoded but its first section is not"
])
- AsciiParam {..} :< xs
+ Just (AsciiParam {..}, xs)
→ let t = A.toText apPayload
in
decodeSeq' decoder xs $ chunks ⊳ t
projects / Lucu.git / blobdiff