Many bugfixes

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

diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs
index ee929ad8d0660eb023782be5a4a6b806dbf82434..791c891f46d8be9009da9632537b40400c4bf378 100644 (file)
--- a/Network/HTTP/Lucu/RFC2231.hs
+++ b/Network/HTTP/Lucu/RFC2231.hs
@@ -17,6 +17,7 @@ module Network.HTTP.Lucu.RFC2231
     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
@@ -46,25 +47,31 @@ import System.IO.Unsafe
 
 -- |Convert parameter values to an '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
+{-# INLINEABLE printPairInUTF8 #-}
 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 "=" ⊕
@@ -74,6 +81,7 @@ printPairInAscii name value
           A.toAsciiBuilder value
 
 escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
+{-# INLINEABLE escapeUnsafeChars #-}
 escapeUnsafeChars bs b
     = case BS.uncons bs of
         Nothing         → b
@@ -84,15 +92,18 @@ escapeUnsafeChars bs b
                           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' ∷ 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 {
@@ -112,19 +123,21 @@ data ExtendedParam
       }
 
 section ∷ ExtendedParam → Integer
+{-# INLINE section #-}
 section (InitialEncodedParam {..}) = 0
 section ep                         = epSection ep
 
 -- |'Parser' for parameter values.
 paramsP ∷ Parser (Map CIAscii Text)
+{-# INLINEABLE paramsP #-}
 paramsP = decodeParams =≪ P.many (try paramP)
 
 paramP ∷ Parser ExtendedParam
 paramP = do skipMany lws
-            _   ← char ';'
+            void $ char ';'
             skipMany lws
             epm ← nameP
-            _   ← char '='
+            void $ char '='
             case epm of
               (name, 0, True)
                   → do (charset, payload) ← initialEncodedValue
@@ -139,22 +152,16 @@ paramP = do skipMany lws
 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
-         _       ← 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
@@ -166,13 +173,15 @@ initialEncodedValue
     where
       metadata ∷ Parser CIAscii
       metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
-                 takeWhile (\c → isToken c ∧ c ≢ '\'')
+                 takeWhile (\c → c ≢ '\'' ∧ isToken c)
 
 encodedPayload ∷ Parser BS.ByteString
+{-# INLINE encodedPayload #-}
 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
@@ -181,19 +190,23 @@ isHexChar ∷ Char → Bool
 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
+{-# 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
+{-# INLINE rawChars #-}
 rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%')
 
 decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text)
+{-# INLINE decodeParams #-}
 decodeParams = (mapM decodeSections =≪) ∘ sortBySection
 
 sortBySection ∷ ∀m. Monad m
@@ -213,12 +226,13 @@ sortBySection = flip go (∅)
                     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'
-                       (Just _, _)
+                       Just _
                            → fail (concat [ "Duplicate section "
                                           , show $ section x
                                           , " for parameter '"