Haddock overhaul

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

diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs
index a8e29cb44870866fc74f2eb86d2e6a33afce30b7..ee929ad8d0660eb023782be5a4a6b806dbf82434 100644 (file)
--- a/Network/HTTP/Lucu/RFC2231.hs
+++ b/Network/HTTP/Lucu/RFC2231.hs
@@ -5,15 +5,18 @@
   , ScopedTypeVariables
   , UnicodeSyntax
   #-}
   , 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:
 -- 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
 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
 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.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

 
 

+-- |Convert parameter values to an 'AsciiBuilder'.

 printParams ∷ Map CIAscii Text → AsciiBuilder
 printParams params
     | M.null params = (∅)
 printParams ∷ Map CIAscii Text → AsciiBuilder
 printParams params
     | M.null params = (∅)


@@ -107,6 +115,7 @@ 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)
 paramsP = decodeParams =≪ P.many (try paramP)
 
 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)
            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 +227,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 +247,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)