    {-# LANGUAGE OverloadedStrings #-}

    module Network.Wai.Application.Classic.Field where

    import Control.Arrow (first)
    import Control.Monad (mplus)
    import Data.ByteString (ByteString)
    import qualified Data.ByteString as BS
    import qualified Data.ByteString.Char8 as B8
    import qualified Data.Map as Map
    import Data.Maybe
    import Data.StaticHash (StaticHash)
    import qualified Data.StaticHash as SH
    import qualified Data.Text as T
    import Network.HTTP.Types
    import Network.Mime (defaultMimeMap, defaultMimeType, MimeType)
    import Network.SockAddr
    import Network.Wai
    import Network.Wai.Application.Classic.Header
    import Network.Wai.Application.Classic.Lang
    import Network.Wai.Application.Classic.Types

    ----------------------------------------------------------------

    languages :: RequestHeaders -> [ByteString]
    languages :: RequestHeaders -> [ByteString]
    languages = [ByteString]
    -> (ByteString -> [ByteString]) -> Maybe ByteString -> [ByteString]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [] ByteString -> [ByteString]
    parseLang (Maybe ByteString -> [ByteString])
    -> (RequestHeaders -> Maybe ByteString)
    -> RequestHeaders
    -> [ByteString]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HeaderName -> RequestHeaders -> Maybe ByteString
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup HeaderName
    hAcceptLanguage

    ----------------------------------------------------------------

    textPlainHeader :: ResponseHeaders
    textPlainHeader :: RequestHeaders
    textPlainHeader = [(HeaderName
    hContentType,ByteString
    "text/plain")]

    textHtmlHeader :: ResponseHeaders
    textHtmlHeader :: RequestHeaders
    textHtmlHeader = [(HeaderName
    hContentType,ByteString
    "text/html")]

    locationHeader :: ByteString -> ResponseHeaders
    locationHeader :: ByteString -> RequestHeaders
    locationHeader ByteString
    url = [(HeaderName
    hLocation, ByteString
    url)]

    -- FIXME: the case where "Via:" already exists
    addVia :: ClassicAppSpec -> Request -> ResponseHeaders -> ResponseHeaders
    addVia :: ClassicAppSpec -> Request -> RequestHeaders -> RequestHeaders
    addVia ClassicAppSpec
    cspec Request
    req RequestHeaders
    hdr = (HeaderName
    hVia, ByteString
    val) Header -> RequestHeaders -> RequestHeaders
    forall a. a -> [a] -> [a]
    : RequestHeaders
    hdr
      where
        ver :: HttpVersion
    ver = Request -> HttpVersion
    httpVersion Request
    req
        val :: ByteString
    val = [ByteString] -> ByteString
    BS.concat [
            Int -> ByteString
    forall a. Show a => a -> ByteString
    showBS (HttpVersion -> Int
    httpMajor HttpVersion
    ver)
          , ByteString
    "."
          , Int -> ByteString
    forall a. Show a => a -> ByteString
    showBS (HttpVersion -> Int
    httpMinor HttpVersion
    ver)
          , ByteString
    " "
          , ByteString
    host
          , ByteString
    " ("
          , ClassicAppSpec -> ByteString
    softwareName ClassicAppSpec
    cspec
          , ByteString
    ")"
          ]
        host :: ByteString
    host = ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe ByteString
    "" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Request -> Maybe ByteString
    requestHeaderHost Request
    req

    addForwardedFor :: Request -> ResponseHeaders -> ResponseHeaders
    addForwardedFor :: Request -> RequestHeaders -> RequestHeaders
    addForwardedFor Request
    req RequestHeaders
    hdr = (HeaderName
    hXForwardedFor, ByteString
    addr) Header -> RequestHeaders -> RequestHeaders
    forall a. a -> [a] -> [a]
    : RequestHeaders
    hdr
      where
        addr :: ByteString
    addr = String -> ByteString
    B8.pack (String -> ByteString)
    -> (Request -> String) -> Request -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SockAddr -> String
    showSockAddr (SockAddr -> String) -> (Request -> SockAddr) -> Request -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Request -> SockAddr
    remoteHost (Request -> ByteString) -> Request -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Request
    req

    newHeader :: Bool -> ByteString -> ResponseHeaders
    newHeader :: Bool -> ByteString -> RequestHeaders
    newHeader Bool
    ishtml ByteString
    file
      | Bool
    ishtml    =  RequestHeaders
    textHtmlHeader
      | Bool
    otherwise = [(HeaderName
    hContentType, ByteString -> ByteString
    mimeType ByteString
    file)]

    mimeType :: ByteString -> MimeType
    mimeType :: ByteString -> ByteString
    mimeType ByteString
    file = ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe ByteString
    defaultMimeType (Maybe ByteString -> ByteString)
    -> ([ByteString] -> Maybe ByteString) -> [ByteString] -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Maybe ByteString -> Maybe ByteString -> Maybe ByteString)
    -> Maybe ByteString -> [Maybe ByteString] -> Maybe ByteString
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Maybe ByteString -> Maybe ByteString -> Maybe ByteString
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    mplus Maybe ByteString
    forall a. Maybe a
    Nothing ([Maybe ByteString] -> Maybe ByteString)
    -> ([ByteString] -> [Maybe ByteString])
    -> [ByteString]
    -> Maybe ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ByteString -> Maybe ByteString)
    -> [ByteString] -> [Maybe ByteString]
    forall a b. (a -> b) -> [a] -> [b]
    map ByteString -> Maybe ByteString
    lok ([ByteString] -> ByteString) -> [ByteString] -> ByteString
    forall a b. (a -> b) -> a -> b
    $ [ByteString]
    targets
      where
        targets :: [ByteString]
    targets = ByteString -> [ByteString]
    extensions ByteString
    file
        lok :: ByteString -> Maybe ByteString
    lok ByteString
    x = ByteString -> StaticHash ByteString ByteString -> Maybe ByteString
    forall k v.
    (Eq k, Ord k, Hashable k) =>
    k -> StaticHash k v -> Maybe v
    SH.lookup ByteString
    x StaticHash ByteString ByteString
    defaultMimeTypes'

    extensions :: ByteString -> [ByteString]
    extensions :: ByteString -> [ByteString]
    extensions ByteString
    file = [ByteString]
    exts
      where
        entire :: ByteString
    entire = case (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
    BS.break (Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == Word8
    46) ByteString
    file of -- '.'
            (ByteString
    _,ByteString
    "") -> ByteString
    ""
            (ByteString
    _,ByteString
    x)  -> HasCallStack => ByteString -> ByteString
    ByteString -> ByteString
    BS.tail ByteString
    x
        exts :: [ByteString]
    exts = if ByteString
    entire ByteString -> ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == ByteString
    "" then [] else ByteString
    entire ByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    : Word8 -> ByteString -> [ByteString]
    BS.split Word8
    46 ByteString
    file

    defaultMimeTypes' :: StaticHash ByteString MimeType
    defaultMimeTypes' :: StaticHash ByteString ByteString
    defaultMimeTypes' = [(ByteString, ByteString)] -> StaticHash ByteString ByteString
    forall k v. (Eq k, Ord k, Hashable k) => [(k, v)] -> StaticHash k v
    SH.fromList ([(ByteString, ByteString)] -> StaticHash ByteString ByteString)
    -> [(ByteString, ByteString)] -> StaticHash ByteString ByteString
    forall a b. (a -> b) -> a -> b
    $ ((Extension, ByteString) -> (ByteString, ByteString))
    -> [(Extension, ByteString)] -> [(ByteString, ByteString)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Extension -> ByteString)
    -> (Extension, ByteString) -> (ByteString, ByteString)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first (String -> ByteString
    B8.pack (String -> ByteString)
    -> (Extension -> String) -> Extension -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Extension -> String
    T.unpack)) ([(Extension, ByteString)] -> [(ByteString, ByteString)])
    -> [(Extension, ByteString)] -> [(ByteString, ByteString)]
    forall a b. (a -> b) -> a -> b
    $ Map Extension ByteString -> [(Extension, ByteString)]
    forall k a. Map k a -> [(k, a)]
    Map.toList Map Extension ByteString
    defaultMimeMap

    showBS :: Show a => a -> ByteString
    showBS :: forall a. Show a => a -> ByteString
    showBS = String -> ByteString
    B8.pack (String -> ByteString) -> (a -> String) -> a -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> String
    forall a. Show a => a -> String
    show