@@ -0,0 +1,258 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE BangPatterns #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+
7+-- | Module containing parsers and utilities for managing @Accept-Encoding@ headers and the overall process of encoding selection.
8+--
9+-- See https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.3
10+module Obelisk.Asset.Accept
11+ ( AcceptableEncodings(..)
12+ , Encoding(..)
13+ , QValue(..)
14+ , QValueResolution
15+ , acceptEncodingBody
16+ , chooseEncoding
17+ , missingAcceptableEncodings
18+ ) where
19+
20+#ifdef __GLASGOW_HASKELL__
21+#if __GLASGOW_HASKELL__ < 710
22+import Prelude hiding (takeWhile, sequence)
23+import Data.Traversable (sequence)
24+#else
25+import Prelude hiding (takeWhile)
26+#endif
27+#else
28+import Prelude hiding (takeWhile)
29+#endif
30+
31+import Control.Applicative ((<|>), optional)
32+import Control.Arrow (second)
33+import Control.Monad (replicateM, void)
34+import Data.Attoparsec.ByteString as AttoBS
35+import Data.Attoparsec.ByteString.Char8 as AC8
36+import Data.ByteString (ByteString)
37+import qualified Data.ByteString as BS
38+import Data.Either (partitionEithers)
39+import Data.Fixed (E3, Fixed(..), resolution)
40+import Data.List (sort)
41+import Data.Map (Map)
42+import qualified Data.Map as Map
43+import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
44+import Data.Monoid ((<>))
45+import Data.Ord (Down(..))
46+import Data.Proxy (Proxy(..))
47+import Data.String (IsString)
48+import Data.Word (Word8)
49+
50+
51+-- | Type of a particular named encoding technique, such as @gzip@.
52+--
53+-- See https://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.5
54+newtype Encoding = Encoding { unEncoding :: ByteString } deriving (Show, Read, Eq, Ord, IsString)
55+
56+-- | Maximum precision of a Q value, in particular 3 decimal places of precision as given by the standard.
57+type QValueResolution = E3
58+
59+-- | Type of an HTTP @qvalue@ or quality value indicating how preferred some encoding is relative to some other one.
60+--
61+-- See https://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.9
62+newtype QValue = QValue { unQValue :: Fixed QValueResolution } deriving (Show, Read, Eq, Ord)
63+
64+-- | Structure used for picking a mutually acceptable encoding, holding a default 'QValue' along with 'QValue's for a number of 'Encoding's and typically
65+-- represented in HTTP as a string like gzip; q=1.0, identity; q=0.5, *; q=0.0@.
66+--
67+-- See https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.3
68+data AcceptableEncodings = AcceptableEncodings
69+ { _acceptableEncodings_defaultQValue :: QValue
70+ -- ^The 'QValue' associated with the default encoding value @*@, indicating any unmentioned encoding.
71+ , _acceptableEncodings_byEncoding :: Map Encoding QValue
72+ -- ^'QValue's for each 'Encoding'.
73+ } deriving (Show, Read, Eq, Ord)
74+
75+-- | When no Accept-Encoding header is present, prefer identity, then gzip or compress, then anything else available.
76+missingAcceptableEncodings :: AcceptableEncodings
77+missingAcceptableEncodings = AcceptableEncodings
78+ { _acceptableEncodings_defaultQValue = QValue 0.001
79+ , _acceptableEncodings_byEncoding = Map.fromList
80+ [ (Encoding "identity", QValue 1)
81+ , (Encoding "gzip", QValue 0.5)
82+ , (Encoding "compress", QValue 0.5)
83+ ]
84+ }
85+
86+-- | Takes a list of 'Encoding's and an 'AcceptableEncodings' representing preferences and returns @Just 'Encoding'@ to use of the given list based on those
87+-- preferences. An 'Encoding' is preferred if it has a higher 'QValue' or in the case of ties if it comes first in the given list of encodings. An encoding
88+-- with a @QValue@ of 0 will never be chosen. If no encoding could be chosen, either because no encodings were given or because 0 @QValue@s suppressed them,
89+-- then @Nothing@ is returned.
90+--
91+-- See https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.3
92+chooseEncoding :: [Encoding] -> AcceptableEncodings -> Maybe Encoding
93+chooseEncoding es ae = fmap snd $ listToMaybe $ sort $ catMaybes $ zipWith f es [(1::Int)..]
94+ where f e n = case encodingQValue e ae of
95+ QValue 0 -> Nothing
96+ q -> Just ((Down q, n), e) -- Choose by quality first (in descending order), then by the server's preference order
97+
98+-- | Helper function for 'chooseEncoding' that returns the default AcceptableEncoding if requested encoding is unavailable
99+encodingQValue :: Encoding -> AcceptableEncodings -> QValue
100+encodingQValue e ae = Map.findWithDefault (_acceptableEncodings_defaultQValue ae) e $ _acceptableEncodings_byEncoding ae
101+
102+-- | Attoparsec 'Parser' for parsing an 'AcceptableEncodings' from the value of an @Accept-Encoding@ header, as specified by HTTP/1.1 / RFC2616.
103+--
104+-- See https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.3
105+acceptEncodingBody :: Parser AcceptableEncodings
106+acceptEncodingBody = do
107+ l <- hashRule (Just 1) Nothing $ do -- partially applied hashRule awaiting to be passed Parser a
108+ c <- (Nothing <$ literal "*") <|> (Just <$> contentCoding) -- Parser Nothing <|> Parser Encoding
109+ mq <- optional $ do
110+ literal ";"
111+ literal "q"
112+ literal "="
113+ qvalue
114+ let q = fromMaybe (QValue 1) mq
115+ return (c, q)
116+ let (stars, specificEncodings) = partitionEithers $ flip map l $ \(c, q) -> case c of
117+ Nothing -> Left q
118+ Just n -> Right (n, q)
119+ starQValue <- case stars of
120+ [] -> return Nothing
121+ [q] -> return $ Just q
122+ _ -> fail "acceptEncodingBody: multiple * values provided"
123+ byEncodingProvided <- sequence $ Map.fromListWithKey (\k _ _ -> fail $ "acceptEncodingBody: encoding " <> show k <> " repeated multiple times") $ map (second return) specificEncodings
124+ let defaultIdentityQValue = fromMaybe (QValue 1) starQValue -- identity has a default qvalue of 1 unless * is given a different qvalue explicitly
125+ defaultQValue = fromMaybe (QValue 0) starQValue
126+ byEncoding = Map.filter (/= defaultQValue) -- Canonicalize: qvalues equal to the default are redundant
127+ . Map.alter (Just . fromMaybe defaultIdentityQValue) "identity" -- Add implicit "identity" encoding, unless it has been explicitly added
128+ $ byEncodingProvided
129+ return $ AcceptableEncodings defaultQValue byEncoding
130+
131+-- | Parser for a 'QValue'.
132+--
133+-- See http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.9
134+qvalue :: Parser QValue
135+qvalue = do
136+ skipMany lws
137+ q0 <|> q1
138+ where q0 = do
139+ char '0'
140+ decimals <- option [] $ do
141+ char '.'
142+ starRule (Just 0) (Just numAllowedDigits) digit
143+ return $ QValue $ MkFixed $ fromIntegral $ (read ('0' : decimals) :: Int) * 10 ^ (numAllowedDigits - length decimals)
144+ q1 = do
145+ char '1'
146+ option () $ do
147+ char '.'
148+ starRule (Just 0) (Just numAllowedDigits) $ char '0'
149+ return ()
150+ return $ QValue 1
151+ numAllowedDigits :: Int
152+ numAllowedDigits = fromIntegral $ resolution (Proxy :: Proxy QValueResolution)
153+
154+-- | Helper function used in 'acceptEncodingBody' to evaluate Encoding as ByteString
155+contentCoding :: Parser Encoding
156+contentCoding = Encoding <$> token
157+
158+-- | Helper function used in 'contentCoding' that skips lightweight spaces and consumes input while 'isTokenChar' returns True
159+token :: Parser ByteString
160+token = skipMany lws >> AttoBS.takeWhile1 isTokenChar
161+
162+-- | Helper function used in 'acceptEncodingBody', discards evaluation and returns a 'Parser ()' to continue parsing
163+literal :: ByteString -> Parser ()
164+literal s = void $ skipMany lws >> string s
165+
166+-- | Helper function used in 'token' to validate if ByteStringChar is printable but not a control or seperator char
167+isTokenChar :: Word8 -> Bool
168+isTokenChar c = isChar c && not (isCtl c || isSeparator c)
169+
170+-- | Helper function used in 'isTokenChar' to validate if ByteStringChar is a control or printable char
171+isChar :: Word8 -> Bool
172+isChar c = c <= 127
173+
174+-- | Helper function used in 'isTokenChar' to validate if ByteStringChar is a control char
175+isCtl :: Word8 -> Bool
176+isCtl c = c <= 31 || c == 127
177+
178+-- | Helper function used in 'isTokenChar' to validate if ByteStringChar is a seperator char
179+isSeparator :: Word8 -> Bool
180+isSeparator c = BS.elem c $ spVal `BS.cons` htVal `BS.cons` "()<>@,;:\\\"/[]?={}"
181+
182+-- | A version of 'liftM2' that is strict in the result of its first
183+-- action.
184+liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c
185+liftM2' f a b = do
186+ !x <- a
187+ y <- b
188+ return (f x y)
189+{-# INLINE liftM2' #-}
190+
191+-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.1
192+starRule :: Maybe Int -> Maybe Int -> Parser a -> Parser [a]
193+starRule minNum maxNum element = do
194+ let numMandatory = fromMaybe 0 minNum
195+ mandatoryVals <- replicateM numMandatory element
196+ optionalVals <- case maxNum of
197+ Nothing -> many' element
198+ Just n -> do
199+ let countUpTo 0 _ = return []
200+ countUpTo m a = liftM2' (:) a (countUpTo (pred m) a) <|> return []
201+ countUpTo (n - numMandatory) element
202+ return $ mandatoryVals ++ optionalVals
203+
204+-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.1
205+-- The spec is a bit ambiguous on whether extra commas and whitespace are permitted before and after the elements; this implementation permits them
206+hashRule :: forall a. Maybe Int -> Maybe Int -> Parser a -> Parser [a]
207+hashRule minNum maxNum element = do
208+ let numMandatory = fromMaybe 0 minNum
209+ sep :: Parser ()
210+ sep = do
211+ skipMany1 $ do
212+ skipMany lws
213+ char ','
214+ return ()
215+ processMandatory :: Bool -> Int -> Parser [a]
216+ processMandatory isInitial 0 = processOptional isInitial $ fmap (subtract numMandatory) maxNum
217+ processMandatory isInitial n = do
218+ if isInitial then void $ optional sep else sep
219+ liftM2' (:) (skipMany lws >> element) $ processMandatory False $ pred n
220+ processOptional :: Bool -> Maybe Int -> Parser [a]
221+ processOptional _ (Just 0) = return []
222+ processOptional isInitial n = (<|> return []) $ do
223+ if isInitial then void $ optional sep else sep
224+ liftM2' (:) (skipMany lws >> element) $ processOptional False $ fmap pred n
225+ result <- processMandatory True numMandatory
226+ _ <- optional sep
227+ skipMany lws
228+ return result
229+
230+-- | Linear whitespace
231+-- See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
232+lws :: Parser ()
233+lws = do
234+ option () $ cr >> lf
235+ starRule (Just 1) Nothing $ sp <|> ht
236+ return ()
237+
238+-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
239+cr :: Parser ()
240+cr = void $ word8 13
241+
242+-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
243+lf :: Parser ()
244+lf = void $ word8 10
245+
246+-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
247+sp :: Parser ()
248+sp = void $ word8 spVal
249+
250+spVal :: Word8
251+spVal = 32
252+
253+-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
254+ht :: Parser ()
255+ht = void $ word8 htVal
256+
257+htVal :: Word8
258+htVal = 9