Network/HTTP/Lucu/ContentCoding.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5 module Network.HTTP.Lucu.ContentCoding
   6     ( AcceptEncoding(..)
   7
   8     , acceptEncodingListP
   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 acceptEncodingListP ∷ Parser [AcceptEncoding]
  38 acceptEncodingListP = listOf accEncP
  39
  40 accEncP ∷ Parser AcceptEncoding
  41 accEncP = 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     = if coding ≡ "x-gzip" then
  51           "gzip"
  52       else
  53           if coding ≡ "x-compress" then
  54               "compress"
  55           else
  56               coding
  57
  58 unnormalizeCoding ∷ CIAscii → CIAscii
  59 unnormalizeCoding coding
  60     = if coding ≡ "gzip" then
  61           "x-gzip"
  62       else
  63           if coding ≡ "compress" then
  64               "x-compress"
  65           else
  66               coding