    {-# 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 = 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 =
                                changeVal
                                    hAccept
                                    "application/json"
                                    $ requestHeaders 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} {b}.
    ByteString
    -> Status
    -> [(HeaderName, ByteString)]
    -> ((((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived)
        -> b)
    -> b
    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)
        -> b)
    -> b
    addCallback ByteString
    cb Status
    s [(HeaderName, ByteString)]
    hs (((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived) -> b
    wb =
            (((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived) -> b
    wb ((((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived)
     -> b)
    -> (((Builder -> IO ()) -> IO () -> IO a) -> IO ResponseReceived)
    -> b
    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
    '('
                _ <- (Builder -> IO ()) -> IO () -> IO a
    body Builder -> IO ()
    sendChunk IO ()
    flush
                sendChunk $ char7 ')'

    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)
            (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