{-# LANGUAGE
- CPP
- , DeriveDataTypeable
+ DeriveDataTypeable
, DoAndIfThenElse
+ , FlexibleInstances
, GeneralizedNewtypeDeriving
+ , MultiParamTypeClasses
, OverloadedStrings
, RecordWildCards
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
-- |Parsing and printing MIME parameter values
-- (<http://tools.ietf.org/html/rfc2231>).
module Network.HTTP.Lucu.MIMEParams
- ( MIMEParams(..)
+ ( MIMEParams
, printMIMEParams
, mimeParams
)
where
-import Control.Applicative
+import Control.Applicative hiding (empty)
+import Control.Arrow
import Control.Monad hiding (mapM)
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
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.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
-- (<http://tools.ietf.org/html/rfc2045#section-5.1>).
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
+ lift (MIMEParams m) = [| MIMEParams $(lift m) |]
+
+instance Unfoldable MIMEParams (CIAscii, Text) where
+ {-# INLINE insert #-}
+ insert p (MIMEParams m)
+ = MIMEParams $ insert p m
+ {-# INLINE empty #-}
+ empty
+ = MIMEParams empty
+ {-# INLINE singleton #-}
+ singleton p
+ = MIMEParams $ singleton p
+ {-# INLINE insertMany #-}
+ insertMany f (MIMEParams m)
+ = MIMEParams $ insertMany f m
+ {-# INLINE insertManySorted #-}
+ insertManySorted f (MIMEParams m)
+ = MIMEParams $ insertManySorted f m
+
+instance Foldable MIMEParams (CIAscii, Text) where
+ {-# INLINE null #-}
+ null (MIMEParams m) = null m
+ {-# INLINE size #-}
+ size (MIMEParams m) = size m
+ {-# INLINE foldr #-}
+ foldr f b (MIMEParams m) = foldr f b m
+
+instance Collection MIMEParams (CIAscii, Text) where
+ {-# INLINE filter #-}
+ filter f (MIMEParams m) = MIMEParams $ filter f m
+
+instance Indexed MIMEParams CIAscii Text where
+ {-# INLINE index #-}
+ index k (MIMEParams m) = index k m
+ {-# INLINE adjust #-}
+ adjust f k (MIMEParams m) = MIMEParams $ adjust f k m
+ {-# INLINE inDomain #-}
+ inDomain k (MIMEParams m) = inDomain k m
+
+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 α β
+
+instance SortingCollection MIMEParams (CIAscii, Text) where
+ {-# INLINE minView #-}
+ minView (MIMEParams m) = second MIMEParams <$> minView m
-- |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
+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 #-}
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