{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

-- |
-- Module      : Network.HTTP.Forwarded
-- Copyright   : (c) Marek Fajkus
-- License     : BSD3
--
-- Maintainer  : marek.faj@gmail.com
--
-- Parsing and Serialization of [Forwarded](https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Forwarded)
-- HTTP header values.

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


-- | Representation of Forwarded header data
-- All field are optional
data Forwarded = Forwarded
  { Forwarded -> Maybe ByteString
forwardedBy    :: Maybe ByteString
  , Forwarded -> Maybe ByteString
forwardedFor   :: Maybe ByteString
  , Forwarded -> Maybe ByteString
forwardedHost  :: Maybe ByteString
  , Forwarded -> Maybe (CI ByteString)
forwardedProto :: Maybe (CI ByteString)
  } deriving (Forwarded -> Forwarded -> Bool
(Forwarded -> Forwarded -> Bool)
-> (Forwarded -> Forwarded -> Bool) -> Eq Forwarded
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Forwarded -> Forwarded -> Bool
$c/= :: Forwarded -> Forwarded -> Bool
== :: Forwarded -> Forwarded -> Bool
$c== :: Forwarded -> Forwarded -> Bool
Eq, Int -> Forwarded -> ShowS
[Forwarded] -> ShowS
Forwarded -> String
(Int -> Forwarded -> ShowS)
-> (Forwarded -> String)
-> ([Forwarded] -> ShowS)
-> Show Forwarded
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Forwarded] -> ShowS
$cshowList :: [Forwarded] -> ShowS
show :: Forwarded -> String
$cshow :: Forwarded -> String
showsPrec :: Int -> Forwarded -> ShowS
$cshowsPrec :: Int -> Forwarded -> ShowS
Show)


empty :: Forwarded
empty :: Forwarded
empty = Forwarded :: Maybe ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Maybe (CI ByteString)
-> Forwarded
Forwarded
  { forwardedBy :: Maybe ByteString
forwardedBy    = Maybe ByteString
forall a. Maybe a
Nothing
  , forwardedFor :: Maybe ByteString
forwardedFor   = Maybe ByteString
forall a. Maybe a
Nothing
  , forwardedHost :: Maybe ByteString
forwardedHost  = Maybe ByteString
forall a. Maybe a
Nothing
  , forwardedProto :: Maybe (CI ByteString)
forwardedProto = Maybe (CI ByteString)
forall a. Maybe a
Nothing
  }


-- | Parse @ByteString@ to Forwarded header
-- Note that this function works with the values
-- of the header only. Extraction of value
-- from header depends what representation of headers
-- you're using.
--
-- In case of Wai you can extract headers as following:
--
-- > :set -XOverloadedStrings
-- > import Network.Wai
-- > import Network.HTTP.Forwarded
-- > getForwarded req = parseForwarded <$> "forwarded" `lookup` requestHeaders req
-- > :t getForwarded
-- > getForwarded :: Request -> Maybe Forwarded
parseForwarded :: ByteString -> Forwarded
parseForwarded :: ByteString -> Forwarded
parseForwarded = ((ByteString, ByteString) -> Forwarded -> Forwarded)
-> Forwarded -> [(ByteString, ByteString)] -> Forwarded
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ByteString, ByteString) -> Forwarded -> Forwarded
forall a.
(Eq a, IsString a) =>
(a, ByteString) -> Forwarded -> Forwarded
accumulate Forwarded
empty ([(ByteString, ByteString)] -> Forwarded)
-> (ByteString -> [(ByteString, ByteString)])
-> ByteString
-> Forwarded
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(ByteString, ByteString)]
parseForwarded'
  where
    accumulate :: (a, ByteString) -> Forwarded -> Forwarded
accumulate (a
key, ByteString
val) Forwarded
acc =
      case a
key of
        a
"by"    -> Forwarded
acc { forwardedBy :: Maybe ByteString
forwardedBy = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
val }
        a
"for"   -> Forwarded
acc { forwardedFor :: Maybe ByteString
forwardedFor = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
val }
        a
