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

22
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)
import qualified Network.HTTP.ReverseProxy as ReverseProxy
#endif
import Network.HTTP.Types (status200)
import Network.HTTP.Types (status200, status503)
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 SrcLoc (Located)
import Data.FileEmbed (embedFile)
@ -135,11 +136,18 @@ reverseProxy opts iappPort = do
manager <- newManager def
#endif
let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html")
let onExc _ _ = return $ responseLBS status200
[ ("content-type", "text/html")
, ("Refresh", "1")
]
refreshHtml
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")
, ("Refresh", "1")
]
refreshHtml
let runProxy =
run (develPort opts) $ waiProxyToSettings

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

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