X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMIMEParams.hs;h=a3722a34958bfae90194a724e823c5c380fca553;hp=bfde1c932e3156e4db53456994c15943f3b8e9e4;hb=68afccfff5a39e92903c467fac3a99734ce8a404;hpb=48bc90d66a45c0b9b6f52272b46cf2949ed802e3 diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index bfde1c9..a3722a3 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -1,21 +1,27 @@ {-# LANGUAGE DeriveDataTypeable , DoAndIfThenElse + , FlexibleInstances , GeneralizedNewtypeDeriving + , MultiParamTypeClasses , OverloadedStrings , RecordWildCards , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax #-} +{-# OPTIONS_GHC -ddump-splices #-} -- FIXME +-- THINKME: GHC 7.0.3 gives us a false warning. +{-# OPTIONS_GHC -fno-warn-missing-methods #-} -- |Parsing and printing MIME parameter values -- (). module Network.HTTP.Lucu.MIMEParams - ( MIMEParams(..) + ( MIMEParams , printMIMEParams , 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) @@ -24,49 +30,71 @@ import Data.Attoparsec.Char8 as P 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.Collections +import Data.Collections.BaseInstances () +import qualified Data.Collections.Newtype.TH as C +import qualified Data.Map as M (Map) import Data.Monoid 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.Typeable import Data.Word -import Language.Haskell.TH.Syntax +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, filter, foldr, lookup, mapM, null, takeWhile) import Prelude.Unicode -- |A 'Map' from MIME parameter attributes to values. Attributes are -- always case-insensitive according to RFC 2045 -- (). newtype MIMEParams - = MIMEParams (Map CIAscii Text) + = MIMEParams (M.Map CIAscii Text) deriving (Eq, Show, Read, Monoid, Typeable) -instance Lift MIMEParams where - lift (MIMEParams m) = [| MIMEParams $(liftParams m) |] - where - liftParams ∷ Map CIAscii Text → Q Exp - liftParams = liftMap liftCIAscii liftText +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 α β -- |Convert MIME parameter values to an 'AsciiBuilder'. printMIMEParams ∷ MIMEParams → AsciiBuilder {-# INLINEABLE printMIMEParams #-} -printMIMEParams (MIMEParams m) = M.foldlWithKey f (∅) m - -- THINKME: Use foldlWithKey' for newer Data.Map +printMIMEParams = foldl' f (∅) where - f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder + f ∷ AsciiBuilder → (CIAscii, Text) → AsciiBuilder {-# INLINE f #-} - f ab k v = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v + f ab (k, v) = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v printPair ∷ CIAscii → Text → AsciiBuilder {-# INLINEABLE printPair #-} @@ -180,8 +208,7 @@ initialEncodedValue -- 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 @@ -221,30 +248,32 @@ rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%') 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 _ @@ -255,16 +284,16 @@ sortBySection = flip go (∅) , "'" ]) -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') @@ -280,19 +309,19 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) 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 @@ -300,12 +329,12 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) → 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 @@ -317,7 +346,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) , 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