X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRFC2231.hs;h=ee929ad8d0660eb023782be5a4a6b806dbf82434;hb=9668dc27a02b59d7bfb1e9e40af3d2619700ad69;hp=a8e29cb44870866fc74f2eb86d2e6a33afce30b7;hpb=7a7fc1ababca9cfc667870b1c7da78378072bb6b;p=Lucu.git

diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs
index a8e29cb..ee929ad 100644
--- a/Network/HTTP/Lucu/RFC2231.hs
+++ b/Network/HTTP/Lucu/RFC2231.hs
@@ -5,15 +5,18 @@
   , ScopedTypeVariables
   , UnicodeSyntax
   #-}
--- |Provide facilities to encode/decode MIME parameter values in
+-- |Provide functionalities to encode/decode MIME parameter values in
 -- character sets other than US-ASCII. See:
--- http://www.faqs.org/rfcs/rfc2231.html
+-- <http://www.faqs.org/rfcs/rfc2231.html>
+--
+-- You usually don't have to use this module directly.
 module Network.HTTP.Lucu.RFC2231
     ( printParams
     , paramsP
     )
     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
@@ -25,18 +28,23 @@ import Data.Foldable
 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.Text.ICU.Convert as TC
 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 System.IO.Unsafe
 
+-- |Convert parameter values to an 'AsciiBuilder'.
 printParams ∷ Map CIAscii Text → AsciiBuilder
 printParams params
     | M.null params = (∅)
@@ -107,6 +115,7 @@ section ∷ ExtendedParam → Integer
 section (InitialEncodedParam {..}) = 0
 section ep                         = epSection ep
 
+-- |'Parser' for parameter values.
 paramsP ∷ Parser (Map CIAscii Text)
 paramsP = decodeParams =≪ P.many (try paramP)
 
@@ -141,12 +150,19 @@ nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
            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) <$>
@@ -211,16 +227,19 @@ sortBySection = flip go (∅)
                                           ])
 
 decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text
-decodeSections = flip (flip go 0) (∅)
+decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
     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
-                  → return $ T.concat $ toList chunks
+                  → return sects
               Just ((sect, p), m')
                   | sect ≡ expectedSect
-                        → error "FIXME"
+                        → toSeq m' (expectedSect + 1) (sects ⊳ p)
                   | otherwise
                         → fail (concat [ "Missing section "
                                        , show $ section p
@@ -228,3 +247,56 @@ decodeSections = flip (flip go 0) (∅)
                                        , 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)