-- | Some helpers for dealing with WAI 'Header's.
module Network.Wai.Header (
    contentLength,
    parseQValueList,
    replaceHeader,
) where

import Control.Monad (guard)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.ByteString.Internal (w2c)
import Data.Word8 (_0, _1, _period, _semicolon, _space)
import Network.HTTP.Types as H
import Text.Read (readMaybe)

import Network.Wai.Util (dropWhileEnd, splitCommas)

-- | More useful for a response. A Wai Request already has a requestBodyLength
contentLength :: [(HeaderName, S8.ByteString)] -> Maybe Integer
contentLength :: [(HeaderName, ByteString)] -> Maybe Integer
contentLength [(HeaderName, ByteString)]
hdrs = HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
H.hContentLength [(HeaderName, ByteString)]
hdrs Maybe ByteString -> (ByteString -> Maybe Integer) -> Maybe Integer
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe Integer
readInt

readInt :: S8.ByteString -> Maybe Integer
readInt :: ByteString -> Maybe Integer
readInt ByteString
bs =
    case ByteString -> Maybe (Integer, ByteString)
S8.readInteger ByteString
bs of
        -- 'S.all' is also 'True' for an empty string
        Just (Integer
i, ByteString
rest) | (Word8 -> Bool) -> ByteString -> Bool
S.all (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space) ByteString
rest -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
        Maybe (Integer, ByteString)
_ -> Maybe Integer
forall a. Maybe a
Nothing

replaceHeader :: H.HeaderName -> S.ByteString -> [H.Header] -> [H.Header]
replaceHeader :: HeaderName
-> ByteString
-> [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)]
replaceHeader HeaderName
name ByteString
val [(HeaderName, ByteString)]
old =
    (HeaderName
name, ByteString
val) (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
name) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) [(HeaderName, ByteString)]
old

-- | Only to be used on header's values which support quality value syntax
--
-- A few things to keep in mind when using this function:
-- * The resulting 'Int' will be anywhere from 1000 to 0 ("1" = 1000, "0.6" = 600, "0.025" = 25)
-- * The absence of a Q value will result in 'Just 1000'
-- * A bad parse of the Q value will result in a 'Nothing', e.g.
--   * Q value has more than 3 digits behind the dot
--   * Q value is missing
--   * Q value is higher than 1
--   * Q value is not a number
parseQValueList :: S8.ByteString -> [(S8.ByteString, Maybe Int)]
parseQValueList :: ByteString -> [(ByteString, Maybe Int)]
parseQValueList = (ByteString -> (ByteString, Maybe Int))
-> [ByteString] -> [(ByteString, Maybe Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> (ByteString, Maybe Int)
go ([ByteString] -> [(ByteString, Maybe Int)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(ByteString, Maybe Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
splitCommas
  where
    go :: ByteString -> (ByteString, Maybe Int)
go = (ByteString, ByteString) -> (ByteString, Maybe Int)
checkQ ((ByteString, ByteString) -> (ByteString, Maybe Int))
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> (ByteString, Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_semicolon)
    checkQ :: (S.ByteString, S.ByteString) -> (S.ByteString, Maybe Int)
    checkQ :: (ByteString, ByteString) -> (ByteString, Maybe Int)
checkQ (ByteString
val, ByteString
"") = (ByteString
val, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1000)
    checkQ (ByteString
val, ByteString
bs) =
        -- RFC 7231 says optional whitespace can be around the semicolon.
        -- So drop any before it       ,           . and any behind it       $ and drop the semicolon
        ( (Word8 -> Bool) -> ByteString -> ByteString
dropWhileEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space) ByteString
val
        , ByteString -> Maybe Int
forall {b}. (Num b, Read b) => ByteString -> Maybe b
parseQval (ByteString -> Maybe Int)
-> (ByteString -> ByteString) -> ByteString -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space) (ByteString -> Maybe Int) -> ByteString -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
1 ByteString
bs
        )
      where
        parseQval :: ByteString -> Maybe b
parseQval ByteString
qVal = do
            ByteString
q <- ByteString -> ByteString -> Maybe ByteString
S.stripPrefix ByteString
"q=" ByteString
qVal
            (Word8
i, ByteString
rest) <- ByteString -> Maybe (Word8, ByteString)
S.uncons ByteString
q
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$
                Word8
i Word8 -> [Word8] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word8
_0, Word8
_1]
                    Bool -> Bool -> Bool
&& ByteString -> Int
S.length ByteString
rest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
4
            case ByteString -> Maybe (Word8, ByteString)
S.uncons ByteString
rest of
                Maybe (Word8, ByteString)
Nothing
                    -- q = "0" or "1"
                    | Word8
i Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_0 -> b -> Maybe b
forall a. a -> Maybe a
Just b
0
                    | Word8
i Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_1 -> b -> Maybe b
forall a. a -> Maybe a
Just b
1000
                    | Bool
otherwise -> Maybe b
forall a. Maybe a
Nothing
                Just (Word8
dot, ByteString
trail)
                    | Word8
dot Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_period Bool -> Bool -> Bool
&& Bool -> Bool
not (Word8
i Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_1 Bool -> Bool -> Bool
&& (Word8 -> Bool) -> ByteString -> Bool
S.any (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_0) ByteString
trail) -> do
                        let len :: Int
len = ByteString -> Int
S.length ByteString
trail
                            extraZeroes :: [Char]
extraZeroes = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len) Char
'0'
                        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                        [Char] -> Maybe b
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe b) -> [Char] -> Maybe b
forall a b. (a -> b) -> a -> b
$ Word8 -> Char
w2c Word8
i Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: ByteString -> [Char]
S8.unpack ByteString
trail [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
extraZeroes
                    | Bool
otherwise -> Maybe b
forall a. Maybe a
Nothing