@@ -1,212 +0,0 @@
1−{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}
2−module Focus.HTTP.Accept where
3−
4−#ifdef __GLASGOW_HASKELL__
5−#if __GLASGOW_HASKELL__ < 710
6−import Prelude hiding (takeWhile, sequence)
7−import Control.Monad hiding (sequence)
8−import Data.Traversable (sequence)
9−#else
10−import Prelude hiding (takeWhile)
11−import Control.Monad
12−#endif
13−#else
14−import Prelude hiding (takeWhile)
15−import Control.Monad
16−#endif
17−
18−import Control.Applicative
19−import qualified Data.ByteString as BS
20−import Data.Attoparsec.ByteString as A
21−import Data.Attoparsec.ByteString.Char8 as AC8
22−import Data.ByteString (ByteString)
23−import Data.Maybe
24−import Data.Word (Word8)
25−import Data.Monoid
26−import Data.Fixed
27−import Data.Map (Map)
28−import qualified Data.Map as Map
29−import Data.Either
30−import Control.Arrow
31−import Data.List
32−import Data.String
33−import Data.Proxy
34−import Data.Ord
35−
36−newtype Encoding = Encoding { unEncoding :: ByteString } deriving (Show, Read, Eq, Ord, IsString)
37−type QValueResolution = E3 -- This resolution is given by the standard
38−newtype QValue = QValue { unQValue :: Fixed QValueResolution } deriving (Show, Read, Eq, Ord)
39−
40−-- | When no Accept-encoding header is present, prefer identity, then gzip or compress, then anything else available
41−--
42−-- See http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html
43−missingAcceptableEncodings :: AcceptableEncodings
44−missingAcceptableEncodings = AcceptableEncodings
45− { _acceptableEncodings_defaultQValue = QValue 0.001
46− , _acceptableEncodings_byEncoding = Map.fromList
47− [ (Encoding "identity", QValue 1)
48− , (Encoding "gzip", QValue 0.5)
49− , (Encoding "compress", QValue 0.5)
50− ]
51− }
52−
53−data AcceptableEncodings
54− = AcceptableEncodings { _acceptableEncodings_defaultQValue :: QValue
55− , _acceptableEncodings_byEncoding :: Map Encoding QValue
56− }
57− deriving (Show, Read, Eq, Ord)
58−
59−chooseEncoding :: [Encoding] -> AcceptableEncodings -> Maybe Encoding
60−chooseEncoding es ae = fmap snd $ listToMaybe $ sort $ catMaybes $ zipWith f es [(1::Int)..]
61− where f e n = case encodingQValue e ae of
62− QValue 0 -> Nothing
63− q -> Just ((Down q, n), e) -- Choose by quality first (in descending order), then by the server's preference order
64−
65−encodingQValue :: Encoding -> AcceptableEncodings -> QValue
66−encodingQValue e ae = Map.findWithDefault (_acceptableEncodings_defaultQValue ae) e $ _acceptableEncodings_byEncoding ae
67−
68−acceptEncodingBody :: Parser AcceptableEncodings
69−acceptEncodingBody = do
70− l <- hashRule (Just 1) Nothing $ do
71− c <- (Nothing <$ literal "*") <|> (Just <$> contentCoding)
72− mq <- optional $ do
73− literal ";"
74− literal "q"
75− literal "="
76− qvalue
77− let q = fromMaybe (QValue 1) mq
78− return (c, q)
79− let (stars, specificEncodings) = partitionEithers $ flip map l $ \(c, q) -> case c of
80− Nothing -> Left q
81− Just n -> Right (n, q)
82− starQValue <- case stars of
83− [] -> return Nothing
84− [q] -> return $ Just q
85− _ -> fail "acceptEncodingBody: multiple * values provided"
86− byEncodingProvided <- sequence $ Map.fromListWithKey (\k _ _ -> fail $ "acceptEncodingBody: encoding " <> show k <> " repeated multiple times") $ map (second return) specificEncodings
87− let defaultIdentityQValue = fromMaybe (QValue 1) starQValue -- identity has a default qvalue of 1 unless * is given a different qvalue explicitly
88− defaultQValue = fromMaybe (QValue 0) starQValue
89− byEncoding = Map.filter (/= defaultQValue) -- Canonicalize: qvalues equal to the default are redundant
90− . Map.alter (Just . fromMaybe defaultIdentityQValue) "identity" -- Add implicit "identity" encoding, unless it has been explicitly added
91− $ byEncodingProvided
92− return $ AcceptableEncodings defaultQValue byEncoding
93−
94−-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.9
95−qvalue :: Parser QValue
96−qvalue = do
97− skipMany lws
98− q0 <|> q1
99− where q0 = do
100− char '0'
101− decimals <- option [] $ do
102− char '.'
103− starRule (Just 0) (Just numAllowedDigits) digit
104− return $ QValue $ MkFixed $ fromIntegral $ (read ('0' : decimals) :: Int) * 10 ^ (numAllowedDigits - length decimals)
105− q1 = do
106− char '1'
107− option () $ do
108− char '.'
109− starRule (Just 0) (Just numAllowedDigits) $ char '0'
110− return ()
111− return $ QValue 1
112− numAllowedDigits :: Int
113− numAllowedDigits = fromIntegral $ resolution (Proxy :: Proxy QValueResolution)
114−
115−contentCoding :: Parser Encoding
116−contentCoding = Encoding <$> token
117−
118−token :: Parser ByteString
119−token = skipMany lws >> A.takeWhile1 isTokenChar
120−
121−literal :: ByteString -> Parser ()
122−literal s = void $ skipMany lws >> string s
123−
124−isTokenChar :: Word8 -> Bool
125−isTokenChar c = isChar c && not (isCtl c || isSeparator c)
126−
127−isChar :: Word8 -> Bool
128−isChar c = c <= 127
129−
130−isCtl :: Word8 -> Bool
131−isCtl c = c <= 31 || c == 127
132−
133−isSeparator :: Word8 -> Bool
134−isSeparator c = BS.elem c $ spVal `BS.cons` htVal `BS.cons` "()<>@,;:\\\"/[]?={}"
135−
136−-- | A version of 'liftM2' that is strict in the result of its first
137−-- action.
138−liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c
139−liftM2' f a b = do
140− !x <- a
141− y <- b
142− return (f x y)
143−{-# INLINE liftM2' #-}
144−
145−-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.1
146−starRule :: Maybe Int -> Maybe Int -> Parser a -> Parser [a]
147−starRule minNum maxNum element = do
148− let numMandatory = fromMaybe 0 minNum
149− mandatoryVals <- replicateM numMandatory element
150− optionalVals <- case maxNum of
151− Nothing -> many' element
152− Just n -> do
153− let countUpTo 0 _ = return []
154− countUpTo m a = liftM2' (:) a (countUpTo (pred m) a) <|> return []
155− countUpTo (n - numMandatory) element
156− return $ mandatoryVals ++ optionalVals
157−
158−-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.1
159−-- The spec is a bit ambiguous on whether extra commas and whitespace are permitted before and after the elements; this implementation permits them
160−hashRule :: forall a. Maybe Int -> Maybe Int -> Parser a -> Parser [a]
161−hashRule minNum maxNum element = do
162− let numMandatory = fromMaybe 0 minNum
163− sep :: Parser ()
164− sep = do
165− skipMany1 $ do
166− skipMany lws
167− char ','
168− return ()
169− processMandatory :: Bool -> Int -> Parser [a]
170− processMandatory isInitial 0 = processOptional isInitial $ fmap (subtract numMandatory) maxNum
171− processMandatory isInitial n = do
172− if isInitial then void $ optional sep else sep
173− liftM2' (:) (skipMany lws >> element) $ processMandatory False $ pred n
174− processOptional :: Bool -> Maybe Int -> Parser [a]
175− processOptional _ (Just 0) = return []
176− processOptional isInitial n = (<|> return []) $ do
177− if isInitial then void $ optional sep else sep
178− liftM2' (:) (skipMany lws >> element) $ processOptional False $ fmap pred n
179− result <- processMandatory True numMandatory
180− _ <- optional sep
181− skipMany lws
182− return result
183−
184−-- | Linear whitespace
185−-- See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
186−lws :: Parser ()
187−lws = do
188− option () $ cr >> lf
189− starRule (Just 1) Nothing $ sp <|> ht
190− return ()
191−
192−-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
193−cr :: Parser ()
194−cr = void $ word8 13
195−
196−-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
197−lf :: Parser ()
198−lf = void $ word8 10
199−
200−-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
201−sp :: Parser ()
202−sp = void $ word8 spVal
203−
204−spVal :: Word8
205−spVal = 32
206−
207−-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
208−ht :: Parser ()
209−ht = void $ word8 htVal
210−
211−htVal :: Word8
212−htVal = 9