Many bugfixes

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

diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs
index 1d49646947dacb0d81a848b8a9d658ccda541370..791c891f46d8be9009da9632537b40400c4bf378 100644 (file)
--- a/Network/HTTP/Lucu/RFC2231.hs
+++ b/Network/HTTP/Lucu/RFC2231.hs
@@ -5,15 +5,19 @@
   , 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 hiding (mapM)

 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


@@ -32,33 +36,42 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.ICU.Convert as TC
 import Data.Text.Encoding
 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 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 ∷ Map CIAscii Text → AsciiBuilder

-printParams params
-    | M.null params = (∅)
-    | otherwise     = A.toAsciiBuilder "; " ⊕
-                      joinWith "; " (map printPair $ M.toList params)
+{-# INLINEABLE printParams #-}
+printParams m = M.foldlWithKey f (∅) m
+    -- THINKME: Use foldlWithKey' for newer Data.Map
+    where
+      f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder
+      {-# INLINE f #-}
+      f ab k v = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v

 
 

-printPair ∷ (CIAscii, Text) → AsciiBuilder
-printPair (name, value)
+printPair ∷ CIAscii → Text → AsciiBuilder
+{-# INLINEABLE printPair #-}
+printPair name value

     | T.any (> '\xFF') value
         = printPairInUTF8 name value
     | otherwise
         = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value)
 
 printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder
     | T.any (> '\xFF') value
         = printPairInUTF8 name value
     | otherwise
         = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value)
 
 printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder

+{-# INLINEABLE printPairInUTF8 #-}

 printPairInUTF8 name value
     = A.toAsciiBuilder (A.fromCIAscii name) ⊕
       A.toAsciiBuilder "*=utf-8''" ⊕
       escapeUnsafeChars (encodeUtf8 value) (∅)
 
 printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder
 printPairInUTF8 name value
     = A.toAsciiBuilder (A.fromCIAscii name) ⊕
       A.toAsciiBuilder "*=utf-8''" ⊕
       escapeUnsafeChars (encodeUtf8 value) (∅)
 
 printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder

+{-# INLINEABLE printPairInAscii #-}

 printPairInAscii name value
     = A.toAsciiBuilder (A.fromCIAscii name) ⊕
       A.toAsciiBuilder "=" ⊕
 printPairInAscii name value
     = A.toAsciiBuilder (A.fromCIAscii name) ⊕
       A.toAsciiBuilder "=" ⊕


@@ -68,6 +81,7 @@ printPairInAscii name value
           A.toAsciiBuilder value
 
 escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
           A.toAsciiBuilder value
 
 escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder

+{-# INLINEABLE escapeUnsafeChars #-}

 escapeUnsafeChars bs b
     = case BS.uncons bs of
         Nothing         → b
 escapeUnsafeChars bs b
     = case BS.uncons bs of
         Nothing         → b


@@ -78,15 +92,18 @@ escapeUnsafeChars bs b
                           b ⊕ toHex (fromIntegral $ fromEnum c)
 
 toHex ∷ Word8 → AsciiBuilder
                           b ⊕ toHex (fromIntegral $ fromEnum c)
 
 toHex ∷ Word8 → AsciiBuilder

+{-# INLINEABLE toHex #-}

 toHex o = A.toAsciiBuilder "%" ⊕
           A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8)
                                                , toHex' (o .&.   0x0F) ])
 toHex o = A.toAsciiBuilder "%" ⊕
           A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8)
                                                , toHex' (o .&.   0x0F) ])

-
-toHex' ∷ Word8 → Char
-toHex' o
-    | o ≤ 0x09  = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o
-    | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A)
-
+    where
+      toHex' ∷ Word8 → Char
+      {-# INLINEABLE toHex' #-}
+      toHex' h
+          | h ≤ 0x09  = toEnum $ fromIntegral
+                               $ fromEnum '0' + fromIntegral h
+          | otherwise = toEnum $ fromIntegral
+                               $ fromEnum 'A' + fromIntegral (h - 0x0A)

 
 data ExtendedParam
     = InitialEncodedParam {
 
 data ExtendedParam
     = InitialEncodedParam {


@@ -106,18 +123,21 @@ data ExtendedParam
       }
 
 section ∷ ExtendedParam → Integer
       }
 
 section ∷ ExtendedParam → Integer

+{-# INLINE section #-}

 section (InitialEncodedParam {..}) = 0
 section ep                         = epSection ep
 
 section (InitialEncodedParam {..}) = 0
 section ep                         = epSection ep
 

+-- |'Parser' for parameter values.

 paramsP ∷ Parser (Map CIAscii Text)
 paramsP ∷ Parser (Map CIAscii Text)

+{-# INLINEABLE paramsP #-}

 paramsP = decodeParams =≪ P.many (try paramP)
 
 paramP ∷ Parser ExtendedParam
 paramP = do skipMany lws
 paramsP = decodeParams =≪ P.many (try paramP)
 
 paramP ∷ Parser ExtendedParam
 paramP = do skipMany lws

-            _   ← char ';'
+            void $ char ';'

             skipMany lws
             epm ← nameP
             skipMany lws
             epm ← nameP

-            _   ← char '='
+            void $ char '='

             case epm of
               (name, 0, True)
                   → do (charset, payload) ← initialEncodedValue
             case epm of
               (name, 0, True)
                   → do (charset, payload) ← initialEncodedValue


@@ -132,26 +152,20 @@ paramP = do skipMany lws
 nameP ∷ Parser (CIAscii, Integer, Bool)
 nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
                        takeWhile1 (\c → isToken c ∧ c ≢ '*')
 nameP ∷ Parser (CIAscii, Integer, Bool)
 nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
                        takeWhile1 (\c → isToken c ∧ c ≢ '*')

-           sect      ← option 0 $
-                       try $
-                       do _ ← char '*'
-                          n ← decimal
-                          return n
-           isEncoded ← option False $
-                       do _ ← char '*'
-                          return True
+           sect      ← option 0     $ try (char '*' *> decimal  )
+           isEncoded ← option False $ try (char '*' *> pure True)

            return (name, sect, isEncoded)
 
 initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
 initialEncodedValue
     = do charset ← metadata
            return (name, sect, isEncoded)
 
 initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
 initialEncodedValue
     = do charset ← metadata

-         _       ← char '\''
-         _       ← metadata -- Ignore the language tag
-         _       ← char '\''
+         void $ char '\''
+         void $ metadata -- Ignore the language tag
+         void $ char '\''

          payload ← encodedPayload
          if charset ≡ "" then
              -- NOTE: I'm not sure this is the right thing, but RFC
          payload ← encodedPayload
          if charset ≡ "" then
              -- NOTE: I'm not sure this is the right thing, but RFC

-             -- 2231 doesn't tell us what should we do when the
+             -- 2231 doesn't tell us what we should do when the

              -- charset is omitted.
              return ("US-ASCII", payload)
          else
              -- charset is omitted.
              return ("US-ASCII", payload)
          else


@@ -159,13 +173,15 @@ initialEncodedValue
     where
       metadata ∷ Parser CIAscii
       metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
     where
       metadata ∷ Parser CIAscii
       metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>

-                 takeWhile (\c → isToken c ∧ c ≢ '\'')
+                 takeWhile (\c → c ≢ '\'' ∧ isToken c)

 
 encodedPayload ∷ Parser BS.ByteString
 
 encodedPayload ∷ Parser BS.ByteString

+{-# INLINE encodedPayload #-}

 encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars)
 
 hexChar ∷ Parser BS.ByteString
 encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars)
 
 hexChar ∷ Parser BS.ByteString

-hexChar = do _ ← char '%'
+{-# INLINEABLE hexChar #-}
+hexChar = do void $ char '%'

              h ← satisfy isHexChar
              l ← satisfy isHexChar
              return $ BS.singleton $ hexToChar h l
              h ← satisfy isHexChar
              l ← satisfy isHexChar
              return $ BS.singleton $ hexToChar h l


@@ -174,19 +190,23 @@ isHexChar ∷ Char → Bool
 isHexChar = inClass "0-9a-fA-F"
 
 hexToChar ∷ Char → Char → Char
 isHexChar = inClass "0-9a-fA-F"
 
 hexToChar ∷ Char → Char → Char

+{-# INLINE hexToChar #-}

 hexToChar h l
     = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l
 
 hexToInt ∷ Char → Int
 hexToChar h l
     = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l
 
 hexToInt ∷ Char → Int

+{-# INLINEABLE hexToInt #-}

 hexToInt c
     | c ≤ '9'   = ord c - ord '0'
     | c ≤ 'F'   = ord c - ord 'A' + 10
     | otherwise = ord c - ord 'a' + 10
 
 rawChars ∷ Parser BS.ByteString
 hexToInt c
     | c ≤ '9'   = ord c - ord '0'
     | c ≤ 'F'   = ord c - ord 'A' + 10
     | otherwise = ord c - ord 'a' + 10
 
 rawChars ∷ Parser BS.ByteString

+{-# INLINE rawChars #-}

 rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%')
 
 decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text)
 rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%')
 
 decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text)

+{-# INLINE decodeParams #-}

 decodeParams = (mapM decodeSections =≪) ∘ sortBySection
 
 sortBySection ∷ ∀m. Monad m
 decodeParams = (mapM decodeSections =≪) ∘ sortBySection
 
 sortBySection ∷ ∀m. Monad m


@@ -206,12 +226,13 @@ sortBySection = flip go (∅)
                     in
                       go xs m'
               Just s
                     in
                       go xs m'
               Just s

-                  → case M.insertLookupWithKey (\_ s' _ → s') (section x) x s of
-                       (Nothing, s')
-                           → let m' = M.insert (epName x) s' m
+                  → case M.lookup (section x) s of
+                       Nothing
+                           → let s' = M.insert (section x) x  s
+                                 m' = M.insert (epName  x) s' m

                              in
                                go xs m'
                              in
                                go xs m'

-                       (Just _, _)
+                       Just _

                            → fail (concat [ "Duplicate section "
                                           , show $ section x
                                           , " for parameter '"
                            → fail (concat [ "Duplicate section "
                                           , show $ section x
                                           , " for parameter '"


@@ -251,7 +272,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                        let t = TC.toUnicode conv epPayload
                        decodeSeq' (Just conv) xs $ S.singleton t
               ContinuedEncodedParam {..} :< _
                        let t = TC.toUnicode conv epPayload
                        decodeSeq' (Just conv) xs $ S.singleton t
               ContinuedEncodedParam {..} :< _

-                  → fail "decodeSeq: internal error: ContinuedEncodedParam at section 0"
+                  → fail "decodeSeq: internal error: CEP at section 0"

               AsciiParam {..} :< xs
                   → let t = A.toText apPayload
                     in
               AsciiParam {..} :< xs
                   → let t = A.toText apPayload
                     in


@@ -266,7 +287,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
               EmptyL
                   → return $ T.concat $ toList chunks
               InitialEncodedParam {..} :< _
               EmptyL
                   → return $ T.concat $ toList chunks
               InitialEncodedParam {..} :< _

-                  → fail "decodeSeq': internal error: InitialEncodedParam at section > 0"
+                  → fail "decodeSeq': internal error: IEP at section > 0"

               ContinuedEncodedParam {..} :< xs
                   → case convM of
                        Just conv
               ContinuedEncodedParam {..} :< xs
                   → case convM of
                        Just conv


@@ -278,7 +299,7 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                                           , show epSection
                                           , " for parameter '"
                                           , A.toString $ A.fromCIAscii epName
                                           , show epSection
                                           , " for parameter '"
                                           , A.toString $ A.fromCIAscii epName

-                                          , "' is encoded but its section 0 is not"
+                                          , "' is encoded but its first section is not"

                                           ])
               AsciiParam {..} :< xs
                   → let t = A.toText apPayload
                                           ])
               AsciiParam {..} :< xs
                   → let t = A.toText apPayload


@@ -287,4 +308,9 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
 
       openConv ∷ CIAscii → m TC.Converter
       openConv charset
 
       openConv ∷ CIAscii → m TC.Converter
       openConv charset

-          = fail "FIXME"
+          = 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)