Reimplement MultipartForm

[Lucu.git] / Network / HTTP / Lucu / RFC2231.hs

diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs
index 791c891f46d8be9009da9632537b40400c4bf378..1046c5df516f47ebcb06bcaf1ea1228a381cba72 100644 (file)
--- a/Network/HTTP/Lucu/RFC2231.hs
+++ b/Network/HTTP/Lucu/RFC2231.hs
@@ -2,7 +2,6 @@
     DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards
     DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards

-  , ScopedTypeVariables

   , UnicodeSyntax
   #-}
 -- |Provide functionalities to encode/decode MIME parameter values in
   , 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
 --
 -- You usually don't have to use this module directly.
 module Network.HTTP.Lucu.RFC2231

-    ( printParams
-    , paramsP
+    ( printMIMEParams
+    , mimeParams

     )
     where
 import Control.Applicative
     )
     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 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 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.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 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
     -- 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
 
 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
 
 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)
              -- 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
          else
              return (charset, payload)
     where


@@ -209,12 +206,13 @@ decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text)
 {-# INLINE decodeParams #-}
 decodeParams = (mapM decodeSections =≪) ∘ sortBySection
 
 {-# INLINE decodeParams #-}
 decodeParams = (mapM decodeSections =≪) ∘ sortBySection
 

-sortBySection ∷ ∀m. Monad m
+sortBySection ∷ Monad m

               ⇒ [ExtendedParam]
               → m (Map CIAscii (Map Integer ExtendedParam))
 sortBySection = flip go (∅)
     where
               ⇒ [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
          → 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
 decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
     where

-      toSeq ∷ Map Integer ExtendedParam
+      toSeq ∷ Monad m
+            ⇒ Map Integer ExtendedParam

             → Integer
             → Seq ExtendedParam
             → m (Seq 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
       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
               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
 
                     in
                       decodeSeq' Nothing xs $ S.singleton t
 

-      decodeSeq' ∷ Maybe (TC.Converter)
+      decodeSeq' ∷ Monad m
+                 ⇒ Maybe Decoder

                  → Seq ExtendedParam
                  → Seq Text
                  → m Text
                  → 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 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
                        Nothing
                            → fail (concat [ "Section "
                                           , show epSection


@@ -304,13 +303,19 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
               AsciiParam {..} :< xs
                   → let t = A.toText apPayload
                     in
               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)