"host"  -> Forwarded
acc { forwardedHost :: Maybe ByteString
forwardedHost = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
val }
        a
"proto" -> Forwarded
acc { forwardedProto :: Maybe (CI ByteString)
forwardedProto = CI ByteString -> Maybe (CI ByteString)
forall a. a -> Maybe a
Just (CI ByteString -> Maybe (CI ByteString))
-> CI ByteString -> Maybe (CI ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CaseInsensitive.mk ByteString
val }
        a
_       -> Forwarded
acc


parseForwarded' :: ByteString -> [ (ByteString, ByteString) ]
parseForwarded' :: ByteString -> [(ByteString, ByteString)]
parseForwarded' ByteString
s
  | ByteString -> Bool
ByteString.null ByteString
s = []
  | Bool
otherwise =
      let (ByteString
x, ByteString
y) = Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
59 ByteString
s -- semicolon
      in ByteString -> (ByteString, ByteString)
parsePart ByteString
x (ByteString, ByteString)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. a -> [a] -> [a]
: ByteString -> [(ByteString, ByteString)]
parseForwarded' ByteString
y


parsePart :: ByteString -> (ByteString, ByteString)
parsePart :: ByteString -> (ByteString, ByteString)
parsePart ByteString
s = (ByteString
key', ByteString
value)
  where
    (ByteString
key, ByteString
value) =
      Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
61 ByteString
s -- equals sign
    key' :: ByteString
key' =
      (Word8 -> Bool) -> ByteString -> ByteString
ByteString.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32) ByteString
key -- space


breakDiscard :: Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard :: Word8 -> ByteString -> (ByteString, ByteString)
breakDiscard Word8
w ByteString
s = (ByteString
x, Int -> ByteString -> ByteString
ByteString.drop Int
1 ByteString
y)
  where
    (ByteString
x, ByteString
y) =
      (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
ByteString.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
w) ByteString
s


-- | Serialize `Forwarded` data type back
-- to ByteString representation.
serializeForwarded :: Forwarded -> ByteString
serializeForwarded :: Forwarded -> ByteString
serializeForwarded Forwarded { Maybe ByteString
Maybe (CI ByteString)
forwardedProto :: Maybe (CI ByteString)
forwardedHost :: Maybe ByteString
forwardedFor :: Maybe ByteString
forwardedBy :: Maybe ByteString
forwardedProto :: Forwarded -> Maybe (CI ByteString)
forwardedHost :: Forwarded -> Maybe ByteString
forwardedFor :: Forwarded -> Maybe ByteString
forwardedBy :: Forwarded -> Maybe ByteString
.. } =
    ByteString -> [ByteString] -> ByteString
ByteString.intercalate ByteString
"; " ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ByteString]
xs
    where
      xs :: [Maybe ByteString]
xs =
        [ ByteString -> Maybe ByteString -> Maybe ByteString
forall a. (Semigroup a, IsString a) => a -> Maybe a -> Maybe a
strVal ByteString
"by" Maybe ByteString
forwardedBy
        , ByteString -> Maybe ByteString -> Maybe ByteString
forall a. (Semigroup a, IsString a) => a -> Maybe a -> Maybe a
strVal ByteString
"for" Maybe ByteString
forwardedFor
        , ByteString -> Maybe ByteString -> Maybe ByteString
forall a. (Semigroup a, IsString a) => a -> Maybe a -> Maybe a
strVal ByteString
"host" Maybe ByteString
forwardedHost
        , ByteString -> Maybe ByteString -> Maybe ByteString
forall a. (Semigroup a, IsString a) => a -> Maybe a -> Maybe a
strVal ByteString
"proto" (Maybe ByteString -> Maybe ByteString)
-> Maybe ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
CaseInsensitive.original (CI ByteString -> ByteString)
-> Maybe (CI ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CI ByteString)
forwardedProto
        ]

      strVal :: a -> Maybe a -> Maybe a
strVal a
_ Maybe a
Nothing      = Maybe a
forall a. Maybe a
Nothing
      strVal a
key (Just a
val) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a
key a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"=" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
val