summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2019-02-04 01:32:38 +0300
committerdefanor <defanor@uberspace.net>2019-02-04 01:32:38 +0300
commit118e4bc3642b227cffa3f3a5a150d1fa95808917 (patch)
tree7a603b9ae48921a316ab3a13ffdabd2cc6acf9c0
parent7c376f213869209876e339fb66304c49f82aa363 (diff)
downloadpgxhtml-118e4bc3642b227cffa3f3a5a150d1fa95808917.zip
pgxhtml-118e4bc3642b227cffa3f3a5a150d1fa95808917.tar.gz
pgxhtml-118e4bc3642b227cffa3f3a5a150d1fa95808917.tar.bz2
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.hs29
1 files changed, 15 insertions, 14 deletions
diff --git a/Main.hs b/Main.hs
index 49408ee..4bd9f60 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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)