From 4ef5c4e29379c8eed49f6f24ab5f4a3d73cfe3a5 Mon Sep 17 00:00:00 2001
From: Daniel Schadt <kingdread@gmx.de>
Date: Thu, 15 Jul 2021 10:48:18 +0200
Subject: Implement XML configuration support

This alleviates the need to define the server in Haskell and
re-compile the binary every time something in the configuration changes.
---
 app/Main.hs | 38 +++++++++++++++++++++++++-------------
 1 file changed, 25 insertions(+), 13 deletions(-)

(limited to 'app')

diff --git a/app/Main.hs b/app/Main.hs
index 50ca151..29dfc95 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,19 +1,31 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 module Main where
 
 import Cana
-import Cana.Protocol
-import Cana.Router
-import Cana.Extra
+import Cana.Server
 
-defaultResponse :: GeminiResponse
-defaultResponse = GeminiResponse
-  { responseStatus = codeSuccess
-  , responseMeta   = "text/gemini"
-  , responseData   = "# Hello World\nThis page was served by Cana."
-  }
+import Data.Maybe
+import System.IO
+import System.Exit
+import System.Environment
 
 main :: IO ()
-main = runGeminiServer Nothing defaultGeminiPort "certificate.crt" "private.key"
-  [ (anyRoute, staticFiles "gmdocs")
-  ]
+main = do
+  configPath <- configPath
+  config <- loadConfig configPath
+  case config of
+    Left err ->
+      printError "Error loading configuration:" err >> exitFailure
+
+    Right c -> runGeminiServer' c >>= \case
+      Left err -> printError "Server error:" err >> exitFailure
+      Right _  -> return ()
+
+    where
+      configPath = do
+        args <- getArgs
+        return . fromMaybe "cana.xml" $ listToMaybe args
+
+      printError title err = do
+        hPutStrLn stderr title
+        hPutStrLn stderr err
-- 
cgit v1.2.3