haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Respect accept header for JSON in devel server #719

Browse Source
This commit is contained in:
Michael Snoyman 2014-04-24 07:14:01 +03:00
parent f43c7fd3e4
commit 99831b52a2
2 changed files with 16 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
yesod-bin/Devel.hs
View File

@ -77,9 +77,10 @@ import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
#if MIN_VERSION_http_reverse_proxy(0, 2, 0) #if MIN_VERSION_http_reverse_proxy(0, 2, 0)
import qualified Network.HTTP.ReverseProxy as ReverseProxy import qualified Network.HTTP.ReverseProxy as ReverseProxy
#endif #endif
import Network.HTTP.Types (status200) import Network.HTTP.Types (status200, status503)
import Network.Socket (sClose) import Network.Socket (sClose)
import Network.Wai (responseLBS) import Network.Wai (responseLBS, requestHeaders)
import Network.Wai.Parse (parseHttpAccept)
import Network.Wai.Handler.Warp (run) import Network.Wai.Handler.Warp (run)
import SrcLoc (Located) import SrcLoc (Located)
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
@ -135,7 +136,14 @@ reverseProxy opts iappPort = do
manager <- newManager def manager <- newManager def
#endif #endif
let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html") let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html")
let onExc _ _ = return $ responseLBS status200 let onExc _ req
| maybe False (("application/json" `elem`) . parseHttpAccept)
(lookup "accept" $ requestHeaders req) =
return $ responseLBS status503
[ ("Retry-After", "1")
]
"{\"message\":\"Recompiling\"}"
| otherwise = return $ responseLBS status200
[ ("content-type", "text/html") [ ("content-type", "text/html")
, ("Refresh", "1") , ("Refresh", "1")
] ]

1
yesod-bin/yesod-bin.cabal
View File

@ -91,6 +91,7 @@ executable yesod
, transformers , transformers
, warp >= 1.3.7.5 , warp >= 1.3.7.5
, wai >= 1.4 , wai >= 1.4
, wai-extra
, data-default-class , data-default-class
, streaming-commons , streaming-commons