Network/HTTP/Lucu/ContentCoding.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , MultiParamTypeClasses
   4   , OverloadedStrings
   5   , UnicodeSyntax
   6   #-}
   7 module Network.HTTP.Lucu.ContentCoding
   8     ( AcceptEncoding(..)
   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.Attoparsec.Parsable
  17 import Data.ByteString (ByteString)
  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 Parsable ByteString [AcceptEncoding] where
  40     {-# INLINE parser #-}
  41     parser = listOf parser
  42
  43 instance Parsable ByteString AcceptEncoding where
  44     {-# INLINE parser #-}
  45     parser = 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