{-# 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