Bugfix

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

diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs
index a8e29cb44870866fc74f2eb86d2e6a33afce30b7..9856f474eb94281b8280fc9110780fe43643a278 100644 (file)
--- a/Network/HTTP/Lucu/RFC2231.hs
+++ b/Network/HTTP/Lucu/RFC2231.hs
@@ -14,6 +14,7 @@ module Network.HTTP.Lucu.RFC2231
     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative

+import qualified Control.Exception as E

 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import qualified Data.Ascii as A
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import qualified Data.Ascii as A


@@ -25,17 +26,21 @@ import Data.Foldable
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Monoid.Unicode
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Monoid.Unicode

+import Data.Sequence (Seq, ViewL(..))

 import qualified Data.Sequence as S
 import Data.Sequence.Unicode hiding ((∅))
 import Data.Text (Text)
 import qualified Data.Text as T
 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.Encoding

+import Data.Text.ICU.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

 
 printParams ∷ Map CIAscii Text → AsciiBuilder
 printParams params
 
 printParams ∷ Map CIAscii Text → AsciiBuilder
 printParams params


@@ -141,12 +146,19 @@ nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
            return (name, sect, isEncoded)
 
 initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
            return (name, sect, isEncoded)
 
 initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)

-initialEncodedValue = do charset ← metadata
-                         _       ← char '\''
-                         _       ← metadata -- Ignore the language tag
-                         _       ← char '\''
-                         payload ← encodedPayload
-                         return (charset, payload)
+initialEncodedValue
+    = do charset ← metadata
+         _       ← char '\''
+         _       ← metadata -- Ignore the language tag
+         _       ← char '\''
+         payload ← encodedPayload
+         if charset ≡ "" then
+             -- 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)
+         else
+             return (charset, payload)

     where
       metadata ∷ Parser CIAscii
       metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
     where
       metadata ∷ Parser CIAscii
       metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>


@@ -211,16 +223,19 @@ sortBySection = flip go (∅)
                                           ])
 
 decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text
                                           ])
 
 decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text

-decodeSections = flip (flip go 0) (∅)
+decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)

     where
     where

-      go ∷ Map Integer ExtendedParam → Integer → S.Seq Text → m Text
-      go m expectedSect chunks
+      toSeq ∷ Map Integer ExtendedParam
+            → Integer
+            → Seq ExtendedParam
+            → m (Seq ExtendedParam)
+      toSeq m expectedSect sects

           = case M.minViewWithKey m of
               Nothing
           = case M.minViewWithKey m of
               Nothing

-                  → return $ T.concat $ toList chunks
+                  → return sects

               Just ((sect, p), m')
                   | sect ≡ expectedSect
               Just ((sect, p), m')
                   | sect ≡ expectedSect

-                        → error "FIXME"
+                        → toSeq m' (expectedSect + 1) (sects ⊳ p)

                   | otherwise
                         → fail (concat [ "Missing section "
                                        , show $ section p
                   | otherwise
                         → fail (concat [ "Missing section "
                                        , show $ section p


@@ -228,3 +243,56 @@ decodeSections = flip (flip go 0) (∅)
                                        , A.toString $ A.fromCIAscii $ epName p
                                        , "'"
                                        ])
                                        , A.toString $ A.fromCIAscii $ epName p
                                        , "'"
                                        ])

+
+      decodeSeq ∷ 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
+              ContinuedEncodedParam {..} :< _
+                  → fail "decodeSeq: internal error: CEP at section 0"
+              AsciiParam {..} :< xs
+                  → let t = A.toText apPayload
+                    in
+                      decodeSeq' Nothing xs $ S.singleton t
+
+      decodeSeq' ∷ Maybe (TC.Converter)
+                 → Seq ExtendedParam
+                 → Seq Text
+                 → m Text
+      decodeSeq' convM 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
+                       Nothing
+                           → fail (concat [ "Section "
+                                          , show epSection
+                                          , " for parameter '"
+                                          , A.toString $ A.fromCIAscii epName
+                                          , "' is encoded but its first section is not"
+                                          ])
+              AsciiParam {..} :< xs
+                  → let t = A.toText apPayload
+                    in
+                      decodeSeq' convM xs $ chunks ⊳ t
+
+      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)