{-# 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
mapReqHeaders :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapReqHeaders 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)