X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRFC2231.hs;h=1046c5df516f47ebcb06bcaf1ea1228a381cba72;hp=791c891f46d8be9009da9632537b40400c4bf378;hb=a362be1c8664306b970c32e1df9b62081498feb1;hpb=45e3770f440c9fa8668f7e33063d630d73bcbe55

diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs
index 791c891..1046c5d 100644
--- a/Network/HTTP/Lucu/RFC2231.hs
+++ b/Network/HTTP/Lucu/RFC2231.hs
@@ -2,7 +2,6 @@
     DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards
-  , ScopedTypeVariables
   , UnicodeSyntax
   #-}
 -- |Provide functionalities to encode/decode MIME parameter values in
@@ -11,12 +10,11 @@
 --
 -- 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)
@@ -34,21 +32,19 @@ import qualified Data.Sequence as S
 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
@@ -127,10 +123,10 @@ section ∷ ExtendedParam → Integer
 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
@@ -168,6 +164,7 @@ initialEncodedValue
              -- 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
@@ -209,12 +206,13 @@ decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text)
 {-# 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
@@ -240,10 +238,11 @@ sortBySection = flip go (∅)
                                           , "'"
                                           ])
 
-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)
@@ -262,15 +261,15 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                                        , "'"
                                        ])
 
-      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
@@ -278,22 +277,22 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                     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
@@ -304,13 +303,19 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
               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)