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

-- | 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 = forall a. a -> Maybe a -> a
fromMaybe ByteString
B8.empty forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
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 forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"callback" forall a b. (a -> b) -> a -> b
$ Request -> Query
queryString Request
env
                else forall a. Maybe a
Nothing
    let env' :: Request
env' =
            case Maybe ByteString
callback of
                Maybe ByteString
Nothing -> Request
env
                Just ByteString
_ -> Request
env
                        { requestHeaders :: RequestHeaders
requestHeaders = forall a.
Eq a =>
a -> ByteString -> [(a, ByteString)] -> [(a, ByteString)]
changeVal HeaderName
hAccept
                                           ByteString
"application/json"
                                           forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
env
                        }
    Application
app Request
env' 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 RequestHeaders
hs Builder
b) =
        Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ case RequestHeaders -> Maybe RequestHeaders
checkJSON RequestHeaders
hs of
            Maybe RequestHeaders
Nothing -> Response
r
            Just RequestHeaders
hs' -> Status -> RequestHeaders -> Builder -> Response
responseBuilder Status
s RequestHeaders
hs' forall a b. (a -> b) -> a -> b
$
                ByteString -> Builder
byteStringCopy ByteString
c
                forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char7 Char
'('
                forall a. Monoid a => a -> a -> a
`mappend` Builder
b
                forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char7 Char
')'
    go ByteString
c Response
r =
        case RequestHeaders -> Maybe RequestHeaders
checkJSON RequestHeaders
hs of
            Just RequestHeaders
hs' -> forall {a} {b}.
ByteString
-> Status
-> RequestHeaders
-> ((((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived)
    -> b)
-> b
addCallback ByteString
c Status
s RequestHeaders
hs' forall {a}. (StreamingBody -> IO a) -> IO a
wb
            Maybe RequestHeaders
Nothing -> Response -> IO ResponseReceived
sendResponse Response
r
      where
        (Status
s, RequestHeaders
hs, (StreamingBody -> IO a) -> IO a
wb) = forall a.
Response
-> (Status, RequestHeaders, (StreamingBody -> IO a) -> IO a)
responseToStream Response
r

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

    addCallback :: ByteString
-> Status
-> RequestHeaders
-> ((((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived)
    -> b)
-> b
addCallback ByteString
cb Status
s RequestHeaders
hs (((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived) -> b
wb =
        (((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived) -> b
wb forall a b. (a -> b) -> a -> b
$ \(Builder -> IO ()) -> IO () -> IO a
body -> Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> RequestHeaders -> StreamingBody -> Response
responseStream Status
s RequestHeaders
hs forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush -> do
            Builder -> IO ()
sendChunk forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteStringCopy ByteString
cb 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 forall a b. (a -> b) -> a -> b
$ Char -> Builder
char7 Char
')'

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