Still working on RFC2231

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs
index 9e99829025956543632e6a05db9f11a5ca9f7692..e0f6e422ce867b96e9e1b36e2a3024dff5e3cfb3 100644 (file)
--- a/Network/HTTP/Lucu/RFC2231.hs
+++ b/Network/HTTP/Lucu/RFC2231.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    OverloadedStrings
+    DoAndIfThenElse
+  , OverloadedStrings
   , UnicodeSyntax
   #-}
 -- |Provide facilities to encode/decode MIME parameter values in
@@ -7,13 +8,16 @@
 -- http://www.faqs.org/rfcs/rfc2231.html
 module Network.HTTP.Lucu.RFC2231
     ( printParams
---    , paramsP
+    , paramsP
     )
     where
+import Control.Applicative
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import qualified Data.Ascii as A
+import Data.Attoparsec.Char8 as P
 import Data.Bits
 import qualified Data.ByteString.Char8 as BS
+import Data.Char
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Monoid.Unicode
@@ -23,6 +27,7 @@ import Data.Text.Encoding
 import Data.Word
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
+import Prelude hiding (takeWhile)
 import Prelude.Unicode
 
 printParams ∷ Map CIAscii Text → AsciiBuilder
@@ -73,8 +78,93 @@ printParams params
           | o ≤ 0x09  = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o
           | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A)
 
-{-
-decode ∷ [(CIAscii, Ascii)] → Map CIAscii Text
-{-# INLINEABLE decode #-}
-decode = error "FIXME: not implemented"
--}
\ No newline at end of file
+
+data ExtendedParam
+    = InitialEncodedParam {
+        epName    ∷ !CIAscii
+      , epCharset ∷ !CIAscii
+      , epPayload ∷ !BS.ByteString
+      }
+    | ContinuedEncodedParam {
+        epName    ∷ !CIAscii
+      , epSection ∷ !Integer
+      , epPayload ∷ !BS.ByteString
+      }
+    | AsciiParam {
+        epName    ∷ !CIAscii
+      , epSection ∷ !Integer
+      , apPayload ∷ !Ascii
+      }
+
+paramsP ∷ Parser (Map CIAscii Text)
+paramsP = decodeParams <$> P.many (try paramP)
+    where
+      paramP ∷ Parser ExtendedParam
+      paramP = do skipMany lws
+                  _   ← char ';'
+                  skipMany lws
+                  epm ← nameP
+                  _   ← char '='
+                  case epm of
+                    (name, 0, True)
+                        → do (charset, payload) ← initialEncodedValue
+                             return $ InitialEncodedParam name charset payload
+                    (name, section, True)
+                        → do payload ← encodedPayload
+                             return $ ContinuedEncodedParam name section payload
+                    (name, section, False)
+                        → do payload ← token <|> quotedStr
+                             return $ AsciiParam name section payload
+
+      nameP ∷ Parser (CIAscii, Integer, Bool)
+      nameP = do name      ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
+                             takeWhile1 (\c → isToken c ∧ c ≢ '*')
+                 section   ← option 0 $
+                                 try $
+                                 do _ ← char '*'
+                                    n ← decimal
+                                    return n
+                 isEncoded ← option False $
+                                 do _ ← char '*'
+                                    return True
+                 return (name, section, isEncoded)
+
+      initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
+      initialEncodedValue = do charset ← metadata
+                               _       ← char '\''
+                               _       ← metadata -- Ignore the language tag
+                               _       ← char '\''
+                               payload ← encodedPayload
+                               return (charset, payload)
+          where
+            metadata ∷ Parser CIAscii
+            metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
+                       takeWhile (\c → isToken c ∧ c ≢ '\'')
+
+      encodedPayload ∷ Parser BS.ByteString
+      encodedPayload = BS.concat <$> P.many (hexChar <|> literal)
+          where
+            hexChar ∷ Parser BS.ByteString
+            hexChar = do _ ← char '%'
+                         h ← satisfy isHexChar
+                         l ← satisfy isHexChar
+                         return $ BS.singleton $ hexToChar h l
+
+            isHexChar ∷ Char → Bool
+            isHexChar = inClass "0-9a-fA-F"
+
+            hexToChar ∷ Char → Char → Char
+            hexToChar h l
+                = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l
+
+            hexToInt ∷ Char → Int
+            hexToInt c
+                | c ≤ '9'   = ord c - ord '0'
+                | c ≤ 'F'   = ord c - ord 'A' + 10
+                | otherwise = ord c - ord 'a' + 10
+
+            literal ∷ Parser BS.ByteString
+            literal = takeWhile1 (\c → isToken c ∧ c ≢ '%')
+
+      decodeParams ∷ [ExtendedParam] → Map CIAscii Text
+      decodeParams = error "FIXME"