← Back to branch summary

~ubuntu-branches/ubuntu/vivid/haskell-wai-extra/vivid-proposed

« back to all changes in this revision

Viewing changes to Network/Wai/Middleware/Jsonp.hs

  • Committer: Package Import Robot
  • Author(s): Colin Watson
  • Date: 2014-06-17 10:04:13 UTC
  • mfrom: (2.3.2 sid)
  • Revision ID: package-import@ubuntu.com-20140617100413-2uuvzmq864x7nzu0
Tags: 3.0.0-2
* Fix typo in libghc-network-dev minimum version.
* Build-depend on libghc-data-default-dev and libghc-zlib-dev for tests.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/Middleware/Jsonp.hs
25
25
import Control.Monad (join)
26
26
import Data.Maybe (fromMaybe)
27
27
import qualified Data.ByteString as S
28
 
import qualified Data.Conduit as C
29
28
import Data.CaseInsensitive (CI)
30
29
import Network.HTTP.Types (Status)
31
30
 
37
36
-- having a content type of \"text\/javascript\" and calling the specified
38
37
-- callback function.
39
38
jsonp :: Middleware
40
 
jsonp app env = do
 
39
jsonp app env sendResponse = do
41
40
    let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env
42
41
    let callback :: Maybe B8.ByteString
43
42
        callback =
52
51
                                           "application/json"
53
52
                                           $ requestHeaders env
54
53
                        }
55
 
    res <- app env'
56
 
    return $ case callback of
57
 
        Nothing -> res
58
 
        Just c -> go c res
 
54
    app env' $ \res ->
 
55
        case callback of
 
56
            Nothing -> sendResponse res
 
57
            Just c -> go c res
59
58
  where
60
59
    go c r@(ResponseBuilder s hs b) =
61
 
        case checkJSON hs of
 
60
        sendResponse $ case checkJSON hs of
62
61
            Nothing -> r
63
 
            Just hs' -> ResponseBuilder s hs' $
 
62
            Just hs' -> responseBuilder s hs' $
64
63
                copyByteString c
65
64
                `mappend` fromChar '('
66
65
                `mappend` b
68
67
    go c r =
69
68
        case checkJSON hs of
70
69
            Just hs' -> addCallback c s hs' wb
71
 
            Nothing -> r
 
70
            Nothing -> sendResponse r
72
71
      where
73
 
        (s, hs, wb) = responseToSource r
 
72
        (s, hs, wb) = responseToStream r
74
73
 
75
74
    checkJSON hs =
76
75
        case lookup "Content-Type" hs of
80
79
            _ -> Nothing
81
80
    fixHeaders = changeVal "Content-Type" "text/javascript"
82
81
 
83
 
    addCallback :: ByteString
84
 
                -> Status
85
 
                -> [(CI ByteString, ByteString)]
86
 
                -> (forall b. WithSource IO (C.Flush Builder) b)
87
 
                -> Response
88
82
    addCallback cb s hs wb =
89
 
        ResponseSource s hs $ \f -> wb $ \b -> f $
90
 
            C.yield (C.Chunk $ copyByteString cb `mappend` fromChar '(')
91
 
            `mappend` b
92
 
            `mappend` C.yield (C.Chunk $ fromChar ')')
 
83
        wb $ \body -> sendResponse $ responseStream s hs $ \sendChunk flush -> do
 
84
            sendChunk $ copyByteString cb `mappend` fromChar '('
 
85
            body sendChunk flush
 
86
            sendChunk $ fromChar ')'
93
87
 
94
88
changeVal :: Eq a
95
89
          => a