@@ -0,0 +1,258 @@
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE BangPatterns #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+-- | Module containing parsers and utilities for managing @Accept-Encoding@ headers and the overall process of encoding selection.
9+-- See https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.3
10+module Obelisk.Asset.Accept
11+ ( AcceptableEncodings(..)
17+ , missingAcceptableEncodings
20+#ifdef __GLASGOW_HASKELL__
21+#if __GLASGOW_HASKELL__ < 710
22+import Prelude hiding (takeWhile, sequence)
23+import Data.Traversable (sequence)
25+import Prelude hiding (takeWhile)
28+import Prelude hiding (takeWhile)
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)
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)
51+-- | Type of a particular named encoding technique, such as @gzip@.
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)
56+-- | Maximum precision of a Q value, in particular 3 decimal places of precision as given by the standard.
57+type QValueResolution = E3
59+-- | Type of an HTTP @qvalue@ or quality value indicating how preferred some encoding is relative to some other one.
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)
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@.
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)
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)
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.
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
96+ q -> Just ((Down q, n), e) -- Choose by quality first (in descending order), then by the server's preference order
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
102+-- | Attoparsec 'Parser' for parsing an 'AcceptableEncodings' from the value of an @Accept-Encoding@ header, as specified by HTTP/1.1 / RFC2616.
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
114+ let q = fromMaybe (QValue 1) mq
116+ let (stars, specificEncodings) = partitionEithers $ flip map l $ \(c, q) -> case c of
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
131+-- | Parser for a 'QValue'.
133+-- See http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.9
134+qvalue :: Parser QValue
140+ decimals <- option [] $ do
142+ starRule (Just 0) (Just numAllowedDigits) digit
143+ return $ QValue $ MkFixed $ fromIntegral $ (read ('0' : decimals) :: Int) * 10 ^ (numAllowedDigits - length decimals)
148+ starRule (Just 0) (Just numAllowedDigits) $ char '0'
151+ numAllowedDigits :: Int
152+ numAllowedDigits = fromIntegral $ resolution (Proxy :: Proxy QValueResolution)
154+-- | Helper function used in 'acceptEncodingBody' to evaluate Encoding as ByteString
155+contentCoding :: Parser Encoding
156+contentCoding = Encoding <$> token
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
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
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)
170+-- | Helper function used in 'isTokenChar' to validate if ByteStringChar is a control or printable char
171+isChar :: Word8 -> Bool
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
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` "()<>@,;:\\\"/[]?={}"
182+-- | A version of 'liftM2' that is strict in the result of its first
184+liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c
189+{-# INLINE liftM2' #-}
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
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
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
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
230+-- | Linear whitespace
231+-- See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
234+ option () $ cr >> lf
235+ starRule (Just 1) Nothing $ sp <|> ht
238+-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
242+-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
246+-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
248+sp = void $ word8 spVal
253+-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
255+ht = void $ word8 htVal