{-# LANGUAGE OverloadedStrings #-}
module Web.Spock.Internal.Util where
import Data.Maybe
import Network.HTTP.Types
import Network.Wai.Internal
import qualified Data.Text as T
import qualified Data.HashMap.Strict as HM
data ClientPreferredFormat
= PrefJSON
| PrefXML
| PrefHTML
| PrefText
| PrefUnknown
deriving (Int -> ClientPreferredFormat -> ShowS
[ClientPreferredFormat] -> ShowS
ClientPreferredFormat -> String
(Int -> ClientPreferredFormat -> ShowS)
-> (ClientPreferredFormat -> String)
-> ([ClientPreferredFormat] -> ShowS)
-> Show ClientPreferredFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientPreferredFormat] -> ShowS
$cshowList :: [ClientPreferredFormat] -> ShowS
show :: ClientPreferredFormat -> String
$cshow :: ClientPreferredFormat -> String
showsPrec :: Int -> ClientPreferredFormat -> ShowS
$cshowsPrec :: Int -> ClientPreferredFormat -> ShowS
Show, ClientPreferredFormat -> ClientPreferredFormat -> Bool
(ClientPreferredFormat -> ClientPreferredFormat -> Bool)
-> (ClientPreferredFormat -> ClientPreferredFormat -> Bool)
-> Eq ClientPreferredFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClientPreferredFormat -> ClientPreferredFormat -> Bool
$c/= :: ClientPreferredFormat -> ClientPreferredFormat -> Bool
== :: ClientPreferredFormat -> ClientPreferredFormat -> Bool
$c== :: ClientPreferredFormat -> ClientPreferredFormat -> Bool
Eq)
mimeMapping :: HM.HashMap T.Text ClientPreferredFormat
mimeMapping :: HashMap Text ClientPreferredFormat
mimeMapping =
[(Text, ClientPreferredFormat)]
-> HashMap Text ClientPreferredFormat
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
[ (Text
"application/json", ClientPreferredFormat
PrefJSON)
, (Text
"text/javascript", ClientPreferredFormat
PrefJSON)
, (Text
"text/json", ClientPreferredFormat
PrefJSON)
, (Text
"application/javascript", ClientPreferredFormat
PrefJSON)
, (Text
"application/xml", ClientPreferredFormat
PrefXML)
, (Text
"text/xml", ClientPreferredFormat
PrefXML)
, (Text
"text/plain", ClientPreferredFormat
PrefText)
, (Text
"text/html", ClientPreferredFormat
PrefHTML)
, (Text
"application/xhtml+xml", ClientPreferredFormat
PrefHTML)
]
detectPreferredFormat :: T.Text -> ClientPreferredFormat
detectPreferredFormat :: Text -> ClientPreferredFormat
detectPreferredFormat Text
t =
let (Text
mimeTypeStr, Text
_) = Text -> Text -> (Text, Text)
T.breakOn Text
";" Text
t
mimeTypes :: [Text]
mimeTypes = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
T.toLower (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"," Text
mimeTypeStr
firstMatch :: [Text] -> ClientPreferredFormat
firstMatch [] = ClientPreferredFormat
PrefUnknown
firstMatch (Text
x:[Text]
xs) = ClientPreferredFormat
-> Maybe ClientPreferredFormat -> ClientPreferredFormat
forall a. a -> Maybe a -> a
fromMaybe ([Text] -> ClientPreferredFormat
firstMatch [Text]
xs) (Text
-> HashMap Text ClientPreferredFormat
-> Maybe ClientPreferredFormat
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
x HashMap Text ClientPreferredFormat
mimeMapping)
in [Text] -> ClientPreferredFormat
firstMatch [Text]
mimeTypes
mapReqHeaders :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response
ResponseHeaders -> ResponseHeaders
f Response
resp =
case Response
resp of
(ResponseFile Status
s ResponseHeaders
h String
b1 Maybe FilePart
b2) -> Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
ResponseFile Status
s (ResponseHeaders -> ResponseHeaders
f ResponseHeaders
h) String
b1 Maybe FilePart
b2
(ResponseBuilder Status
s ResponseHeaders
h Builder
b) -> Status -> ResponseHeaders -> Builder -> Response
ResponseBuilder Status
s (ResponseHeaders -> ResponseHeaders
f ResponseHeaders
h) Builder
b
(ResponseStream Status
s ResponseHeaders
h StreamingBody
b) -> Status -> ResponseHeaders -> StreamingBody -> Response
ResponseStream Status
s (ResponseHeaders -> ResponseHeaders
f ResponseHeaders
h) StreamingBody
b
(ResponseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
x Response
r) -> (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
ResponseRaw IO ByteString -> (ByteString -> IO ()) -> IO ()
x ((ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapReqHeaders ResponseHeaders -> ResponseHeaders
f Response
r)