From 118e4bc3642b227cffa3f3a5a150d1fa95808917 Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Mon, 4 Feb 2019 01:32:38 +0300
Subject: 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.
---
 Main.hs | 29 +++++++++++++++--------------
 1 file changed, 15 insertions(+), 14 deletions(-)

(limited to 'Main.hs')

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)
-- 
cgit v1.2.3