diff options
author | defanor <defanor@uberspace.net> | 2019-02-04 01:32:38 +0300 |
---|---|---|
committer | defanor <defanor@uberspace.net> | 2019-02-04 01:32:38 +0300 |
commit | 118e4bc3642b227cffa3f3a5a150d1fa95808917 (patch) | |
tree | 7a603b9ae48921a316ab3a13ffdabd2cc6acf9c0 | |
parent | 7c376f213869209876e339fb66304c49f82aa363 (diff) |
Use System.Timeout directly
The previously used Network.Wai.Middleware.Timeout is a part of
wai-extra, which has quite a few dependencies. Still depending on it,
but this is a step towards reducing the dependencies.
-rw-r--r-- | Main.hs | 29 |
1 files changed, 15 insertions, 14 deletions
@@ -48,7 +48,7 @@ import Data.Maybe (mapMaybe) import Data.Text.Encoding (encodeUtf8) import Network.Wai.Middleware.HttpAuth (extractBasicAuth) import Network.HTTP.Types.Header (hWWWAuthenticate) -import Network.Wai.Middleware.Timeout (timeout) +import System.Timeout (timeout) import Network.Wai.Handler.FastCGI (run) import Control.Monad (join) import Control.Arrow ((***)) @@ -252,16 +252,17 @@ main = do conf <- decodeEnv case conf of Left err -> putStrLn err - Right conf' -> run - $ timeout (connectionTimeout conf') $ \req respond -> - case ("authorised" `elem` pathInfo req, extractBasicAuth - =<< lookup hAuthorization (requestHeaders req)) of - (True, Just (l, p)) -> - serve conf' - (connect $ ConnectInfo "" 0 (BS.unpack l) (BS.unpack p) "") - req respond - (True, Nothing) -> - respond $ responseLBS unauthorized401 - [( hWWWAuthenticate - , "Basic realm=\"Protected area\", charset=\"UTF-8\"")] "" - _ -> serve conf' (connectPostgreSQL "") req respond + Right conf' -> run $ \req respond -> + maybe (respond $ responseLBS status504 [] "") pure =<< + timeout (connectionTimeout conf' * 10 ^ (6 :: Int)) + (case ("authorised" `elem` pathInfo req, extractBasicAuth + =<< lookup hAuthorization (requestHeaders req)) of + (True, Just (l, p)) -> + serve conf' + (connect $ ConnectInfo "" 0 (BS.unpack l) (BS.unpack p) "") + req respond + (True, Nothing) -> + respond $ responseLBS unauthorized401 + [( hWWWAuthenticate + , "Basic realm=\"Protected area\", charset=\"UTF-8\"")] "" + _ -> serve conf' (connectPostgreSQL "") req respond) |