{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP.Forwarded
( Forwarded(..)
, parseForwarded
, serializeForwarded
) where
import Data.ByteString (ByteString)
import Data.CaseInsensitive (CI)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Word (Word8)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import qualified Data.ByteString as ByteString
import qualified Data.CaseInsensitive as CaseInsensitive
import qualified Data.Char as Char
data Forwarded = Forwarded
{ forwardedBy :: Maybe ByteString
, forwardedFor :: Maybe ByteString
, forwardedHost :: Maybe ByteString
, forwardedProto :: Maybe (CI ByteString)
} deriving (Eq, Show)
empty :: Forwarded
empty = Forwarded
{ forwardedBy = Nothing
, forwardedFor = Nothing
, forwardedHost = Nothing
, forwardedProto = Nothing
}
parseForwarded :: ByteString -> Forwarded
parseForwarded = foldr accumulate empty . parseForwarded'
where
accumulate (key, val) acc =
case key of
"by" -> acc { forwardedBy = Just val }
"for" -> acc { forwardedFor = Just val }
"host" -> acc { forwardedHost = Just val }
"proto" -> acc { forwardedProto = Just $ CaseInsensitive.mk val }
_ -> acc
parseForwarded' :: ByteString -> [ (ByteString, ByteString) ]
parseForwarded' s
| ByteString.null s = []
| otherwise =
let (x, y) = breakDiscard 59 s
in parsePart x : parseForwarded' y
parsePart :: ByteString -> (ByteString, ByteString)
parsePart s = (key', value)
where
(key, value) =
breakDiscard 61 s
key' =
ByteString.dropWhile (== 32) key
breakDiscard :: Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard w s = (x, ByteString.drop 1 y)
where
(x, y) =
ByteString.break (== w) s
serializeForwarded :: Forwarded -> ByteString
serializeForwarded Forwarded { .. } =
ByteString.intercalate "; " $ catMaybes xs
where
xs =
[ strVal "by" forwardedBy
, strVal "for" forwardedFor
, strVal "host" forwardedHost
, strVal "proto" $ CaseInsensitive.original <$> forwardedProto
]
strVal _ Nothing = Nothing
strVal key (Just val) = Just $ key <> "=" <> val