Network/HTTP/Lucu/ContentCoding.hs

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