Say good bye to the ugliness of "text" </> "plain".

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

diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs
new file mode 100644 (file)
index 0000000..37adda3
--- /dev/null
+++ b/Network/HTTP/Lucu/ContentCoding.hs
@@ -0,0 +1,46 @@
+module Network.HTTP.Lucu.ContentCoding
+    ( acceptEncodingListP
+    , normalizeCoding
+    , unnormalizeCoding
+    , orderAcceptEncodings
+    )
+    where
+
+import           Data.Char
+import           Data.Maybe
+import           Network.HTTP.Lucu.Parser
+import           Network.HTTP.Lucu.Parser.Http
+
+
+acceptEncodingListP :: Parser [(String, Maybe Double)]
+acceptEncodingListP = allowEOF $! listOf accEncP
+
+      
+accEncP :: Parser (String, Maybe Double)
+accEncP = do coding <- token
+             qVal   <- option Nothing
+                       $ do string ";q="
+                            q <- qvalue
+                            return $ Just q
+             return (normalizeCoding coding, qVal)
+
+
+normalizeCoding :: String -> String
+normalizeCoding coding
+    = case map toLower coding of
+        "x-gzip"     -> "gzip"
+        "x-compress" -> "compress"
+        other        -> other
+
+
+unnormalizeCoding :: String -> String
+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)
+    = fromMaybe 0 q1 `compare` fromMaybe 0 q2