module SecondTransfer.Utils.HTTPHeaders (
lowercaseHeaders
,headersAreLowercase
,headersAreLowercaseAtHeaderEditor
,fetchHeader
,HeaderEditor
,fromList
,toList
,headerLens
,replaceHeaderValue
,replaceHostByAuthority
,introduceDateHeader
) where
import qualified Control.Lens as L
import Control.Lens ( (^.) )
import qualified Data.ByteString as B
import Data.ByteString.Char8 (pack)
import Data.Char (isUpper)
import Data.List (find)
import Data.Text (toLower)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.Map.Strict as Ms
import Data.Word (Word8)
import Data.Time.Format (formatTime, defaultTimeLocale)
import Data.Time.Clock (getCurrentTime)
#ifndef IMPLICIT_MONOID
import Control.Applicative ((<$>))
#endif
import SecondTransfer.MainLoop.CoherentWorker (Headers)
lowercaseHeaders :: Headers -> Headers
lowercaseHeaders = map (\(h,v) -> (low h, v))
where
low = encodeUtf8 . toLower . decodeUtf8
headersAreLowercase :: Headers -> Bool
headersAreLowercase headers =
foldl
(\ prev (hn, _) -> (flip (&&)) (aTitleIsLowercase hn) $! prev)
True
headers
headersAreLowercaseAtHeaderEditor :: HeaderEditor -> Bool
headersAreLowercaseAtHeaderEditor header_editor =
Ms.foldlWithKey'
(\ prev hn _ -> (flip (&&)) (aTitleIsLowercase . toFlatBs $ hn) $! prev)
True
(innerMap header_editor)
aTitleIsLowercase :: B.ByteString -> Bool
aTitleIsLowercase a_title = not . T.any isUpper . decodeUtf8 $ a_title
fetchHeader :: Headers -> B.ByteString -> Maybe B.ByteString
fetchHeader headers header_name =
snd
<$>
find ( \ x -> fst x == header_name ) headers
newtype Autosorted = Autosorted { toFlatBs :: B.ByteString }
deriving Eq
colon :: Word8
colon = fromIntegral . fromEnum $ ':'
instance Ord Autosorted where
compare (Autosorted a) (Autosorted b) | (B.head a) == colon, (B.head b) /= colon = LT
compare (Autosorted a) (Autosorted b) | (B.head a) /= colon, (B.head b) == colon = GT
compare (Autosorted a) (Autosorted b) = compare a b
newtype HeaderEditor = HeaderEditor { innerMap :: Ms.Map Autosorted B.ByteString }
fromList :: Headers -> HeaderEditor
fromList = HeaderEditor . Ms.fromList . map (\(hn, hv) -> (Autosorted hn, hv))
toList :: HeaderEditor -> Headers
toList (HeaderEditor m) = [ (toFlatBs x, v) | (x,v) <- Ms.toList m ]
replaceHeaderValue :: HeaderEditor -> B.ByteString -> Maybe B.ByteString -> HeaderEditor
replaceHeaderValue (HeaderEditor m) header_name maybe_header_value =
HeaderEditor $ Ms.alter (const maybe_header_value) (Autosorted header_name) m
headerLens :: B.ByteString -> L.Lens' HeaderEditor (Maybe B.ByteString)
headerLens name =
L.lens
(Ms.lookup hname . innerMap )
(\(HeaderEditor hs) mhv -> HeaderEditor $ Ms.alter (const mhv) hname hs)
where
hname = Autosorted name
replaceHostByAuthority :: HeaderEditor -> HeaderEditor
replaceHostByAuthority headers =
let
host_lens :: L.Lens' HeaderEditor (Maybe B.ByteString)
host_lens = headerLens "host"
authority_lens = headerLens ":authority"
maybe_host_header = headers ^. host_lens
no_hosts = L.set host_lens Nothing headers
in
case maybe_host_header of
Nothing -> headers
Just host -> L.set authority_lens (Just host) no_hosts
introduceDateHeader :: HeaderEditor -> IO HeaderEditor
introduceDateHeader header_editor = do
current_time <- getCurrentTime
let
date_header_lens = headerLens "date"
formatted_date = Just . pack $
formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" current_time
new_editor = L.set date_header_lens formatted_date header_editor
return new_editor