X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FContentCoding.hs;h=033b48b4d941b6d462cfa4ebac231d0f3f1869d2;hb=db4a546d0d462cb94639b1f273bf0b78bccc960c;hp=0771efa91ace3e052f43d5b298597270c04a3c79;hpb=f62b6f07bbf1eefcf552163d8f7daa6e0862ed5d;p=Lucu.git

diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs
index 0771efa..033b48b 100644
--- a/Network/HTTP/Lucu/ContentCoding.hs
+++ b/Network/HTTP/Lucu/ContentCoding.hs
@@ -1,48 +1,64 @@
+{-# LANGUAGE
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , OverloadedStrings
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.ContentCoding
-    ( acceptEncodingListP
+    ( AcceptEncoding(..)
     , normalizeCoding
     , unnormalizeCoding
-    , orderAcceptEncodings
     )
     where
+import Control.Applicative
+import Data.Ascii (CIAscii, toCIAscii)
+import Data.Attoparsec.Char8
+import Data.Attoparsec.Parsable
+import Data.ByteString (ByteString)
+import Data.Ord
+import Data.Maybe
+import Network.HTTP.Lucu.Parser.Http
+import Prelude.Unicode
 
-import           Data.Char
-import           Data.Ord
-import           Data.Maybe
-import           Network.HTTP.Lucu.Parser
-import           Network.HTTP.Lucu.Parser.Http
+data AcceptEncoding
+    = AcceptEncoding {
+        aeEncoding ∷ !CIAscii
+      , aeQValue   ∷ !(Maybe Double)
+      }
+      deriving (Eq, Show)
 
+instance Ord AcceptEncoding where
+    (AcceptEncoding c1 q1) `compare` (AcceptEncoding c2 q2)
+        | q1' > q1' = GT
+        | q1' < q2' = LT
+        | otherwise = compare c1 c2
+        where
+          q1' = fromMaybe 0 q1
+          q2' = fromMaybe 0 q2
 
-acceptEncodingListP :: Parser [(String, Maybe Double)]
-acceptEncodingListP = allowEOF $! listOf accEncP
+instance Parsable ByteString [AcceptEncoding] where
+    {-# INLINE parser #-}
+    parser = listOf parser
 
-      
-accEncP :: Parser (String, Maybe Double)
-accEncP = do coding <- token
-             qVal   <- option Nothing
-                       $ do string ";q="
-                            q <- qvalue
-                            return $ Just q
-             return (normalizeCoding coding, qVal)
+instance Parsable ByteString AcceptEncoding where
+    {-# INLINE parser #-}
+    parser = do coding ← toCIAscii <$> token
+                qVal   ← option Nothing
+                             $ do _ ← string ";q="
+                                  q ← qvalue
+                                  return $ Just q
+                return $ AcceptEncoding (normalizeCoding coding) qVal
 
-
-normalizeCoding :: String -> String
+normalizeCoding ∷ CIAscii → CIAscii
+{-# INLINEABLE normalizeCoding #-}
 normalizeCoding coding
-    = case map toLower coding of
-        "x-gzip"     -> "gzip"
-        "x-compress" -> "compress"
-        other        -> other
-
+    | coding ≡ "x-gzip"     = "gzip"
+    | coding ≡ "x-compress" = "compress"
+    | otherwise             = coding
 
-unnormalizeCoding :: String -> String
+unnormalizeCoding ∷ CIAscii → CIAscii
+{-# INLINEABLE unnormalizeCoding #-}
 unnormalizeCoding coding
-    = case map toLower coding of
-        "gzip"     -> "x-gzip"
-        "compress" -> "x-compress"
-        other        -> other
-
-
-orderAcceptEncodings :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering
-orderAcceptEncodings (_, q1) (_, q2)
-    = comparing (fromMaybe 0) q1 q2
-
+    | coding ≡ "gzip"     = "x-gzip"
+    | coding ≡ "compress" = "x-compress"
+    | otherwise           = coding