@@ -0,0 +1,212 @@
1+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}
2+module Obelisk.Asset.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