From efc5f33a153033d90fdcb8d27cc4db0892a27145 Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Mon, 4 Feb 2019 02:29:58 +0300
Subject: Remove the dependency on envy

It's not that useful for a couple of variables, but an additional
dependency.
---
 Main.hs       | 54 +++++++++++++++++++++---------------------------------
 pgxhtml.cabal |  1 -
 2 files changed, 21 insertions(+), 34 deletions(-)

diff --git a/Main.hs b/Main.hs
index 4bd9f60..e85eed3 100644
--- a/Main.hs
+++ b/Main.hs
@@ -44,7 +44,7 @@ import Web.FormUrlEncoded (Form(..), urlDecodeForm)
 import Database.PostgreSQL.Simple.ToField (Action (..))
 import Database.PostgreSQL.Simple.Internal (withConnection)
 import Database.PostgreSQL.LibPQ (getCancel, cancel)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, fromMaybe)
 import Data.Text.Encoding (encodeUtf8)
 import Network.Wai.Middleware.HttpAuth (extractBasicAuth)
 import Network.HTTP.Types.Header (hWWWAuthenticate)
@@ -54,7 +54,7 @@ import Control.Monad (join)
 import Control.Arrow ((***))
 import Control.Exception (bracket, finally, catches, Handler(..))
 import System.FilePath (replaceExtension, takeFileName, (</>))
-import System.Envy (decodeEnv, FromEnv(..), envMaybe, (.!=))
+import System.Environment (lookupEnv)
 import Data.List (nubBy)
 import Foreign
 import Foreign.C
@@ -132,17 +132,6 @@ instance FromField PgXmlString where
            "Expected xml type, got " ++ BS.unpack tName
       else pure $ PgXmlString mdata
 
-data EnvConfig = EnvConfig
-  { connectionTimeout :: Int
-    -- ^ HTTP connection timeout, in seconds
-  , xsltDirectory :: FilePath
-    -- ^ A directory to read XSLTs from
-  }
-
-instance FromEnv EnvConfig where
-  fromEnv =
-    EnvConfig <$> envMaybe "TIMEOUT" .!= 10 <*> envMaybe "XSLT_DIR" .!= ""
-
 data Error = ESQL SqlError
            | EFormat FormatError
            | EQuery QueryError
@@ -213,8 +202,8 @@ errorXML (ESQL e) = mkError "sql_error"
   , ("hint", sqlErrorHint e) ]
 errorXML (EResult e) = mkError "result_error" [("message", BS.pack $ errMessage e)]
 
-serve :: EnvConfig -> IO Connection -> Application
-serve conf ioc req respond = do
+serve :: FilePath -> IO Connection -> Application
+serve xsltDirectory ioc req respond = do
   form' <- urlDecodeForm <$> strictRequestBody req
   case form' of
     Left err -> respError notAcceptable406 $ EOther $
@@ -236,7 +225,7 @@ serve conf ioc req respond = do
       _ -> respError imATeapot418 (EOther "No query is provided")
   where
     qs = queryString req
-    xsltPath = xsltDirectory conf
+    xsltPath = xsltDirectory
                </> replaceExtension
                (takeFileName (BS.unpack $ rawPathInfo req)) "xsl"
     resp st xml = do
@@ -249,20 +238,19 @@ serve conf ioc req respond = do
 main :: IO ()
 main = do
   exsltRegisterAll
-  conf <- decodeEnv
-  case conf of
-    Left err -> putStrLn err
-    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)
+  xsltDir <- fromMaybe "." <$> lookupEnv "XSLT_DIR"
+  to <- maybe 10 read <$> lookupEnv "TIMEOUT"
+  run $ \req respond ->
+    maybe (respond $ responseLBS status504 [] "") pure =<<
+    timeout (to * 10 ^ (6 :: Int))
+    (case ("authorised" `elem` pathInfo req, extractBasicAuth
+            =<< lookup hAuthorization (requestHeaders req)) of
+        (True, Just (l, p)) ->
+          serve xsltDir
+          (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 xsltDir (connectPostgreSQL "") req respond)
diff --git a/pgxhtml.cabal b/pgxhtml.cabal
index 7d64932..9f8adcc 100644
--- a/pgxhtml.cabal
+++ b/pgxhtml.cabal
@@ -18,7 +18,6 @@ executable pgxhtml
   other-extensions:    OverloadedStrings
   build-depends:       base >=4.9 && <5
                      , bytestring >=0.10 && <0.11
-                     , envy >=1.5 && <1.6
                      , filepath >=1.4 && <1.5
                      , http-api-data >=0.3 && <0.4
                      , http-types >=0.12 && <0.13
-- 
cgit v1.2.3