Network/HTTP/Lucu/ContentCoding.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5 module Network.HTTP.Lucu.ContentCoding
   6     ( AcceptEncoding(..)
   7
   8     , acceptEncodingList
   9     , normalizeCoding
  10     , unnormalizeCoding
  11     )
  12     where
  13 import Control.Applicative
  14 import Data.Ascii (CIAscii, toCIAscii)
  15 import Data.Attoparsec.Char8
  16 import Data.Ord
  17 import Data.Maybe
  18 import Network.HTTP.Lucu.Parser.Http
  19 import Prelude.Unicode
  20
  21 data AcceptEncoding
  22     = AcceptEncoding {
  23         aeEncoding ∷ !CIAscii
  24       , aeQValue   ∷ !(Maybe Double)
  25       }
  26       deriving (Eq, Show)
  27
  28 instance Ord AcceptEncoding where
  29     (AcceptEncoding c1 q1) `compare` (AcceptEncoding c2 q2)
  30         | q1' > q1' = GT
  31         | q1' < q2' = LT
  32         | otherwise = compare c1 c2
  33         where
  34           q1' = fromMaybe 0 q1
  35           q2' = fromMaybe 0 q2
  36
  37 acceptEncodingList ∷ Parser [AcceptEncoding]
  38 acceptEncodingList = listOf accEnc
  39
  40 accEnc ∷ Parser AcceptEncoding
  41 accEnc = do coding ← toCIAscii <$> token
  42             qVal   ← option Nothing
  43                      $ do _ ← string ";q="
  44                           q ← qvalue
  45                           return $ Just q
  46             return $ AcceptEncoding (normalizeCoding coding) qVal
  47
  48 normalizeCoding ∷ CIAscii → CIAscii
  49 normalizeCoding coding
  50     | coding ≡ "x-gzip"     = "gzip"
  51     | coding ≡ "x-compress" = "compress"
  52     | otherwise             = coding
  53
  54 unnormalizeCoding ∷ CIAscii → CIAscii
  55 unnormalizeCoding coding
  56     | coding ≡ "gzip"     = "x-gzip"
  57     | coding ≡ "compress" = "x-compress"
  58     | otherwise           = coding