{-# LANGUAGE RankNTypes, CPP #-}
---------------------------------------------------------
-- |
-- Module        : Network.Wai.Middleware.Jsonp
-- Copyright     : Michael Snoyman
-- License       : BSD3
--
-- Maintainer    : Michael Snoyman <michael@snoyman.com>
-- Stability     : Unstable
-- Portability   : portable
--
-- Automatic wrapping of JSON responses to convert into JSONP.
--
---------------------------------------------------------
module Network.Wai.Middleware.Jsonp (jsonp) where

import Network.Wai
import Network.Wai.Internal
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import Data.ByteString.Builder.Extra (byteStringCopy)
import Data.ByteString.Builder (char7)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mappend)
#endif
import Control.Monad (join)
import Data.Maybe (fromMaybe)
import qualified Data.ByteString as S
import Network.HTTP.Types (hAccept, hContentType)

-- | Wrap json responses in a jsonp callback.
--
-- Basically, if the user requested a \"text\/javascript\" and supplied a
-- \"callback\" GET parameter, ask the application for an
-- \"application/json\" response, then convert that into a JSONP response,
-- having a content type of \"text\/javascript\" and calling the specified
-- callback function.
jsonp :: Middleware
jsonp :: Middleware
jsonp Application
app Request
env Response -> IO ResponseReceived
sendResponse = do
    let accept :: ByteString
accept = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
B8.empty (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
env
    let callback :: Maybe B8.ByteString
        callback :: Maybe ByteString
callback =
            if String -> ByteString
B8.pack String
"text/javascript" ByteString -> ByteString -> Bool
`B8.isInfixOf` ByteString
accept
                then Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe ByteString) -> Maybe ByteString)
