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 !CIAscii !(Maybe Double)
  23       deriving (Eq, Show)
  24
  25 instance Ord AcceptEncoding where
  26     (AcceptEncoding c1 q1) `compare` (AcceptEncoding c2 q2)
  27         | q1' > q1' = GT
  28         | q1' < q2' = LT
  29         | otherwise = compare c1 c2
  30         where
  31           q1' = fromMaybe 0 q1
  32           q2' = fromMaybe 0 q2
  33
  34 acceptEncodingListP ∷ Parser [(CIAscii, Maybe Double)]
  35 acceptEncodingListP = listOf accEncP
  36
  37 accEncP ∷ Parser (CIAscii, Maybe Double)
  38 accEncP = do coding ← toCIAscii <$> token
  39              qVal   ← option Nothing
  40                       $ do _ ← string ";q="
  41                            q ← qvalue
  42                            return $ Just q
  43              return (normalizeCoding coding, qVal)
  44
  45 normalizeCoding ∷ CIAscii → CIAscii
  46 normalizeCoding coding
  47     = if coding ≡ "x-gzip" then
  48           "gzip"
  49       else
  50           if coding ≡ "x-compress" then
  51               "compress"
  52           else
  53               coding
  54
  55 unnormalizeCoding ∷ CIAscii → CIAscii
  56 unnormalizeCoding coding
  57     = if coding ≡ "gzip" then
  58           "x-gzip"
  59       else
  60           if coding ≡ "compress" then
  61               "x-compress"
  62           else
  63               coding