DoAndIfThenElse
, OverloadedStrings
, RecordWildCards
- , ScopedTypeVariables
, UnicodeSyntax
#-}
-- |Provide functionalities to encode/decode MIME parameter values in
--
-- You usually don't have to use this module directly.
module Network.HTTP.Lucu.RFC2231
- ( printParams
- , paramsP
+ ( printMIMEParams
+ , mimeParams
)
where
import Control.Applicative
-import qualified Control.Exception as E
import Control.Monad hiding (mapM)
import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import Data.Sequence.Unicode hiding ((∅))
import Data.Text (Text)
import qualified Data.Text as T
-import qualified Data.Text.ICU.Convert as TC
import Data.Text.Encoding
-import Data.Text.ICU.Error
+import Data.Text.Encoding.Error
import Data.Traversable
import Data.Word
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
import Prelude hiding (concat, mapM, takeWhile)
import Prelude.Unicode
-import System.IO.Unsafe
--- |Convert parameter values to an 'AsciiBuilder'.
-printParams ∷ Map CIAscii Text → AsciiBuilder
-{-# INLINEABLE printParams #-}
-printParams m = M.foldlWithKey f (∅) m
+-- |Convert MIME parameter values to an 'AsciiBuilder'.
+printMIMEParams ∷ Map CIAscii Text → AsciiBuilder
+{-# INLINEABLE printMIMEParams #-}
+printMIMEParams m = M.foldlWithKey f (∅) m
-- THINKME: Use foldlWithKey' for newer Data.Map
where
f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder
section (InitialEncodedParam {..}) = 0
section ep = epSection ep
--- |'Parser' for parameter values.
-paramsP ∷ Parser (Map CIAscii Text)
-{-# INLINEABLE paramsP #-}
-paramsP = decodeParams =≪ P.many (try paramP)
+-- |'Parser' for MIME parameter values.
+mimeParams ∷ Parser (Map CIAscii Text)
+{-# INLINEABLE mimeParams #-}
+mimeParams = decodeParams =≪ P.many (try paramP)
paramP ∷ Parser ExtendedParam
paramP = do skipMany lws
-- 2231 doesn't tell us what we should do when the
-- charset is omitted.
return ("US-ASCII", payload)
+ -- FIXME: Rethink about this behaviour.
else
return (charset, payload)
where
{-# INLINE decodeParams #-}
decodeParams = (mapM decodeSections =≪) ∘ sortBySection
-sortBySection ∷ ∀m. Monad m
+sortBySection ∷ Monad m
⇒ [ExtendedParam]
→ m (Map CIAscii (Map Integer ExtendedParam))
sortBySection = flip go (∅)
where
- go ∷ [ExtendedParam]
+ go ∷ Monad m
+ ⇒ [ExtendedParam]
→ Map CIAscii (Map Integer ExtendedParam)
→ m (Map CIAscii (Map Integer ExtendedParam))
go [] m = return m
, "'"
])
-decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text
+decodeSections ∷ Monad m ⇒ Map Integer ExtendedParam → m Text
decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
where
- toSeq ∷ Map Integer ExtendedParam
+ toSeq ∷ Monad m
+ ⇒ Map Integer ExtendedParam
→ Integer
→ Seq ExtendedParam
→ m (Seq ExtendedParam)
, "'"
])
- decodeSeq ∷ Seq ExtendedParam → m Text
+ decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text
decodeSeq sects
= case S.viewl sects of
EmptyL
→ fail "decodeSeq: internal error: empty seq"
InitialEncodedParam {..} :< xs
- → do conv ← openConv epCharset
- let t = TC.toUnicode conv epPayload
- decodeSeq' (Just conv) xs $ S.singleton t
+ → do d ← getDecoder epCharset
+ t ← decodeStr d epPayload
+ decodeSeq' (Just d) xs $ S.singleton t
ContinuedEncodedParam {..} :< _
→ fail "decodeSeq: internal error: CEP at section 0"
AsciiParam {..} :< xs
in
decodeSeq' Nothing xs $ S.singleton t
- decodeSeq' ∷ Maybe (TC.Converter)
+ decodeSeq' ∷ Monad m
+ ⇒ Maybe Decoder
→ Seq ExtendedParam
→ Seq Text
→ m Text
- decodeSeq' convM sects chunks
+ decodeSeq' decoder sects chunks
= case S.viewl sects of
EmptyL
→ return $ T.concat $ toList chunks
InitialEncodedParam {..} :< _
→ fail "decodeSeq': internal error: IEP at section > 0"
ContinuedEncodedParam {..} :< xs
- → case convM of
- Just conv
- → let t = TC.toUnicode conv epPayload
- in
- decodeSeq' convM xs $ chunks ⊳ t
+ → case decoder of
+ Just d
+ → do t ← decodeStr d epPayload
+ decodeSeq' decoder xs $ chunks ⊳ t
Nothing
→ fail (concat [ "Section "
, show epSection
AsciiParam {..} :< xs
→ let t = A.toText apPayload
in
- decodeSeq' convM xs $ chunks ⊳ t
+ decodeSeq' decoder xs $ chunks ⊳ t
+
+type Decoder = BS.ByteString → Either UnicodeException Text
+
+decodeStr ∷ Monad m ⇒ Decoder → BS.ByteString → m Text
+decodeStr decoder str
+ = case decoder str of
+ Right t → return t
+ Left e → fail $ show e
- openConv ∷ CIAscii → m TC.Converter
- openConv charset
- = let cs = A.toString $ A.fromCIAscii charset
- open' = TC.open cs (Just True)
- in
- case unsafePerformIO $ E.try open' of
- Right conv → return conv
- Left err → fail $ show (err ∷ ICUError)
+getDecoder ∷ Monad m ⇒ CIAscii → m Decoder
+getDecoder charset
+ | charset ≡ "UTF-8" = return decodeUtf8'
+ | charset ≡ "US-ASCII" = return decodeUtf8'
+ | otherwise = fail $ "No decoders found for charset: "
+ ⧺ A.toString (A.fromCIAscii charset)
projects / Lucu.git / blobdiff