{-# 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
= [(HeaderName
hContentType,ByteString
"text/plain")]
textHtmlHeader :: ResponseHeaders
= [(HeaderName
hContentType,ByteString
"text/html")]
locationHeader :: ByteString -> ResponseHeaders
ByteString
url = [(HeaderName
hLocation, ByteString
url)]
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
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