-> Maybe (Maybe ByteString) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> [(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"callback" ([(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString))
-> [(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> [(ByteString, Maybe ByteString)]
queryString Request
env
                else Maybe ByteString
forall a. Maybe a
Nothing
    let env' :: Request
env' =
            case Maybe ByteString
callback of
                Maybe ByteString
Nothing -> Request
env
                Just ByteString
_ -> Request
env
                        { requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = HeaderName
-> ByteString
-> [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)]
forall a.
Eq a =>
a -> ByteString -> [(a, ByteString)] -> [(a, ByteString)]
changeVal HeaderName
hAccept
                                           ByteString
"application/json"
                                           ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
env
                        }
    Application
app Request
env' ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res ->
        case Maybe ByteString
callback of
            Maybe ByteString
Nothing -> Response -> IO ResponseReceived
sendResponse Response
res
            Just ByteString
c -> ByteString -> Response -> IO ResponseReceived
go ByteString
c Response
res
  where
    go :: ByteString -> Response -> IO ResponseReceived
go ByteString
c r :: Response
r@(ResponseBuilder Status
s [(HeaderName, ByteString)]
hs Builder
b) =
        Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ case [(HeaderName, ByteString)] -> Maybe [(HeaderName, ByteString)]
checkJSON [(HeaderName, ByteString)]
hs of
            Maybe [(HeaderName, ByteString)]
Nothing -> Response
r
            Just [(HeaderName, ByteString)]
hs' -> Status -> [(HeaderName, ByteString)] -> Builder -> Response
responseBuilder Status
s [(HeaderName, ByteString)]
hs' (Builder -> Response) -> Builder -> Response
forall a b. (a -> b) -> a -> b
$
                ByteString -> Builder
byteStringCopy ByteString
c
                Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char7 Char
'('
                Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
b
                Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char7 Char
')'
    go ByteString
c Response
r =
        case [(HeaderName, ByteString)] -> Maybe [(HeaderName, ByteString)]
checkJSON [(HeaderName, ByteString)]
hs of
            Just [(HeaderName, ByteString)]
hs' -> ByteString
-> Status
-> [(HeaderName, ByteString)]
-> ((((Builder -> IO ()) -> IO () -> IO ()) -> IO ResponseReceived)
    -> IO ResponseReceived)
-> IO ResponseReceived
forall a t.
ByteString
-> Status
-> [(HeaderName, ByteString)]
-> ((((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived)
    -> t)
-> t
addCallback ByteString
c Status
s [(HeaderName, ByteString)]
hs' (((Builder -> IO ()) -> IO () -> IO ()) -> IO ResponseReceived)
-> IO ResponseReceived
forall a. (((Builder -> IO ()) -> IO () -> IO ()) -> IO a) -> IO a
wb
            Maybe [(HeaderName, ByteString)]
Nothing -> Response -> IO ResponseReceived
sendResponse Response
r
      where
        (Status
s, [(HeaderName, ByteString)]
hs, (((Builder -> IO ()) -> IO () -> IO ()) -> IO a) -> IO a
wb) = Response
-> (Status, [(HeaderName, ByteString)],
    (((Builder -> IO ()) -> IO () -> IO ()) -> IO a) -> IO a)
forall a.
Response
-> (Status, [(HeaderName, ByteString)],
    (((Builder -> IO ()) -> IO () -> IO ()) -> IO a) -> IO a)
responseToStream Response
r

    checkJSON :: [(HeaderName, ByteString)] -> Maybe [(HeaderName, ByteString)]
checkJSON [(HeaderName, ByteString)]
hs =
        case HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType [(HeaderName, ByteString)]
hs of
            Just ByteString
x
                | String -> ByteString
B8.pack String
"application/json" ByteString -> ByteString -> Bool
`S.isPrefixOf` ByteString
x ->
                    [(HeaderName, ByteString)] -> Maybe [(HeaderName, ByteString)]
forall a. a -> Maybe a
Just ([(HeaderName, ByteString)] -> Maybe [(HeaderName, ByteString)])
-> [(HeaderName, ByteString)] -> Maybe [(HeaderName, ByteString)]
forall a b. (a -> b) -> a -> b
$ [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
fixHeaders [(HeaderName, ByteString)]
hs
            Maybe ByteString
_ -> Maybe [(HeaderName, ByteString)]
forall a. Maybe a
Nothing
    fixHeaders :: [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
fixHeaders = HeaderName
-> ByteString
-> [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)]
forall a.
Eq a =>
a -> ByteString -> [(a, ByteString)] -> [(a, ByteString)]
changeVal HeaderName
hContentType ByteString
"text/javascript"

    addCallback :: ByteString
-> Status
-> [(HeaderName, ByteString)]
-> ((((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived)
    -> t)
-> t
addCallback ByteString
cb Status
s [(HeaderName, ByteString)]
hs (((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived) -> t
wb =
        (((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived) -> t
wb ((((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived)
 -> t)
-> (((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived)
-> t
forall a b. (a -> b) -> a -> b
$ \(Builder -> IO ()) -> IO () -> IO a
body -> Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status
-> [(HeaderName, ByteString)]
-> ((Builder -> IO ()) -> IO () -> IO ())
-> Response
responseStream Status
s [(HeaderName, ByteString)]
hs (((Builder -> IO ()) -> IO () -> IO ()) -> Response)
-> ((Builder -> IO ()) -> IO () -> IO ()) -> Response
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush -> do
            Builder -> IO ()
sendChunk (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteStringCopy ByteString
cb Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char7 Char
'('
            a
_ <- (Builder -> IO ()) -> IO () -> IO a
body Builder -> IO ()
sendChunk IO ()
flush
            Builder -> IO ()
sendChunk (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Char -> Builder
char7 Char
')'

changeVal :: Eq a
          => a
          -> ByteString
          -> [(a, ByteString)]
          -> [(a, ByteString)]
changeVal :: a -> ByteString -> [(a, ByteString)] -> [(a, ByteString)]
changeVal a
key ByteString
val [(a, ByteString)]
old = (a
key, ByteString
val)
                      (a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
: ((a, ByteString) -> Bool) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
k, ByteString
_) -> a
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
key) [(a, ByteString)]
old